--- /dev/null
+
+USING: kernel assocs locals combinators
+ math math.functions system unicode.case ;
+
+IN: dns.cache.nx
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: nx-cache ( -- table ) H{ } ;
+
+: nx-cache-at ( name -- time ) >lower nx-cache at ;
+: nx-cache-delete-at ( name -- ) >lower nx-cache delete-at ;
+: nx-cache-set-at ( time name -- ) >lower nx-cache set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: now ( -- seconds ) millis 1000.0 / round >integer ;
+
+:: non-existent-name? ( NAME -- ? )
+ [let | TIME [ NAME nx-cache-at ] |
+ {
+ { [ TIME f = ] [ f ] }
+ { [ TIME now <= ] [ NAME nx-cache-delete-at f ] }
+ { [ t ] [ t ] }
+ }
+ cond
+ ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: cache-non-existent-name ( NAME TTL -- )
+ [let | TIME [ TTL now + ] | TIME NAME nx-cache-set-at ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: kernel sequences assocs sets locals combinators
+ accessors system math math.functions unicode.case prettyprint
+ combinators.smart dns ;
+
+IN: dns.cache.rr
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <entry> time data ;
+
+: now ( -- seconds ) millis 1000.0 / round >integer ;
+
+: expired? ( <entry> -- ? ) time>> now <= ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-cache-key ( obj -- key )
+ [ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cache ( -- table ) H{ } ;
+
+: cache-at ( obj -- ent ) make-cache-key cache at ;
+: cache-delete ( obj -- ) make-cache-key cache delete-at ;
+: cache-set-at ( ent obj -- ) make-cache-key cache set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: cache-get ( OBJ -- rrs/f )
+ [let | ENT [ OBJ cache-at ] |
+ {
+ { [ ENT f = ] [ f ] }
+ { [ ENT expired? ] [ OBJ cache-delete f ] }
+ {
+ [ t ]
+ [
+ [let | NAME [ OBJ name>> ]
+ TYPE [ OBJ type>> ]
+ CLASS [ OBJ class>> ]
+ TTL [ ENT time>> now - ] |
+ ENT data>>
+ [| RDATA | T{ rr f NAME TYPE CLASS TTL RDATA } ]
+ map
+ ]
+ ]
+ }
+ }
+ cond
+ ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: cache-add ( RR -- )
+ [let | ENT [ RR cache-at ]
+ TIME [ RR ttl>> now + ]
+ RDATA [ RR rdata>> ] |
+ {
+ { [ ENT f = ] [ T{ <entry> f TIME V{ RDATA } } RR cache-set-at ] }
+ { [ ENT expired? ] [ RR cache-delete RR cache-add ] }
+ { [ t ] [ TIME ENT (>>time) RDATA ENT data>> adjoin ] }
+ }
+ cond
+ ] ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel byte-arrays combinators strings arrays sequences splitting
+ grouping
+ math math.functions math.parser random
+ destructors
+ io io.binary io.sockets io.encodings.binary
+ accessors
+ combinators.smart
+ assocs
+ ;
+
+IN: dns
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: query name type class ;
+
+TUPLE: rr name type class ttl rdata ;
+
+TUPLE: hinfo cpu os ;
+
+TUPLE: mx preference exchange ;
+
+TUPLE: soa mname rname serial refresh retry expire minimum ;
+
+TUPLE: message
+ id qr opcode aa tc rd ra z rcode
+ question-section
+ answer-section
+ authority-section
+ additional-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: random-id ( -- id ) 2 16 ^ random ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! TYPE
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT AAAA ;
+
+: type-table ( -- table )
+ {
+ { A 1 }
+ { NS 2 }
+ { MD 3 }
+ { MF 4 }
+ { CNAME 5 }
+ { SOA 6 }
+ { MB 7 }
+ { MG 8 }
+ { MR 9 }
+ { NULL 10 }
+ { WKS 11 }
+ { PTR 12 }
+ { HINFO 13 }
+ { MINFO 14 }
+ { MX 15 }
+ { TXT 16 }
+ { AAAA 28 }
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! CLASS
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOLS: IN CS CH HS ;
+
+: class-table ( -- table )
+ {
+ { IN 1 }
+ { CS 2 }
+ { CH 3 }
+ { HS 4 }
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! OPCODE
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOLS: QUERY IQUERY STATUS ;
+
+: opcode-table ( -- table )
+ {
+ { QUERY 0 }
+ { IQUERY 1 }
+ { STATUS 2 }
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! RCODE
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
+ REFUSED ;
+
+: rcode-table ( -- table )
+ {
+ { NO-ERROR 0 }
+ { FORMAT-ERROR 1 }
+ { SERVER-FAILURE 2 }
+ { NAME-ERROR 3 }
+ { NOT-IMPLEMENTED 4 }
+ { REFUSED 5 }
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <message> ( -- message )
+ message new
+ random-id >>id
+ 0 >>qr
+ QUERY >>opcode
+ 0 >>aa
+ 0 >>tc
+ 1 >>rd
+ 0 >>ra
+ 0 >>z
+ NO-ERROR >>rcode
+ { } >>question-section
+ { } >>answer-section
+ { } >>authority-section
+ { } >>additional-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 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 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: uint8->ba ( n -- ba ) 1 >be ;
+: uint16->ba ( n -- ba ) 2 >be ;
+: uint32->ba ( n -- ba ) 4 >be ;
+: uint64->ba ( n -- ba ) 8 >be ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dn->ba ( dn -- ba ) "." split [ label->ba ] map concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: query->ba ( query -- ba )
+ [
+ {
+ [ name>> dn->ba ]
+ [ type>> type-table at uint16->ba ]
+ [ class>> class-table at uint16->ba ]
+ } cleave
+ ] output>array concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: hinfo->ba ( rdata -- ba )
+ [ cpu>> label->ba ]
+ [ os>> label->ba ]
+ bi append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mx->ba ( rdata -- ba )
+ [ preference>> uint16->ba ]
+ [ exchange>> dn->ba ]
+ bi append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: soa->ba ( rdata -- ba )
+ [
+ {
+ [ mname>> dn->ba ]
+ [ rname>> dn->ba ]
+ [ serial>> uint32->ba ]
+ [ refresh>> uint32->ba ]
+ [ retry>> uint32->ba ]
+ [ expire>> uint32->ba ]
+ [ minimum>> uint32->ba ]
+ } cleave
+ ] output>array concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rdata->ba ( type rdata -- ba )
+ swap
+ {
+ { CNAME [ dn->ba ] }
+ { HINFO [ hinfo->ba ] }
+ { MX [ mx->ba ] }
+ { NS [ dn->ba ] }
+ { PTR [ dn->ba ] }
+ { SOA [ soa->ba ] }
+ { A [ ip->ba ] }
+ }
+ case ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rr->ba ( rr -- ba )
+ [
+ {
+ [ name>> dn->ba ]
+ [ type>> type-table at uint16->ba ]
+ [ class>> class-table at uint16->ba ]
+ [ ttl>> uint32->ba ]
+ [
+ [ type>> ] [ rdata>> ] bi rdata->ba
+ [ length uint16->ba ] [ ] bi append
+ ]
+ } cleave
+ ] output>array concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: header-bits-ba ( message -- ba )
+ [
+ {
+ [ qr>> 15 shift ]
+ [ opcode>> opcode-table at 11 shift ]
+ [ aa>> 10 shift ]
+ [ tc>> 9 shift ]
+ [ rd>> 8 shift ]
+ [ ra>> 7 shift ]
+ [ z>> 4 shift ]
+ [ rcode>> rcode-table at 0 shift ]
+ } cleave
+ ] sum-outputs uint16->ba ;
+
+: message->ba ( message -- ba )
+ [
+ {
+ [ id>> uint16->ba ]
+ [ header-bits-ba ]
+ [ question-section>> length uint16->ba ]
+ [ answer-section>> length uint16->ba ]
+ [ authority-section>> length uint16->ba ]
+ [ additional-section>> length uint16->ba ]
+ [ question-section>> [ query->ba ] map concat ]
+ [ answer-section>> [ rr->ba ] map concat ]
+ [ authority-section>> [ rr->ba ] map concat ]
+ [ additional-section>> [ rr->ba ] map concat ]
+ } cleave
+ ] output>array concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-single ( ba i -- n ) at ;
+: get-double ( ba i -- n ) dup 2 + subseq be> ;
+: get-quad ( ba i -- n ) dup 4 + subseq be> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: label-length ( ba i -- length ) get-single ;
+
+: skip-label ( ba i -- ba i ) 2dup label-length + 1 + ;
+
+: null-label? ( ba i -- ? ) get-single 0 = ;
+
+: get-label ( ba i -- label ) [ 1 + ] [ skip-label nip ] 2bi subseq >string ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bit-test ( a b -- ? ) bitand 0 = not ;
+
+: pointer? ( ba i -- ? ) get-single BIN: 11000000 bit-test ;
+
+: pointer ( ba i -- val ) get-double BIN: 0011111111111111 bitand ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: skip-name ( ba i -- ba i )
+ {
+ { [ 2dup null-label? ] [ 1 + ] }
+ { [ 2dup pointer? ] [ 2 + ] }
+ { [ t ] [ skip-label skip-name ] }
+ }
+ cond ;
+
+: get-name ( ba i -- name )
+ {
+ { [ 2dup null-label? ] [ 2drop "" ] }
+ { [ 2dup pointer? ] [ dupd pointer get-name ] }
+ {
+ [ t ]
+ [
+ [ get-label ]
+ [ skip-label get-name ]
+ 2bi
+ "." glue
+ ]
+ }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-query ( ba i -- query )
+ [ get-name ]
+ [
+ skip-name
+ [ 0 + get-double type-table value-at ]
+ [ 2 + get-double class-table value-at ]
+ 2bi
+ ]
+ 2bi query boa ;
+
+: skip-query ( ba i -- ba i ) skip-name 4 + ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-mx ( ba i -- mx ) [ get-double ] [ 2 + get-double ] 2bi mx boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-soa ( ba i -- soa )
+ {
+ [ get-name ]
+ [ skip-name get-name ]
+ [
+ skip-name
+ skip-name
+ {
+ [ 0 + get-quad ]
+ [ 4 + get-quad ]
+ [ 8 + get-quad ]
+ [ 12 + get-quad ]
+ [ 16 + get-quad ]
+ }
+ 2cleave
+ ]
+ }
+ 2cleave soa boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 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 ] }
+ { NS [ get-name ] }
+ { PTR [ get-name ] }
+ { MX [ get-mx ] }
+ { SOA [ get-soa ] }
+ { A [ get-ip ] }
+ { AAAA [ get-ipv6 ] }
+ }
+ case ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-rr ( ba i -- rr )
+ [ get-name ]
+ [
+ skip-name
+ {
+ [ 0 + get-double type-table value-at ]
+ [ 2 + get-double class-table value-at ]
+ [ 4 + get-quad ]
+ [ [ 10 + ] [ get-double type-table value-at ] 2bi get-rdata ]
+ }
+ 2cleave
+ ]
+ 2bi rr boa ;
+
+: skip-rr ( ba i -- ba i ) skip-name 8 + 2dup get-double + 2 + ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-question-section ( ba i count -- seq ba i )
+ [ drop [ skip-query ] [ get-query ] 2bi ] map -rot ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-rr-section ( ba i count -- seq ba i )
+ [ drop [ skip-rr ] [ get-rr ] 2bi ] map -rot ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: >> ( x n -- y ) neg shift ;
+
+: get-header-bits ( ba i -- qr opcode aa tc rd ra z rcode )
+ get-double
+ {
+ [ 15 >> BIN: 1 bitand ]
+ [ 11 >> BIN: 111 bitand opcode-table value-at ]
+ [ 10 >> BIN: 1 bitand ]
+ [ 9 >> BIN: 1 bitand ]
+ [ 8 >> BIN: 1 bitand ]
+ [ 7 >> BIN: 1 bitand ]
+ [ 4 >> BIN: 111 bitand ]
+ [ BIN: 1111 bitand rcode-table value-at ]
+ }
+ cleave ;
+
+: parse-message ( ba -- message )
+ 0
+ {
+ [ get-double ]
+ [ 2 + get-header-bits ]
+ [
+ 4 +
+ {
+ [ 8 + ]
+ [ 0 + get-double ]
+ [ 2 + get-double ]
+ [ 4 + get-double ]
+ [ 6 + get-double ]
+ }
+ 2cleave
+ {
+ [ get-question-section ]
+ [ get-rr-section ]
+ [ get-rr-section ]
+ [ get-rr-section ]
+ } spread
+ 2drop
+ ]
+ }
+ 2cleave message boa ;
+
+: ba->message ( ba -- message ) parse-message ;
+
+: with-message-bytes ( ba quot -- ) [ ba->message ] dip call message->ba ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: send-receive-udp ( ba server -- ba )
+ f 0 <inet4> <datagram>
+ [
+ [ send ] [ receive drop ] bi
+ ]
+ with-disposal ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: send-receive-tcp ( ba server -- ba )
+ [ dup length 2 >be prepend ] [ ] bi*
+ binary
+ [
+ write flush
+ 2 read be> read
+ ]
+ with-client ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: >dns-inet4 ( obj -- inet4 )
+ dup string?
+ [ 53 <inet4> ]
+ [ ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ask-server ( message server -- message )
+ [ message->ba ] [ >dns-inet4 ] bi*
+ 2dup
+ send-receive-udp parse-message
+ dup tc>> 1 =
+ [ drop send-receive-tcp parse-message ]
+ [ nip nip ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dns-servers ( -- seq ) V{ } ;
+
+: dns-server ( -- server ) dns-servers random ;
+
+: ask ( message -- message ) dns-server ask-server ;
+
+: query->message ( query -- message ) <message> swap 1array >>question-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: message-query ( message -- query ) question-section>> first ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ERROR: name-error name ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fully-qualified ( name -- name )
+ {
+ { [ dup empty? ] [ "." append ] }
+ { [ dup peek CHAR: . = ] [ ] }
+ { [ t ] [ "." append ] }
+ }
+ cond ;
--- /dev/null
+
+USING: kernel sequences combinators accessors locals random
+ combinators.short-circuit
+ io.sockets
+ dns dns.util dns.cache.rr dns.cache.nx
+ dns.resolver ;
+
+IN: dns.forwarding
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: 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 ] |
+
+ 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
+ ] |
+
+ RRS
+ [ RRS/CNAME RRS append ]
+ [ f ]
+ if
+ ] ] ]
+ ]
+ if
+ ] ]
+ ]
+ if
+ ] ;
+
+:: 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
+ ]
+ ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 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 ;
+
+:: cache-message ( MSG -- msg )
+ MSG rcode>> NAME-ERROR =
+ [
+ [let | RR/SOA [ MSG
+ authority-section>>
+ [ type>> SOA = ] filter
+ dup empty? [ drop f ] [ first ] if ] |
+ RR/SOA
+ [
+ [let | NAME [ MSG message-query name>> ]
+ TTL [ MSG message-soa ttl>> ] |
+ NAME TTL cache-non-existent-name
+ ]
+ ]
+ when
+ ]
+ ]
+ 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 ;
+
+: answer-from-server ( msg servers -- msg ) ask-servers 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> ] |
+
+ [
+ SOCKET receive-packet
+ [ parse-message SERVERS find-answer message->ba ]
+ change-data
+ respond
+ ]
+ forever
+
+ ] ;
--- /dev/null
+
+USING: kernel combinators sequences splitting math
+ io.files io.encodings.utf8 random dns.util ;
+
+IN: dns.misc
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: resolv-conf-servers ( -- seq )
+ "/etc/resolv.conf" utf8 file-lines
+ [ " " split ] map
+ [ first "nameserver" = ] filter
+ [ second ] map ;
+
+: resolv-conf-server ( -- ip ) resolv-conf-servers random ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: domain-has-name? ( domain name -- ? )
+ {
+ { [ 2dup = ] [ 2drop t ] }
+ { [ 2dup longer? ] [ 2drop f ] }
+ { [ t ] [ cdr-name domain-has-name? ] }
+ }
+ cond ;
+
+: name-in-domain? ( name domain -- ? ) swap domain-has-name? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: kernel accessors namespaces continuations
+ io io.sockets io.binary io.timeouts io.encodings.binary
+ destructors
+ locals strings sequences random prettyprint calendar dns dns.misc ;
+
+IN: dns.resolver
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: send-receive-udp ( BA SERVER -- ba )
+ T{ inet4 f f 0 } <datagram>
+ T{ duration { second 3 } } over set-timeout
+ [| SOCKET | BA SERVER SOCKET send SOCKET receive drop ]
+ with-disposal ;
+
+:: send-receive-tcp ( BA SERVER -- ba )
+ [let | BA [ BA length 2 >be BA append ] |
+ SERVER binary
+ [
+ T{ duration { second 3 } } input-stream get set-timeout
+ BA write flush 2 read be> read
+ ]
+ with-client ] ;
+
+:: send-receive-server ( BA SERVER -- msg )
+ [let | RESULT [ BA SERVER send-receive-udp parse-message ] |
+ RESULT tc>> 1 =
+ [ BA SERVER send-receive-tcp parse-message ]
+ [ RESULT ]
+ if ] ;
+
+: >dns-inet4 ( obj -- inet4 ) dup string? [ 53 <inet4> ] [ ] if ;
+
+:: send-receive-servers ( BA SERVERS -- msg )
+ SERVERS empty? [ "send-receive-servers: servers list empty" throw ] when
+ [let | SERVER [ SERVERS random >dns-inet4 ] |
+ ! if this throws an error ...
+ [ BA SERVER send-receive-server ]
+ ! we try with the other servers...
+ [ drop BA SERVER SERVERS remove send-receive-servers ]
+ recover ] ;
+
+:: ask-servers ( MSG SERVERS -- msg )
+ MSG message->ba SERVERS send-receive-servers ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fully-qualified ( name -- name ) dup "." tail? [ ] [ "." append ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dns-servers ( -- seq )
+ \ dns-servers get
+ [ ]
+ [ resolv-conf-servers \ dns-servers set dns-servers ]
+ if* ;
+
+! : dns-server ( -- server ) dns-servers random ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dns-ip4 ( name -- ips )
+ fully-qualified
+ [let | MSG [ A IN query boa query->message dns-servers ask-servers ] |
+ MSG rcode>> NO-ERROR =
+ [ MSG answer-section>> [ type>> A = ] filter [ rdata>> ] map ]
+ [ "dns-ip: rcode = " MSG rcode>> unparse append throw ]
+ if ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+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 ;
+
--- /dev/null
+
+USING: kernel sequences random accessors dns ;
+
+IN: dns.stub
+
+! Stub resolver
+!
+! Generally useful, but particularly when running a forwarding,
+! caching, nameserver on localhost with multiple Factor instances
+! querying it.
+
+: name->ip ( name -- ip )
+ A IN query boa
+ query->message
+ ask
+ dup rcode>> NAME-ERROR =
+ [ message-query name>> name-error ]
+ [ answer-section>> [ type>> A = ] filter random rdata>> ]
+ if ;
+
--- /dev/null
+
+USING: kernel sequences sorting math math.order macros fry ;
+
+IN: dns.util
+
+: tri-chain ( obj p q r -- x y z )
+ [ [ call dup ] dip call dup ] dip call ; inline
+
+MACRO: 1if ( test then else -- ) '[ dup @ _ _ if ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: sort-largest-first ( seq -- seq ) [ [ length ] compare ] sort reverse ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: longer? ( seq seq -- ? ) [ length ] bi@ > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: io.sockets accessors ;
+
+TUPLE: packet data addr socket ;
+
+: receive-packet ( socket -- packet ) [ receive ] keep packet boa ;
+
+: respond ( packet -- ) [ data>> ] [ addr>> ] [ socket>> ] tri send ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: forever ( quot: ( -- ) -- ) [ call ] [ forever ] bi ; inline recursive
\ No newline at end of file
+++ /dev/null
-
-USING: kernel assocs locals combinators
- math math.functions system unicode.case ;
-
-IN: dns.cache.nx
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: nx-cache ( -- table ) H{ } ;
-
-: nx-cache-at ( name -- time ) >lower nx-cache at ;
-: nx-cache-delete-at ( name -- ) >lower nx-cache delete-at ;
-: nx-cache-set-at ( time name -- ) >lower nx-cache set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: now ( -- seconds ) millis 1000.0 / round >integer ;
-
-:: non-existent-name? ( NAME -- ? )
- [let | TIME [ NAME nx-cache-at ] |
- {
- { [ TIME f = ] [ f ] }
- { [ TIME now <= ] [ NAME nx-cache-delete-at f ] }
- { [ t ] [ t ] }
- }
- cond
- ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: cache-non-existent-name ( NAME TTL -- )
- [let | TIME [ TTL now + ] | TIME NAME nx-cache-set-at ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: kernel sequences assocs sets locals combinators
- accessors system math math.functions unicode.case prettyprint
- combinators.smart dns ;
-
-IN: dns.cache.rr
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <entry> time data ;
-
-: now ( -- seconds ) millis 1000.0 / round >integer ;
-
-: expired? ( <entry> -- ? ) time>> now <= ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-cache-key ( obj -- key )
- [ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cache ( -- table ) H{ } ;
-
-: cache-at ( obj -- ent ) make-cache-key cache at ;
-: cache-delete ( obj -- ) make-cache-key cache delete-at ;
-: cache-set-at ( ent obj -- ) make-cache-key cache set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: cache-get ( OBJ -- rrs/f )
- [let | ENT [ OBJ cache-at ] |
- {
- { [ ENT f = ] [ f ] }
- { [ ENT expired? ] [ OBJ cache-delete f ] }
- {
- [ t ]
- [
- [let | NAME [ OBJ name>> ]
- TYPE [ OBJ type>> ]
- CLASS [ OBJ class>> ]
- TTL [ ENT time>> now - ] |
- ENT data>>
- [| RDATA | T{ rr f NAME TYPE CLASS TTL RDATA } ]
- map
- ]
- ]
- }
- }
- cond
- ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: cache-add ( RR -- )
- [let | ENT [ RR cache-at ]
- TIME [ RR ttl>> now + ]
- RDATA [ RR rdata>> ] |
- {
- { [ ENT f = ] [ T{ <entry> f TIME V{ RDATA } } RR cache-set-at ] }
- { [ ENT expired? ] [ RR cache-delete RR cache-add ] }
- { [ t ] [ TIME ENT (>>time) RDATA ENT data>> adjoin ] }
- }
- cond
- ] ;
\ No newline at end of file
+++ /dev/null
-
-USING: kernel byte-arrays combinators strings arrays sequences splitting
- grouping
- math math.functions math.parser random
- destructors
- io io.binary io.sockets io.encodings.binary
- accessors
- combinators.smart
- assocs
- ;
-
-IN: dns
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: query name type class ;
-
-TUPLE: rr name type class ttl rdata ;
-
-TUPLE: hinfo cpu os ;
-
-TUPLE: mx preference exchange ;
-
-TUPLE: soa mname rname serial refresh retry expire minimum ;
-
-TUPLE: message
- id qr opcode aa tc rd ra z rcode
- question-section
- answer-section
- authority-section
- additional-section ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: random-id ( -- id ) 2 16 ^ random ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! TYPE
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT AAAA ;
-
-: type-table ( -- table )
- {
- { A 1 }
- { NS 2 }
- { MD 3 }
- { MF 4 }
- { CNAME 5 }
- { SOA 6 }
- { MB 7 }
- { MG 8 }
- { MR 9 }
- { NULL 10 }
- { WKS 11 }
- { PTR 12 }
- { HINFO 13 }
- { MINFO 14 }
- { MX 15 }
- { TXT 16 }
- { AAAA 28 }
- } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! CLASS
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOLS: IN CS CH HS ;
-
-: class-table ( -- table )
- {
- { IN 1 }
- { CS 2 }
- { CH 3 }
- { HS 4 }
- } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! OPCODE
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOLS: QUERY IQUERY STATUS ;
-
-: opcode-table ( -- table )
- {
- { QUERY 0 }
- { IQUERY 1 }
- { STATUS 2 }
- } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! RCODE
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
- REFUSED ;
-
-: rcode-table ( -- table )
- {
- { NO-ERROR 0 }
- { FORMAT-ERROR 1 }
- { SERVER-FAILURE 2 }
- { NAME-ERROR 3 }
- { NOT-IMPLEMENTED 4 }
- { REFUSED 5 }
- } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: <message> ( -- message )
- message new
- random-id >>id
- 0 >>qr
- QUERY >>opcode
- 0 >>aa
- 0 >>tc
- 1 >>rd
- 0 >>ra
- 0 >>z
- NO-ERROR >>rcode
- { } >>question-section
- { } >>answer-section
- { } >>authority-section
- { } >>additional-section ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: 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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: uint8->ba ( n -- ba ) 1 >be ;
-: uint16->ba ( n -- ba ) 2 >be ;
-: uint32->ba ( n -- ba ) 4 >be ;
-: uint64->ba ( n -- ba ) 8 >be ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dn->ba ( dn -- ba ) "." split [ label->ba ] map concat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: query->ba ( query -- ba )
- [
- {
- [ name>> dn->ba ]
- [ type>> type-table at uint16->ba ]
- [ class>> class-table at uint16->ba ]
- } cleave
- ] output>array concat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: hinfo->ba ( rdata -- ba )
- [ cpu>> label->ba ]
- [ os>> label->ba ]
- bi append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: mx->ba ( rdata -- ba )
- [ preference>> uint16->ba ]
- [ exchange>> dn->ba ]
- bi append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: soa->ba ( rdata -- ba )
- [
- {
- [ mname>> dn->ba ]
- [ rname>> dn->ba ]
- [ serial>> uint32->ba ]
- [ refresh>> uint32->ba ]
- [ retry>> uint32->ba ]
- [ expire>> uint32->ba ]
- [ minimum>> uint32->ba ]
- } cleave
- ] output>array concat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: rdata->ba ( type rdata -- ba )
- swap
- {
- { CNAME [ dn->ba ] }
- { HINFO [ hinfo->ba ] }
- { MX [ mx->ba ] }
- { NS [ dn->ba ] }
- { PTR [ dn->ba ] }
- { SOA [ soa->ba ] }
- { A [ ip->ba ] }
- }
- case ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: rr->ba ( rr -- ba )
- [
- {
- [ name>> dn->ba ]
- [ type>> type-table at uint16->ba ]
- [ class>> class-table at uint16->ba ]
- [ ttl>> uint32->ba ]
- [
- [ type>> ] [ rdata>> ] bi rdata->ba
- [ length uint16->ba ] [ ] bi append
- ]
- } cleave
- ] output>array concat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: header-bits-ba ( message -- ba )
- [
- {
- [ qr>> 15 shift ]
- [ opcode>> opcode-table at 11 shift ]
- [ aa>> 10 shift ]
- [ tc>> 9 shift ]
- [ rd>> 8 shift ]
- [ ra>> 7 shift ]
- [ z>> 4 shift ]
- [ rcode>> rcode-table at 0 shift ]
- } cleave
- ] sum-outputs uint16->ba ;
-
-: message->ba ( message -- ba )
- [
- {
- [ id>> uint16->ba ]
- [ header-bits-ba ]
- [ question-section>> length uint16->ba ]
- [ answer-section>> length uint16->ba ]
- [ authority-section>> length uint16->ba ]
- [ additional-section>> length uint16->ba ]
- [ question-section>> [ query->ba ] map concat ]
- [ answer-section>> [ rr->ba ] map concat ]
- [ authority-section>> [ rr->ba ] map concat ]
- [ additional-section>> [ rr->ba ] map concat ]
- } cleave
- ] output>array concat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-single ( ba i -- n ) at ;
-: get-double ( ba i -- n ) dup 2 + subseq be> ;
-: get-quad ( ba i -- n ) dup 4 + subseq be> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: label-length ( ba i -- length ) get-single ;
-
-: skip-label ( ba i -- ba i ) 2dup label-length + 1 + ;
-
-: null-label? ( ba i -- ? ) get-single 0 = ;
-
-: get-label ( ba i -- label ) [ 1 + ] [ skip-label nip ] 2bi subseq >string ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bit-test ( a b -- ? ) bitand 0 = not ;
-
-: pointer? ( ba i -- ? ) get-single BIN: 11000000 bit-test ;
-
-: pointer ( ba i -- val ) get-double BIN: 0011111111111111 bitand ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: skip-name ( ba i -- ba i )
- {
- { [ 2dup null-label? ] [ 1 + ] }
- { [ 2dup pointer? ] [ 2 + ] }
- { [ t ] [ skip-label skip-name ] }
- }
- cond ;
-
-: get-name ( ba i -- name )
- {
- { [ 2dup null-label? ] [ 2drop "" ] }
- { [ 2dup pointer? ] [ dupd pointer get-name ] }
- {
- [ t ]
- [
- [ get-label ]
- [ skip-label get-name ]
- 2bi
- "." glue
- ]
- }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-query ( ba i -- query )
- [ get-name ]
- [
- skip-name
- [ 0 + get-double type-table value-at ]
- [ 2 + get-double class-table value-at ]
- 2bi
- ]
- 2bi query boa ;
-
-: skip-query ( ba i -- ba i ) skip-name 4 + ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-mx ( ba i -- mx ) [ get-double ] [ 2 + get-double ] 2bi mx boa ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-soa ( ba i -- soa )
- {
- [ get-name ]
- [ skip-name get-name ]
- [
- skip-name
- skip-name
- {
- [ 0 + get-quad ]
- [ 4 + get-quad ]
- [ 8 + get-quad ]
- [ 12 + get-quad ]
- [ 16 + get-quad ]
- }
- 2cleave
- ]
- }
- 2cleave soa boa ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: 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 ] }
- { NS [ get-name ] }
- { PTR [ get-name ] }
- { MX [ get-mx ] }
- { SOA [ get-soa ] }
- { A [ get-ip ] }
- { AAAA [ get-ipv6 ] }
- }
- case ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-rr ( ba i -- rr )
- [ get-name ]
- [
- skip-name
- {
- [ 0 + get-double type-table value-at ]
- [ 2 + get-double class-table value-at ]
- [ 4 + get-quad ]
- [ [ 10 + ] [ get-double type-table value-at ] 2bi get-rdata ]
- }
- 2cleave
- ]
- 2bi rr boa ;
-
-: skip-rr ( ba i -- ba i ) skip-name 8 + 2dup get-double + 2 + ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-question-section ( ba i count -- seq ba i )
- [ drop [ skip-query ] [ get-query ] 2bi ] map -rot ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-rr-section ( ba i count -- seq ba i )
- [ drop [ skip-rr ] [ get-rr ] 2bi ] map -rot ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: >> ( x n -- y ) neg shift ;
-
-: get-header-bits ( ba i -- qr opcode aa tc rd ra z rcode )
- get-double
- {
- [ 15 >> BIN: 1 bitand ]
- [ 11 >> BIN: 111 bitand opcode-table value-at ]
- [ 10 >> BIN: 1 bitand ]
- [ 9 >> BIN: 1 bitand ]
- [ 8 >> BIN: 1 bitand ]
- [ 7 >> BIN: 1 bitand ]
- [ 4 >> BIN: 111 bitand ]
- [ BIN: 1111 bitand rcode-table value-at ]
- }
- cleave ;
-
-: parse-message ( ba -- message )
- 0
- {
- [ get-double ]
- [ 2 + get-header-bits ]
- [
- 4 +
- {
- [ 8 + ]
- [ 0 + get-double ]
- [ 2 + get-double ]
- [ 4 + get-double ]
- [ 6 + get-double ]
- }
- 2cleave
- {
- [ get-question-section ]
- [ get-rr-section ]
- [ get-rr-section ]
- [ get-rr-section ]
- } spread
- 2drop
- ]
- }
- 2cleave message boa ;
-
-: ba->message ( ba -- message ) parse-message ;
-
-: with-message-bytes ( ba quot -- ) [ ba->message ] dip call message->ba ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: send-receive-udp ( ba server -- ba )
- f 0 <inet4> <datagram>
- [
- [ send ] [ receive drop ] bi
- ]
- with-disposal ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: send-receive-tcp ( ba server -- ba )
- [ dup length 2 >be prepend ] [ ] bi*
- binary
- [
- write flush
- 2 read be> read
- ]
- with-client ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: >dns-inet4 ( obj -- inet4 )
- dup string?
- [ 53 <inet4> ]
- [ ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ask-server ( message server -- message )
- [ message->ba ] [ >dns-inet4 ] bi*
- 2dup
- send-receive-udp parse-message
- dup tc>> 1 =
- [ drop send-receive-tcp parse-message ]
- [ nip nip ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dns-servers ( -- seq ) V{ } ;
-
-: dns-server ( -- server ) dns-servers random ;
-
-: ask ( message -- message ) dns-server ask-server ;
-
-: query->message ( query -- message ) <message> swap 1array >>question-section ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: message-query ( message -- query ) question-section>> first ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ERROR: name-error name ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: fully-qualified ( name -- name )
- {
- { [ dup empty? ] [ "." append ] }
- { [ dup peek CHAR: . = ] [ ] }
- { [ t ] [ "." append ] }
- }
- cond ;
+++ /dev/null
-
-USING: kernel sequences combinators accessors locals random
- combinators.short-circuit
- io.sockets
- dns dns.util dns.cache.rr dns.cache.nx
- dns.resolver ;
-
-IN: dns.forwarding
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: 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 ] |
-
- 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
- ] |
-
- RRS
- [ RRS/CNAME RRS append ]
- [ f ]
- if
- ] ] ]
- ]
- if
- ] ]
- ]
- if
- ] ;
-
-:: 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
- ]
- ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: 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 ;
-
-:: cache-message ( MSG -- msg )
- MSG rcode>> NAME-ERROR =
- [
- [let | RR/SOA [ MSG
- authority-section>>
- [ type>> SOA = ] filter
- dup empty? [ drop f ] [ first ] if ] |
- RR/SOA
- [
- [let | NAME [ MSG message-query name>> ]
- TTL [ MSG message-soa ttl>> ] |
- NAME TTL cache-non-existent-name
- ]
- ]
- when
- ]
- ]
- 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 ;
-
-: answer-from-server ( msg servers -- msg ) ask-servers 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> ] |
-
- [
- SOCKET receive-packet
- [ parse-message SERVERS find-answer message->ba ]
- change-data
- respond
- ]
- forever
-
- ] ;
+++ /dev/null
-
-USING: kernel combinators sequences splitting math
- io.files io.encodings.utf8 random dns.util ;
-
-IN: dns.misc
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: resolv-conf-servers ( -- seq )
- "/etc/resolv.conf" utf8 file-lines
- [ " " split ] map
- [ first "nameserver" = ] filter
- [ second ] map ;
-
-: resolv-conf-server ( -- ip ) resolv-conf-servers random ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: domain-has-name? ( domain name -- ? )
- {
- { [ 2dup = ] [ 2drop t ] }
- { [ 2dup longer? ] [ 2drop f ] }
- { [ t ] [ cdr-name domain-has-name? ] }
- }
- cond ;
-
-: name-in-domain? ( name domain -- ? ) swap domain-has-name? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: kernel accessors namespaces continuations
- io io.sockets io.binary io.timeouts io.encodings.binary
- destructors
- locals strings sequences random prettyprint calendar dns dns.misc ;
-
-IN: dns.resolver
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: send-receive-udp ( BA SERVER -- ba )
- T{ inet4 f f 0 } <datagram>
- T{ duration { second 3 } } over set-timeout
- [| SOCKET | BA SERVER SOCKET send SOCKET receive drop ]
- with-disposal ;
-
-:: send-receive-tcp ( BA SERVER -- ba )
- [let | BA [ BA length 2 >be BA append ] |
- SERVER binary
- [
- T{ duration { second 3 } } input-stream get set-timeout
- BA write flush 2 read be> read
- ]
- with-client ] ;
-
-:: send-receive-server ( BA SERVER -- msg )
- [let | RESULT [ BA SERVER send-receive-udp parse-message ] |
- RESULT tc>> 1 =
- [ BA SERVER send-receive-tcp parse-message ]
- [ RESULT ]
- if ] ;
-
-: >dns-inet4 ( obj -- inet4 ) dup string? [ 53 <inet4> ] [ ] if ;
-
-:: send-receive-servers ( BA SERVERS -- msg )
- SERVERS empty? [ "send-receive-servers: servers list empty" throw ] when
- [let | SERVER [ SERVERS random >dns-inet4 ] |
- ! if this throws an error ...
- [ BA SERVER send-receive-server ]
- ! we try with the other servers...
- [ drop BA SERVER SERVERS remove send-receive-servers ]
- recover ] ;
-
-:: ask-servers ( MSG SERVERS -- msg )
- MSG message->ba SERVERS send-receive-servers ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: fully-qualified ( name -- name ) dup "." tail? [ ] [ "." append ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dns-servers ( -- seq )
- \ dns-servers get
- [ ]
- [ resolv-conf-servers \ dns-servers set dns-servers ]
- if* ;
-
-! : dns-server ( -- server ) dns-servers random ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dns-ip4 ( name -- ips )
- fully-qualified
- [let | MSG [ A IN query boa query->message dns-servers ask-servers ] |
- MSG rcode>> NO-ERROR =
- [ MSG answer-section>> [ type>> A = ] filter [ rdata>> ] map ]
- [ "dns-ip: rcode = " MSG rcode>> unparse append throw ]
- if ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: kernel combinators sequences sets math threads namespaces continuations
- debugger io io.sockets unicode.case accessors destructors
- combinators.short-circuit combinators.smart
- newfx 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 prefix-on ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 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 ]
- [ 1st swap clone over rdata>> >>name query->rrs prefix-on ]
- [ 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 ;
-
+++ /dev/null
-
-USING: kernel sequences random accessors dns ;
-
-IN: dns.stub
-
-! Stub resolver
-!
-! Generally useful, but particularly when running a forwarding,
-! caching, nameserver on localhost with multiple Factor instances
-! querying it.
-
-: name->ip ( name -- ip )
- A IN query boa
- query->message
- ask
- dup rcode>> NAME-ERROR =
- [ message-query name>> name-error ]
- [ answer-section>> [ type>> A = ] filter random rdata>> ]
- if ;
-
+++ /dev/null
-
-USING: kernel sequences sorting math math.order macros fry ;
-
-IN: dns.util
-
-: tri-chain ( obj p q r -- x y z )
- [ [ call dup ] dip call dup ] dip call ; inline
-
-MACRO: 1if ( test then else -- ) '[ dup @ _ _ if ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: sort-largest-first ( seq -- seq ) [ [ length ] compare ] sort reverse ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: longer? ( seq seq -- ? ) [ length ] bi@ > ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: io.sockets accessors ;
-
-TUPLE: packet data addr socket ;
-
-: receive-packet ( socket -- packet ) [ receive ] keep packet boa ;
-
-: respond ( packet -- ) [ data>> ] [ addr>> ] [ socket>> ] tri send ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: forever ( quot: ( -- ) -- ) [ call ] [ forever ] bi ; inline recursive
\ No newline at end of file
projects / factor.git / commitdiff