dns.forwarding: Check in rewritten version
Eduardo Cavazos
parent
6e03452f75
commit
9f131b7e45
|
|
@ -1,105 +1,102 @@
|
||||||
|
|
||||||
USING: combinators.short-circuit kernel
|
USING: kernel sequences combinators accessors locals random
|
||||||
combinators
|
combinators.short-circuit
|
||||||
vectors
|
|
||||||
sequences
|
|
||||||
io.sockets
|
io.sockets
|
||||||
accessors
|
dns dns.util dns.cache.rr dns.cache.nx ;
|
||||||
combinators.lib
|
|
||||||
newfx
|
|
||||||
dns dns.cache dns.misc ;
|
|
||||||
|
|
||||||
IN: dns.forwarding
|
IN: dns.forwarding
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
! DNS server - caching, forwarding
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: (socket) ( -- vec ) V{ f } ;
|
: forever ( quot -- ) [ call ] [ forever ] bi ; inline recursive
|
||||||
|
|
||||||
: socket ( -- socket ) (socket) 1st ;
|
|
||||||
|
|
||||||
: init-socket-on-port ( port -- )
|
|
||||||
f swap <inet4> <datagram> 0 (socket) as-mutate ;
|
|
||||||
|
|
||||||
: init-socket ( -- ) 53 init-socket-on-port ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: (upstream-server) ( -- 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 ] |
|
||||||
|
|
||||||
: upstream-server ( -- ip ) (upstream-server) 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
|
||||||
|
] |
|
||||||
|
|
||||||
: set-upstream-server ( ip -- ) 0 (upstream-server) as-mutate ;
|
RRS
|
||||||
|
[ RRS/CNAME RRS append ]
|
||||||
|
[ f ]
|
||||||
|
if
|
||||||
|
] ] ]
|
||||||
|
]
|
||||||
|
if
|
||||||
|
] ]
|
||||||
|
]
|
||||||
|
if
|
||||||
|
] ;
|
||||||
|
|
||||||
: init-upstream-server ( -- )
|
:: answer-from-cache ( MSG -- msg/f )
|
||||||
upstream-server not
|
[let | QUERY [ MSG message-query ] |
|
||||||
[ resolv-conf-server set-upstream-server ]
|
|
||||||
when ;
|
[let | NX [ QUERY name>> non-existent-name? ]
|
||||||
|
RRS [ QUERY query->rrs ] |
|
||||||
|
|
||||||
|
{
|
||||||
|
{ [ NX ] [ MSG NAME-ERROR >>rcode ] }
|
||||||
|
{ [ RRS ] [ MSG RRS >>answer-section ] }
|
||||||
|
{ [ t ] [ f ] }
|
||||||
|
}
|
||||||
|
cond
|
||||||
|
]
|
||||||
|
] ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: rrs? ( obj -- ? ) { [ NX = not ] [ f = not ] } 1&& ;
|
: message-soa ( message -- rr/soa )
|
||||||
|
authority-section>> [ type>> SOA = ] filter first ;
|
||||||
|
|
||||||
|
:: 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 ;
|
||||||
|
|
||||||
|
: answer-from-server ( msg servers -- msg ) random ask-server cache-message ;
|
||||||
|
|
||||||
|
:: find-answer ( MSG SERVERS -- msg )
|
||||||
|
{ [ MSG answer-from-cache ] [ MSG SERVERS answer-from-server ] } 0|| ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
:: 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
|
SOCKET receive-packet
|
||||||
dup clone CNAME >>type cache-get* dup { [ NX = ] [ f = ] } 1||
|
[ parse-message SERVERS find-answer message->ba ]
|
||||||
[ nip ]
|
change-data
|
||||||
[ ! query rrs
|
respond
|
||||||
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
|
|
||||||
]
|
]
|
||||||
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
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue