diff --git a/extra/dns/cache/cache.factor b/extra/dns/cache/cache.factor deleted file mode 100644 index 5c4539b913..0000000000 --- a/extra/dns/cache/cache.factor +++ /dev/null @@ -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 ] } " " 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 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - diff --git a/extra/dns/cache/rr/rr.factor b/extra/dns/cache/rr/rr.factor index f3082b124c..77d787ff27 100644 --- a/extra/dns/cache/rr/rr.factor +++ b/extra/dns/cache/rr/rr.factor @@ -39,7 +39,7 @@ TUPLE: 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 diff --git a/extra/dns/forwarding/forwarding.factor b/extra/dns/forwarding/forwarding.factor index 87f9821153..31037c477a 100644 --- a/extra/dns/forwarding/forwarding.factor +++ b/extra/dns/forwarding/forwarding.factor @@ -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 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 ] | -: 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 \ No newline at end of file + ] ; diff --git a/extra/dns/util/util.factor b/extra/dns/util/util.factor index 96cf6c0a1e..9ae7389940 100644 --- a/extra/dns/util/util.factor +++ b/extra/dns/util/util.factor @@ -28,3 +28,6 @@ TUPLE: packet data addr socket ; : respond ( packet -- ) [ data>> ] [ addr>> ] [ socket>> ] tri send ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: forever ( quot -- ) [ call ] [ forever ] bi ; inline recursive \ No newline at end of file