209 lines
6.3 KiB
Factor
209 lines
6.3 KiB
Factor
|
|
USING: kernel combinators sequences sets math threads namespaces continuations
|
|
debugger io io.sockets unicode.case accessors destructors
|
|
combinators.short-circuit combinators.smart
|
|
fry arrays
|
|
dns dns.util dns.misc ;
|
|
|
|
IN: dns.server
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
SYMBOL: records-var
|
|
|
|
: records ( -- records ) records-var get ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: {name-type-class} ( obj -- array )
|
|
[ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ;
|
|
|
|
: rr=query? ( obj obj -- ? ) [ {name-type-class} ] bi@ = ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: matching-rrs ( query -- rrs ) records [ rr=query? ] with filter ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! zones
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: zones ( -- names ) records [ type>> NS = ] filter [ name>> ] map prune ;
|
|
: my-zones ( -- names ) records [ type>> SOA = ] filter [ name>> ] map ;
|
|
|
|
: delegated-zones ( -- names ) zones my-zones diff ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! name->zone
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: name->zone ( name -- zone/f )
|
|
zones sort-largest-first [ name-in-domain? ] with find nip ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! name->authority
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: name->authority ( name -- rrs-ns ) name->zone NS IN query boa matching-rrs ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! extract-names
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: rr->rdata-names ( rr -- names/f )
|
|
{
|
|
{ [ dup type>> NS = ] [ rdata>> 1array ] }
|
|
{ [ dup type>> MX = ] [ rdata>> exchange>> 1array ] }
|
|
{ [ dup type>> CNAME = ] [ rdata>> 1array ] }
|
|
{ [ t ] [ drop f ] }
|
|
}
|
|
cond ;
|
|
|
|
: extract-rdata-names ( message -- names )
|
|
[ answer-section>> ] [ authority-section>> ] bi append
|
|
[ rr->rdata-names ] map concat ;
|
|
|
|
: extract-names ( message -- names )
|
|
[ message-query name>> ] [ extract-rdata-names ] bi swap prefix ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! fill-authority
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: fill-authority ( message -- message )
|
|
dup
|
|
extract-names [ name->authority ] map concat prune
|
|
over answer-section>> diff
|
|
>>authority-section ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! fill-additional
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: name->rrs-a ( name -- rrs-a ) A IN query boa matching-rrs ;
|
|
|
|
: fill-additional ( message -- message )
|
|
dup
|
|
extract-rdata-names [ name->rrs-a ] map concat prune
|
|
over answer-section>> diff
|
|
>>additional-section ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! query->rrs
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
DEFER: query->rrs
|
|
|
|
: matching-rrs? ( query -- rrs/f ) matching-rrs [ empty? ] [ drop f ] [ ] 1if ;
|
|
|
|
: matching-cname? ( query -- rrs/f )
|
|
[ ] [ clone CNAME >>type matching-rrs ] bi ! query rrs
|
|
[ empty? not ]
|
|
[ first swap clone over rdata>> >>name query->rrs swap prefix ]
|
|
[ 2drop f ]
|
|
1if ;
|
|
|
|
: query->rrs ( query -- rrs/f ) { [ matching-rrs? ] [ matching-cname? ] } 1|| ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! have-answers
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: have-answers ( message -- message/f )
|
|
dup message-query query->rrs
|
|
[ empty? ]
|
|
[ 2drop f ]
|
|
[ >>answer-section fill-authority fill-additional ]
|
|
1if ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! have-delegates?
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ;
|
|
|
|
: is-soa? ( name -- ? ) SOA IN query boa matching-rrs empty? not ;
|
|
|
|
: have-ns? ( name -- rrs/f )
|
|
NS IN query boa matching-rrs [ empty? ] [ drop f ] [ ] 1if ;
|
|
|
|
: name->delegates ( name -- rrs-ns )
|
|
{
|
|
[ "" = { } and ]
|
|
[ is-soa? { } and ]
|
|
[ have-ns? ]
|
|
[ cdr-name name->delegates ]
|
|
}
|
|
1|| ;
|
|
|
|
: have-delegates ( message -- message/f )
|
|
dup message-query name>> name->delegates ! message rrs-ns
|
|
[ empty? ]
|
|
[ 2drop f ]
|
|
[
|
|
dup [ rdata>> A IN query boa matching-rrs ] map concat
|
|
! message rrs-ns rrs-a
|
|
[ >>authority-section ]
|
|
[ >>additional-section ]
|
|
bi*
|
|
]
|
|
1if ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! outsize-zones
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: outside-zones ( message -- message/f )
|
|
dup message-query name>> name->zone f =
|
|
[ ]
|
|
[ drop f ]
|
|
if ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
! is-nx
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: is-nx ( message -- message/f )
|
|
[ message-query name>> records [ name>> = ] with filter empty? ]
|
|
[
|
|
NAME-ERROR >>rcode
|
|
dup
|
|
message-query name>> name->zone SOA IN query boa matching-rrs
|
|
>>authority-section
|
|
]
|
|
[ drop f ]
|
|
1if ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: none-of-type ( message -- message )
|
|
dup
|
|
message-query name>> name->zone SOA IN query boa matching-rrs
|
|
>>authority-section ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: find-answer ( message -- message )
|
|
{
|
|
[ have-answers ]
|
|
[ have-delegates ]
|
|
[ outside-zones ]
|
|
[ is-nx ]
|
|
[ none-of-type ]
|
|
}
|
|
1|| ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: (handle-request) ( packet -- )
|
|
[ [ find-answer ] with-message-bytes ] change-data respond ;
|
|
|
|
: handle-request ( packet -- ) [ (handle-request) ] curry in-thread ;
|
|
|
|
: receive-loop ( socket -- )
|
|
[ receive-packet handle-request ] [ receive-loop ] bi ;
|
|
|
|
: loop ( addr-spec -- )
|
|
[ <datagram> '[ _ [ receive-loop ] with-disposal ] try ] [ loop ] bi ;
|
|
|