steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-05-29 02:47:54 -05:00
parent d57c66690d 6d15c7615f
commit 05b02c5fc5
4 changed files with 217 additions and 2 deletions
extra
combinators/lib
dns

13
extra/combinators/lib/lib.factor
View File

@ -77,8 +77,21 @@ MACRO: <--&& ( quots -- )
[ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit
[ 2nip ] append ;
! or
MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
MACRO: 0|| ( quots -- ? ) [ [ t ] ] f short-circuit ;
MACRO: 1|| ( quots -- ? )
[ [ dup ] prepend [ t ] ] f short-circuit [ nip ] append ;
MACRO: 2|| ( quots -- ? )
[ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
MACRO: 3|| ( quots -- ? )
[ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ifte
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

11
extra/dns/cache/cache.factor vendored
View File

@ -68,7 +68,7 @@ SYMBOL: NX
: expired? ( entry -- ? ) time>> time->ttl 0 <= ;
: cache-get ( query -- result )
: cache-get* ( query -- rrs/NX/f )
dup table-get ! query result
{
{ [ dup f = ] [ 2drop f ] } ! not in the cache
@ -80,6 +80,15 @@ SYMBOL: NX
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ERROR: name-error name ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cache-get ( query -- rrs/f )
dup cache-get* dup NX = [ drop name>> name-error ] [ nip ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rr->entry ( rr -- entry )
[ ttl>> ttl->time ] [ rdata>> {1} >vector ] bi entry boa ;

13
extra/dns/dns.factor
View File

@ -38,7 +38,7 @@ TUPLE: message
! TYPE
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ;
SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT AAAA ;
: type-table ( -- table )
{
@ -58,6 +58,7 @@ SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ;
{ MINFO 14 }
{ MX 15 }
{ TXT 16 }
{ AAAA 28 }
} ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -126,6 +127,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
: ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ;
: ipv6->ba ( ip -- ba ) ":" split [ 16 base> ] map [ 2 >be ] map concat ;
: label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -330,6 +333,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
: get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: get-ipv6 ( ba i -- ip )
dup 16 + subseq 2 group [ be> 16 >base ] map ":" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: get-rdata ( ba i type -- rdata )
{
{ CNAME [ get-name ] }
@ -338,6 +348,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
{ MX [ get-mx ] }
{ SOA [ get-soa ] }
{ A [ get-ip ] }
{ AAAA [ get-ipv6 ] }
}
case ;

182
extra/dns/recursive/recursive.factor Normal file
View File

@ -0,0 +1,182 @@
USING: kernel continuations
combinators
sequences
random
unicode.case
accessors symbols
combinators.lib combinators.cleave
newfx
dns dns.cache ;
IN: dns.recursive
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: root-dns-servers ( -- servers )
{
"192.5.5.241"
"192.112.36.4"
"128.63.2.53"
"192.36.148.17"
"192.58.128.30"
"193.0.14.129"
"199.7.83.42"
"202.12.27.33"
"198.41.0.4"
} ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cache-message ( message -- message )
dup dup rcode>> NAME-ERROR =
[
[ question-section>> 1st ]
[ authority-section>> [ type>> SOA = ] filter random ttl>> ]
bi
cache-nx
]
[
{
[ answer-section>> cache-add-rrs ]
[ authority-section>> cache-add-rrs ]
[ additional-section>> cache-add-rrs ]
}
cleave
]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: query->message ( query -- message ) <query-message> ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: {name-type-class} ( obj -- seq )
[ name>> >lower ] [ type>> ] [ class>> ] tri {3} ;
: rr=query? ( rr query -- ? ) [ {name-type-class} ] bi@ = ;
: rr-filter ( rrs query -- rrs ) [ rr=query? ] curry filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: message-query ( message -- query ) question-section>> 1st ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: answer-hits ( message -- rrs )
[ answer-section>> ] [ message-query ] bi rr-filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: name-hits ( message -- rrs )
[ answer-section>> ] [ message-query clone A >>type ] bi rr-filter ;
: cname-hits ( message -- rrs )
[ answer-section>> ] [ message-query clone CNAME >>type ] bi rr-filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: authority-hits ( message -- rrs )
authority-section>> [ type>> NS = ] filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOLS: ANSWERED NO-NAME-SERVERS UNCLASSIFIED ;
: classify-message ( message -- symbol )
{
{ [ dup rcode>> NAME-ERROR = ] [ drop NAME-ERROR ] }
{ [ dup rcode>> SERVER-FAILURE = ] [ drop SERVER-FAILURE ] }
{ [ dup answer-hits empty? not ] [ drop ANSWERED ] }
{ [ dup cname-hits empty? not ] [ drop CNAME ] }
{ [ dup authority-hits empty? ] [ drop NO-NAME-SERVERS ] }
{ [ t ] [ drop UNCLASSIFIED ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
DEFER: name->ip
! : name->ip/f ( name -- ip/f ) [ name->ip ] [ drop f ] recover ;
! : extract-ns-ips ( message -- ips )
! authority-hits [ rdata>> name->ip/f ] map [ ] filter ;
: extract-ns-ips ( message -- ips )
authority-hits [ rdata>> name->ip ] map [ ] filter ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: recursive-query ( query servers -- message )
dup random ! query servers server
pick query->message 0 >>rd ! query servers server message
over ask-server ! query servers server message
cache-message ! query servers server message
dup classify-message ! query servers server message sym
{
{ NAME-ERROR [ -roll 3drop ] }
{ ANSWERED [ -roll 3drop ] }
{ CNAME [ -roll 3drop ] }
{ NO-NAME-SERVERS [ -roll 3drop ] }
{
SERVER-FAILURE
[
-roll ! message query servers server
remove ! message query servers
dup empty?
[ 2drop ]
[ rot drop recursive-query ]
if
]
}
[ ! query servers server message sym
drop nip nip ! query message
extract-ns-ips ! query ips
recursive-query
]
}
case ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: canonical/cache ( name -- name )
dup CNAME IN query boa cache-get dup [ nip 1st rdata>> ] [ drop ] if ;
: name->ip/cache ( name -- ip/f )
canonical/cache
A IN query boa cache-get dup [ random rdata>> ] [ ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: name-hits? ( message -- message ? ) dup name-hits empty? not ;
: cname-hits? ( message -- message ? ) dup cname-hits empty? not ;
: name->ip/server ( name -- ip-or-f )
A IN query boa root-dns-servers recursive-query ! message
{
{ [ name-hits? ] [ name-hits random rdata>> ] }
{ [ cname-hits? ] [ cname-hits random rdata>> name->ip ] }
{ [ t ] [ drop f ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : name->ip ( name -- ip )
! { [ name->ip/cache ] [ name->ip/server ] [ name-error ] } 1|| ;
: name->ip ( name -- ip )
dup name->ip/cache dup
[ nip ]
[
drop dup name->ip/server dup
[ nip ]
[ drop name-error ]
if
]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!