Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
af5af53794
|
|
@ -1,145 +0,0 @@
|
|||
|
||||
USING: kernel system
|
||||
combinators
|
||||
vectors sequences assocs
|
||||
math math.functions
|
||||
prettyprint unicode.case
|
||||
accessors
|
||||
combinators.cleave
|
||||
newfx
|
||||
dns ;
|
||||
|
||||
IN: dns.cache
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: cache ( -- table ) H{ } ;
|
||||
|
||||
! key: 'name type class' (as string)
|
||||
! val: entry
|
||||
|
||||
TUPLE: entry time data ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: query->key ( query -- key )
|
||||
{ [ name>> >lower ] [ type>> unparse ] [ class>> unparse ] } <arr> " " join ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: table-get ( query -- result ) query->key cache of ;
|
||||
|
||||
: table-check ( query -- ? ) query->key cache key? ;
|
||||
|
||||
: table-add ( query value -- ) [ query->key ] [ ] bi* cache at-mutate ;
|
||||
|
||||
: table-rem ( query -- ) query->key cache delete-key-of drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: now ( -- seconds ) millis 1000.0 / round >integer ;
|
||||
|
||||
: ttl->time ( ttl -- seconds ) now + ;
|
||||
|
||||
: time->ttl ( time -- ttl ) now - ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: NX
|
||||
|
||||
: cache-nx ( query ttl -- ) ttl->time NX entry boa table-add ;
|
||||
|
||||
: nx? ( obj -- ? ) dup entry? [ data>> NX = ] [ drop f ] if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: query->rr ( query -- rr ) [ name>> ] [ type>> ] [ class>> ] tri f f rr boa ;
|
||||
|
||||
: query+entry->rrs ( query entry -- rrs )
|
||||
swap ! entry query
|
||||
query->rr ! entry rr
|
||||
over ! entry rr entry
|
||||
time>> time->ttl >>ttl ! entry rr
|
||||
swap ! rr entry
|
||||
data>> [ >r dup clone r> >>rdata ] map
|
||||
nip ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: expired? ( entry -- ? ) time>> time->ttl 0 <= ;
|
||||
|
||||
: cache-get* ( query -- rrs/NX/f )
|
||||
dup table-get ! query result
|
||||
{
|
||||
{ [ dup f = ] [ 2drop f ] } ! not in the cache
|
||||
{ [ dup expired? ] [ drop table-rem f ] } ! here but expired
|
||||
{ [ dup nx? ] [ 2drop NX ] } ! negative result cached
|
||||
{ [ t ] [ query+entry->rrs ] } ! good to go
|
||||
}
|
||||
cond ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: 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 ;
|
||||
|
||||
: maybe-pushed-on ( obj seq -- )
|
||||
2dup member-of?
|
||||
[ 2drop ]
|
||||
[ pushed-on ]
|
||||
if ;
|
||||
|
||||
: add-rr-to-entry ( rr entry -- )
|
||||
over ttl>> ttl->time >>time
|
||||
[ rdata>> ] [ data>> ] bi* maybe-pushed-on ;
|
||||
|
||||
: cache-add ( query rr -- )
|
||||
over table-get ! query rr entry
|
||||
{
|
||||
{ [ dup f = ] [ drop rr->entry table-add ] }
|
||||
{ [ dup nx? ] [ drop over table-rem rr->entry table-add ] }
|
||||
{ [ dup expired? ] [ drop rr->entry table-add ] }
|
||||
{ [ t ] [ rot drop add-rr-to-entry ] }
|
||||
}
|
||||
cond ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: rr->query ( rr -- query ) [ name>> ] [ type>> ] [ class>> ] tri query boa ;
|
||||
|
||||
: cache-add-rr ( rr -- ) [ rr->query ] [ ] bi cache-add ;
|
||||
|
||||
: cache-add-rrs ( rrs -- ) [ cache-add-rr ] each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! cache-name-error
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: message-soa ( message -- rr/soa )
|
||||
authority-section>> [ type>> SOA = ] filter 1st ;
|
||||
|
||||
: cache-name-error ( message -- message )
|
||||
dup
|
||||
[ message-query ] [ message-soa ttl>> ] bi
|
||||
cache-nx ;
|
||||
|
||||
: cache-message-records ( message -- message )
|
||||
dup
|
||||
{
|
||||
[ answer-section>> cache-add-rrs ]
|
||||
[ authority-section>> cache-add-rrs ]
|
||||
[ additional-section>> cache-add-rrs ]
|
||||
}
|
||||
cleave ;
|
||||
|
||||
: cache-message ( message -- message )
|
||||
dup rcode>> NAME-ERROR = [ cache-name-error ] when
|
||||
cache-message-records ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -39,7 +39,7 @@ TUPLE: <entry> time data ;
|
|||
[let | NAME [ OBJ name>> ]
|
||||
TYPE [ OBJ type>> ]
|
||||
CLASS [ OBJ class>> ]
|
||||
TTL [ now ENT time>> - ] |
|
||||
TTL [ ENT time>> now - ] |
|
||||
ENT data>>
|
||||
[| RDATA | T{ rr f NAME TYPE CLASS TTL RDATA } ]
|
||||
map
|
||||
|
|
|
|||
|
|
@ -1,105 +1,98 @@
|
|||
|
||||
USING: combinators.short-circuit kernel
|
||||
combinators
|
||||
vectors
|
||||
sequences
|
||||
USING: kernel sequences combinators accessors locals random
|
||||
combinators.short-circuit
|
||||
io.sockets
|
||||
accessors
|
||||
combinators.lib
|
||||
newfx
|
||||
dns dns.cache dns.misc ;
|
||||
dns dns.util dns.cache.rr dns.cache.nx ;
|
||||
|
||||
IN: dns.forwarding
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! DNS server - caching, forwarding
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: (socket) ( -- vec ) V{ f } ;
|
||||
:: query->rrs ( QUERY -- rrs/f )
|
||||
[let | RRS [ QUERY cache-get ] |
|
||||
RRS
|
||||
[ RRS ]
|
||||
[
|
||||
[let | NAME [ QUERY name>> ]
|
||||
TYPE [ QUERY type>> ]
|
||||
CLASS [ QUERY class>> ] |
|
||||
|
||||
[let | RRS/CNAME [ T{ query f NAME CNAME CLASS } cache-get ] |
|
||||
|
||||
: socket ( -- socket ) (socket) 1st ;
|
||||
RRS/CNAME f =
|
||||
[ f ]
|
||||
[
|
||||
[let | RR/CNAME [ RRS/CNAME first ] |
|
||||
|
||||
[let | REAL-NAME [ RR/CNAME rdata>> ] |
|
||||
|
||||
[let | RRS [
|
||||
T{ query f REAL-NAME TYPE CLASS } query->rrs
|
||||
] |
|
||||
|
||||
: init-socket-on-port ( port -- )
|
||||
f swap <inet4> <datagram> 0 (socket) as-mutate ;
|
||||
RRS
|
||||
[ RRS/CNAME RRS append ]
|
||||
[ f ]
|
||||
if
|
||||
] ] ]
|
||||
]
|
||||
if
|
||||
] ]
|
||||
]
|
||||
if
|
||||
] ;
|
||||
|
||||
: init-socket ( -- ) 53 init-socket-on-port ;
|
||||
:: answer-from-cache ( MSG -- msg/f )
|
||||
[let | QUERY [ MSG message-query ] |
|
||||
|
||||
[let | NX [ QUERY name>> non-existent-name? ]
|
||||
RRS [ QUERY query->rrs ] |
|
||||
|
||||
{
|
||||
{ [ NX ] [ MSG NAME-ERROR >>rcode ] }
|
||||
{ [ RRS ] [ MSG RRS >>answer-section ] }
|
||||
{ [ t ] [ f ] }
|
||||
}
|
||||
cond
|
||||
]
|
||||
] ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: (upstream-server) ( -- vec ) V{ f } ;
|
||||
: message-soa ( message -- rr/soa )
|
||||
authority-section>> [ type>> SOA = ] filter first ;
|
||||
|
||||
: upstream-server ( -- ip ) (upstream-server) 1st ;
|
||||
:: cache-message ( MSG -- msg )
|
||||
MSG rcode>> NAME-ERROR =
|
||||
[
|
||||
[let | NAME [ MSG message-query name>> ]
|
||||
TTL [ MSG message-soa ttl>> ] |
|
||||
NAME TTL cache-non-existent-name
|
||||
]
|
||||
]
|
||||
when
|
||||
MSG answer-section>> [ cache-add ] each
|
||||
MSG authority-section>> [ cache-add ] each
|
||||
MSG additional-section>> [ cache-add ] each
|
||||
MSG ;
|
||||
|
||||
: set-upstream-server ( ip -- ) 0 (upstream-server) as-mutate ;
|
||||
: answer-from-server ( msg servers -- msg ) random ask-server cache-message ;
|
||||
|
||||
: init-upstream-server ( -- )
|
||||
upstream-server not
|
||||
[ resolv-conf-server set-upstream-server ]
|
||||
when ;
|
||||
:: find-answer ( MSG SERVERS -- msg )
|
||||
{ [ MSG answer-from-cache ] [ MSG SERVERS answer-from-server ] } 0|| ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: rrs? ( obj -- ? ) { [ NX = not ] [ f = not ] } 1&& ;
|
||||
:: start-server ( ADDR-SPEC SERVERS -- )
|
||||
|
||||
[let | SOCKET [ ADDR-SPEC <datagram> ] |
|
||||
|
||||
: query->answer/cache ( query -- rrs/NX/f )
|
||||
dup cache-get* dup { [ rrs? ] [ NX = ] } 1||
|
||||
[ nip ]
|
||||
[
|
||||
drop
|
||||
dup clone CNAME >>type cache-get* dup { [ NX = ] [ f = ] } 1||
|
||||
[ nip ]
|
||||
[ ! query rrs
|
||||
tuck ! rrs query rrs
|
||||
1st ! rrs query rr/cname
|
||||
rdata>> ! rrs query name
|
||||
>r clone r> >>name ! rrs query
|
||||
query->answer/cache ! rrs rrs/NX/f
|
||||
dup rrs? [ append ] [ nip ] if
|
||||
]
|
||||
if
|
||||
SOCKET receive-packet
|
||||
[ parse-message SERVERS find-answer message->ba ]
|
||||
change-data
|
||||
respond
|
||||
]
|
||||
if ;
|
||||
forever
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: answer-from-cache ( message -- message/f )
|
||||
dup message-query ! message query
|
||||
dup query->answer/cache ! message query rrs/NX/f
|
||||
{
|
||||
{ [ dup f = ] [ 3drop f ] }
|
||||
{ [ dup NX = ] [ 2drop NAME-ERROR >>rcode ] }
|
||||
{ [ t ] [ nip >>answer-section ] }
|
||||
}
|
||||
cond ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: answer-from-server ( message -- message )
|
||||
upstream-server ask-server
|
||||
cache-message ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: find-answer ( message -- message )
|
||||
dup answer-from-cache dup
|
||||
[ nip ]
|
||||
[ drop answer-from-server ]
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: loop ( -- )
|
||||
socket receive ! byte-array addr-spec
|
||||
swap ! addr-spec byte-array
|
||||
parse-message ! addr-spec message
|
||||
find-answer ! addr-spec message
|
||||
message->ba ! addr-spec byte-array
|
||||
swap ! byte-array addr-spec
|
||||
socket send
|
||||
loop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: start ( -- ) init-socket init-upstream-server loop ;
|
||||
|
||||
MAIN: start
|
||||
] ;
|
||||
|
|
|
|||
|
|
@ -28,3 +28,6 @@ TUPLE: packet data addr socket ;
|
|||
|
||||
: respond ( packet -- ) [ data>> ] [ addr>> ] [ socket>> ] tri send ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: forever ( quot -- ) [ call ] [ forever ] bi ; inline recursive
|
||||
Loading…
Reference in New Issue