diff --git a/big-bang-driver.rkt b/big-bang-driver.rkt index 58460c0..4bac855 100644 --- a/big-bang-driver.rkt +++ b/big-bang-driver.rkt @@ -9,12 +9,12 @@ (require "api.rkt") (require "codec.rkt") (require "zonedb.rkt") -(require "network-query.rkt") (require "resolver.rkt") (require "dump-bytes.rkt") (require "os.rkt") (require "os-big-bang.rkt") (require "os-udp.rkt") +(require "os-dns.rkt") ;; Instantiated with a SOA record for the zone it is serving as well ;; as a zone's worth of DNS data which is used to answer queries @@ -29,14 +29,6 @@ ;; determines subzones based on the RRs it is configured with at ;; startup. -(struct bad-dns-packet (detail source sink reason) #:prefab) -(struct dns-request (message source) #:prefab) -(struct dns-reply (message sink) #:prefab) - -;; (define (spy label) -;; (os-big-bang 'none -;; (subscribe 'spy (message-handlers w [x (write `(,label ,x)) (newline)])))) - ;; start-server : UInt16 RR ListOf -> Void ;; Starts a server that will answer questions received on the given ;; UDP port based on the RRs it is given and the zone origin specified @@ -57,7 +49,6 @@ (unsubscribe 'wait-for-server-socket) (spawn (dns-read-driver s)) (spawn (dns-write-driver s)) - ;;(spawn (spy 'DNS-MESSAGE)) (subscribe 'packet-handler (packet-handler s)))])))) (define (packet-handler s) @@ -72,45 +63,15 @@ (ground-vm (os-big-bang (void) (spawn udp-driver) - ;;(spawn (spy 'UDP-MESSAGE)) (spawn (nested-vm boot-server))))) -(define (dns-read-driver s) - (os-big-bang 'no-state - (subscribe 'packet-reader - (meta-message-handlers w - [(udp-packet source (== s) body) - (transition w - (send-message - (with-handlers ((exn:fail? (lambda (e) - (bad-dns-packet body source s - 'unparseable)))) - (define message (packet->dns-message body)) - (case (dns-message-direction message) - ((request) (dns-request message source)) - ((response) (bad-dns-packet message source s - 'unexpected-dns-response))))))])))) - -(define (dns-write-driver s) - (os-big-bang 'no-state - (subscribe 'packet-writer - (message-handlers w - [(dns-reply message sink) - (transition w - (with-handlers ((exn:fail? (lambda (e) - (send-message - (bad-dns-packet message s sink - 'unencodable))))) - (send-meta-message - (udp-packet s sink (dns-message->packet message)))))])))) - (define (first-only xs) (if (null? xs) xs (cons (car xs) '()))) (define (handle-request soa-rr zone request) - (match-define (dns-request request-message request-source) request) + (match-define (dns-request request-message request-source request-sink) request) (define (make-reply name send-name-error? answers authorities additional) (dns-message (dns-message-id request-message) @@ -158,7 +119,7 @@ ;; TODO: check opcode and direction in request ;; TODO: think again about multiple questions in one packet (map (lambda (q) - (dns-reply (answer-question q make-reply) request-source)) + (dns-reply (answer-question q make-reply) request-sink request-source)) (first-only (dns-message-questions request-message)))) (require "test-rrs.rkt") diff --git a/network-query.rkt b/network-query.rkt index 900ab11..6378cda 100644 --- a/network-query.rkt +++ b/network-query.rkt @@ -5,6 +5,9 @@ (require "api.rkt") (require "codec.rkt") (require "zonedb.rkt") +(require "os-big-bang.rkt") +(require "os-udp.rkt") +(require "os-dns.rkt") (provide network-query/addresses) @@ -70,24 +73,23 @@ (match-define (vector a b c d) ip-address) (format "~a.~a.~a.~a" a b c d)) -(define (make-network-query-packet q) - (dns-message->packet - (dns-message (random 65536) - 'request - 'query - 'non-authoritative - 'not-truncated - 'no-recursion-desired - 'no-recursion-available - 'no-error - (list q) - '() - '() - '()))) +(define (make-dns-query-message q) + (dns-message (random 65536) + 'request + 'query + 'non-authoritative + 'not-truncated + 'no-recursion-desired + 'no-recursion-available + 'no-error + (list q) + '() + '() + '())) ;; incorporate-dns-reply : -;; DNSMessage CompiledZone RR ( -> Maybe ) -;; -> Maybe +;; DNSMessage CompiledZone RR +;; -> (or Maybe 'no-answer) ;; ;; Incorporates RRs from the answer, authorities, and additional ;; sections of the passed-in `message` to the passed-in `zone`, @@ -95,10 +97,8 @@ ;; `rr-name` falls in the bailiwick of the given `ns-rr`. All of this ;; only happens if the passed-in message's `dns-message-response-code` ;; is `'no-error`: if it's `'name-error`, then `#f` is returned, and -;; if it's any other code,the `keep-trying` thunk is invoked. (If the -;; caller is `network-query/addresses`, then `keep-trying` will try -;; other servers from the list of IPs available.) -(define (incorporate-dns-reply message zone ns-rr keep-trying) +;; if it's any other code, `'no-answer` is returned. +(define (incorporate-dns-reply message zone ns-rr) (case (dns-message-response-code message) [(no-error) (foldl (lambda (claim-rr zone) @@ -110,53 +110,51 @@ (dns-message-authorities message) (dns-message-additional message)))] [(name-error) #f] - [else (keep-trying)])) + [else 'no-answer])) ;; network-query/addresses : -;; Question CompiledZone RR ListOf -> Maybe +;; UdpAddress Question CompiledZone RR ListOf +;; (Maybe -> ListOf) -> ListOf ;; ;; Repeatedly uses `network-query/addresses/timeout` to try asking the ;; whole of `server-ips` the question `q`, starting with a timeout of ;; `first-timeout` seconds and increasing each time ;; `network-query/addresses/timeout` returns `'no-answer` up to a ;; give-up timeout limit. -(define (network-query/addresses q zone ns-rr server-ips) - (let ((s (udp-open-socket #f #f))) - (let try-with-timeout ((timeout first-timeout)) - (match (network-query/addresses/timeout s q zone ns-rr server-ips timeout) - ['no-answer - (define new-timeout (next-timeout timeout)) - (if new-timeout - (try-with-timeout new-timeout) - zone)] - [result result])))) +(define (network-query/addresses s q zone ns-rr server-ips k) + (let try-with-timeout ((timeout first-timeout)) + (network-query/addresses/timeout s q zone ns-rr server-ips timeout + (lambda (result) + (if (eq? result 'no-answer) + (let ((new-timeout (next-timeout timeout))) + (if new-timeout + (try-with-timeout new-timeout) + (k zone))) + (k result)))))) ;; network-query/addresses/timeout : -;; UdpSocket Question CompiledZone RR ListOf Seconds -;; -> (or Maybe 'no-answer) +;; UdpAddress Question CompiledZone RR ListOf Seconds +;; ((or Maybe 'no-answer) -> ListOf) -> ListOf ;; ;; Sends the question to each of the servers whose addresses are given ;; in `server-ips` using `network-query/address/timeout`, one at a ;; time, in order, trying the next in the list only if `'no-answer` ;; results from the most recent communication attempt. If and when the ;; list is exhausted, `'no-answer` is returned. -(define (network-query/addresses/timeout s q zone ns-rr server-ips timeout) +(define (network-query/addresses/timeout s q zone ns-rr server-ips timeout k) ;; TODO: randomize ordering of servers in list. (let search ((remaining-ips server-ips)) (if (null? remaining-ips) - 'no-answer - (match (network-query/address/timeout s q zone ns-rr (car remaining-ips) timeout) - ['no-answer (search (cdr remaining-ips))] - [result result])))) - -(define (udp-receive/timeout s buffer timeout-seconds) - (sync/timeout timeout-seconds (udp-receive!-evt s buffer))) - -(require racket/pretty) ;; TODO: remove + (k 'no-answer) + (network-query/address/timeout s q zone ns-rr (car remaining-ips) timeout + (lambda (result) + (if (eq? result 'no-answer) + (search (cdr remaining-ips)) + (k result))))))) ;; network-query/address/timeout : -;; UdpSocket Question CompiledZone RR IPv4 Seconds -;; -> (or Maybe 'no-answer) +;; UdpAddress Question CompiledZone RR IPv4 Seconds +;; ((or Maybe 'no-answer) -> ListOf) -> ListOf ;; ;; Sends the question to the server address `server-ip` given. Waits ;; `timeout` seconds for an answer: if one arrives, it is incorporated @@ -164,23 +162,22 @@ ;; result is returned to the caller. If the timeout expires before a ;; reply is received, or some error result is received from the ;; server, `'no-answer` is returned to the caller. -(define (network-query/address/timeout s q zone ns-rr server-ip timeout) +(define (network-query/address/timeout s q zone ns-rr server-ip timeout k) (define server-host-name (ip->host-name server-ip)) (define server-port 53) - (write `(querying ,server-host-name ,server-port with timeout ,timeout)) (newline) - (udp-send-to s server-host-name server-port (make-network-query-packet q)) - (define buffer (make-bytes 512)) ;; maximum DNS reply length - (define result (udp-receive/timeout s buffer timeout)) - ;; TODO: correlate query-ID - ;; TODO: maybe receive only specifically from the queried IP address? - (if result - (let* ((reply-length (car result)) - (packet (subbytes buffer 0 reply-length)) - (reply-message (packet->dns-message packet))) - (pretty-print `(response ,result ,reply-message)) - (incorporate-dns-reply reply-message - zone - ns-rr - (lambda () 'no-answer))) - 'no-answer)) - + (define query (make-dns-query-message q)) + (define req (dns-request query + s + (udp-address server-host-name server-port))) + (define subscription-id (list s (dns-message-id query))) + (list (send-message req) + ;; TODO: timeout! + (subscribe subscription-id + (message-handlers w + [(dns-reply reply-message source (== s)) + ;; TODO: maybe receive only specifically from the queried IP address? + (if (not (= (dns-message-id reply-message) (dns-message-id query))) + w + (transition w + (unsubscribe subscription-id) + (k (incorporate-dns-reply reply-message zone ns-rr))))])))) diff --git a/os-dns.rkt b/os-dns.rkt new file mode 100644 index 0000000..98d2437 --- /dev/null +++ b/os-dns.rkt @@ -0,0 +1,59 @@ +#lang racket/base + +;; DNS drivers using os-big-bang.rkt and os-udp.rkt. + +(require racket/match) +(require "codec.rkt") +(require "os-big-bang.rkt") +(require "os-udp.rkt") + +(provide (struct-out bad-dns-packet) + (struct-out dns-request) + (struct-out dns-reply) + dns-read-driver + dns-write-driver + dns-spy) + +(struct bad-dns-packet (detail source sink reason) #:prefab) +(struct dns-request (message source sink) #:prefab) +(struct dns-reply (message source sink) #:prefab) + +(define (dns-read-driver s) + (os-big-bang 'no-state + (subscribe 'packet-reader + (meta-message-handlers w + [(udp-packet source (== s) body) + (transition w + (send-message + (with-handlers ((exn:fail? (lambda (e) + (bad-dns-packet body source s + 'unparseable)))) + (define message (packet->dns-message body)) + (case (dns-message-direction message) + ((request) (dns-request message source s)) + ((response) (dns-reply message source s))))))])))) + +(define (dns-write-driver s) + (define (translate message sink) + (with-handlers ((exn:fail? (lambda (e) + (send-message (bad-dns-packet message s sink 'unencodable))))) + (send-meta-message (udp-packet s sink (dns-message->packet message))))) + (os-big-bang 'no-state + (subscribe 'packet-writer + (message-handlers w + [(dns-request message (== s) sink) + (transition w (translate message sink))] + [(dns-reply message (== s) sink) + (transition w (translate message sink))])))) + +(require racket/pretty) +(define dns-spy + (os-big-bang 'none + (subscribe 'spy + (message-handlers w + [(dns-request message source sink) + (pretty-display `(DNS (,source asks ,sink) + ,@(dns-message-questions message)))] + [(dns-reply message source sink) + (pretty-display `(DNS (,source answers ,sink) ,message))] + [x (write `(DNS ,x)) (newline)])))) diff --git a/os-udp.rkt b/os-udp.rkt index 998784f..10ba0cf 100644 --- a/os-udp.rkt +++ b/os-udp.rkt @@ -9,7 +9,8 @@ (provide (struct-out udp-address) (struct-out udp-packet) - udp-driver) + udp-driver + udp-spy) ;; A UdpAddress is one of ;; -- a (udp-address String Uint16), representing a remote socket @@ -32,7 +33,9 @@ (define s (udp-open-socket #f #f)) (when port-number (udp-bind! s #f port-number)) - (define sname (udp-address #f port-number)) + (define-values (_local-address local-port _remote-address _remote-port) + (udp-addresses s #t)) + (define sname (udp-address #f local-port)) (spawn (userland (udp-sender sname s))) (spawn (userland (udp-receiver sname s buffer-size))) (spawn (userland (udp-closer sname s))) @@ -44,11 +47,7 @@ [`(close ,(== sname)) (void)] [(udp-packet (== sname) (udp-address host port) body) - (meta-send (lambda () - (printf "<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~n~v~n" body) - (dump-bytes! body (bytes-length body)) - (flush-output) - (udp-send-to s host port body))) + (meta-send (lambda () (udp-send-to s host port body))) (loop)])))) (define ((udp-receiver sname s buffer-size)) @@ -62,9 +61,6 @@ (udp-receive!-evt s buffer) => (list packet-length host port)) (define packet (subbytes buffer 0 packet-length)) - (printf ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>~n~v~n" packet) - (dump-bytes! buffer packet-length) - (flush-output) (send (udp-packet (udp-address host port) sname packet)) (loop)])))) @@ -72,3 +68,15 @@ (wait (message-handlers [`(close ,(== sname)) (udp-close s)]))) + +(define udp-spy + (userland + (lambda () + (let loop () + (wait (message-handlers + [(udp-packet source dest body) + (write `(UDP ,source --> ,dest)) (newline) + (dump-bytes! body (bytes-length body))] + [x + (write `(UDP ,x)) (newline)])) + (loop))))) diff --git a/proxy.rkt b/proxy.rkt index 75e1ee9..807af83 100644 --- a/proxy.rkt +++ b/proxy.rkt @@ -1,218 +1,121 @@ #lang racket/base -;; Simple imperative DNS proxy. +;; DNS proxy using os-big-bang.rkt and os-udp.rkt. -(require racket/unit) (require racket/match) -(require racket/udp) (require racket/set) (require racket/bool) (require "../racket-bitsyntax/main.rkt") (require "api.rkt") (require "codec.rkt") (require "zonedb.rkt") -(require "resolver-unit.rkt") +(require "network-query.rkt") +(require "resolver.rkt") (require "dump-bytes.rkt") -(require "simple-udp-service.rkt") - -(require racket/pretty) - -(define-values/invoke-unit/infer (link resolver@ simple-udp-service-udp-operations@)) +(require "os.rkt") +(require "os-big-bang.rkt") +(require "os-udp.rkt") +(require "os-dns.rkt") ;; Instantiated with a collection of trusted roots to begin its ;; searches from. Performs recursive queries. Doesn't yet cache ;; responses, but will do so in future. -;; An Address can be an (address String Uint16) or #f, where an -;; address struct represents nonlocal UDP sockets, and #f represents -;; the local socket. This way, we don't need to know the IP or port of -;; the local socket, and we can be "multihomed". -(struct address (host port) #:prefab) ;; a UDP IP/port-number combination - -(struct bad-dns-packet (detail source target reason) #:prefab) -(struct world-message (body source target) #:prefab) - -;; ServerState -(struct world (roots continuations) #:prefab) - -(define action-prompt (make-continuation-prompt-tag 'world-action)) - -;; TODO: Avoid attack amplification by not starting work on questions -;; that are already underway - -;; TODO: Timeouts!! - -(define (send/suspend outbound-messages awaken-key) - (call-with-composable-continuation - (lambda (k) - (abort-current-continuation action-prompt - (lambda () (values (lambda (w k) - (values outbound-messages - (struct-copy world w - [continuations (hash-set (world-continuations w) - awaken-key - k)]))) - k)))) - action-prompt)) - -;; ( -> X) ServerState -> X ServerState -;; In this specific instance, X is likely to be ListOf. -(define (run-inferior boot world) - (call-with-continuation-barrier ;; TODO: ??? - (lambda () - (define-values (computation-step-result computation-step-continuation) - (call-with-continuation-prompt (lambda () (values (boot) #f)) action-prompt)) - (cond - ((eq? computation-step-continuation #f) - ;; The computation is finished, and has yielded a result. - (values computation-step-result world)) - (else - ;; The computation is not finished, but is waiting for an - ;; action to complete. - (computation-step-result world computation-step-continuation)))))) - ;; start-proxy : UInt16 ListOf -> Void -;; Starts a proxy service that will answer questions received on the -;; given UDP port based on the NS RRs it is given. -(define (start-proxy port-number raw-roots) - ;; Compile the table of roots - (define roots (compile-zone-db raw-roots)) - (pretty-print roots) +(require racket/pretty) +(define (start-proxy port-number rrs) + ;; Compile the zone hash table + (define zone (compile-zone-db rrs)) + (pretty-print zone) - (define initial-world (world roots (make-immutable-hash))) + (define boot-server + (os-big-bang 'no-state + (spawn dns-spy) + (send-meta-message `(request create-server-socket (udp new ,port-number 512))) + (subscribe 'wait-for-server-socket + (meta-message-handlers w + [`(reply create-server-socket ,s) + (transition w + (unsubscribe 'wait-for-server-socket) + (spawn (dns-read-driver s)) + (spawn (dns-write-driver s)) + (send-meta-message + `(request create-client-socket (udp new 0 512))) + (client-socket-waiter s))])))) - (start-udp-service - port-number - udp-packet->message - outbound-message? - message->udp-packet - (message-handlers old-world - [(? bad-dns-packet? p) - (pretty-print p) - (values '() old-world)] - [(? request-from-downstream? r) - (handle-request r old-world)] - [(? reply-from-upstream? r) - (handle-reply r old-world)]) - (lambda (unhandled state) - (error 'dns-server "Unhandled packet ~v" unhandled)) - initial-world - #:packet-size-limit 512)) + (define (client-socket-waiter s) + (subscribe 'wait-for-client-socket + (meta-message-handlers w + [`(reply create-client-socket ,c) + (transition w + (unsubscribe 'wait-for-client-socket) + (spawn (dns-read-driver c)) + (spawn (dns-write-driver c)) + (subscribe 'packet-handler (packet-handler s c)))]))) -(define (udp-packet->message packet) - (match-define (udp-packet body host port) packet) - (define a (address host port)) - (with-handlers ((exn:fail? (lambda (e) (bad-dns-packet body a #f 'unparseable)))) - (define message (packet->dns-message body)) - (world-message message a #f))) + (define (packet-handler s c) + (message-handlers old-state + [(? bad-dns-packet? p) + (pretty-print p) ;; TODO: perhaps use metalevel events? perhaps don't bother though + old-state] + [(and r (dns-request _ _ (== s))) ;; We only listen for requests on our server socket + (transition old-state (spawn (request-handler zone r c)))])) -(define (message->udp-packet m) - (match-define (world-message body _ (address host port)) m) - (udp-packet (dns-message->packet body) host port)) + (ground-vm (os-big-bang (void) + (spawn udp-spy) + (spawn udp-driver) + (spawn (nested-vm boot-server))))) -(define (local-address? a) - (eq? a #f)) +(define (request-handler zone request client-sock) + ;; 1. try resolving locally + ;; 2. if it answers, send that out. otherwise, it needs to request something recursively. + ;; 3. if the socket doesn't exist, request it, and wait for the reply. + ;; 4. start processing the network query: it will result in a send/receive/timeout combo + ;; 5. on timeout, try a different server, or if there aren't any + ;; more, report failure to the resolver + ;; 6. on packet, report success to the resolver and goto 2. + ;; -. remember to release the socket when we're done! -(define (remote-address? a) - (address? a)) + (match-define (dns-request request-message request-source request-sink) request) + (define question (and (pair? (dns-message-questions request-message)) + (car (dns-message-questions request-message)))) -(define (outbound-message? m) - (and (world-message? m) - (local-address? (world-message-source m)) - (remote-address? (world-message-target m)))) + (define (make-reply answers authorities additional) + (dns-message (dns-message-id request-message) + 'response + 'query + 'non-authoritative + 'not-truncated + (dns-message-recursion-desired request-message) + 'recursion-available + 'no-error + (list question) + (rr-set->list answers) + (rr-set->list authorities) + (rr-set->list additional))) -(define (inbound-message? m) - (and (world-message? m) - (remote-address? (world-message-source m)) - (local-address? (world-message-target m)))) + (define (resolver-actions qr) + (match qr + [(resolver-network-query q zone ns-rr addresses k) ;; need subquestion answered + (write `(INTERMEDIATE ,q ,ns-rr (,(length addresses) addresses))) (newline) + (network-query/addresses client-sock q zone ns-rr addresses + (lambda (qr) (resolver-actions (k qr))))] + [#f ;; got a name-error/NXDOMAIN from some nameserver + ;; TODO: re-examine my reasoning for not sending name-error/NXDOMAIN here + (send-message (dns-reply (make-reply (set) (set) (set)) request-sink request-source))] + [(question-result _ _ anss auths adds) + (send-message (dns-reply (make-reply anss auths adds) request-sink request-source))])) -(define (request-from-downstream? m) - (and (inbound-message? m) - (eq? (dns-message-direction (world-message-body m)) 'request) - (eq? (dns-message-opcode (world-message-body m)) 'query))) + (if (eq? question #f) + (os-big-bang 'no-questions-no-processing-no-answers) + (os-big-bang '??? + (resolver-actions + (resolve-from-zone question + zone + #f ;; no SOA, since we're not authoritative for anything + #t ;; we *are* however recursive. + (set) ;; haven't tried any nameservers yet + values))))) -(define (reply-from-upstream? m) - (and (inbound-message? m) - (eq? (dns-message-direction (world-message-body m)) 'response) - (eq? (dns-message-opcode (world-message-body m)) 'query))) - -(define (handle-request r old-world) - (match-define (world-message (struct* dns-message - ([id query-id] - [recursion-desired recursion-desired] - [questions questions])) - request-source - request-target) - r) - (if (null? questions) - (values '() old-world) - ;; TODO: ignoring all but the car - good? bad? hmm? - (answer-question (car questions) old-world (world-roots old-world) - query-id recursion-desired request-source))) - -;; resolve-iteratively : Question SetOf -> QuestionResult -;; Follows a chain of referrals until it finds an answer to its -;; question. -(define (resolve-iteratively q ns-rrset) - (let search ((seen (set)) - (remaining (set->list ns-rrset))) - (cond - [(null? remaining) #f] ;; no answer available - [(set-member? (car remaining) seen) (search seen (cdr remaining))] - [else - (define first-ns-rr (car remaining)) - (define ns-name (rr-name first-ns-rr)) - (define ns-addr - ....... - Should the main algorithm iterate to solution/fixpoint instead of recursing? - If so, how should it treat cnames? - (pretty-print 'resolve-iteratively) - (define sub-query-id (random 65536) - (define sub-query (dns-message sub-query-id - 'request - 'query - 'non-authoritative - 'not-truncated - #f - 'no-recursion-available - 'no-error - (list q) - (list) - (list) - (list))) - (pretty-print `(back with ,(send/suspend - - (error 'resolve-iteratively "Gah!")) - -;; TODO: Make sure we follow the guidelines and rules for implementing -;; DNS proxies more strictly. -(define (answer-question q w cache query-id recursion-desired request-source) - (define (make-answer ns us ds) - (list (world-message (dns-message query-id - 'response - 'query - 'non-authoritative - 'not-truncated - recursion-desired - 'recursion-available - 'no-error - (list q) - ns - us - ds) - #f - request-source))) - (run-inferior (lambda () - (match (resolve-from-zone q #f cache resolve-iteratively values) - [#f - (make-answer '() '() '())] - [(question-result _ new-cache answers authorities additional) - (make-answer answers authorities additional)])) - w)) - -(define (handle-reply r old-world) - (error 'handle-reply "Unimplemented")) - -(start-proxy 5555 - (list (rr '() 'ns 'in 30 '(#"google-public-dns-a" #"google" #"com")) - (rr '(#"google-public-dns-a" #"google" #"com") 'a 'in 30 '#(8 8 8 8)))) +(require "test-rrs.rkt") +(start-proxy 5555 test-roots) diff --git a/resolver-test.rkt b/resolver-test.rkt index 1be831d..e8dee0d 100644 --- a/resolver-test.rkt +++ b/resolver-test.rkt @@ -11,6 +11,7 @@ (require "zonedb.rkt") (require "network-query.rkt") (require "resolver.rkt") +(require "test-rrs.rkt") ;; (require racket/trace) ;; (trace ;;resolve-from-zone @@ -31,7 +32,8 @@ (match qr [(resolver-network-query q zone ns-rr addresses k) (write `(INTERMEDIATE ,q ,ns-rr (,(length addresses) addresses))) (newline) - (drive-resolver (k (network-query/addresses q zone ns-rr addresses)))] + (network-query/addresses 'foo q zone ns-rr addresses + (lambda (qr) (drive-resolver (k qr))))] [_ qr])) (define (run-question name qtype) @@ -40,15 +42,7 @@ (compile-zone-db ;; (list (rr '() 'ns 'in 30 '(#"google-public-dns-a" #"google" #"com")) ;; (rr '(#"google-public-dns-a" #"google" #"com") 'a 'in 30 '#(8 8 8 8))) - (list (rr '() 'ns 'in 30 '(#"f" #"root-servers" #"net")) - (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(198 41 0 4)) - (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 228 79 201)) - (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 33 4 12)) - (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 203 230 10)) - (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 112 36 4)) - (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(128 63 2 53)) - (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 58 128 30)) - (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(193 0 14 129))) + test-roots ) #f #t diff --git a/resolver.rkt b/resolver.rkt index ae4b038..b06512a 100644 --- a/resolver.rkt +++ b/resolver.rkt @@ -11,6 +11,17 @@ (provide (struct-out resolver-network-query) resolve-from-zone) +;; A ResolverResult is one of +;; -- a QuestionResult, a complete answer to the issued question, or +;; -- a ResolverNetworkQuery, a subquestion that must be answered +;; before resolution can continue. + +;; A ResolverContinuation is a (Maybe -> ResolverResult). + +;; A ResolverNetworkQuery is a (resolver-network-query Question +;; CompiledZone RR ListOf ResolverContinuation), +;; representing a subquestion that must be answered before resolution +;; can continue. (struct resolver-network-query (q zone ns-rr addresses k) #:transparent) ;; Rules: @@ -186,9 +197,11 @@ (question-result q zone ns-rrset - (and start-of-authority (set start-of-authority)) + (if start-of-authority (set start-of-authority) (set)) (additional-section/a zone (set-map ns-rrset rr-rdata)))) +;; TODO: simplify external API here, supplying such as (set) for +;; nameservers-tried and values for k. (define (resolve-from-zone q zone start-of-authority recursion-desired? nameservers-tried k) (answer-from-zone q zone start-of-authority recursion-desired? k @@ -200,7 +213,6 @@ (let ((best-nameserver (random-element best-nameservers))) (network-query q zone best-nameserver (lambda (enhanced-zone) - (write `(BACK-FROM-NETWORK-QUERY (original-question ,q) (best-nameserver ,best-nameserver) (qr ,enhanced-zone))) (newline) (if (eq? enhanced-zone #f) ;; name-error received! (k #f) diff --git a/test-rrs.rkt b/test-rrs.rkt index 03dfaf8..f50b55b 100644 --- a/test-rrs.rkt +++ b/test-rrs.rkt @@ -2,7 +2,7 @@ (require "api.rkt") -(provide test-soa-rr test-rrs) +(provide test-soa-rr test-rrs test-roots) (define test-soa-rr (rr '(#"example") 'soa 'in 30 @@ -25,3 +25,14 @@ (rr '(#"hello" #"example") 'txt 'in 30 '(#"Hello CRASH")) (rr '(#"subzone" #"example") 'ns 'in 30 '(#"subns" #"example")) (rr '(#"subns" #"example") 'a 'in 30 '#(127 0 0 2)))) + +(define test-roots + (list (rr '() 'ns 'in 30 '(#"f" #"root-servers" #"net")) + (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(198 41 0 4)) + (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 228 79 201)) + (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 33 4 12)) + (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 203 230 10)) + (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 112 36 4)) + (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(128 63 2 53)) + (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(192 58 128 30)) + (rr '(#"f" #"root-servers" #"net") 'a 'in 30 '#(193 0 14 129))))