Merge branch 'master' of git://factorcode.org/git/factor
commit
05b02c5fc5
|
@ -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
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
Loading…
Reference in New Issue