Convert network-query to evented style and implement proxy.

Create os-dns.rkt from code in big-bang-driver.rkt.

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<RR> -> 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")

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)
+(define (make-dns-query-message q)
-  (dns-message->packet
+  (dns-message (random 65536)
-   (dns-message (random 65536)
+	       'request
-		'request
+	       'query
-		'query
+	       'non-authoritative
-		'non-authoritative
+	       'not-truncated
-		'not-truncated
+	       'no-recursion-desired
-		'no-recursion-desired
+	       'no-recursion-available
-		'no-recursion-available
+	       'no-error
-		'no-error
+	       (list q)
-		(list q)
+	       '()
-		'()
+	       '()
-		'()
+	       '()))
-		'())))
 
 ;; incorporate-dns-reply :
-;;   DNSMessage CompiledZone RR<NS> ( -> Maybe<CompiledZone> )
+;;   DNSMessage CompiledZone RR<NS>
-;;   -> Maybe<CompiledZone>
+;;   -> (or Maybe<CompiledZone> '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
+;; if it's any other code, `'no-answer` is returned.
-;; caller is `network-query/addresses`, then `keep-trying` will try
+(define (incorporate-dns-reply message zone ns-rr)
-;; other servers from the list of IPs available.)
-(define (incorporate-dns-reply message zone ns-rr keep-trying)
   (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<NS> ListOf<IPv4> -> Maybe<CompiledZone>
+;;   UdpAddress Question CompiledZone RR<NS> ListOf<IPv4>
+;;     (Maybe<CompiledZone> -> ListOf<Action>) -> ListOf<Action>
 ;;
 ;; 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)
+(define (network-query/addresses s q zone ns-rr server-ips k)
-  (let ((s (udp-open-socket #f #f)))
+  (let try-with-timeout ((timeout first-timeout))
-    (let try-with-timeout ((timeout first-timeout))
+    (network-query/addresses/timeout s q zone ns-rr server-ips timeout
-      (match (network-query/addresses/timeout s q zone ns-rr server-ips timeout)
+     (lambda (result)
-	['no-answer
+       (if (eq? result 'no-answer)
-	 (define new-timeout (next-timeout timeout))
+	   (let ((new-timeout (next-timeout timeout)))
-	 (if new-timeout
+	     (if new-timeout
-	     (try-with-timeout new-timeout)
+		 (try-with-timeout new-timeout)
-	     zone)]
+		 (k zone)))
-	[result result]))))
+	   (k result))))))
 
 ;; network-query/addresses/timeout :
-;;   UdpSocket Question CompiledZone RR<NS> ListOf<IPv4> Seconds
+;;   UdpAddress Question CompiledZone RR<NS> ListOf<IPv4> Seconds
-;;   -> (or Maybe<CompiledZone> 'no-answer)
+;;     ((or Maybe<CompiledZone> 'no-answer) -> ListOf<Action>) -> ListOf<Action>
 ;;
 ;; 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
+	(k 'no-answer)
-	(match (network-query/address/timeout s q zone ns-rr (car remaining-ips) timeout)
+	(network-query/address/timeout s q zone ns-rr (car remaining-ips) timeout
-	  ['no-answer (search (cdr remaining-ips))]
+	 (lambda (result)
-	  [result result]))))
+	   (if (eq? result 'no-answer)
-
+	       (search (cdr remaining-ips))
-(define (udp-receive/timeout s buffer timeout-seconds)
+	       (k result)))))))
-  (sync/timeout timeout-seconds (udp-receive!-evt s buffer)))
-
-(require racket/pretty) ;; TODO: remove
 
 ;; network-query/address/timeout :
-;;   UdpSocket Question CompiledZone RR<NS> IPv4 Seconds
+;;   UdpAddress Question CompiledZone RR<NS> IPv4 Seconds
-;;   -> (or Maybe<CompiledZone> 'no-answer)
+;;     ((or Maybe<CompiledZone> 'no-answer) -> ListOf<Action>) -> ListOf<Action>
 ;;
 ;; 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)
+  (define query (make-dns-query-message q))
-  (udp-send-to s server-host-name server-port (make-network-query-packet q))
+  (define req (dns-request query
-  (define buffer (make-bytes 512)) ;; maximum DNS reply length
+			   s
-  (define result (udp-receive/timeout s buffer timeout))
+			   (udp-address server-host-name server-port)))
-  ;; TODO: correlate query-ID
+  (define subscription-id (list s (dns-message-id query)))
-  ;; TODO: maybe receive only specifically from the queried IP address?
+  (list (send-message req)
-  (if result
+	;; TODO: timeout!
-      (let* ((reply-length (car result))
+	(subscribe subscription-id
-	     (packet (subbytes buffer 0 reply-length))
+		   (message-handlers w
-	     (reply-message (packet->dns-message packet)))
+		    [(dns-reply reply-message source (== s))
-	(pretty-print `(response ,result ,reply-message))
+		     ;; TODO: maybe receive only specifically from the queried IP address?
-	(incorporate-dns-reply reply-message
+		     (if (not (= (dns-message-id reply-message) (dns-message-id query)))
-			       zone
+			 w
-			       ns-rr
+			 (transition w
-			       (lambda () 'no-answer)))
+				     (unsubscribe subscription-id)
-      'no-answer))
+				     (k (incorporate-dns-reply reply-message zone ns-rr))))]))))
-

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)]))))

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 ()
+	    (meta-send (lambda () (udp-send-to s host port body)))
-			 (printf "<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~n~v~n" body)
-			 (dump-bytes! body (bytes-length body))
-			 (flush-output)
-			 (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)))))

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 "os.rkt")
-
+(require "os-big-bang.rkt")
-(require racket/pretty)
+(require "os-udp.rkt")
-
+(require "os-dns.rkt")
-(define-values/invoke-unit/infer (link resolver@ simple-udp-service-udp-operations@))
 
 ;; 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<WorldMessage>.
-(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<RR> -> Void
-;; Starts a proxy service that will answer questions received on the
+(require racket/pretty)
-;; given UDP port based on the NS RRs it is given.
+(define (start-proxy port-number rrs)
-(define (start-proxy port-number raw-roots)
+  ;; Compile the zone hash table
-  ;; Compile the table of roots
+  (define zone (compile-zone-db rrs))
-  (define roots (compile-zone-db raw-roots))
+  (pretty-print zone)
-  (pretty-print roots)
 
-  (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
+  (define (client-socket-waiter s)
-   port-number
+    (subscribe 'wait-for-client-socket
-   udp-packet->message
+	       (meta-message-handlers w
-   outbound-message?
+		[`(reply create-client-socket ,c)
-   message->udp-packet
+		 (transition w
-   (message-handlers old-world
+			     (unsubscribe 'wait-for-client-socket)
-		     [(? bad-dns-packet? p)
+			     (spawn (dns-read-driver c))
-		      (pretty-print p)
+			     (spawn (dns-write-driver c))
-		      (values '() old-world)]
+			     (subscribe 'packet-handler (packet-handler s c)))])))
-		     [(? 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 (udp-packet->message packet)
+  (define (packet-handler s c)
-  (match-define (udp-packet body host port) packet)
+    (message-handlers old-state
-  (define a (address host port))
+     [(? bad-dns-packet? p)
-  (with-handlers ((exn:fail? (lambda (e) (bad-dns-packet body a #f 'unparseable))))
+      (pretty-print p) ;; TODO: perhaps use metalevel events? perhaps don't bother though
-    (define message (packet->dns-message body))
+      old-state]
-    (world-message message a #f)))
+     [(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)
+  (ground-vm (os-big-bang (void)
-  (match-define (world-message body _ (address host port)) m)
+			  (spawn udp-spy)
-  (udp-packet (dns-message->packet body) host port))
+			  (spawn udp-driver)
+			  (spawn (nested-vm boot-server)))))
 
-(define (local-address? a)
+(define (request-handler zone request client-sock)
-  (eq? a #f))
+  ;; 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)
+  (match-define (dns-request request-message request-source request-sink) request)
-  (address? a))
+  (define question (and (pair? (dns-message-questions request-message))
+			(car (dns-message-questions request-message))))
 
-(define (outbound-message? m)
+  (define (make-reply answers authorities additional)
-  (and (world-message? m)
+    (dns-message (dns-message-id request-message)
-       (local-address? (world-message-source m))
+		 'response
-       (remote-address? (world-message-target m))))
+		 '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)
+  (define (resolver-actions qr)
-  (and (world-message? m)
+    (match qr
-       (remote-address? (world-message-source m))
+      [(resolver-network-query q zone ns-rr addresses k) ;; need subquestion answered
-       (local-address? (world-message-target m))))
+       (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)
+  (if (eq? question #f)
-  (and (inbound-message? m)
+      (os-big-bang 'no-questions-no-processing-no-answers)
-       (eq? (dns-message-direction (world-message-body m)) 'request)
+      (os-big-bang '???
-       (eq? (dns-message-opcode (world-message-body m)) 'query)))
+		   (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)
+(require "test-rrs.rkt")
-  (and (inbound-message? m)
+(start-proxy 5555 test-roots)
-       (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<RR> -> 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))))

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"))
+		       test-roots
-			     (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)))
 		       )
 		      #f
 		      #t

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<CompiledZone> -> ResolverResult).
+
+;; A ResolverNetworkQuery is a (resolver-network-query Question
+;; CompiledZone RR<NS> ListOf<IPv4> 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)

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))))