Remove polling support.

TODO

@@ -1,5 +1,3 @@
-## DNS
-
 Make RData and RRType the same thing so it becomes impossible to make
 a mistake.
 
@@ -18,66 +16,3 @@ Tests needed:
     - looping domain-name (using compressed format)
     - compressed domain-name pointing into hyperspace
     - txt record with rdata filled with a list of empty byte-strings
-
-### Proxy
-
-#### Make CNAME NXDOMAIN refer to the target record, not the CNAME itself
-
-See also RFC 2308 section 2.1 and
-http://homepage.ntlworld.com./jonathan.deboynepollard/FGA/dns-response-taxonomy.html
-
-Basically, if the CNAME record is in the response, that's sufficient
-indication that the name of the CNAME exists! So NXDOMAIN clearly
-doesn't make sense to apply there.
-
-#### Should the cache replace SOAs by serial number?
-
-It probably shouldn't cache SOA records at all. Djbdns doesn't.
-("dnscache does not cache SOA records", from http://cr.yp.to/djbdns/dnscache.html)
-
-### Zero-timeout RRs in subqueries
-
-Currently they make it appear that there are no available answers!
-
-E.g. this IN A query for maps.bpl.org. Note the zero-timeout A records
-that come back from dns-lproof2.
-
-    1348086228 DNS: '#s(udp-address "127.0.0.1" 41127) asks '#s(udp-listener 5555) 44280
-    1348086228    : (list (question (domain '(#"maps" #"bpl" #"org") '(#"maps" #"bpl" #"org")) 'a 'in #f))
-    1348086228 dns-vm PID 114447 ((packet-relay #s(active-request #s(udp-address 127.0.0.1 41127) 44280))) started
-    1348086228 DNS: (question (domain '(#"maps" #"bpl" #"org") '(#"maps" #"bpl" #"org")) 'a 'in #f)
-    1348086228 dns-vm PID 114448 ((question-handler #s(question #(struct:domain (maps bpl org) (maps bpl org)) a in #f))) started
-    1348086228 dns-vm PID 114449 ((network-query #s(question #(struct:domain (maps bpl org) (maps bpl org)) a in #f))) started
-    1348086228 DNS: (question (domain '(#"dns-lproof1" #"bpl" #"org") '(#"dns-lproof1" #"bpl" #"org")) 'a 'in (ns-subq (question (domain '(#"maps" #"bpl" #"org") '(#"maps" #"bpl" #"org")) 'a 'in #f)))
-    1348086228 dns-vm PID 114450 ((question-handler #s(question #(struct:domain (dns-lproof1 bpl org) (dns-lproof1 bpl org)) a in #s((ns-subq subquestion 1) #s(question #(struct:domain (maps bpl org) (maps bpl org)) a in #f))))) started
-    1348086228 DNS: (answered-question (question (domain '(#"dns-lproof1" #"bpl" #"org") '(#"dns-lproof1" #"bpl" #"org")) 'a 'in (ns-subq (question (domain '(#"maps" #"bpl" #"org") '(#"maps" #"bpl" #"org")) 'a 'in #f))) (complete-answer (set (rr (domain '(#"dns-lproof1" #"bpl" #"org") '(#"dns-lproof1" #"bpl" #"org")) 'a 'in 9484 '#(192 80 65 2))) (set) (set)))
-    1348086228 dns-vm PID 114450 ((question-handler #s(question #(struct:domain (dns-lproof1 bpl org) (dns-lproof1 bpl org)) a in #s((ns-subq subquestion 1) #s(question #(struct:domain (maps bpl org) (maps bpl org)) a in #f))))) garbage-collected
-    1348086228 DNS: '(request network-query/allocate-query-id441781 allocate-query-id)
-    1348086228 DNS: '(reply network-query/allocate-query-id441781 11080)
-    1348086228 DNS: '#s(udp-handle dns-client) asks '#s(udp-address "192.80.65.2" 53) 11080
-    1348086228    : (list (question (domain '(#"maps" #"bpl" #"org") '(#"maps" #"bpl" #"org")) 'a 'in #f))
-    1348086228 DNS: '#s(set-timer (#s(udp-handle dns-client) 11080) 3000 relative)
-    1348086231 DNS: '#s(timer-expired (#s(udp-handle dns-client) 11080) 1348086231475.239)
-    1348086231 DNS: (question (domain '(#"dns-lproof2" #"bpl" #"org") '(#"dns-lproof2" #"bpl" #"org")) 'a 'in (ns-subq (question (domain '(#"maps" #"bpl" #"org") '(#"maps" #"bpl" #"org")) 'a 'in #f)))
-    1348086231 DNS: '(release-query-id 11080)
-    1348086231 dns-vm PID 114451 ((question-handler #s(question #(struct:domain (dns-lproof2 bpl org) (dns-lproof2 bpl org)) a in #s((ns-subq subquestion 1) #s(question #(struct:domain (maps bpl org) (maps bpl org)) a in #f))))) started
-    1348086231 DNS: (answered-question (question (domain '(#"dns-lproof2" #"bpl" #"org") '(#"dns-lproof2" #"bpl" #"org")) 'a 'in (ns-subq (question (domain '(#"maps" #"bpl" #"org") '(#"maps" #"bpl" #"org")) 'a 'in #f))) (complete-answer (set (rr (domain '(#"dns-lproof2" #"bpl" #"org") '(#"dns-lproof2" #"bpl" #"org")) 'a 'in 9481 '#(216 236 248 2))) (set) (set)))
-    1348086231 dns-vm PID 114451 ((question-handler #s(question #(struct:domain (dns-lproof2 bpl org) (dns-lproof2 bpl org)) a in #s((ns-subq subquestion 1) #s(question #(struct:domain (maps bpl org) (maps bpl org)) a in #f))))) garbage-collected
-    1348086231 DNS: '(request network-query/allocate-query-id441790 allocate-query-id)
-    1348086231 DNS: '(reply network-query/allocate-query-id441790 8847)
-    1348086231 DNS: '#s(udp-handle dns-client) asks '#s(udp-address "216.236.248.2" 53) 8847
-    1348086231    : (list (question (domain '(#"maps" #"bpl" #"org") '(#"maps" #"bpl" #"org")) 'a 'in #f))
-    1348086231 DNS: '#s(set-timer (#s(udp-handle dns-client) 8847) 3000 relative)
-    1348086231 DNS: '#s(udp-address "216.236.248.2" 53) answers '#s(udp-handle dns-client)
-
-    1348086231    : (dns-message 8847 'response 'query 'authoritative 'not-truncated 'no-recursion-desired 'no-recursion-available 'no-error (list (question (domain '(#"maps" #"bpl" #"org") '(#"maps" #"bpl" #"org")) 'a 'in #f)) (list (rr (domain '(#"maps" #"bpl" #"org") '(#"maps" #"bpl" #"org")) 'a 'in 0 '#(216 236 252 42)) (rr (domain '(#"maps" #"bpl" #"org") '(#"maps" #"bpl" #"org")) 'a 'in 0 '#(192 80 65 42))) '() '())
-    1348086231 DNS: (network-reply 'referral441777 (complete-answer (set (rr (domain '(#"maps" #"bpl" #"org") '(#"maps" #"bpl" #"org")) 'a 'in 0 '#(192 80 65 42)) (rr (domain '(#"maps" #"bpl" #"org") '(#"maps" #"bpl" #"org")) 'a 'in 0 '#(216 236 252 42))) (set) (set)))
-    1348086231 DNS: '(release-query-id 8847)
-    1348086231 dns-vm PID 114449 ((network-query #s(question #(struct:domain (maps bpl org) (maps bpl org)) a in #f))) garbage-collected
-    1348086231 DNS: (answered-question (question (domain '(#"maps" #"bpl" #"org") '(#"maps" #"bpl" #"org")) 'a 'in #f) (complete-answer (set) (set) (set)))
-    1348086231 DNS: (set-timer (list 'check-dns-expiry (domain '(#"maps" #"bpl" #"org") '(#"maps" #"bpl" #"org"))) 0 'relative)
-    1348086231 dns-vm PID 114448 ((question-handler #s(question #(struct:domain (maps bpl org) (maps bpl org)) a in #f))) garbage-collected
-    1348086231 DNS: '#s(udp-listener 5555) answers '#s(udp-address "127.0.0.1" 41127)
-    1348086231    : (dns-message 44280 'response 'query 'non-authoritative 'not-truncated 'recursion-desired 'recursion-available 'no-error (list (question (domain '(#"maps" #"bpl" #"org") '(#"maps" #"bpl" #"org")) 'a 'in #f)) '() '() '())
-    1348086231 dns-vm PID 114447 ((packet-relay #s(active-request #s(udp-address 127.0.0.1 41127) 44280))) garbage-collected
-    1348086231 DNS: (timer-expired (list 'check-dns-expiry (domain '(#"maps" #"bpl" #"org") '(#"maps" #"bpl" #"org"))) 1348086231532.27)

api.rkt

@@ -1,27 +1,10 @@
 #lang racket/base
 ;; Definitions for use in the API to the functionality of the library.
 
-(provide (except-out (struct-out domain) domain)
-	 (rename-out [make-domain domain])
-	 domain-root?
-	 domain-parent
-
-	 (struct-out question)
-	 question-cyclic?
-	 question-too-glueless?
-	 question-restarted?
-	 restart-question
-	 cname-question
-	 ns-question
-
-	 (struct-out answered-question)
+(provide (struct-out question)
+	 (struct-out question-result)
 	 (struct-out rr)
 
-	 (struct-out complete-answer)
-	 empty-complete-answer
-	 merge-answers
-	 extract-addresses
-
 	 (struct-out hinfo)
 	 (struct-out minfo)
 	 (struct-out mx)
@@ -35,30 +18,10 @@
 	 qclass->value value->qclass)
 
 (require "mapping.rkt")
-(require racket/set)
-(require racket/match)
 
-;; (These utilities need to be defined ahead of the domain struct
-;; definition.)
-(define (domain=? a b recursive-equal?)
-  (recursive-equal? (domain-downcased-labels a)
-		    (domain-downcased-labels b)))
-
-(define (domain-hash-1/2 d recursive-hash)
-  (recursive-hash (domain-downcased-labels d)))
-
-;; A DomainName is a (domain ListOf<Bytes>), representing a domain
-;; name. The head of the list is the leftmost label; for example,
-;; www.google.com is represented as '(#"www" #"google" #"com").
-(struct domain (labels downcased-labels)
-	#:transparent
-	#:property prop:equal+hash (list domain=? domain-hash-1/2 domain-hash-1/2))
-
-(require "../racket-matrix/struct-map.rkt")
-(install-struct-mapper! struct:domain
-			(lambda (f seed x)
-			  (let-values (((labels seed) (f (domain-labels x) seed)))
-			    (values (make-domain labels) seed))))
+;; A DomainName is a ListOf<Bytes>, representing a domain name. The
+;; head of the list is the leftmost label; for example, www.google.com
+;; is represented as '(#"www" #"google" #"com").
 
 ;; A ShortString is a String with length 255 or shorter.
 
@@ -71,38 +34,21 @@
 ;; is represented as (vector #x20 #x01 #x0d #xb8 #x85 #xa3 #x00 #x00
 ;; #x00 #x00 #x8a #x2e #x03 #x70 #x73 #x34).
 
-;; A Question is a (question DomainName QueryType QueryClass
-;; QuestionContext), representing a DNS question: "What are the RRs
-;; for the given name, type and class?" as well as a possible parent
-;; question that the answer to this question is to contribute to the
-;; answer to.
-(struct question (name type class context) #:prefab)
+;; A Question is a (question DomainName QueryType QueryClass),
+;; representing a DNS question: "What are the RRs for the given name,
+;; type and class?"
+(struct question (name type class) #:transparent)
 
-;; A QuestionContext is one of
-;; -- (cname-subq Question), resulting from the expansion of a CNAME
-;; -- (ns-subq Question), resulting from a network referral
-;; -- #f, an original question from a remote peer
-;; -- 'restart, a restarted question.
-;;
-;; The context is needed to break cycles in the DNS database. If the
-;; context chain ends in 'restart, then the question results from an
-;; excessively-glueless subquestion not represented here, and should
-;; *not* in turn be considered for gluelessness-restarting: this is
-;; needed to avoid a different kind of infinite loop.
-(struct subquestion (parent) #:prefab)
-(struct cname-subq subquestion () #:prefab)
-(struct ns-subq subquestion () #:prefab)
-
-;; An AnsweredQuestion is an (answered-question Question
-;; Maybe<CompleteAnswer>).
-(struct answered-question (q a) #:prefab)
-
-;; A CompleteAnswer is a (complete-answer Set<RR> Set<RR> Set<RR>)
-(struct complete-answer (rrs authorities additional) #:prefab)
+;; A QuestionResult is a (question-result Question CompiledZone
+;; SetOf<RR> SetOf<RR> SetOf<RR>), representing the results of
+;; answering a Question in the context of a given RR database,
+;; possibly after recursively asking other servers for answers.
+(struct question-result (question knowledge answers authorities additional)
+	#:transparent)
 
 ;; An RR is a (rr DomainName RRType RRClass Uint32 RData),
 ;; representing a resource record.
-(struct rr (name type class ttl rdata) #:prefab)
+(struct rr (name type class ttl rdata) #:transparent)
 
 ;; An RData is one of
 ;; - a DomainName, for CNAME, MB, MD, MF, MG, MR, NS and PTR records
@@ -122,12 +68,12 @@
 ;;
 ;; Many of these variants are obsolete in today's DNS database (marked
 ;; [O] above).
-(struct hinfo (cpu os) #:prefab)
-(struct minfo (rmailbx emailbx) #:prefab)
-(struct mx (preference exchange) #:prefab)
-(struct soa (mname rname serial refresh retry expire minimum) #:prefab)
-(struct wks (address protocol bitmap) #:prefab)
-(struct srv (priority weight port target) #:prefab)
+(struct hinfo (cpu os) #:transparent)
+(struct minfo (rmailbx emailbx) #:transparent)
+(struct mx (preference exchange) #:transparent)
+(struct soa (mname rname serial refresh retry expire minimum) #:transparent)
+(struct wks (address protocol bitmap) #:transparent)
+(struct srv (priority weight port target) #:transparent)
 
 ;; An RRType is a Symbol or a Number, one of the possibilities given
 ;; in the following define-mapping. It represents the type of an
@@ -185,125 +131,3 @@
   #:forward-default class->value
   #:backward-default value->class
   (* 255))
-
-;; ListOf<Bytes> -> ListOf<Bytes>
-;; Converts the 7-bit ASCII bytes in the argument to lower-case
-;; equivalents. Used to normalize case for domain-name comparisons.
-(define (downcase-labels labels)
-  (for/list ([label labels])
-    (define b (make-bytes (bytes-length label)))
-    (for ([i (bytes-length label)])
-      (define v (bytes-ref label i))
-      (bytes-set! b i (if (<= 65 v 90) (+ 32 v) v)))
-    b))
-
-;; ListOf<Bytes> -> DomainName
-;; Replacement constructor for domain structs. Automatically downcases
-;; labels appropriately.
-(define (make-domain labels)
-  (domain labels (downcase-labels labels)))
-
-;; DomainName -> Boolean
-(define (domain-root? d)
-  (null? (domain-labels d)))
-
-;; DomainName -> Maybe<DomainName>
-(define (domain-parent d)
-  (and (pair? (domain-labels d))
-       (domain (cdr (domain-labels d))
-	       (cdr (domain-downcased-labels d)))))
-
-;; -> CompleteAnswer
-(define (empty-complete-answer)
-  (complete-answer (set) (set) (set)))
-
-;; CompleteAnswer CompleteAnswer -> CompleteAnswer
-(define (merge-answers a1 a2)
-  (match-define (complete-answer n1 u1 d1) a1)
-  (match-define (complete-answer n2 u2 d2) a2)
-  (complete-answer (set-union n1 n2)
-		   (set-union u1 u2)
-		   (set-union d1 d2)))
-
-;; DomainName Maybe<CompleteAnswer> -> SetOf<IPv4>
-(define (extract-addresses name ans)
-  (match ans
-    [#f ;; name-error/NXDOMAIN, so definitely no addresses.
-     (set)]
-    [(complete-answer ns us ds)
-     (define rrs (set->list (set-union ns us ds)))
-     (let loop ((names (list name))
-		(ips (set))
-		(seen (set)))
-       (if (null? names)
-	   ips
-	   (let* ((name (car names))
-		  (records (filter (lambda (rr) (equal? name (rr-name rr))) rrs)))
-	     (if (set-member? seen name)
-		 (loop (cdr names) ips seen)
-		 (let ((a-records (filter (lambda (rr) (equal? 'a (rr-type rr))) records))
-		       (cname-records (filter (lambda (rr) (equal? 'cname (rr-type rr))) records)))
-		   (loop (append (map rr-rdata cname-records) (cdr names))
-			 (set-union ips (list->set (map rr-rdata a-records)))
-			 (set-add seen name)))))))]))
-
-;; Question -> Boolean
-;; #t iff this question is being asked in order to supply answers
-;; contributing to a parent context that's trying to answer exactly
-;; this question.
-(define (question-cyclic? q)
-  (match-define (question name type class parent) q)
-  (let search ((ancestor parent))
-    (match ancestor
-      [(subquestion (question (== name) (== type) (== class) _)) #t] ;; uh-oh! A cycle!
-      [(subquestion (question _ _ _ ancestor-parent)) (search ancestor-parent)] ;; recursive case
-      [_ #f]))) ;; no further parents -> definitely not cyclic
-
-;; Question -> Boolean
-;; If we're looking up a nameserver's address, in order to look up a
-;; nameserver's address, in order to answer some question, that came
-;; from the outside world, then that's too glueless.  See
-;; http://cr.yp.to/djbdns/notes.html in the sections "Gluelessness"
-;; and "Expiring glue".
-(define (question-too-glueless? q)
-  (define count
-    (let search ((q q) (acc 0))
-      (match-define (question _ _ _ parent) q)
-      (cond
-       [(ns-subq? parent) (search (subquestion-parent parent) (+ acc 1))]
-       [(subquestion? parent) (search (subquestion-parent parent) acc)]
-       [else acc])))
-  (if (>= count 2)
-      ;; We're (at least) at the right nesting level: now see if this
-      ;; question was already the result of a restart. If so, we
-      ;; grimly press on with it unchanged.
-      (not (question-restarted? q))
-      #f))
-
-;; Question -> Boolean
-;; #t iff this question is being asked in the context of some
-;; excessively glueless subquestion.
-(define (question-restarted? q)
-  (match-define (question name type class parent) q)
-  (let search ((ancestor parent))
-    (match ancestor
-      [(subquestion (question _ _ _ ancestor-parent)) (search ancestor-parent)]
-      ['restart #t]
-      [_ #f])))
-
-;; Question -> Question
-;; Returns a question equivalent to q, but in a 'restart context, for
-;; retracing from the roots in cases of excessive gluelessness.
-(define (restart-question q)
-  (struct-copy question q [context 'restart]))
-
-;; DomainName Question -> Question
-;; Produces a new question with CNAME context.
-(define (cname-question name q)
-  (match-define (question _ type class _) q)
-  (question name type class (cname-subq q)))
-
-;; DomainName Question -> Question
-;; Produces a new question with NS context.
-(define (ns-question name q)
-  (question name 'a 'in (ns-subq q))) ;; TODO: 'aaaa ?

codec.rkt

@@ -7,12 +7,7 @@
 	 (struct-out dns-message)
 
 	 packet->dns-message
-	 dns-message->packet
-
-	 max-ttl
-
-	 ;; For the use of zonedb's save/load routines, etc.
-	 t:rr)
+	 dns-message->packet)
 
 (require "api.rkt")
 (require "mapping.rkt")
@@ -60,7 +55,7 @@
 		     answers
 		     authorities
 		     additional)
-	#:prefab)
+	#:transparent)
 
 ;; Bit-syntax type for counted repeats of a value.
 ;; Example: Length-prefixed list of 32-bit unsigned words:
@@ -68,18 +63,19 @@
 ;;   (bit-string (vals :: (t:ntimes bits 32)))
 (define-syntax t:ntimes
   (syntax-rules ()
-    ((_ #t input ks kf times-to-repeat option ...)
-     (let loop ((count times-to-repeat)
-		(acc '())
-		(input input))
-       (cond
-	((positive? count) (bit-string-case input
-			     ([ (v :: option ...) (rest :: binary) ]
-			      (loop (- count 1) (cons v acc) rest))
-			     (else (kf))))
-	(else (ks (reverse acc) input)))))
-    ((_ #f vs option ...)
-     (t:listof #f vs option ...))))
+    ((_ #t times-to-repeat option ...)
+     (lambda (input ks kf)
+       (let loop ((count times-to-repeat)
+		  (acc '())
+		  (input input))
+	 (cond
+	  ((positive? count) (bit-string-case input
+			       ([ (v :: option ...) (rest :: binary) ]
+				(loop (- count 1) (cons v acc) rest))
+			       (else (kf))))
+	  (else (ks (reverse acc) input))))))
+    ((_ #f option ...)
+     (t:listof #f option ...))))
 
 ;; Bit-syntax type for repeats of a value until no more input available.
 ;; Example: List of 32-bit unsigned words:
@@ -87,22 +83,24 @@
 ;;   (bit-string (vals :: (t:listof bits 32)))
 (define-syntax t:listof
   (syntax-rules ()
-    ((_ #t input ks kf option ...)
-     (let loop ((acc '())
-		(input input))
-       (bit-string-case input
-	 ([ (v :: option ...) (rest :: binary) ]
-	  (loop (cons v acc) rest))
-	 ([]
-	  (ks (reverse acc) #""))
-	 (else
-	  (kf)))))
-    ((_ #f vs option ...)
-     (let loop ((vs vs))
-       (cond
-	((pair? vs) (bit-string ((car vs) :: option ...)
-				((loop (cdr vs)) :: binary)))
-	(else (bit-string)))))))
+    ((_ #t option ...)
+     (lambda (input ks kf)
+       (let loop ((acc '())
+		  (input input))
+	 (bit-string-case input
+	   ([ (v :: option ...) (rest :: binary) ]
+	    (loop (cons v acc) rest))
+	   ([]
+	    (ks (reverse acc) #""))
+	   (else
+	    (kf))))))
+    ((_ #f option ...)
+     (lambda (vs)
+       (let loop ((vs vs))
+	 (cond
+	  ((pair? vs) (bit-string ((car vs) :: option ...)
+				  ((loop (cdr vs)) :: binary)))
+	  (else (bit-string))))))))
 
 ;; <rfc1035>
 ;; All communications inside of the domain protocol are carried in a single
@@ -203,18 +201,18 @@
 ;;   (bit-string (v :: (t:named-bit 'zero 'one)))
 (define-syntax t:named-bit
   (syntax-rules ()
-    ((_ #t input ks kf name0 name1)
-     (bit-string-case input
-       ([ (v :: bits 1) (rest :: binary) ]
-	(ks (if (zero? v) name0 name1) rest))
-       (else (kf))))
-    ((_ #f v name0 name1)
-     (cond
-      ((eq? v name1) (bit-string (1 :: bits 1)))
-      ((eq? v name0) (bit-string (0 :: bits 1)))
-      (else (error 't:named-bit
-		   "Value supplied is neither ~v nor ~v: ~v"
-		   name0 name1 v))))))
+    ((_ #t name0 name1) (lambda (input ks kf)
+			  (bit-string-case input
+			    ([ (v :: bits 1) (rest :: binary) ]
+			     (ks (if (zero? v) name0 name1) rest))
+			    (else (kf)))))
+    ((_ #f name0 name1) (lambda (v)
+			  (cond
+			   ((eq? v name1) (bit-string (1 :: bits 1)))
+			   ((eq? v name0) (bit-string (0 :: bits 1)))
+			   (else (error 't:named-bit
+					"Value supplied is neither ~v nor ~v: ~v"
+					name0 name1 v)))))))
 
 ;; Bit-syntax type for a DomainName. When decoding (but not when
 ;; encoding!), we support DNS's weird compressed domain-name syntax;
@@ -222,19 +220,19 @@
 ;; let it refer to random substrings within the packet.
 (define-syntax t:domain-name
   (syntax-rules ()
-    ((_ #t input ks kf whole-packet)
-     (let-values (((name rest) (parse-domain-name whole-packet input '())))
-       (ks (domain name) rest)))
-    ((_ #f val)
-     (encode-domain-name val))))
+    ((_ #t whole-packet)
+     (lambda (input ks kf)
+       (let-values (((name rest) (parse-domain-name whole-packet input '())))
+	 (ks name rest))))
+    ((_ #f)
+     encode-domain-name)))
 
 ;; DomainName -> Bitstring
-(define (encode-domain-name name)
-  (define labels (domain-labels name))
+(define (encode-domain-name labels)
   (bit-string (labels :: (t:listof (t:pascal-string "Label" 64)))
 	      (0 :: integer bytes 1))) ;; end of list of labels!
 
-;; Bytes Bytes ListOf<Natural> -> ListOf<Bytes>
+;; Bytes Bytes ListOf<Natural> -> DomainName
 ;; PRECONDITION: input never empty
 ;; INVARIANT: pointers-followed contains every "jump target" we have
 ;; jumped to so far during decoding of this domain-name, in order to
@@ -268,18 +266,20 @@
 ;; the given maximum, an error is signalled.
 (define-syntax t:pascal-string
   (syntax-rules ()
-    ((_ #t input ks kf)
-     (bit-string-case input
-       ([ len (body :: binary bytes len) (rest :: binary) ]
-	(ks (bit-string->bytes body) rest))
-       (else (kf))))
-    ((_ #f s)
-     (t:pascal-string #f s "Character-string" 256))
-    ((_ #f s string-kind length-limit)
-     (let ((len (bytes-length s)))
-       (when (>= len length-limit)
-	 (error 't:pascal-string "~s too long: ~v" string-kind s))
-       (bit-string len (s :: binary))))))
+    ((_ #t)
+     (lambda (input ks kf)
+       (bit-string-case input
+	 ([ len (body :: binary bytes len) (rest :: binary) ]
+	  (ks (bit-string->bytes body) rest))
+	 (else (kf)))))
+    ((_ #f)
+     (t:pascal-string #f "Character-string" 256))
+    ((_ #f string-kind length-limit)
+     (lambda (s)
+       (let ((len (bytes-length s)))
+	 (when (>= len length-limit)
+	   (error 't:pascal-string "~s too long: ~v" string-kind s))
+	 (bit-string len (s :: binary)))))))
 
 ;; <rfc1035>
 ;; The question section is used to carry the "question" in most queries,
@@ -303,21 +303,22 @@
 ;; whole packet because the question may contain nested domain-names.
 (define-syntax t:question
   (syntax-rules ()
-    ((_ #t input ks kf whole-packet)
-     (bit-string-case input
-       ([ (qname :: (t:domain-name whole-packet))
-	  (qtype :: bits 16)
-	  (qclass :: bits 16)
-	  (tail :: binary) ]
-	(ks (question qname
-		      (value->qtype qtype)
-		      (value->qclass qclass)
-		      #f)
-	    tail))))
-    ((_ #f q)
-     (bit-string ((question-name q) :: (t:domain-name))
-		 ((qtype->value (question-type q)) :: bits 16)
-		 ((qclass->value (question-class q)) :: bits 16)))))
+    ((_ #t whole-packet)
+     (lambda (input ks kf)
+       (bit-string-case input
+	 ([ (qname :: (t:domain-name whole-packet))
+	    (qtype :: bits 16)
+	    (qclass :: bits 16)
+	    (tail :: binary) ]
+	  (ks (question qname
+			(value->qtype qtype)
+			(value->qclass qclass))
+	      tail)))))
+    ((_ #f)
+     (lambda (q)
+       (bit-string ((question-name q) :: (t:domain-name))
+		   ((qtype->value (question-type q)) :: bits 16)
+		   ((qclass->value (question-class q)) :: bits 16))))))
 
 ;; <rfc1035>
 ;; All RRs have the same top level format shown below:
@@ -348,10 +349,11 @@
 ;; packet because the RR may contain nested domain-names.
 (define-syntax t:rr
   (syntax-rules ()
-    ((_ #t input ks kf whole-packet)
-     (decode-rr whole-packet input ks kf))
-    ((_ #f rr)
-     (encode-rr rr))))
+    ((_ #t whole-packet)
+     (lambda (input ks kf)
+       (decode-rr whole-packet input ks kf)))
+    ((_ #f)
+     encode-rr)))
 
 ;; Bytes Bytes (RR Bytes -> A) ( -> A) -> A
 ;; Helper for t:rr.
@@ -462,6 +464,3 @@
 		       ((srv-port rdata) :: bits 16)
 		       ((srv-target rdata) :: (t:domain-name))))
     (else rdata)))
-
-;; UInt32
-(define max-ttl #xffffffff)

driver.rkt

@@ -1,18 +1,16 @@
 #lang racket/base
 
-;; DNS server using os-big-bang.rkt and os-udp.rkt.
+;; Simple imperative DNS server.
 
 (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.rkt")
-(require "../racket-matrix/os2.rkt")
-(require "../racket-matrix/os2-udp.rkt")
-(require "os2-dns.rkt")
+(require "dump-bytes.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
@@ -27,6 +25,36 @@
 ;;    determines subzones based on the RRs it is configured with at
 ;;    startup.
 
+(define (authoritativeness-for dn soa-rr)
+  (if (in-bailiwick? dn (rr-name soa-rr))
+      'authoritative
+      'non-authoritative))
+
+;; ASSUMPTION: r1 and r2 are both DNS replies to the same query.
+;; ASSUMPTION: no response-codes other than no-error or name-error are in use.
+(define (merge-replies r1 r2)
+  (dns-message (dns-message-id r1)
+	       'response
+	       'query
+	       (if (and (eqv? (dns-message-authoritative r1) 'authoritative)
+			(eqv? (dns-message-authoritative r2) 'authoritative))
+		   'authoritative
+		   'non-authoritative)
+	       'not-truncated
+	       (dns-message-recursion-desired r1)
+	       'no-recursion-available
+	       (if (and (eqv? (dns-message-response-code r1) 'name-error)
+			(eqv? (dns-message-response-code r2) 'name-error))
+		   'name-error
+		   'no-error)
+	       (dns-message-questions r1)
+	       (rr-listset-union (dns-message-answers r1) (dns-message-answers r2))
+	       (rr-listset-union (dns-message-authorities r1) (dns-message-authorities r2))
+	       (rr-listset-union (dns-message-additional r1) (dns-message-additional r2))))
+
+(define (rr-listset-union xs1 xs2)
+  (rr-set->list (set-union (list->set xs1) (list->set xs2))))
+
 ;; 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
@@ -35,94 +63,144 @@
 (define (start-server port-number soa-rr rrs)
   ;; Compile the zone hash table
   (define zone (compile-zone-db (cons soa-rr rrs)))
-  (define local-addr (udp-listener port-number))
 
-  (display ";; Ready.\n")
+  (pretty-print zone)
 
-  (ground-vm
-   (transition 'no-state
-     ;; (spawn udp-spy #:debug-name 'udp-spy)
-     (spawn udp-driver #:debug-name 'udp-driver)
-     (spawn (nested-vm #:debug-name 'dns-vm
-	     (transition 'no-state
-	       (spawn dns-spy #:debug-name 'dns-spy)
-	       (spawn (dns-read-driver local-addr) #:debug-name 'dns-read-driver)
-	       (spawn (dns-write-driver local-addr) #:debug-name 'dns-write-driver)
-	       (role (topic-subscriber (bad-dns-packet (wild) (wild) (wild) (wild)))
-		 [p (begin (log-error (pretty-format p))
-			   '())])
-	       (role (topic-subscriber (dns-request (wild) (wild) (wild)))
-		 [r (map send-message (handle-request soa-rr zone r))])))
-	    #:debug-name 'dns-vm))))
+  ;; Set up the socket
+  (define s (udp-open-socket #f #f))
+  (udp-bind! s #f port-number)
 
-(define (handle-request soa-rr zone request)
-  (match-define (dns-request request-message request-source request-sink) request)
+  (define (service-loop)
+    (with-handlers ((exn:break? (lambda (e) (raise e)))
+		    (exn? (lambda (e)
+			    (display "Error in DNS service handler:") (newline)
+			    (write e)
+			    (newline)
+			    (newline))))
+      (read-and-process-request))
+    (service-loop))
 
-  (define (make-reply name send-name-error? answers authorities additional)
-    (dns-message (dns-message-id request-message)
-		 'response
-		 'query
-		 (if (in-bailiwick? name (rr-name soa-rr)) 'authoritative 'non-authoritative)
-		 'not-truncated
-		 (dns-message-recursion-desired request-message)
-		 'no-recursion-available
-		 (if send-name-error? 'name-error 'no-error)
-		 (dns-message-questions request-message)
-		 (rr-set->list answers)
-		 (rr-set->list authorities)
-		 (rr-set->list additional)))
+  (define (read-and-process-request)
+    (define buffer (make-bytes 512))
+    (define-values (packet-length source-hostname source-port)
+      (udp-receive! s buffer))
+
+    (define (send-error error-response-code)
+      (bit-string-case buffer
+	([ (id :: bits 16) (:: binary) ]
+	 (udp-send-to s source-hostname source-port
+		      (dns-message->packet
+		       (dns-message id 'response 'query
+			     'non-authoritative 'not-truncated
+			     'no-recursion-desired 'no-recursion-available
+			     error-response-code '() '() '() '()))))
+	(else
+	 ;; We don't even have enough information in the packet to reply.
+	 (void))))
+
+    (display "----------------------------------------") (newline)
+    (write (subbytes buffer 0 packet-length)) (newline)
+    (dump-bytes! buffer packet-length)
+    (flush-output)
+
+    (define request-message
+      (with-handlers ((exn? (lambda (e)
+			      (send-error 'format-error)
+			      (raise e))))
+	(packet->dns-message (subbytes buffer 0 packet-length))))
+
+    ;;(write request-message) (newline)
+
+    (define (make-reply name send-name-error? answers authorities additional)
+      (dns-message (dns-message-id request-message)
+		   'response
+		   'query
+		   (authoritativeness-for name soa-rr)
+		   'not-truncated
+		   (dns-message-recursion-desired request-message)
+		   'no-recursion-available
+		   (if send-name-error? 'name-error 'no-error)
+		   (dns-message-questions request-message)
+		   (rr-set->list answers)
+		   (rr-set->list authorities)
+		   (rr-set->list additional)))
+
+    (define reply-packet
+      (with-handlers ((exn? (lambda (e)
+			      (send-error 'server-failure)
+			      (raise e))))
+	;; TODO: check opcode and direction in request
+	(define questions (dns-message-questions request-message))
+	(if (null? questions)
+	    #f ;; No questions -> don't send any replies
+	    (begin
+	      ;; TODO: what if there are multiple questions in one
+	      ;; request packet? Single reply, or multiple replies?
+	      ;; Process the additional questions, or ignore them?
+	      ;; djbdns looks like it handles exactly one question per
+	      ;; request, ignoring any excess...
+	      (dns-message->packet (answer-question (car questions) make-reply))))))
+
+    ;; TODO: Truncation
+    (when reply-packet
+      (udp-send-to s source-hostname source-port reply-packet)))
 
   (define (answer-question q make-reply)
-    ;; Notice that we claim to be authoritative for our configured
-    ;; zone. If we ever answer name-error, that means there are no RRs
-    ;; *at all* for the queried name. If there are RRs for the queried
-    ;; name, but they happen not to be the ones asked for, name-error
-    ;; must *not* be returned: instead, a normal no-error reply is
-    ;; sent with an empty answer section.
-    ;;
-    ;; If we wanted to support caching of negative replies, we'd
-    ;; follow the guidelines in section 4.3.4 "Negative response
-    ;; caching" of RFC1034, adding our zone SOA with an appropriate
-    ;; TTL to the additional section of the reply.
-    ;;
-    ;; TODO: We support returning out-of-bailiwick records (glue)
-    ;; here. Reexamine the rules for doing so.
-    (match-define (question qname qtype qclass #f) q)
+    (let resolve ((name (question-name q)))
+      ;; Notice that we claim to be authoritative for our configured
+      ;; zone. If we ever answer name-error, that means there are no
+      ;; RRs *at all* for the queried name. If there are RRs for the
+      ;; queried name, but they happen not to be the ones asked for,
+      ;; name-error must *not* be returned: instead, a normal
+      ;; no-error reply is sent with an empty answer section.
+      ;;
+      ;; If we wanted to support caching of negative replies, we'd
+      ;; follow the guidelines in section 4.3.4 "Negative response
+      ;; caching" of RFC1034, adding our zone SOA with an
+      ;; appropriate TTL to the additional section of the reply.
+      ;;
+      ;; TODO: We support returning out-of-bailiwick records (glue)
+      ;; here. Reexamine the rules for doing so.
+      (cond
+       ((hash-ref zone name #f) =>
+	;; The full name matches in our zone database.
+	(lambda (rrset)
+	  (define filtered-rrs (filter-rrs rrset (question-type q) (question-class q)))
+	  (define cnames (filter-by-type rrset 'cname))
+	  (define base-reply (make-reply name
+					 #f
+					 (set-union cnames filtered-rrs)
+					 (set soa-rr)
+					 (set)))
+	  ;; Algorithm for CNAME expansion from RFC 1034 4.3.2 step 3a.
+	  (if (and (not (set-empty? cnames))
+		   (not (eqv? (question-type q) 'cname)))
+	      (foldl (lambda (cname-rr current-reply)
+		       (merge-replies current-reply
+				      (resolve (rr-rdata cname-rr))))
+		     base-reply
+		     (set->list cnames))
+	      base-reply)))
+       ((referral-for name soa-rr zone) =>
+	;; No full name match, but a referral to somewhere beneath our
+	;; SOA but within our zone.
+	(lambda (ns-rrset)
+	  (make-reply name
+		      #f
+		      ns-rrset
+		      (set soa-rr)
+		      (additional-section/a zone (set-map ns-rrset rr-rdata)))))
+       (else
+	;; Neither a full name match nor a referral is
+	;; available. Answer name-error (NXDOMAIN) if the queried
+	;; name is in-bailiwick, or a normal no-error otherwise.
+	(make-reply name
+		    (in-bailiwick? name (rr-name soa-rr))
+		    (set)
+		    (set)
+		    (set))))))
 
-    (define (expand-cnames worklist ans)
-      (match worklist
-	['()
-	 (match-define (complete-answer ns us ds) ans)
-	 (make-reply qname #f ns us ds)]
-	[(cons next-cname rest)
-	 (define a (resolve-from-zone (question next-cname qtype qclass q) zone soa-rr (set)))
-	 (incorporate-answer a rest ans)]))
-
-    (define (incorporate-answer this-answer worklist ans)
-      (match this-answer
-	[(partial-answer new-info more-cnames)
-	 (expand-cnames (append worklist more-cnames)
-			(merge-answers new-info ans))]
-	[(? complete-answer?)
-	 (expand-cnames worklist
-			(merge-answers this-answer ans))]
-	[_ ;; #f or a referral
-	 (expand-cnames worklist ans)]))
-
-    (match (resolve-from-zone q zone soa-rr (set))
-      [#f ;; Signal name-error/NXDOMAIN
-       (make-reply qname #t (set) (set) (set))]
-      [(referral _ ns-rrs additional)
-       (make-reply qname #f ns-rrs (set soa-rr) additional)]
-      [this-answer
-       (incorporate-answer this-answer '() (empty-complete-answer))]))
-
-  ;; TODO: check opcode and direction in request
-  ;; TODO: think again about multiple questions in one packet
-  (match (dns-message-questions request-message)
-    ['() '()]
-    [(cons q _)
-     (list (dns-reply (answer-question q make-reply) request-sink request-source))]))
+  (service-loop))
 
 (require "test-rrs.rkt")
-(start-server (test-port-number) test-soa-rr test-rrs)
+(start-server 5555 test-soa-rr test-rrs)

dump-bytes.rkt

@@ -0,0 +1,45 @@
+#lang racket/base
+
+(provide dump-bytes!)
+
+(define (hex width n)
+  (define s (number->string n 16))
+  (define slen (string-length s))
+  (cond
+   ((< slen width) (string-append (make-string (- width slen) #\0) s))
+   ((= slen width) s)
+   ((> slen width) (substring s 0 width))))
+
+(define (dump-bytes! bs requested-count)
+  (define count (min requested-count (bytes-length bs)))
+  (define clipped (subbytes bs 0 count))
+  (define (dump-hex i)
+    (if (< i count)
+	(display (hex 2 (bytes-ref clipped i)))
+	(display "  "))
+    (display #\space))
+  (define (dump-char i)
+    (if (< i count)
+	(let ((ch (bytes-ref clipped i)))
+	  (if (<= 32 ch 127)
+	      (display (integer->char ch))
+	      (display #\.)))
+	(display #\space)))
+  (define (for-each-between f low high)
+    (do ((i low (+ i 1)))
+	((= i high))
+      (f i)))
+  (define (dump-line i)
+    (display (hex 8 i))
+    (display #\space)
+    (for-each-between dump-hex i (+ i 8))
+    (display ": ")
+    (for-each-between dump-hex (+ i 8) (+ i 16))
+    (display #\space)
+    (for-each-between dump-char i (+ i 8))
+    (display " : ")
+    (for-each-between dump-char (+ i 8) (+ i 16))
+    (newline))
+  (do ((i 0 (+ i 16)))
+      ((>= i count))
+    (dump-line i)))

experiments/quadratic-choice-evt-fold.rkt

@@ -1,25 +0,0 @@
-(require srfi/1)
-
-(define (c v acc) acc)
-(define (c v acc) (choice-evt never-evt acc))
-(define (c v acc) (choice-evt (handle-evt always-evt void) acc))
-
-(define-values (c1 c2) (values values list))
-(define-values (c1 c2) (values (lambda (i) never-evt) choice-evt))
-(define-values (c1 c2) (values (lambda (i) (handle-evt always-evt void)) choice-evt))
-
-(for-each (lambda (n)
-	    (define limit (* 128 (expt 2 n)))
-	    (write limit)
-	    (newline)
-	    (time (do ((i 0 (+ i 1))
-		       (e never-evt (c i e)))
-		      ((= i limit) e))))
-	  (iota 16))
-
-(for-each (lambda (n)
-	    (define limit (* 128 (expt 2 n)))
-	    (write limit)
-	    (newline)
-	    (time (apply c2 (map c1 (iota limit)))))
-	  (iota 16))

experiments/sfclient.rkt

@@ -1,42 +0,0 @@
-#lang racket/base
-
-(require "os-big-bang.rkt")
-(require "os-udp.rkt")
-(require "os-timer.rkt" racket/match)
-
-(define getter
-  (os-big-bang 'none
-    (send-message `(request create-echo-socket (udp new 0 65536)))
-    (subscribe/fresh sub
-      (message-handlers w
-	[`(reply create-echo-socket ,sname)
-	 (transition w
-	   (unsubscribe sub)
-	   (send-message (udp-packet sname (udp-address "127.0.0.1" 5678) #"get"))
-	   (send-message (set-timer 'timeout 500 #t))
-	   (subscribe 'reply-waiter
-	     (message-handlers w
-	       [(udp-packet source (== sname) reply-bytes)
-		(define counter (integer-bytes->integer reply-bytes #f))
-		(write counter)
-		(newline)
-		(transition w
-		  (send-message 'quit)
-		  (unsubscribe 'reply-waiter))]
-	       [(timer-expired 'timeout _)
-		(write 'timed-out)
-		(newline)
-		(transition w
-		  (send-message 'quit)
-		  (unsubscribe 'reply-waiter))])))]))))
-
-(ground-vm
- (os-big-bang 'none
-   (spawn (os-big-bang 'none
-	    (subscribe 'quit-waiter
-	      (message-handlers w
-		['quit
-		 (exit)]))))
-   (spawn udp-driver)
-   (spawn (timer-driver))
-   (spawn getter)))

experiments/sfclient2.rkt

@@ -1,14 +0,0 @@
-#lang racket/base
-
-(require racket/match)
-(require racket/udp)
-
-(define s (udp-open-socket #f #f))
-(udp-send-to s "127.0.0.1" 5678 #"get")
-(define buffer (make-bytes 8))
-(sync/timeout 0.5
-	      (wrap-evt (udp-receive!-evt s buffer)
-			(match-lambda
-			 [(list 8 _ _)
-			  (write (integer-bytes->integer buffer #f))
-			  (newline)])))

experiments/sfclient3.rkt

@@ -1,24 +0,0 @@
-#lang racket/base
-
-(require racket/match)
-(require racket/udp)
-
-(define s (udp-open-socket #f #f))
-(define buffer (make-bytes 8))
-(define nrepeats 3500)
-
-(for-each
- (lambda (x) (write `(,x milliseconds in ,nrepeats repeats =
-			 ,(exact->inexact (/ x nrepeats)))) (newline))
- (cdr
-  (call-with-values (lambda ()
-		      (time-apply
-		       (lambda ()
-			 (for ([i (in-range nrepeats)])
-			   (udp-send-to s "127.0.0.1" 5678 #"get")
-			   (sync/timeout 0.5
-					 (wrap-evt (udp-receive!-evt s buffer)
-						   (match-lambda
-						    [(list 8 _ _) 'ok])))))
-		       '()))
-    list)))

experiments/sfserver.rkt

@@ -1,25 +0,0 @@
-#lang racket
-
-(require "os-big-bang.rkt")
-(require "os-udp.rkt")
-
-(define counter
-  (os-big-bang 0
-    (send-message `(request create-echo-socket (udp new 5678 65536)))
-    (subscribe/fresh sub
-      (message-handlers current-counter
-	[`(reply create-echo-socket ,sname)
-	 (transition current-counter
-	   (unsubscribe sub)
-	   (subscribe 'packet-handler
-	     (message-handlers current-counter
-	       [(udp-packet source (== sname) #"get")
-		(transition (+ current-counter 1)
-		  (send-message
-		   (udp-packet sname source
-			       (integer->integer-bytes current-counter 8 #f))))])))]))))
-
-(ground-vm
- (os-big-bang 'none
-   (spawn udp-driver)
-   (spawn counter)))

experiments/sfserver2.rkt

@@ -1,29 +0,0 @@
-#lang racket
-
-(require "os-big-bang.rkt")
-(require "os-udp.rkt")
-
-(define (counter server-socket)
-  (os-big-bang 0
-    (subscribe 'packet-handler
-      (message-handlers current-counter
-	[(udp-packet source (== server-socket) #"get")
-	 (transition (+ current-counter 1)
-	   (send-message
-	    (udp-packet server-socket source
-			(integer->integer-bytes current-counter 8 #f))))]))))
-
-(define main
-  (os-big-bang 'no-state
-    (send-message `(request create-echo-socket (udp new 5678 65536)))
-    (subscribe/fresh sub
-      (message-handlers w
-	[`(reply create-echo-socket ,server-socket)
-	 (transition w
-	   (unsubscribe sub)
-	   (spawn (counter server-socket)))]))))
-
-(ground-vm
- (os-big-bang 'none
-   (spawn udp-driver)
-   (spawn main)))

functional-queue.rkt

@@ -0,0 +1,75 @@
+#lang racket/base
+
+(provide make-queue
+	 queue?
+	 enqueue
+	 enqueue-all
+	 dequeue
+	 list->queue
+	 queue->list
+	 queue-length
+	 queue-empty?
+	 queue-append
+	 queue-extract)
+
+(struct queue (head tail) #:transparent)
+
+(define (make-queue)
+  (queue '() '()))
+
+(define (enqueue q v)
+  (queue (queue-head q)
+	 (cons v (queue-tail q))))
+
+(define (enqueue-all q v)
+  (queue (queue-head q)
+	 (append (reverse v) (queue-tail q))))
+
+(define (shuffle q)
+  (if (null? (queue-head q))
+      (queue (reverse (queue-tail q)) '())
+      q))
+
+(define (dequeue q)
+  (let ((q1 (shuffle q)))
+    (values (car (queue-head q1))
+	    (queue (cdr (queue-head q1)) (queue-tail q1)))))
+
+(define (list->queue xs)
+  (queue xs '()))
+
+(define (queue->list q)
+  (append (queue-head q) (reverse (queue-tail q))))
+
+(define (queue-length q)
+  (+ (length (queue-head q))
+     (length (queue-tail q))))
+
+(define (queue-empty? q)
+  (and (null? (queue-head q))
+       (null? (queue-tail q))))
+
+(define (queue-append q1 q2)
+  (queue (append (queue-head q1)
+		 (reverse (queue-tail q1))
+		 (queue-head q2))
+	 (queue-tail q2)))
+
+(define (queue-extract q predicate [default-value #f])
+  (let search-head ((head (queue-head q))
+		    (rejected-head-rev '()))
+    (cond
+     ((null? head) (let search-tail ((tail (reverse (queue-tail q)))
+				     (rejected-tail-rev '()))
+		     (cond
+		      ((null? tail) (values default-value q))
+		      ((predicate (car tail)) (values (car tail)
+						      (queue (queue-head q)
+							     (append (reverse (cdr tail))
+								     rejected-tail-rev))))
+		      (else (search-tail (cdr tail) (cons (car tail) rejected-tail-rev))))))
+     ((predicate (car head)) (values (car head)
+				     (queue (append (reverse rejected-head-rev)
+						    (cdr head))
+					    (queue-tail q))))
+     (else (search-head (cdr head) (cons (car head) rejected-head-rev))))))

ground-udp-operations-unit.rkt

@@ -0,0 +1,14 @@
+#lang racket/unit
+
+(require (prefix-in r: racket/udp))
+(require "udp-operations-sig.rkt")
+
+(import)
+(export udp-operations^)
+
+(define udp-open-socket r:udp-open-socket)
+(define udp-close r:udp-close)
+(define udp-bind! r:udp-bind!)
+(define udp-send-to r:udp-send-to)
+(define (udp-receive/timeout s buffer timeout-seconds)
+  (sync/timeout timeout-seconds (r:udp-receive!-evt s buffer)))

network-query-sig.rkt

@@ -0,0 +1,3 @@
+#lang racket/signature
+
+network-query/addresses ;; Question CompiledZone NS-RR ListOf<IPv4> -> Maybe<CompiledZone>

network-query-unit.rkt

@@ -0,0 +1,185 @@
+#lang racket/unit
+
+(require racket/pretty)
+
+(require racket/match)
+(require "api.rkt")
+(require "codec.rkt")
+(require "zonedb.rkt")
+(require "udp-operations-sig.rkt")
+(require "network-query-sig.rkt")
+
+(import udp-operations^)
+(export network-query^)
+
+;; DJB's rules for handling DNS responses. Some of these are handled
+;; here (specifically, rules 2 through 5, in the action of
+;; incorporate-dns-reply), some are handled in resolver-unit.rkt (rule
+;; 1, in the action of answer-from-zone):
+
+;; <blockquote>
+;; When a cache receives a normal DNS response, it learns exactly one
+;; of the following five pieces of information:
+;;
+;; 1. ``The query was not answered because the query name is an
+;; alias. I need to change the query name and try again.'' This
+;; applies if the answer section of the response contains a CNAME
+;; record for the query name and CNAME does not match the query type.
+;;
+;; 2. ``The query name has no records answering the query, and is also
+;; guaranteed to have no records of any other type.'' This applies if
+;; the response code is NXDOMAIN and #1 doesn't apply. The amount of
+;; time that this information can be cached depends on the contents of
+;; the SOA record in the authority section of the response, if there
+;; is one.
+;;
+;; 3. ``The query name has one or more records answering the query.''
+;; This applies if the answer section of the response contains one or
+;; more records under the query name matching the query type, and #1
+;; doesn't apply, and #2 doesn't apply.
+;;
+;; 4. ``The query was not answered because the server does not have
+;; the answer. I need to contact other servers.'' This applies if the
+;; authority section of the response contains NS records, and the
+;; authority section of the response does not contain SOA records, and
+;; #1 doesn't apply, and #2 doesn't apply, and #3 doesn't apply. The
+;; ``other servers'' are named in the NS records in the authority
+;; section.
+;;
+;; 5. ``The query name has no records answering the query, but it may
+;; have records of another type.'' This applies if #1 doesn't apply,
+;; and #2 doesn't apply, and #3 doesn't apply, and #4 doesn't
+;; apply. The amount of time that this information can be cached
+;; depends on the contents of the SOA record in the authority section,
+;; if there is one.
+;;
+;; This procedure requires an incredible amount of bug-prone parsing
+;; for a very small amount of information. The underlying problem is
+;; that DNS was designed to declare information in a human-oriented
+;; format, rather than to support crucial operations in the simplest
+;; possible way.
+;; </blockquote>
+
+(define first-timeout 3) ;; seconds
+
+;; seconds -> Maybe<seconds>
+(define (next-timeout timeout)
+  (case timeout
+    ((3) 11)
+    ((11) 45)
+    ((45) #f)))
+
+;; IPv4 -> String
+(define (ip->host-name ip-address)
+  (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)
+		'()
+		'()
+		'())))
+
+;; incorporate-dns-reply :
+;;   DNSMessage CompiledZone RR<NS> ( -> Maybe<CompiledZone> )
+;;   -> Maybe<CompiledZone>
+;;
+;; Incorporates RRs from the answer, authorities, and additional
+;; sections of the passed-in `message` to the passed-in `zone`,
+;; returning the augmented zone. RRs are only incorporated if their
+;; `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)
+  (case (dns-message-response-code message)
+    [(no-error) 
+     (foldl (lambda (claim-rr zone)
+	      (if (in-bailiwick? (rr-name claim-rr) ns-rr)
+		  (incorporate-rr claim-rr zone)
+		  zone))
+	    zone
+	    (append (dns-message-answers message)
+		    (dns-message-authorities message)
+		    (dns-message-additional message)))]
+    [(name-error) #f]
+    [else (keep-trying)]))
+
+;; network-query/addresses :
+;;   Question CompiledZone RR<NS> ListOf<IPv4> -> Maybe<CompiledZone>
+;;
+;; 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]))))
+
+;; network-query/addresses/timeout :
+;;   UdpSocket Question CompiledZone RR<NS> ListOf<IPv4> Seconds
+;;   -> (or Maybe<CompiledZone> 'no-answer)
+;;
+;; 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)
+  ;; 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]))))
+
+;; network-query/address/timeout :
+;;   UdpSocket Question CompiledZone RR<NS> IPv4 Seconds
+;;   -> (or Maybe<CompiledZone> 'no-answer)
+;;
+;; Sends the question to the server address `server-ip` given. Waits
+;; `timeout` seconds for an answer: if one arrives, it is incorporated
+;; into the passed-in `zone` (using `incorporate-dns-reply`), and the
+;; 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 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))
+

network-query.rkt

@@ -1,341 +0,0 @@
-#lang racket/base
-
-(require racket/set)
-(require racket/match)
-(require "api.rkt")
-(require "codec.rkt")
-(require "zonedb.rkt")
-(require "../racket-matrix/os2.rkt")
-(require "../racket-matrix/os2-udp.rkt")
-(require "../racket-matrix/os2-timer.rkt")
-(require "os2-dns.rkt")
-
-(provide network-query
-	 (struct-out network-reply))
-
-;; DJB's rules for handling DNS responses. Some of these are handled
-;; here (specifically, rules 2 through 5, in the action of
-;; filter-dns-reply), some are handled in resolver.rkt (rule 1, in the
-;; action of answer-from-zone), and some are handled in the
-;; interaction between the resolver and the network-query modules
-;; (rule 1 as well, the interplay between CNAME expansion and
-;; recursion):
-
-;; <blockquote>
-;; When a cache receives a normal DNS response, it learns exactly one
-;; of the following five pieces of information:
-;;
-;; 1. ``The query was not answered because the query name is an
-;; alias. I need to change the query name and try again.'' This
-;; applies if the answer section of the response contains a CNAME
-;; record for the query name and CNAME does not match the query type.
-;;
-;; 2. ``The query name has no records answering the query, and is also
-;; guaranteed to have no records of any other type.'' This applies if
-;; the response code is NXDOMAIN and #1 doesn't apply. The amount of
-;; time that this information can be cached depends on the contents of
-;; the SOA record in the authority section of the response, if there
-;; is one.
-;;
-;; 3. ``The query name has one or more records answering the query.''
-;; This applies if the answer section of the response contains one or
-;; more records under the query name matching the query type, and #1
-;; doesn't apply, and #2 doesn't apply.
-;;
-;; 4. ``The query was not answered because the server does not have
-;; the answer. I need to contact other servers.'' This applies if the
-;; authority section of the response contains NS records, and the
-;; authority section of the response does not contain SOA records, and
-;; #1 doesn't apply, and #2 doesn't apply, and #3 doesn't apply. The
-;; ``other servers'' are named in the NS records in the authority
-;; section.
-;;
-;; 5. ``The query name has no records answering the query, but it may
-;; have records of another type.'' This applies if #1 doesn't apply,
-;; and #2 doesn't apply, and #3 doesn't apply, and #4 doesn't
-;; apply. The amount of time that this information can be cached
-;; depends on the contents of the SOA record in the authority section,
-;; if there is one.
-;;
-;; This procedure requires an incredible amount of bug-prone parsing
-;; for a very small amount of information. The underlying problem is
-;; that DNS was designed to declare information in a human-oriented
-;; format, rather than to support crucial operations in the simplest
-;; possible way.
-;; </blockquote>
-
-;;---------------------------------------------------------------------------
-
-;; DJB's djbdns logic for determining whether a response is a lame
-;; referral or not is as follows (see his query.c in areas dealing
-;; with the variable "flagreferral" and calls to the function
-;; "log_lame"):
-;;
-;; If a response -
-;;
-;; 1. has response-code no-error (0), and
-;; 2. has no CNAME records in the answer section for the domain we're
-;;    interested in, and
-;; 3. has no records in the answer section for the domain and type
-;;    we're interested in, and
-;; 4. has no SOA records in the authority section, and
-;; 5. has at least one NS record in the authority section, and
-;; 6. that NS record's name is equal to our bailiwick or is not in our
-;;    bailiwick,
-;;
-;; then it is a lame referral.
-;;
-;; Anything with non-zero response-code is clearly not a referral, so
-;; that explains (1). If either of checks (2) and (3) fail then the
-;; answer is a real, sensible answer to the question we posed. I'm not
-;; 100% on why (4) is there; presumably it's to be conservative, and
-;; not treat something possibly-valid as definitely-lame? Rules (5)
-;; and (6) are the real heart of lameness, where a referral is given
-;; to somewhere that can't be more authoritative than the responder
-;; was supposed to be.
-;;
-;; We modify check (4) to ignore SOA records not in bailiwick, just
-;; for consistency. It's correct to leave (5) and (6) alone because
-;; it's incorrect for a server to refer us to anywhere at the same
-;; level of the tree or further up the tree, but we do apply them to
-;; every NS record rather than just the first, which is slightly
-;; stricter than DJB's rule.
-
-;;---------------------------------------------------------------------------
-
-;; A NetworkQueryResult is a ListOf<Action>, some actions to take:
-;; either involved in or resulting from completion of the network
-;; query.
-
-(define first-timeout 3) ;; seconds
-
-;; A NetworkRequest is a (network-request UdpAddress Question
-;; DomainName NEListOf<DomainName> UniqueID) representing the
-;; parameters used to start and process a network query.
-(struct network-request (client-socket
-			 question
-			 zone-origin
-			 server-names
-			 unique-id)
-	#:prefab)
-
-;; A NetworkReply is a (network-reply UniqueID Maybe<CompleteAnswer>)
-;; representing the final result of a network query.
-(struct network-reply (unique-id answer) #:prefab)
-
-;; A NetworkQueryState is a (network-query-state NetworkRequest
-;; Integer Map<DomainName,ListOf<UdpAddress>> ListOf<UdpAddress>
-;; Maybe<DomainName> ListOf<DomainName>), representing an in-progress
-;; DNS network query.
-(struct network-query-state (request
-			     timeout
-			     known-addresses
-			     remaining-addresses
-			     current-name
-			     remaining-names)
-	#:prefab)
-
-;; seconds -> Maybe<seconds>
-(define (next-timeout timeout)
-  (case timeout
-    ((3) 11)
-    ((11) 45)
-    ((45) #f)))
-
-(define (make-dns-query-message q query-id)
-  (dns-message query-id
-	       'request
-	       'query
-	       'non-authoritative
-	       'not-truncated
-	       'no-recursion-desired
-	       'no-recursion-available
-	       'no-error
-	       (list q)
-	       '()
-	       '()
-	       '()))
-
-;; filter-dns-reply : Question DNSMessage DomainName
-;;   -> (or Maybe<CompleteAnswer> 'bad-answer 'lame-delegation)
-;;
-;; Filters RRs from the answer, authorities, and additional sections
-;; of the passed-in `message`, returning the set of RRs surviving the
-;; filter. RRs are only accepted if their `rr-name` falls in the
-;; bailiwick of the given `zone-origin`. 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, `'bad-answer` is returned.
-;;
-;; In cases where a CompleteAnswer would otherwise be returned, if the
-;; answer is in fact a lame delegation (see notes above), then
-;; 'lame-delegation is returned instead.
-(define (filter-dns-reply q message zone-origin)
-  (case (dns-message-response-code message)
-    [(no-error)
-     (define (f l)
-       (list->set (filter (lambda (claim-rr) (in-bailiwick? (rr-name claim-rr) zone-origin)) l)))
-     ;; Here's where we do the "lame referral" check. This code is
-     ;; nice and simple (though wrong) without it. Ho hum.
-     (define answers (f (dns-message-answers message)))
-     (define unfiltered-authorities (dns-message-authorities message))
-     (define non-subzone-ns-rrs ;; all NS authorities not for a STRICT subzone of our zone-origin
-       (filter (lambda (rr) (and (eqv? (rr-type rr) 'ns)
-				 (or (equal? (rr-name rr) zone-origin)
-				     (not (in-bailiwick? (rr-name rr) zone-origin)))))
-	       unfiltered-authorities))
-     (define authorities (f unfiltered-authorities))
-     (define answers-to-q ;; answers specifically to the question we asked
-       (set-filter (lambda (rr) (equal? (rr-name rr) (question-name q))) answers))
-     (define lame?
-       (and (set-empty? (filter-by-type answers-to-q 'cname))
-	    (set-empty? (filter-rrs answers-to-q (question-type q) (question-class q)))
-	    (set-empty? (filter-by-type authorities 'soa))
-	    (not (null? non-subzone-ns-rrs))))
-     (if lame?
-	 'lame-delegation
-	 (complete-answer answers
-			  authorities
-			  (f (dns-message-additional message))))]
-    [(name-error) #f]
-    [else
-     (log-info (format "Abnormal response-code ~v in response to questions ~v"
-		       (dns-message-response-code message)
-		       (dns-message-questions message)))
-     'bad-answer]))
-
-;; IPv4 -> String
-(define (ip->host-name ip-address)
-  (match-define (vector a b c d) ip-address)
-  (format "~a.~a.~a.~a" a b c d))
-
-(define (make-dns-address ip-address)
-  (udp-address (ip->host-name ip-address) 53))
-
-;; network-query : UdpAddress Question DomainName NEListOf<DomainName> UniqueId -> BootK
-(define (network-query s q zone-origin server-names unique-id)
-  (lambda (self-pid)
-    (try-next-server (network-query-state (network-request s q zone-origin server-names unique-id)
-					  first-timeout
-					  (hash)
-					  '()
-					  #f
-					  server-names))))
-
-(define (try-next-server w)
-  (match w
-    [(network-query-state _ #f _ _ _ _)
-     ;; No more timeouts to try, so give up.
-     (on-answer w (empty-complete-answer) #f)]
-    [(network-query-state req timeout _ '() _ '())
-     ;; No more addresses to try with this timeout. Refill the list
-     ;; and bump the timeout and retry.
-     ;; TODO: randomize ordering of servers in list. (Don't forget the initial fill.)
-     (try-next-server (struct-copy network-query-state w
-				   [timeout (next-timeout timeout)]
-				   [remaining-addresses '()]
-				   [current-name #f]
-				   [remaining-names (network-request-server-names req)]))]
-    [(network-query-state req _ known-addresses '() _ (cons current-name remaining-names))
-     (if (hash-has-key? known-addresses current-name)
-	 (try-next-server (struct-copy network-query-state w
-				       [remaining-addresses (hash-ref known-addresses
-								      current-name)]
-				       [current-name current-name]
-				       [remaining-names remaining-names]))
-	 (let ((subq (ns-question current-name (network-request-question req))))
-	   (transition (struct-copy network-query-state w
-				    [current-name current-name]
-				    [remaining-names remaining-names])
-	     (send-message subq)
-	     (role/fresh subq-id (topic-subscriber (answered-question subq (wild)))
-	       #:state w
-	       [(answered-question (== subq) ans)
-		(define ips
-		  (map make-dns-address (set->list (extract-addresses current-name ans))))
-		(sequence-actions
-		    (try-next-server (struct-copy network-query-state w
-						  [known-addresses (hash-set known-addresses
-									     current-name
-									     ips)]
-						  [remaining-addresses ips]))
-		  (delete-role subq-id))]))))]
-    [(network-query-state req timeout _ (cons current-ip remaining-ips) _ _)
-     (define rpc-id (gensym 'network-query/allocate-query-id))
-     (transition w
-       (send-message `(request ,rpc-id allocate-query-id))
-       (role (topic-subscriber `(reply ,rpc-id ,(wild)))
-	 #:name rpc-id
-	 #:state w
-	 [`(reply ,(== rpc-id) ,id)
-	  (sequence-actions (send-request (struct-copy network-query-state w
-						       [remaining-addresses remaining-ips])
-					  id
-					  timeout
-					  current-ip)
-	    (delete-role rpc-id))]))]))
-
-(define (on-answer w ans server-ip)
-  (match ans
-    ['bad-answer ;; can come from filter-dns-reply
-     (try-next-server w)]
-    ['lame-delegation ;; can come from filter-dns-reply
-     (match-define (network-query-state req _ known-addresses _ current-name _) w)
-     (match-define (network-request _ q zone-origin _ _) req)
-     (log-info (format "Lame delegation received from ~v (at ~v) in bailiwick ~v in response to ~v"
-		       current-name
-		       server-ip
-		       zone-origin
-		       q))
-     ;; Actually remove the offending IP address so it's never tried again.
-     (try-next-server (struct-copy network-query-state w
-				   [known-addresses (hash-update known-addresses
-								 current-name
-								 (lambda (addrs)
-								   (remove server-ip addrs)))]))]
-    [else
-     (transition w
-       (send-message (network-reply (network-request-unique-id (network-query-state-request w))
-				    ans)))]))
-
-(define (send-request w query-id timeout server-ip)
-  (match-define (network-request s q zone-origin _ _) (network-query-state-request w))
-  (define query (make-dns-query-message q query-id))
-  (define subscription-id (list s query-id))
-  (define start-time (current-inexact-milliseconds))
-  (log-debug (format "Sending ~v ~v to ~v ~v with ~v seconds of timeout"
-		     q query-id
-		     zone-origin server-ip
-		     timeout))
-  (transition w
-    (send-message (dns-request query s server-ip))
-    (send-message (set-timer subscription-id (* timeout 1000) 'relative))
-    (role (set (topic-subscriber (timer-expired subscription-id (wild)))
-	       (topic-subscriber (dns-reply (wild) (wild) s)))
-      #:name subscription-id
-      #:state w
-      [(timer-expired (== subscription-id) _)
-       (log-debug (format "Timed out ~v ~v to ~v ~v after ~v seconds"
-			  q query-id
-			  zone-origin server-ip
-			  timeout))
-       (sequence-actions (try-next-server w)
-	 (delete-role subscription-id)
-	 (send-message (list 'release-query-id query-id)))]
-      [(dns-reply reply-message source (== s))
-       ;; TODO: maybe receive only specifically from the queried IP address?
-       (log-debug
-	(format
-	 "Answer to ~v from ~v ~v in ~v ms~n-- Answers: ~v~n-- Authorities: ~v~n-- Additional: ~v"
-	 q zone-origin server-ip
-	 (inexact->exact (round (- (current-inexact-milliseconds) start-time)))
-	 (dns-message-answers reply-message)
-	 (dns-message-authorities reply-message)
-	 (dns-message-additional reply-message)))
-       (if (not (= (dns-message-id reply-message) (dns-message-id query)))
-	   (transition w)
-	   (sequence-actions (on-answer w
-					(filter-dns-reply q reply-message zone-origin)
-					server-ip)
-	     (delete-role subscription-id)
-	     (send-message (list 'release-query-id query-id))))])))

os.rkt

@@ -0,0 +1,325 @@
+#lang racket/base
+
+;; Virtualized operating system.
+
+(require racket/match)
+(require racket/list)
+(require "functional-queue.rkt")
+
+(provide
+ ;; Spawning processes
+ (struct-out runnable)
+
+ ;; Waiting for messages
+ (struct-out subscription)
+ (struct-out message-handler)
+
+ ;; Kernel requests
+ (struct-out kernel-mode-transition)
+
+ ;; Constructing, accessing and running VMs
+ make-vm
+ vm?
+ run-vm
+
+ ;; Grounding out the infinite tower of VMs
+ nested-vm-inert?
+ ground-vm
+ )
+
+;; Each VM hosts 0 or more *multiplexed* processes. Each process has
+;; its own state record. In between schedulings, a process consists of
+;; 1 or more message handlers. A message handler is a pair of a message
+;; recogniser and a procedure taking a message and a process state to a
+;; new process state.
+;;
+;; Each VM provides a *communication bus* for its processes to
+;; use. The communication bus is the only form of IPC the VM provides.
+;;
+;; Some processes *relay* messages out from the VM to other
+;; VMs. Because the "tree" of VMs so formed has to be a tree - See
+;; Shivers & Might 2006 for a discussion of this - we gather together
+;; all the interactions between the supervenient VM and its support VM
+;; into a single channel of communication. The relaying processes are,
+;; in effect, device-drivers, providing application-specific
+;; communication services to other processes in the VM.
+;;
+;; We split processes into "user" processes, permitted only to spawn
+;; other user processes and send messages on the VM's bus, and
+;; "kernel" processes, permitted also to spawn other kernel processes
+;; and send messages to the VM's container.
+;;
+;; Time plays an interesting role in a distributed system: if the
+;; medium messages are sent through isn't cooperative enough to let us
+;; know of a failed conversational participant, our only recourse is
+;; /timeout/. Therefore, we require every level of the machine to
+;; support timeouts, though we do not require such timeouts to be tied
+;; to real, wall-clock time: simulated time is just fine. This helps
+;; with testability.
+;;
+;; Racket's alarm-evt is almost the right design for timeouts: its
+;; synchronisation value should be the (or some) value of the clock
+;; after the asked-for time. That way it serves as timeout and
+;; clock-reader in one.
+
+;; VMs are parameterised over:
+;;  - the type of messages carried on the bus, Message
+;;  - the type of patterns over Messages, MessagePattern
+;;  - the type of messages to other VMs, MetaMessage
+;;  - the type of patterns over MetaMessages, MetaMessagePattern
+
+;; A PatternPredicate is a (MessagePattern Message -> Boolean), used
+;; to match a message against a pattern.
+
+;; A VM is a (vm ListBagOf<Suspension>
+;;               QueueOf<Message> ;; TODO: make unordered?
+;;               QueueOf<MetaMessage> ;; TODO: make unordered?
+;;               QueueOf<Runnable>).
+(struct vm (suspensions
+	    pending-messages
+	    pending-meta-messages
+	    pending-processes
+	    pattern-predicate) #:transparent)
+
+;; A TrapK<X> is a X -> InterruptK, representing a suspended process
+;; waiting for some information from the VM before it can continue.
+
+;; An InterruptK is a
+;;   ProcessState -> KernelModeTransition
+;; representing a suspended process that can run instantly without
+;; waiting for more information from the VM. The input is the state of
+;; the process, and the output is the information passed back to the
+;; VM when the process yields the CPU.
+
+;; A Runnable is a (runnable ProcessState InterruptK), representing a
+;; temporarily-suspended runnable process.
+(struct runnable (state k) #:transparent)
+
+;; A Subscription is a
+;; (subscription ProcessState
+;;               ListBagOf<MessageHandler>
+;;               ListBagOf<MetaMessageHandler>).
+(struct subscription (state
+		      message-handlers
+		      meta-message-handlers) #:transparent)
+
+;; A Suspension is a
+;; (suspension ProcessState
+;;             ListBagOf<MessageHandler>
+;;             Map<HID,MetaMessageHandler>).
+(struct suspension (state
+		    message-handlers
+		    meta-message-handlers) #:transparent)
+
+;; A HID is a per-VM unique value, used to identify specific
+;; MetaMessageHandlers. Here, we use gensyms, though an alternative
+;; (and purer) approach would be to keep a counter in the VM and use
+;; that to construct IDs.
+
+;; A MessageHandler is one of
+;; -- (message-handler MessagePattern TrapK<Message>)
+(struct message-handler (pattern k) #:transparent)
+
+;; A KernelModeTransition is a
+;; (kernel-mode-transition Subscription
+;;                         ListBagOf<Message>
+;;			   ListBagOf<MetaMessage>
+;;                         ListBagOf<Runnable>)
+;; representing the subscription for the transitioning process, a list
+;; of messages to emit at both this VM's and its container's level,
+;; and a list of new processes to create and schedule.
+(struct kernel-mode-transition (subscription
+				messages
+				meta-messages
+				new-processes) #:transparent)
+
+;; A ListBagOf<X> is a ListOf<X> with the additional constraint that
+;; order isn't meaningful.
+
+;; TODO: is timeout really primitive? If so, isn't presence primitive?
+;; TODO: what about metatimeout?
+;; TODO: what about spawn-meta-process etc? Come back to this later.
+;; TODO: enforce user-mode restrictions
+;; TODO: timeouts
+
+;; PatternPredicate ( -> KernelModeTransition ) -> VM
+(define (make-vm pattern-predicate boot)
+  (vm (list)
+      (make-queue)
+      (make-queue)
+      (enqueue (make-queue) (runnable (void) (lambda (dummy) (boot))))
+      pattern-predicate))
+
+;; VM -> KernelModeTransition
+;; (A kind of Meta-InterruptK)
+(define (run-vm state)
+  (let* ((state (run-runnables state))
+	 (state (dispatch-messages state))
+	 (meta-messages (queue->list (vm-pending-meta-messages state)))
+	 (meta-handlers (append-map extract-downward-meta-message-handlers (vm-suspensions state)))
+	 (state (struct-copy vm state [pending-meta-messages (make-queue)])))
+    (kernel-mode-transition (subscription state meta-handlers '())
+			    meta-messages
+			    '()
+			    '())))
+
+(define (run-runnables state)
+  (foldl (lambda (r state) (perform-transition ((runnable-k r) (runnable-state r)) state))
+	 (struct-copy vm state [pending-processes (make-queue)])
+	 (queue->list (vm-pending-processes state))))
+
+(define (dispatch-messages state)
+  (foldl dispatch-message
+	 (struct-copy vm state [pending-messages (make-queue)])
+	 (queue->list (vm-pending-messages state))))
+
+(define (extract-downward-meta-message-handlers susp)
+  (for/list ([(hid mmh) (in-hash (suspension-meta-message-handlers susp))])
+    (message-handler (message-handler-pattern mmh) (dispatch-meta-message hid))))
+
+(define (extract-upward-meta-message-handlers susp)
+  (for/list ([(hid mmh) (in-hash (suspension-meta-message-handlers susp))])
+    (message-handler hid (message-handler-k mmh))))
+
+(define (((dispatch-meta-message hid) message) state)
+  (run-vm
+   (foldl (match-suspension message
+			      (lambda (handler-hid message) (equal? hid handler-hid))
+			      extract-upward-meta-message-handlers)
+	  (struct-copy vm state [suspensions '()])
+	  (vm-suspensions state))))
+
+;; KernelModeTransition VM -> VM
+(define (perform-transition transition state)
+  (match transition
+    [(kernel-mode-transition new-subscription
+			     messages
+			     meta-messages
+			     new-processes)
+     (let* ((state (foldl enqueue-message state messages))
+	    (state (foldl enqueue-runnable state new-processes))
+	    (state (enqueue-suspension (subscription->suspension new-subscription) state))
+	    (state (foldl enqueue-meta-message state meta-messages)))
+       state)]
+    [other
+     (error 'vm "Processes must return a kernel-mode-transition struct; got ~v" other)]))
+
+(define (subscription->suspension sub)
+  (match-define (subscription ps mhs mmhs) sub)
+  (suspension ps mhs (for/hash ([mmh mmhs]) (values (gensym 'hid) mmh))))
+
+(define (enqueue-message message state)
+  (struct-copy vm state [pending-messages (enqueue (vm-pending-messages state) message)]))
+
+(define (enqueue-runnable r state)
+  (struct-copy vm state [pending-processes (enqueue (vm-pending-processes state) r)]))
+
+(define (enqueue-suspension susp state)
+  (match susp
+    [(suspension _ '() (? (lambda (h) (zero? (hash-count h)))))
+     ;; dead process because no continuations offered
+     state]
+    [(suspension _ _ _)
+     (struct-copy vm state [suspensions (cons susp (vm-suspensions state))])]))
+
+(define (enqueue-meta-message message state)
+  (struct-copy vm state [pending-meta-messages (enqueue (vm-pending-meta-messages state) message)]))
+
+(define (dispatch-message message state)
+  (foldl (match-suspension message
+			     (vm-pattern-predicate state)
+			     suspension-message-handlers)
+	 (struct-copy vm state [suspensions '()])
+	 (vm-suspensions state)))
+
+(define ((match-suspension message apply-pattern handlers-getter) susp state)
+  (let search-handlers ((message-handlers (handlers-getter susp)))
+    (cond
+     [(null? message-handlers)
+      ;; No handler matched this message. Put the suspension
+      ;; back on the list for some future message.
+      (enqueue-suspension susp state)]
+     [(apply-pattern (message-handler-pattern (car message-handlers)) message)
+      (define trapk (message-handler-k (car message-handlers)))
+      (define interruptk (trapk message))
+      (perform-transition (interruptk (suspension-state susp)) state)]
+     [else
+      (search-handlers (cdr message-handlers))])))
+
+;; VM -> Boolean
+;; When should a VM block? When it has no runnables and no pending
+;; messages. Otherwise, it should poll.
+(define (should-poll? state)
+  (or (not (queue-empty? (vm-pending-processes state)))
+      (not (queue-empty? (vm-pending-messages state)))))
+
+;;---------------------------------------------------------------------------
+
+(define (nested-vm-inert? sub)
+  (match sub
+    [(subscription (vm _ (? queue-empty?) (? queue-empty?) (? queue-empty?) _) '() '())
+     ;; Inert iff not waiting for any messages or metamessages, and
+     ;; with no internal work left to do.
+     #t]
+    [_ #f]))
+
+;; PatternPredicate ( -> KernelModeTransition ) -> Void
+;; In this context,
+;;   Message = a thunk
+;;   MessagePattern = evt?
+;;   MetaMessage, MetaMessagePattern = not defined because there's no outer level
+;; Runs its argument VM until it becomes (provably) inert.
+(define (ground-vm pattern-predicate boot)
+  (let loop ((transition (run-vm (make-vm pattern-predicate boot))))
+    (when (not (nested-vm-inert? (kernel-mode-transition-subscription transition)))
+      (match transition
+	[(kernel-mode-transition (subscription new-state message-handlers '())
+				 outbound-messages '() '())
+	 (for-each (lambda (thunk) (thunk)) outbound-messages)
+	 (define inbound-messages
+	   (map (match-lambda [(message-handler e k) (wrap-evt e (lambda (v) (cons v k)))])
+		message-handlers))
+	 (match-define (cons inbound-value inbound-continuation)
+	   (apply sync inbound-messages))
+	 (loop ((inbound-continuation inbound-value) new-state))]
+	[_
+	 (error 'ground-vm
+		"Outermost VM may not spawn new siblings or send or receive metamessages")]))))
+
+;---------------------------------------------------------------------------
+
+(require racket/pretty)
+
+(define (quit)
+  (kernel-mode-transition (subscription 'none '() '())
+			  '()
+			  '()
+			  '()))
+(define (super-alarm msecs)
+  (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds))))
+(define (sleep-after-sending ms mms n k)
+  (kernel-mode-transition (subscription 'none
+					'()
+					(list (message-handler
+					       (super-alarm (+ (current-inexact-milliseconds) n))
+					       (lambda (_message)
+						 (lambda (_state)
+						   (k))))))
+			  ms
+			  mms
+			  '()))
+(define (sleep n k) (sleep-after-sending '() '() n k))
+(define (yield k) (sleep 0 k))
+(define (print x k) (sleep-after-sending '()
+					 (list (lambda () (pretty-print x)))
+					 0 k))
+(ground-vm (lambda (p m) (p m))
+	   (lambda ()
+	     (print "SLEEPING"
+		    (lambda ()
+		      (sleep 2000
+			     (lambda ()
+			       (yield
+				(lambda ()
+				  (print "HELLO"
+					 quit)))))))))

os2-dns.rkt

@@ -1,63 +0,0 @@
-#lang racket/base
-;; DNS drivers using os2.rkt and os2-udp.rkt.
-
-(require racket/set)
-(require racket/match)
-(require "codec.rkt")
-(require "../racket-matrix/os2.rkt")
-(require "../racket-matrix/os2-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)
-  (transition 'no-state
-    (at-meta-level
-     (role (topic-subscriber (udp-packet (wild) s (wild)))
-       [(udp-packet source (== s) #"")
-	(log-info "Debug dump packet received")
-	(send-message `(debug-dump))]
-       [(udp-packet source (== s) body)
-	(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)))))
-      (at-meta-level
-       (send-message (udp-packet s sink (dns-message->packet message))))))
-  (transition 'no-state
-    (role (set (topic-subscriber (dns-request (wild) s (wild)))
-	       (topic-subscriber (dns-reply   (wild) s (wild))))
-      [(dns-request message (== s) sink) (translate message sink)]
-      [(dns-reply   message (== s) sink) (translate message sink)])))
-
-(define dns-spy
-  (transition 'none
-    (role (topic-subscriber (wild) #:monitor? #t)
-      [(dns-request message source sink)
-       (log-info (format "DNS: ~v asks ~v ~v~n   : ~v"
-			 source sink (dns-message-id message)
-			 (dns-message-questions message)))
-       (void)]
-      [(dns-reply message source sink)
-       (log-info (format "DNS: ~v answers ~v~n   : ~v"
-			 source sink
-			 message))
-       (void)]
-      [x
-       (log-info (format "DNS: ~v" x))
-       (void)])))

proxy.rkt

@@ -1,309 +1,218 @@
 #lang racket/base
 
-;; DNS proxy using os-big-bang.rkt and os-udp.rkt.
+;; Simple imperative DNS proxy.
 
+(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 "network-query.rkt")
-(require "resolver.rkt")
-(require "../racket-matrix/os2.rkt")
-(require "../racket-matrix/os2-udp.rkt")
-(require "../racket-matrix/os2-timer.rkt")
-(require "os2-dns.rkt")
+(require "resolver-unit.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@))
+
 ;; Instantiated with a collection of trusted roots to begin its
-;; searches from. Performs recursive queries.
+;; searches from. Performs recursive queries. Doesn't yet cache
+;; responses, but will do so in future.
 
-;; For discarding retransmitted requests that we're still working on.
-(struct active-request (source id) #:prefab)
+;; 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
 
-;; start-proxy : UInt16 CompiledZone CompiledZone -> Void
-(define (start-proxy port-number zone roots-only)
-  (define server-addr (udp-listener port-number))
-  (define client-addr (udp-handle 'dns-client))
+(struct bad-dns-packet (detail source target reason) #:prefab)
+(struct world-message (body source target) #:prefab)
 
-  (log-info "Ready.")
+;; ServerState
+(struct world (roots continuations) #:prefab)
 
-  (ground-vm
-   (transition 'no-state
-     ;;(spawn udp-spy)
-     (spawn udp-driver #:debug-name 'udp-driver)
-     (spawn (timer-driver 'timer-driver) #:debug-name 'timer-driver)
-     (spawn (nested-vm #:debug-name 'dns-vm
-	     (transition 'no-state
-	       (spawn dns-spy #:debug-name 'dns-spy)
-	       (spawn (timer-relay 'timer-relay:dns) #:debug-name 'timer-relay)
-	       (spawn (query-id-allocator) #:debug-name 'query-id-allocator)
-	       (spawn (dns-read-driver server-addr) #:debug-name 'server-dns-reader)
-	       (spawn (dns-write-driver server-addr) #:debug-name 'server-dns-writer)
-	       (spawn (dns-read-driver client-addr) #:debug-name 'client-dns-reader)
-	       (spawn (dns-write-driver client-addr) #:debug-name 'client-dns-writer)
-	       (spawn (packet-dispatcher server-addr) #:debug-name 'packet-dispatcher)
-	       (spawn (question-dispatcher zone roots-only client-addr)
-		      #:debug-name 'question-dispatcher)))
-	    #:debug-name 'dns-vm))))
+(define action-prompt (make-continuation-prompt-tag 'world-action))
 
-(define (query-id-allocator)
-  ;; TODO: track how many are allocated and throttle requests if too
-  ;; many are in flight
-  (transition (set) ;; SetOf<UInt16>, all active query IDs
-    (role (topic-subscriber `(request ,(wild) allocate-query-id))
-      #:state allocated
-      [`(request ,reply-addr allocate-query-id)
-       (let recheck ()
-	 (define n (random 65536))
-	 (if (set-member? allocated n)
-	     (recheck)
-	     (transition (set-add allocated n)
-	       (send-message `(reply ,reply-addr ,n)))))])
-    (role (topic-subscriber `(release-query-id ,(wild)))
-      #:state allocated
-      [`(release-query-id ,n)
-       (transition (set-remove allocated n))])))
+;; TODO: Avoid attack amplification by not starting work on questions
+;; that are already underway
 
-(define (packet-dispatcher s)
-  (transition (set) ;; SetOf<ActiveRequest>
-    (role (topic-subscriber (bad-dns-packet (wild) (wild) (wild) (wild)))
-      #:state old-active-requests
-      [p
-       (log-error (pretty-format p))
-       ;; TODO: ^ perhaps use metalevel events? perhaps don't bother though
-       (transition old-active-requests)])
-    (role (topic-subscriber (dns-request (wild) (wild) s))
-      #:state old-active-requests
-      [(and r (dns-request m source (== s))) ;; We only listen for requests on our server socket
-       (define req-id (active-request source (dns-message-id m)))
-       ;; TODO: when we have presence/error-handling, remove req-id
-       ;; from active requests once request-handler pseudothread exits.
-       (if (set-member? old-active-requests req-id)
-	   (transition old-active-requests) ;; ignore retransmitted duplicates
-	   (transition (set-add old-active-requests req-id)
-	     (spawn (packet-relay req-id r) #:debug-name (list 'packet-relay req-id))))])
-    (role (topic-subscriber (dns-reply (wild) s (wild)))
-      #:state old-active-requests
-      [(and r (dns-reply m (== s) sink))
-       (define req-id (active-request sink (dns-message-id m)))
-       (transition (set-remove old-active-requests req-id))])))
+;; TODO: Timeouts!!
 
-(define (packet-relay req-id request)
-  (match-define (dns-request request-message request-source request-sink) request)
-  (define (answer->reply q a)
-    (define-values (response-code ns us ds)
-      (match a
-	[#f
-	 (values 'name-error '() '() '())]
-	[(complete-answer ns us ds)
-	 (values 'no-error (rr-set->list ns) (rr-set->list us) (rr-set->list ds))]))
-    (dns-reply (dns-message (dns-message-id request-message)
-			    'response
-			    'query
-			    'non-authoritative
-			    'not-truncated
-			    (dns-message-recursion-desired request-message)
-			    'recursion-available
-			    response-code
-			    (if q (list q) '())
-			    ns
-			    us
-			    ds)
-	       request-sink
-	       request-source))
-  ;; TODO: pay attention to recursion-desired flag
-  (match (dns-message-questions request-message)
-    ['()
-     ;; No questions!
-     (transition 'no-state/packet-relay
-       (send-message (answer->reply #f (empty-complete-answer))))]
-    [(cons original-question _)
-     ;; At least one question
-     (log-debug (format "Looking up ~v with query id ~v"
-			original-question (dns-message-id request-message)))
-     (transition 'no-state/packet-relay
-       (send-message original-question)
-       (role/fresh wait-id (topic-subscriber (answered-question original-question (wild)))
-	 #:state w
-	 [(answered-question (== original-question) answer)
-	  (log-debug (format "Final answer to ~v with query id ~v is ~v"
-			     original-question
-			     (dns-message-id request-message)
-			     answer))
-	  (transition w
-	    (delete-role wait-id)
-	    (send-message (answer->reply original-question answer)))]))]))
+(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))
 
-(define (glueless-question-handler roots-only-zone q client-sock)
-  ;; Restart q, an overly-glueless question, from the roots.
-  (define restarted-question (restart-question q))
-  (transition 'no-state
-    (role/fresh relay (topic-subscriber (answered-question restarted-question (wild)))
-      #:state w
-      [(answered-question (== restarted-question) ans)
-       ;; We got the answer to our restarted question; now transform
-       ;; it into an answer to the original question, to unblock the
-       ;; original questioner.
-       (transition w
-	 (delete-role relay)
-	 (send-message (answered-question q ans)))])
-    (spawn (question-handler roots-only-zone restarted-question client-sock)
-	   #:debug-name (list 'glueless-question-handler-inner restarted-question))))
+;; ( -> 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))))))
 
-(define (question-dispatcher seed-zone roots-only client-sock)
-  (define (transition-and-set-timers new-zone timers)
-    (transition new-zone
-      (for/list ([timerspec timers])
-	(match-define (cons name ttl) timerspec)
-	(send-message (set-timer (list 'check-dns-expiry name) (* ttl 1000) 'relative)))))
-  (define-values (cleaned-seed-zone initial-timers) (zone-expire seed-zone))
-  (sequence-actions (transition-and-set-timers cleaned-seed-zone initial-timers)
-    ;; TODO: consider deduping questions here too?
-    (role (topic-subscriber `(debug-dump))
-      #:state zone
-      [`(debug-dump)
-       (with-output-to-file "zone-proxy.zone"
-	 (lambda ()
-	   (write-bytes (bit-string->bytes (zone->bit-string zone))))
-	 #:mode 'binary
-	 #:exists 'replace)
-       (with-output-to-file "zone-proxy.dump"
-	 (lambda ()
-	   (display "----------------------------------------------------------------------\n")
-	   (display (seconds->date (current-seconds)))
-	   (newline)
-	   (for* ([(name rrmap) zone] [(rr expiry) rrmap])
-	     (write (list rr expiry))
-	     (newline))
-	   (newline))
-	 #:mode 'text
-	 #:exists 'append)
-       (with-output-to-file "zone-proxy.debug"
-	 (lambda ()
-	   (display "----------------------------------------------------------------------\n")
-	   (display (seconds->date (current-seconds)))
-	   (newline)
-	   (pretty-write current-ground-transition))
-	 #:mode 'text
-	 #:exists 'append)
-       (transition zone)])
-    (role (topic-subscriber (question (wild) (wild) (wild) (wild)))
-      #:state zone
-      [(? question? q)
-       (transition zone
-	 (cond
-	  [(question-cyclic? q)
-	   (log-warning (format "Cyclic question ~v" q))
-	   (send-message (answered-question q (empty-complete-answer)))]
-	  [(question-too-glueless? q)
-	   (log-warning (format "Overly-glueless question ~v" q))
-	   (spawn (glueless-question-handler roots-only q client-sock)
-		  #:debug-name (list 'glueless-question-handler-outer q))]
-	  [else
-	   (spawn (question-handler zone q client-sock)
-		  #:debug-name (list 'question-handler q))]))])
-    (role (topic-subscriber (network-reply (wild) (wild)))
-      #:state zone
-      [(network-reply _ answer)
-       (define-values (new-zone timers) (incorporate-complete-answer answer zone))
-       (transition-and-set-timers new-zone timers)])
-    (role (topic-subscriber (timer-expired (list 'check-dns-expiry (wild)) (wild)))
-      #:state zone
-      [(timer-expired (list 'check-dns-expiry name) now-msec)
-       (transition (zone-expire-name zone name (/ now-msec 1000.0)))])))
+;; start-proxy : UInt16 ListOf<RR> -> 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)
 
-(struct question-state (zone q client-sock nameservers-tried retry-count) #:prefab)
-(struct expanding-cnames (q accumulator remaining-count) #:prefab)
+  (define initial-world (world roots (make-immutable-hash)))
 
-(define (question-handler zone q client-sock)
-  (retry-question (question-state zone q client-sock (set) 0)))
+  (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 (send-empty-reply w q)
-  (transition w (send-message (answered-question q (empty-complete-answer)))))
+(define (udp-packet->message packet)
+  (match-define (udp-packet body host port) packet)
+  (define a (address host port))
+  (with-handlers ((exn? (lambda (e) (bad-dns-packet body a #f 'unparseable))))
+    (define message (packet->dns-message body))
+    (world-message message a #f)))
 
-(define (retry-question w)
-  (match w
-    [(question-state _ q _ _ 20) ;; TODO: is this a sensible limit?
-     ;; Too many retries, i.e. too many referrals.
-     (log-error (format "Too many retries: ~v" w))
-     (send-empty-reply w q)]
-    [(question-state zone q client-sock nameservers-tried old-retry-count)
-     ;; Credit remaining. Try once more (perhaps for the first time, in fact).
-     (define resolution-result (resolve-from-zone q zone #f nameservers-tried))
-     (log-debug (format "Resolution result: ~v" resolution-result))
-     (match resolution-result
-       [#f ;; We're not authoritative so this is just a signal that we can't answer usefully
-	(send-empty-reply w q)]
-       [(referral zone-origin nameserver-rrs _)
-	(define referral-id (gensym 'referral))
-	(log-debug (format "Referral for ~v id ~v to ~v servers ~v"
-			   q referral-id (domain-labels zone-origin)
-			   (map domain-labels (set-map nameserver-rrs rr-rdata))))
-	(transition w
-	  (spawn (network-query client-sock
-				q
-				zone-origin
-				(map rr-rdata (set->list nameserver-rrs))
-				referral-id)
-		 #:debug-name (list 'network-query q))
-	  (role (topic-subscriber (network-reply referral-id (wild)))
-	    #:name referral-id
-	    #:state w
-	    [(network-reply (== referral-id) #f) ;; name-error/NXDOMAIN
-	     (transition w
-	       (delete-role referral-id)
-	       (send-message (answered-question q #f)))]
-	    [(network-reply (== referral-id) ans)
-	     (define-values (new-zone ignored-timers) (incorporate-complete-answer ans zone))
-	     (when (log-level? (current-logger) 'debug)
-	       (log-debug (format "Referral ~v results in origin ~v:~n"
-				  referral-id zone-origin))
-	       (for ([k (set-union (list->set (hash-keys zone))
-				   (list->set (hash-keys new-zone)))]
-		     #:when (in-bailiwick? k zone-origin))
-		 (log-debug (format "Old ~v ~v~nNew ~v ~v"
-				    k (hash-ref zone k 'missing)
-				    k (hash-ref new-zone k 'missing))))
-	       (log-debug "=-=-=-=-=-="))
-	     (define nameserver-names (for/set ([rr nameserver-rrs]) (rr-rdata rr)))
-	     (sequence-actions
-		 (retry-question (struct-copy question-state w
-					      [nameservers-tried (set-union nameservers-tried
-									    nameserver-names)]
-					      [zone new-zone]
-					      [retry-count (+ old-retry-count 1)]))
-	       (delete-role referral-id))]))]
-       [(? complete-answer? ans)
-	(transition w (send-message (answered-question q ans)))]
-       [(partial-answer base cnames)
-	(transition (expanding-cnames q base (length cnames))
-	  (map (lambda (cname)
-		 ;; TODO: record chains of CNAMEs to avoid pathologically-long chains
-		 (define cname-q (cname-question cname q))
-		 (list (send-message cname-q)
-		       (role/fresh subscription-id
-			   (topic-subscriber (answered-question cname-q (wild)))
-			 #:state (expanding-cnames q acc remaining)
-			 [(answered-question (== cname-q) ans)
-			  (define new-acc (if ans (merge-answers acc ans) acc))
-			  (define new-remaining (- remaining 1))
-			  (define new-w (expanding-cnames q new-acc new-remaining))
-			  (transition new-w
-			    (delete-role subscription-id)
-			    (if (zero? new-remaining)
-				(send-message (answered-question q new-acc))
-				'()))])))
-	       cnames))])]))
+(define (message->udp-packet m)
+  (match-define (world-message body _ (address host port)) m)
+  (udp-packet (dns-message->packet body) host port))
 
-(require "test-rrs.rkt")
-(require racket/file)
-(file-stream-buffer-mode (current-output-port) 'none)
-(start-proxy (test-port-number)
-	     (if (file-exists? "zone-proxy.zone")
-		 (bit-string->zone (file->bytes "zone-proxy.zone"))
-		 (compile-zone-db test-roots))
-	     (compile-zone-db test-roots))
+(define (local-address? a)
+  (eq? a #f))
+
+(define (remote-address? a)
+  (address? a))
+
+(define (outbound-message? m)
+  (and (world-message? m)
+       (local-address? (world-message-source m))
+       (remote-address? (world-message-target m))))
+
+(define (inbound-message? m)
+  (and (world-message? m)
+       (remote-address? (world-message-source m))
+       (local-address? (world-message-target m))))
+
+(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)))
+
+(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<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)
+		    [#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-sig.rkt

@@ -0,0 +1,3 @@
+#lang racket/signature
+
+resolve-from-zone ;; Question CompiledZone SOA-RR Boolean Set<NS-RR> -> QuestionResult

resolver-test.rkt

@@ -0,0 +1,56 @@
+#lang racket/base
+
+;; Noddy representation of a zone, and various zone and RRSet utilities.
+
+(require racket/unit)
+(require racket/pretty)
+(require racket/set)
+(require racket/match)
+(require "api.rkt")
+(require "codec.rkt")
+(require "zonedb.rkt")
+(require "ground-udp-operations-unit.rkt")
+(require "network-query-unit.rkt")
+(require "resolver-unit.rkt")
+
+(define-values/invoke-unit/infer
+  (link resolver@ network-query@ ground-udp-operations@))
+
+;; (require racket/trace)
+;; (trace ;;resolve-from-zone
+;;        ;;build-referral
+;;        ;;incorporate-claims
+;;        ;;additional-section/a
+;;        ;;network-query
+;;        ;;network-query/addresses
+;;        ;;dns-message->claims
+;;        ;;negative-network-query-result
+;;        ;;closest-untried-nameservers
+;;        ;;answer-from-zone
+;;        ;;merge-replies
+;;        ;;in-bailiwick?
+;;        )
+
+(pretty-print
+ (resolve-from-zone (question
+		     ;;'(#"www" #"google" #"com")
+		     ;;'(#"foo" #"rallyx" #"ccs" #"neu" #"edu")
+		     '(#"rallyx" #"ccs" #"neu" #"edu")
+		     'a
+		     'in)
+		    (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)))
+		     )
+		    #f
+		    #t
+		    (set)))

resolver-unit.rkt

@@ -0,0 +1,204 @@
+#lang racket/unit
+
+(require racket/pretty)
+
+(require racket/set)
+(require racket/match)
+(require "api.rkt")
+(require "codec.rkt")
+(require "zonedb.rkt")
+(require "network-query-sig.rkt")
+(require "resolver-sig.rkt")
+
+(import network-query^)
+(export resolver^)
+
+;; Rules:
+;;
+;;  - If the DB already has an answer, return it.
+;;
+;;  - Otherwise, find the leafmost NS record in the DB for the
+;;    requested name.
+;;
+;;  - Query that service. Augment the DB with the answers received, if
+;;    any. Loop back to the beginning, remembering that we've tried
+;;    the specific service we just interacted with so we don't try it
+;;    again.
+;;
+;;  - Eventually, the DB will have either been augmented with an
+;;    answer, or we will have run out of untried nameservers to ask.
+;;
+;;  - Authoritative NXDOMAINs ('name-error) mean we get to stop
+;;    looking.
+;;
+;;  - Resolve CNAMEs on the way. Remember which names we've been
+;;    resolving in response to any given query, to avoid
+;;    loops. Perhaps limit the length of the chain to avoid
+;;    DoS. (TODO)
+;;
+;;  - Only performs recursive service if so requested.
+;;
+;;  - See RFC 1035 section 7.1.
+
+;; Question CompiledZone -> Boolean
+(define (answer-available? q zone)
+  (hash-has-key? zone (question-name q)))
+
+;; QuestionResult Maybe<QuestionResult> -> QuestionResult
+;; Add the supporting facts from r2 into r1, keeping r1's
+;; question. Replaces the knowledge from r1 with the knowledge from
+;; r2.  Suitable for use when r2 is answering some sub-question of
+;; r1's question.
+(define (merge-replies r1 r2)
+  (match r2
+    [#f r1]
+    [(question-result _ k2 n2 u2 d2) ;; a normal result
+     (match-define (question-result q1 k1 n1 u1 d1) r1)
+     (question-result q1
+		      k2
+		      (set-union n1 n2)
+		      (set-union u1 u2)
+		      (set-union d1 d2))]))
+
+(define (answer-from-zone q zone start-of-authority recursion-desired?)
+  (match-define (question name qtype qclass) q)
+  (define rrset (hash-ref zone name))
+  (define filtered-rrs (filter-rrs rrset qtype qclass))
+  (define cnames (filter-by-type rrset 'cname)) ;; TODO: filter by class too??
+  (define base-reply (question-result q
+				      zone
+				      (set-union cnames filtered-rrs)
+				      (if (and start-of-authority
+					       (in-bailiwick? name start-of-authority))
+					  (set start-of-authority)
+					  (set))
+				      (set)))
+  ;; Algorithm for CNAME expansion from RFC 1034 4.3.2 step 3a.
+  (if (and (not (set-empty? cnames)) (not (eqv? qtype 'cname)))
+      (foldl (lambda (cname-rr current-reply)
+	       (merge-replies current-reply
+			      (resolve-from-zone
+			       (question (rr-rdata cname-rr) qtype qclass)
+			       zone
+			       start-of-authority
+			       recursion-desired?
+			       (set))))
+	     base-reply
+	     (set->list cnames))
+      base-reply))
+
+(define (closest-nameservers name zone)
+  (let search ((name name))
+    (cond
+     ((hash-ref zone name #f) =>
+      ;; There's an entry for this suffix of the original name. Check
+      ;; to see if it has an NS record indicating a subzone.
+      (lambda (rrset)
+	(define ns-rrset (filter-by-type rrset 'ns))
+	(if (set-empty? ns-rrset)
+	    (search (cdr name)) ;; no NS records for this suffix. Keep looking.
+	    ns-rrset)))
+     ((null? name)
+      ;; The root, and we don't have an RRSet for it. Give up.
+      (set))
+     (else
+      ;; Remove a label and keep looking.
+      (search (cdr name))))))
+
+;; Returns a list of NS RRs in some priority order: records for which
+;; we know the associated A record are listed before records for which
+;; we don't.
+(define (closest-untried-nameservers q zone nameservers-tried)
+  (define name (question-name q))
+  (define ns-rrset (closest-nameservers name zone))
+  (let loop ((untried (set->list (set-subtract ns-rrset nameservers-tried)))
+	     (with-address '())
+	     (without-address '()))
+    (if (null? untried)
+	(append with-address without-address)
+	(let ((ns-rr (car untried)))
+	  (define rrs (hash-ref zone (rr-rdata ns-rr) (set)))
+	  (define a-rrs (filter-by-type rrs 'a))
+	  (define has-address? (not (set-empty? a-rrs)))
+	  (loop (cdr untried)
+		(if has-address? (cons ns-rr with-address) with-address)
+		(if has-address? without-address (cons ns-rr without-address)))))))
+
+(define (empty-answer q zone start-of-authority)
+  (if (and start-of-authority
+	   (in-bailiwick? (question-name q) start-of-authority))
+      ;; NXDOMAIN/name-error if the question is something we're qualified to answer
+      #f
+      ;; A normal no-answers packet otherwise.
+      (question-result q
+		       zone
+		       (set)
+		       (set)
+		       (set))))
+
+(define (random-element a-nonempty-list)
+  (car a-nonempty-list))
+
+(define (network-query q zone ns-rr)
+  (define ns-name (rr-rdata ns-rr))
+  ;; ^ the rr-name is the subzone origin; the rr-rdata is the
+  ;; nameserver for the subzone
+  (match (resolve-from-zone (question ns-name 'a 'in) ;; TODO: 'aaaa ?
+			    zone
+			    #f
+			    #t
+			    (set))
+    [#f zone] ;; Can't find the address of the nameserver!
+    [(question-result _ enhanced-zone answers _ _)
+     (define address-rrs (filter-by-type answers 'a))
+     (if (set-empty? address-rrs)
+	 zone ;; Again, no addresses for the nameserver!
+	 (network-query/addresses q
+				  enhanced-zone
+				  ns-rr
+				  (map rr-rdata (set->list address-rrs))))]))
+
+;; additional-section/a : CompiledZone ListOf<DomainName>
+;; Implements the "additional section" rules from RFC 1035 (and the
+;; rules for IPv6 from RFC 3596). Provides A and AAAA records for
+;; names mentioned in the "names" list that have entries in "zone".
+(define (additional-section/a zone names)
+  ;; RFC 3596 (section 3) requires that we process AAAA here as well
+  ;; as A.
+  (foldl (lambda (name section)
+	   (set-union section
+		      (set-filter (lambda (rr) (and (memv (rr-type rr) '(a aaaa))
+						    (eqv? (rr-class rr) 'in)))
+				  (hash-ref zone name))))
+	 (set)
+	 names))
+
+;; build-referral : Question CompiledZone RR SetOf<RR> -> QuestionResult
+;; Used when servers choose iterative referral over recursive
+;; resolution. The RRs in ns-rrset must be NS RRs.
+(define (build-referral q zone start-of-authority ns-rrset)
+  (question-result q
+		   zone
+		   ns-rrset
+		   (and start-of-authority (set start-of-authority))
+		   (additional-section/a zone (set-map ns-rrset rr-rdata))))
+
+(define (resolve-from-zone q zone start-of-authority recursion-desired? nameservers-tried)
+  (if (answer-available? q zone)
+      (answer-from-zone q zone start-of-authority recursion-desired?)
+      (let ((best-nameservers (closest-untried-nameservers q zone nameservers-tried)))
+	(if (null? best-nameservers)
+	    (empty-answer q zone start-of-authority)
+	    (if recursion-desired?
+		(let ((best-nameserver (random-element best-nameservers)))
+		  (define enhanced-zone (network-query q zone best-nameserver))
+		  (if (eq? enhanced-zone #f)
+		      ;; name-error received!
+		      #f
+		      ;; we presumably learned something that might help us
+		      (resolve-from-zone q
+					 enhanced-zone
+					 start-of-authority
+					 recursion-desired?
+					 (set-add nameservers-tried best-nameserver))))
+		(build-referral q zone start-of-authority (list->set best-nameservers)))))))

resolver.rkt

@@ -1,137 +0,0 @@
-#lang racket/base
-
-(require racket/pretty)
-
-(require racket/set)
-(require racket/match)
-(require racket/list)
-(require "api.rkt")
-(require "codec.rkt")
-(require "zonedb.rkt")
-
-(provide (struct-out partial-answer)
-	 (struct-out referral)
-
-	 resolve-from-zone)
-
-;; Rules:
-;;
-;;  - If the DB already has an answer, return it.
-;;
-;;  - Otherwise, find the leafmost NS record in the DB for the
-;;    requested name.
-;;
-;;  - Query that service. Augment the DB with the answers received, if
-;;    any. Loop back to the beginning, remembering that we've tried
-;;    the specific service we just interacted with so we don't try it
-;;    again.
-;;
-;;  - Eventually, the DB will have either been augmented with an
-;;    answer, or we will have run out of untried nameservers to ask.
-;;
-;;  - Authoritative NXDOMAINs ('name-error) mean we get to stop
-;;    looking.
-;;
-;;  - Resolve CNAMEs on the way. Remember which names we've been
-;;    resolving in response to any given query, to avoid
-;;    loops. Perhaps limit the length of the chain to avoid
-;;    DoS. (TODO)
-;;
-;;  - Only performs recursive service if so requested.
-;;
-;;  - See RFC 1035 section 7.1.
-
-;; An Answer is one of
-;; -- a PartialAnswer (some CNAMEs need expanding),
-;; -- a CompleteAnswer (a complete answer ready to send),
-;; -- #f (the domain name does not exist in the CompiledZone given),
-;; -- a Referral (a referral to some other nameserver).
-
-;; A PartialAnswer is a (partial-answer CompleteAnswer ListOf<DomainName>)
-;; A collection of relevant RRs together with some CNAMEs that need expanding.
-(struct partial-answer (base cnames) #:prefab)
-
-;; A Referral is a (referral DomainName Set<RR> Set<RR>)
-(struct referral (zone-origin nameserver-rrs additional) #:prefab)
-
-;; An answer of #f here does NOT indicate a missing domain-name
-;; (name-error/NXDOMAIN), but instead indicates that there are no
-;; records matching the query in the database given. It's up to the
-;; caller to decide what to do about that.
-(define (answer-from-zone q zone start-of-authority)
-  (match-define (question name qtype qclass _) q)
-  (define rrset (or (zone-ref zone name) (set)))
-  (define filtered-rrs (filter-rrs rrset qtype qclass))
-  (define cnames (filter-by-type rrset 'cname)) ;; TODO: filter by class too??
-  (define answer-set (set-union cnames filtered-rrs))
-  (define base (complete-answer answer-set
-				(if (and start-of-authority
-					 (in-bailiwick? name (rr-name start-of-authority)))
-				    (set start-of-authority)
-				    (set))
-				(set)))
-  (cond
-   [(set-empty? answer-set) ;; No matching records or domain absent (deliberately ambiguous)
-    #f]
-   [(or (eq? qtype 'cname) (set-empty? cnames)) ;; Either asking for CNAMEs, or no CNAMEs to expand
-    base]
-   [else ;; Kick off the algorithm for CNAME expansion from RFC 1034 4.3.2 step 3a
-    (partial-answer base (set-map cnames rr-rdata))]))
-
-(define (closest-nameservers name zone)
-  (let search ((name name))
-    (cond
-     ((zone-ref zone name) =>
-      ;; There's an entry for this suffix of the original name. Check
-      ;; to see if it has an NS record indicating a subzone.
-      (lambda (rrset)
-	(define ns-rrset (filter-by-type rrset 'ns))
-	(if (set-empty? ns-rrset)
-	    (search (domain-parent name)) ;; no NS records for this suffix. Keep looking.
-	    ns-rrset)))
-     ((domain-root? name)
-      ;; The root, and we don't have an RRSet for it. Give up.
-      (set))
-     (else
-      ;; Remove a label and keep looking.
-      (search (domain-parent name))))))
-
-;; Returns a set of NS RRs in an arbitrary order.
-(define (closest-untried-nameservers q zone nameservers-tried)
-  (define name (question-name q))
-  (define ns-rrset (closest-nameservers name zone))
-  (for/set ([rr ns-rrset] #:when (not (set-member? nameservers-tried (rr-rdata rr)))) rr))
-
-(define (empty-answer q zone start-of-authority)
-  (if (and start-of-authority ;; we are authoritative for something
-	   (in-bailiwick? (question-name q) (rr-name start-of-authority)) ;; for this in particular
-	   (not (zone-includes-name? zone (question-name q)))) ;; there are no RRs at all for this q
-      ;; NXDOMAIN/name-error: we definitely know there are no RRs at all for this q.
-      #f
-      ;; A normal no-answers packet otherwise.
-      (empty-complete-answer)))
-
-;; additional-section/a : CompiledZone ListOf<DomainName> -> Set<RR>
-;; Implements the "additional section" rules from RFC 1035 (and the
-;; rules for IPv6 from RFC 3596). Provides A and AAAA records for
-;; names mentioned in the "names" list that have entries in "zone".
-(define (additional-section/a zone names)
-  ;; RFC 3596 (section 3) requires that we process AAAA here as well
-  ;; as A.
-  (foldl (lambda (name section)
-	   (set-union section
-		      (set-filter (lambda (rr) (and (memv (rr-type rr) '(a aaaa))
-						    (eqv? (rr-class rr) 'in)))
-				  (or (zone-ref zone name) (set)))))
-	 (set)
-	 names))
-
-(define (resolve-from-zone q zone start-of-authority nameservers-tried)
-  (or (answer-from-zone q zone start-of-authority)
-      (let ((best-nameservers (closest-untried-nameservers q zone nameservers-tried)))
-	(if (set-empty? best-nameservers)
-	    (empty-answer q zone start-of-authority)
-	    (let ((zone-origin (rr-name (car (set->list best-nameservers))))) ;; any entry will do
-	      (referral zone-origin
-			best-nameservers
-			(additional-section/a zone (set-map best-nameservers rr-rdata))))))))

send-signal.rkt

@@ -1,8 +0,0 @@
-#lang racket/base
-
-(require racket/udp)
-(require "test-rrs.rkt")
-
-(define s (udp-open-socket #f #f))
-(define buffer (make-bytes 0))
-(udp-send-to s "127.0.0.1" (test-port-number) #"")

simple-udp-service.rkt

@@ -5,7 +5,7 @@
 (require racket/match)
 (require racket/udp)
 (require (only-in srfi/1 append-reverse))
-(require "../racket-matrix/dump-bytes.rkt")
+(require "dump-bytes.rkt")
 
 (provide (struct-out udp-packet)
 	 message-handlers

simplified-driver.rkt

@@ -10,9 +10,15 @@
 (require "api.rkt")
 (require "codec.rkt")
 (require "zonedb.rkt")
-(require "resolver.rkt")
+(require "ground-udp-operations-unit.rkt")
+(require "network-query-unit.rkt")
+(require "resolver-unit.rkt")
+(require "dump-bytes.rkt")
 (require "simple-udp-service.rkt")
 
+(define-values/invoke-unit/infer
+  (link resolver@ network-query@ ground-udp-operations@))
+
 ;; 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
 ;; authoritatively. Never caches information, never performs recursive
@@ -58,7 +64,7 @@
 
 (define (udp-packet->dns-message packet)
   (match-define (udp-packet body host port) packet)
-  (with-handlers ((exn:fail? (lambda (e) (bad-dns-packet body host port 'unparseable))))
+  (with-handlers ((exn? (lambda (e) (bad-dns-packet body host port 'unparseable))))
     (define message (packet->dns-message body))
     (case (dns-message-direction message)
       ((request) (dns-request message host port))
@@ -91,7 +97,7 @@
     (dns-message (dns-message-id request-message)
 		 'response
 		 'query
-		 (if (in-bailiwick? name (rr-name soa-rr)) 'authoritative 'non-authoritative)
+		 (if (in-bailiwick? name soa-rr) 'authoritative 'non-authoritative)
 		 'not-truncated
 		 (dns-message-recursion-desired request-message)
 		 'no-recursion-available
@@ -116,35 +122,19 @@
     ;;
     ;; TODO: We support returning out-of-bailiwick records (glue)
     ;; here. Reexamine the rules for doing so.
-    (match-define (question qname qtype qclass #f) q)
-
-    (define (expand-cnames worklist ans)
-      (match worklist
-	['()
-	 (match-define (complete-answer ns us ds) ans)
-	 (make-reply qname #f ns us ds)]
-	[(cons next-cname rest)
-	 (define a (resolve-from-zone (question next-cname qtype qclass q) zone soa-rr (set)))
-	 (incorporate-answer a rest ans)]))
-
-    (define (incorporate-answer this-answer worklist ans)
-      (match this-answer
-	[(partial-answer new-info more-cnames)
-	 (expand-cnames (append worklist more-cnames)
-			(merge-answers new-info ans))]
-	[(? complete-answer?)
-	 (expand-cnames worklist
-			(merge-answers this-answer ans))]
-	[_ ;; #f or a referral
-	 (expand-cnames worklist ans)]))
-
-    (match (resolve-from-zone q zone soa-rr (set))
-      [#f ;; Signal name-error/NXDOMAIN
-       (make-reply qname #t (set) (set) (set))]
-      [(referral _ ns-rrs additional)
-       (make-reply qname #f ns-rrs (set soa-rr) additional)]
-      [this-answer
-       (incorporate-answer this-answer '() (empty-complete-answer))]))
+    (match (resolve-from-zone q zone soa-rr #f (set))
+      [#f
+       (make-reply (question-name q)
+		   #t
+		   (set)
+		   (set)
+		   (set))]
+      [(question-result _ _ answers authorities additional)
+       (make-reply (question-name q)
+		   #f
+		   answers
+		   authorities
+		   additional)]))
 
   ;; TODO: check opcode and direction in request
   ;; TODO: think again about multiple questions in one packet
@@ -153,4 +143,4 @@
        (first-only (dns-message-questions request-message))))
 
 (require "test-rrs.rkt")
-(start-server (test-port-number) test-soa-rr test-rrs)
+(start-server 5555 test-soa-rr test-rrs)

stress.rkt

@@ -8,7 +8,6 @@
 (require "../racket-bitsyntax/main.rkt")
 (require "api.rkt")
 (require "codec.rkt")
-(require "test-rrs.rkt")
 
 (require racket/pretty)
 
@@ -37,10 +36,7 @@
 					 'recursion-desired
 					 'no-recursion-available
 					 'no-error
-					 (list (question (domain '(#"www" #"google" #"com"))
-							 'a
-							 'in
-							 #f))
+					 (list (question '(#"example") '* '*))
 					 '()
 					 '()
 					 '()))
@@ -72,4 +68,4 @@
       (record-latency-ms! (- received-time sent-time))
       (loop (- remaining 1)))))
 
-(stress "localhost" (test-port-number) 100000 500)
+(stress "localhost" 5555 100000 500)

test-dns.rkt

@@ -2,8 +2,6 @@
 
 (require "api.rkt")
 (require "codec.rkt")
-(require "zonedb.rkt")
-(require "test-rrs.rkt")
 
 (require rackunit)
 
@@ -121,7 +119,7 @@
 			   'recursion-desired
 			   'no-recursion-available
 			   'no-error
-			   (list (question (domain '(#"google" #"com")) '* 'in #f))
+			   (list (question '(#"google" #"com") '* 'in))
 			   '()
 			   '()
 			   '()))
@@ -136,32 +134,32 @@
 	       'recursion-desired
 	       'recursion-available
 	       'no-error
-	       (list (question (domain '(#"google" #"com")) '* 'in #f))
+	       (list (question '(#"google" #"com") '* 'in))
 	       (list
-		(rr (domain '(#"google" #"com")) 'txt 'in 3119 '(#"v=spf1 include:_netblocks.google.com ip4:216.73.93.70/31 ip4:216.73.93.72/31 ~all"))
-		(rr (domain '(#"google" #"com")) 'a 'in 285 '#(74 125 226 146))
-		(rr (domain '(#"google" #"com")) 'a 'in 285 '#(74 125 226 148))
-		(rr (domain '(#"google" #"com")) 'a 'in 285 '#(74 125 226 145))
-		(rr (domain '(#"google" #"com")) 'a 'in 285 '#(74 125 226 147))
-		(rr (domain '(#"google" #"com")) 'a 'in 285 '#(74 125 226 144))
-		(rr (domain '(#"google" #"com")) 'ns 'in 238877 (domain '(#"ns2" #"google" #"com")))
-		(rr (domain '(#"google" #"com")) 'ns 'in 238877 (domain '(#"ns3" #"google" #"com")))
-		(rr (domain '(#"google" #"com")) 'ns 'in 238877 (domain '(#"ns1" #"google" #"com")))
-		(rr (domain '(#"google" #"com")) 'ns 'in 238877 (domain '(#"ns4" #"google" #"com")))
-		(rr (domain '(#"google" #"com")) 'mx 'in 42 (mx 20 (domain '(#"alt1" #"aspmx" #"l" #"google" #"com"))))
-		(rr (domain '(#"google" #"com")) 'mx 'in 42 (mx 30 (domain '(#"alt2" #"aspmx" #"l" #"google" #"com"))))
-		(rr (domain '(#"google" #"com")) 'mx 'in 42 (mx 10 (domain '(#"aspmx" #"l" #"google" #"com"))))
-		(rr (domain '(#"google" #"com")) 'mx 'in 42 (mx 40 (domain '(#"alt3" #"aspmx" #"l" #"google" #"com"))))
-		(rr (domain '(#"google" #"com")) 'mx 'in 42 (mx 50 (domain '(#"alt4" #"aspmx" #"l" #"google" #"com")))))
+		(rr '(#"google" #"com") 'txt 'in 3119 '(#"v=spf1 include:_netblocks.google.com ip4:216.73.93.70/31 ip4:216.73.93.72/31 ~all"))
+		(rr '(#"google" #"com") 'a 'in 285 '#(74 125 226 146))
+		(rr '(#"google" #"com") 'a 'in 285 '#(74 125 226 148))
+		(rr '(#"google" #"com") 'a 'in 285 '#(74 125 226 145))
+		(rr '(#"google" #"com") 'a 'in 285 '#(74 125 226 147))
+		(rr '(#"google" #"com") 'a 'in 285 '#(74 125 226 144))
+		(rr '(#"google" #"com") 'ns 'in 238877 '(#"ns2" #"google" #"com"))
+		(rr '(#"google" #"com") 'ns 'in 238877 '(#"ns3" #"google" #"com"))
+		(rr '(#"google" #"com") 'ns 'in 238877 '(#"ns1" #"google" #"com"))
+		(rr '(#"google" #"com") 'ns 'in 238877 '(#"ns4" #"google" #"com"))
+		(rr '(#"google" #"com") 'mx 'in 42 (mx 20 '(#"alt1" #"aspmx" #"l" #"google" #"com")))
+		(rr '(#"google" #"com") 'mx 'in 42 (mx 30 '(#"alt2" #"aspmx" #"l" #"google" #"com")))
+		(rr '(#"google" #"com") 'mx 'in 42 (mx 10 '(#"aspmx" #"l" #"google" #"com")))
+		(rr '(#"google" #"com") 'mx 'in 42 (mx 40 '(#"alt3" #"aspmx" #"l" #"google" #"com")))
+		(rr '(#"google" #"com") 'mx 'in 42 (mx 50 '(#"alt4" #"aspmx" #"l" #"google" #"com"))))
 	       '()
 	       (list
-		(rr (domain '(#"ns3" #"google" #"com")) 'a 'in 238287 '#(216 239 36 10))
-		(rr (domain '(#"ns1" #"google" #"com")) 'a 'in 238287 '#(216 239 32 10))
-		(rr (domain '(#"ns4" #"google" #"com")) 'a 'in 238287 '#(216 239 38 10))
-		(rr (domain '(#"ns2" #"google" #"com")) 'a 'in 238287 '#(216 239 34 10))
-		(rr (domain '(#"alt2" #"aspmx" #"l" #"google" #"com")) 'a 'in 240 '#(74 125 39 27))
-		(rr (domain '(#"aspmx" #"l" #"google" #"com")) 'a 'in 246 '#(74 125 115 27))
-		(rr (domain '(#"alt1" #"aspmx" #"l" #"google" #"com")) 'a 'in 33 '#(74 125 77 27)))))
+		(rr '(#"ns3" #"google" #"com") 'a 'in 238287 '#(216 239 36 10))
+		(rr '(#"ns1" #"google" #"com") 'a 'in 238287 '#(216 239 32 10))
+		(rr '(#"ns4" #"google" #"com") 'a 'in 238287 '#(216 239 38 10))
+		(rr '(#"ns2" #"google" #"com") 'a 'in 238287 '#(216 239 34 10))
+		(rr '(#"alt2" #"aspmx" #"l" #"google" #"com") 'a 'in 240 '#(74 125 39 27))
+		(rr '(#"aspmx" #"l" #"google" #"com") 'a 'in 246 '#(74 125 115 27))
+		(rr '(#"alt1" #"aspmx" #"l" #"google" #"com") 'a 'in 33 '#(74 125 77 27)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Roundtrip tests
@@ -231,7 +229,7 @@
 	      'recursion-desired
 	      'no-recursion-available
 	      'no-error
-	      (list (question (domain '(#"google" #"com")) 'aaaa 'in #f))
+	      (list (question '(#"google" #"com") 'aaaa 'in))
 	      '()
 	      '()
 	      '()))
@@ -251,9 +249,9 @@
 	      'recursion-desired
 	      'recursion-available
 	      'no-error
-	      (list (question (domain '(#"google" #"com")) 'aaaa 'in #f))
+	      (list (question '(#"google" #"com") 'aaaa 'in))
 	      '()
-	      (list (rr (domain '(#"google" #"com")) 'soa 'in 594 (soa (domain '(#"ns1" #"google" #"com")) (domain '(#"dns-admin" #"google" #"com")) 1454883 7200 1800 1209600 300)))
+	      (list (rr '(#"google" #"com") 'soa 'in 594 (soa '(#"ns1" #"google" #"com") '(#"dns-admin" #"google" #"com") 1454883 7200 1800 1209600 300)))
 	      '()))
 
 ;; Wed Jun 29 21:05:03 2011 (4e0bcbbf): UDP: localhost sent 32 bytes:
@@ -280,7 +278,7 @@
 	      'recursion-desired
 	      'no-recursion-available
 	      'no-error
-	      (list (question (domain '(#"www" #"google" #"com")) 'aaaa 'in #f))
+	      (list (question '(#"www" #"google" #"com") 'aaaa 'in))
 	      '()
 	      '()
 	      '()))
@@ -299,8 +297,8 @@
 	      'recursion-desired
 	      'no-recursion-available
 	      'no-error
-	      (list (question (domain '(#"www" #"google" #"com")) 'aaaa 'in #f))
-	      (list (rr (domain '(#"www" #"google" #"com")) 'cname 'in 604800 (domain '(#"www" #"l" #"google" #"com"))))
+	      (list (question '(#"www" #"google" #"com") 'aaaa 'in))
+	      (list (rr '(#"www" #"google" #"com") 'cname 'in 604800 '(#"www" #"l" #"google" #"com")))
 	      '()
 	      '()))
 
@@ -329,9 +327,9 @@
 	      'recursion-desired
 	      'no-recursion-available
 	      'no-error
-	      (list (question (domain '(#"ipv6" #"google" #"com")) 'aaaa 'in #f))
-	      (list (rr (domain '(#"ipv6" #"google" #"com")) 'cname 'in 604800 (domain '(#"ipv6" #"l" #"google" #"com")))
-		    (rr (domain '(#"ipv6" #"l" #"google" #"com")) 'aaaa 'in 300 '#(32 1 72 96 128 15 0 0 0 0 0 0 0 0 0 104)))
+	      (list (question '(#"ipv6" #"google" #"com") 'aaaa 'in))
+	      (list (rr '(#"ipv6" #"google" #"com") 'cname 'in 604800 '(#"ipv6" #"l" #"google" #"com"))
+		    (rr '(#"ipv6" #"l" #"google" #"com") 'aaaa 'in 300 '#(32 1 72 96 128 15 0 0 0 0 0 0 0 0 0 104)))
 	      '()
 	      '()))
 
@@ -412,7 +410,7 @@
   #x00 #x04 #xD8 #xEF #x22 #x0A #xC1 #x1A #x00 #x01 #x00 #x01 #x00 #x00 #x0A #xB1
   #x00 #x04 #xD8 #xEF #x24 #x0A #xC1 #x2C #x00 #x01 #x00 #x01 #x00 #x00 #x0A #xB1
   #x00 #x04 #xD8 #xEF #x26 #x0A)
- (let ((X (domain '(#"_xmpp-server" #"_tcp" #"google" #"com"))))
+ (let ((X '(#"_xmpp-server" #"_tcp" #"google" #"com")))
    (dns-message 5066
 		'response
 		'query
@@ -421,49 +419,22 @@
 		'recursion-desired
 		'recursion-available
 		'no-error
-		(list (question X 'srv 'in #f))
-		(list (rr X 'srv 'in 882 (srv 20 0 5269 (domain '(#"xmpp-server4" #"l" #"google" #"com"))))
-		      (rr X 'srv 'in 882 (srv 5 0 5269 (domain '(#"xmpp-server" #"l" #"google" #"com"))))
-		      (rr X 'srv 'in 882 (srv 20 0 5269 (domain '(#"xmpp-server1" #"l" #"google" #"com"))))
-		      (rr X 'srv 'in 882 (srv 20 0 5269 (domain '(#"xmpp-server2" #"l" #"google" #"com"))))
-		      (rr X 'srv 'in 882 (srv 20 0 5269 (domain '(#"xmpp-server3" #"l" #"google" #"com")))))
-		(list (rr (domain '(#"google" #"com")) 'ns 'in 87076 (domain '(#"ns3" #"google" #"com")))
-		      (rr (domain '(#"google" #"com")) 'ns 'in 87076 (domain '(#"ns4" #"google" #"com")))
-		      (rr (domain '(#"google" #"com")) 'ns 'in 87076 (domain '(#"ns2" #"google" #"com")))
-		      (rr (domain '(#"google" #"com")) 'ns 'in 87076 (domain '(#"ns1" #"google" #"com"))))
-		(list (rr (domain '(#"xmpp-server" #"l" #"google" #"com")) 'a 'in 282 '#(74 125 153 125))
-		      (rr (domain '(#"xmpp-server1" #"l" #"google" #"com")) 'a 'in 1782 '#(74 125 53 125))
-		      (rr (domain '(#"xmpp-server2" #"l" #"google" #"com")) 'a 'in 1782 '#(74 125 47 125))
-		      (rr (domain '(#"xmpp-server3" #"l" #"google" #"com")) 'a 'in 1782 '#(74 125 45 125))
-		      (rr (domain '(#"xmpp-server4" #"l" #"google" #"com")) 'a 'in 1782 '#(74 125 45 125))
-		      (rr (domain '(#"ns1" #"google" #"com")) 'a 'in 2737 '#(216 239 32 10))
-		      (rr (domain '(#"ns2" #"google" #"com")) 'a 'in 2737 '#(216 239 34 10))
-		      (rr (domain '(#"ns3" #"google" #"com")) 'a 'in 2737 '#(216 239 36 10))
-		      (rr (domain '(#"ns4" #"google" #"com")) 'a 'in 2737 '#(216 239 38 10))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Zone saving/loading.
-
-(check-equal? (compile-zone-db test-rrs)
-	      (bit-string->zone (zone->bit-string (compile-zone-db test-rrs))))
-
-(check-equal? (compile-zone-db test-roots)
-	      (bit-string->zone (zone->bit-string (compile-zone-db test-roots))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; CNAME sorting
-
-(let ()
-  (define rrs
-    (list (rr (domain '(#"a")) 'cname 'in 30 (domain '(#"b")))
-	  (rr (domain '(#"b")) 'cname 'in 30 (domain '(#"c")))
-	  (rr (domain '(#"c")) 'cname 'in 30 (domain '(#"d")))))
-  (define (check-transpose ns)
-    (define permuted (map (lambda (i) (list-ref rrs i)) ns))
-    (check-equal? (cname-sort permuted) rrs))
-  (check-transpose '(0 1 2))
-  (check-transpose '(0 2 1))
-  (check-transpose '(2 0 1))
-  (check-transpose '(2 1 0))
-  (check-transpose '(1 2 0))
-  (check-transpose '(1 0 2)))
+		(list (question X 'srv 'in))
+		(list (rr X 'srv 'in 882 (srv 20 0 5269 '(#"xmpp-server4" #"l" #"google" #"com")))
+		      (rr X 'srv 'in 882 (srv 5 0 5269 '(#"xmpp-server" #"l" #"google" #"com")))
+		      (rr X 'srv 'in 882 (srv 20 0 5269 '(#"xmpp-server1" #"l" #"google" #"com")))
+		      (rr X 'srv 'in 882 (srv 20 0 5269 '(#"xmpp-server2" #"l" #"google" #"com")))
+		      (rr X 'srv 'in 882 (srv 20 0 5269 '(#"xmpp-server3" #"l" #"google" #"com"))))
+		(list (rr '(#"google" #"com") 'ns 'in 87076 '(#"ns3" #"google" #"com"))
+		      (rr '(#"google" #"com") 'ns 'in 87076 '(#"ns4" #"google" #"com"))
+		      (rr '(#"google" #"com") 'ns 'in 87076 '(#"ns2" #"google" #"com"))
+		      (rr '(#"google" #"com") 'ns 'in 87076 '(#"ns1" #"google" #"com")))
+		(list (rr '(#"xmpp-server" #"l" #"google" #"com") 'a 'in 282 '#(74 125 153 125))
+		      (rr '(#"xmpp-server1" #"l" #"google" #"com") 'a 'in 1782 '#(74 125 53 125))
+		      (rr '(#"xmpp-server2" #"l" #"google" #"com") 'a 'in 1782 '#(74 125 47 125))
+		      (rr '(#"xmpp-server3" #"l" #"google" #"com") 'a 'in 1782 '#(74 125 45 125))
+		      (rr '(#"xmpp-server4" #"l" #"google" #"com") 'a 'in 1782 '#(74 125 45 125))
+		      (rr '(#"ns1" #"google" #"com") 'a 'in 2737 '#(216 239 32 10))
+		      (rr '(#"ns2" #"google" #"com") 'a 'in 2737 '#(216 239 34 10))
+		      (rr '(#"ns3" #"google" #"com") 'a 'in 2737 '#(216 239 36 10))
+		      (rr '(#"ns4" #"google" #"com") 'a 'in 2737 '#(216 239 38 10))))))

test-rrs.rkt

@@ -2,12 +2,12 @@
 
 (require "api.rkt")
 
-(provide (all-defined-out))
+(provide test-soa-rr test-rrs)
 
 (define test-soa-rr
-  (rr (domain '(#"example")) 'soa 'in 30
-      (soa (domain '(#"ns" #"example"))
-	   (domain '(#"tonyg" #"example"))
+  (rr '(#"example") 'soa 'in 30
+      (soa '(#"ns" #"example")
+	   '(#"tonyg" #"example")
 	   1
 	   24
 	   24
@@ -15,61 +15,13 @@
 	   10)))
 
 (define test-rrs
-  (list (rr (domain '(#"localhost" #"example")) 'a 'in 30 '#(127 0 0 1))
-	(rr (domain '(#"example")) 'mx 'in 30 (mx 5 (domain '(#"localhost" #"example"))))
-	(rr (domain '(#"example")) 'mx 'in 30 (mx 10 (domain '(#"subns" #"example"))))
-	(rr (domain '(#"google" #"example")) 'cname 'in 30 (domain '(#"www" #"google" #"com")))
-	(rr (domain '(#"roar" #"example")) 'a 'in 30 '#(192 168 1 1))
-	(rr (domain '(#"alias" #"example")) 'cname 'in 30 (domain '(#"roar" #"example")))
-	(rr (domain '(#"ns" #"example")) 'a 'in 30 '#(127 0 0 1))
-	(rr (domain '(#"hello" #"example")) 'txt 'in 30 '(#"Hello CRASH"))
-	(rr (domain '(#"subzone" #"example")) 'ns 'in 30 (domain '(#"subns" #"example")))
-	(rr (domain '(#"subns" #"example")) 'a 'in 30 '#(127 0 0 2))))
-
-;; (define test-roots
-;;   (list (rr (domain '()) 'ns 'in 30 (domain '(#"f" #"root-servers" #"net")))
-;; 	(rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(198 41 0 4))
-;; 	(rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(192 228 79 201))
-;; 	(rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(192 33 4 12))
-;; 	(rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(192 203 230 10))
-;; 	(rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(192 112 36 4))
-;; 	(rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(128 63 2 53))
-;; 	(rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(192 58 128 30))
-;; 	(rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(193 0 14 129))))
-
-(define test-roots
-  (list (rr (domain '(#"a" #"root-servers" #"net")) 'a 'in 3600000 '#(198 41 0 4))
-	(rr (domain '(#"b" #"root-servers" #"net")) 'a 'in 3600000 '#(192 228 79 201))
-	(rr (domain '(#"c" #"root-servers" #"net")) 'a 'in 3600000 '#(192 33 4 12))
-	(rr (domain '(#"d" #"root-servers" #"net")) 'a 'in 3600000 '#(128 8 10 90))
-	(rr (domain '(#"e" #"root-servers" #"net")) 'a 'in 3600000 '#(192 203 230 10))
-	(rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 3600000 '#(192 5 5 241))
-	(rr (domain '(#"g" #"root-servers" #"net")) 'a 'in 3600000 '#(192 112 36 4))
-	(rr (domain '(#"h" #"root-servers" #"net")) 'a 'in 3600000 '#(128 63 2 53))
-	(rr (domain '(#"i" #"root-servers" #"net")) 'a 'in 3600000 '#(192 36 148 17))
-	(rr (domain '(#"j" #"root-servers" #"net")) 'a 'in 3600000 '#(192 58 128 30))
-	(rr (domain '(#"k" #"root-servers" #"net")) 'a 'in 3600000 '#(193 0 14 129))
-	(rr (domain '(#"l" #"root-servers" #"net")) 'a 'in 3600000 '#(199 7 83 42))
-	(rr (domain '(#"m" #"root-servers" #"net")) 'a 'in 3600000 '#(202 12 27 33))
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"a" #"root-servers" #"net")))
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"b" #"root-servers" #"net")))
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"c" #"root-servers" #"net")))
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"d" #"root-servers" #"net")))
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"e" #"root-servers" #"net")))
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"f" #"root-servers" #"net")))
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"g" #"root-servers" #"net")))
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"h" #"root-servers" #"net")))
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"i" #"root-servers" #"net")))
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"j" #"root-servers" #"net")))
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"k" #"root-servers" #"net")))
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"l" #"root-servers" #"net")))
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"m" #"root-servers" #"net")))))
-
-(define pathological-roots
-  (list (rr (domain '(#"a")) 'ns 'in 30 (domain '(#"ns" #"b")))
-	(rr (domain '(#"b")) 'ns 'in 30 (domain '(#"ns" #"a")))))
-
-(define (test-port-number)
-  (string->number
-   (or (getenv "DNSPORT")
-       (error 'test-port-number "Please set your DNSPORT environment variable."))))
+  (list (rr '(#"localhost" #"example") 'a 'in 30 '#(127 0 0 1))
+	(rr '(#"example") 'mx 'in 30 (mx 5 '(#"localhost" #"example")))
+	(rr '(#"example") 'mx 'in 30 (mx 10 '(#"subns" #"example")))
+	(rr '(#"google" #"example") 'cname 'in 30 '(#"www" #"google" #"com"))
+	(rr '(#"roar" #"example") 'a 'in 30 '#(192 168 1 1))
+	(rr '(#"alias" #"example") 'cname 'in 30 '(#"roar" #"example"))
+	(rr '(#"ns" #"example") 'a 'in 30 '#(127 0 0 1))
+	(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))))

udp-operations-sig.rkt

@@ -0,0 +1,7 @@
+#lang racket/signature
+
+udp-open-socket ;; host port -> socket
+udp-close ;; socket -> void
+udp-bind! ;; socket host port -> void
+udp-send-to ;; socket host port bytes -> void
+udp-receive/timeout ;; socket bytes seconds -> (or (list non-negative-integer host port) #f)

zonedb.rkt

@@ -6,154 +6,40 @@
 (require racket/match)
 (require "api.rkt")
 (require "codec.rkt")
-(require "../racket-bitsyntax/main.rkt")
 
-(provide zone-ref
-	 zone-includes-name?
-	 incorporate-complete-answer
-	 zone-expire-name
-	 zone-expire
-	 empty-zone-db
+(provide incorporate-rr
 	 compile-zone-db
-	 compiled-zone?
 	 in-bailiwick?
 	 set-filter
 	 filter-by-type
 	 filter-rrs
-	 rr-set->list
-	 cname-sort ;; provided for unit tests
-	 zone->bit-string
-	 bit-string->zone)
+	 rr-set->list)
 
-;; An InfiniteLifetime is an (infinite-lifetime RelativeSeconds), a
-;; specification of the TTL to use when sending a non-expiring RR to a
-;; peer.
-(struct infinite-lifetime (ttl) #:prefab)
-
-;; A CompiledZone is a Hash<DomainName,Hash<RR,(or AbsoluteSeconds
-;; InfiniteLifetime)>>, representing a collection of DNS RRSets
-;; indexed by DomainName. Each RR in an RRSet either has an expiry
-;; time associated with it or has an InfiniteLifetime associated with
-;; it, in which case it should not expire.
-
-;; A Timers is a SetOf<(cons DomainName AbsoluteSeconds)>,
-;; representing a collection of timeouts that should be set against
-;; names to to see if their associated RRs have expired.
+;; A CompiledZone is a Hash<DomainName,SetOf<RR>>, representing a
+;; collection of DNS RRSets indexed by DomainName.
 
 ;; TODO: maybe store domain names big-end first? It'd make bailiwick
 ;; and subzone checks into prefix rather than suffix checks. It makes
 ;; domain names into paths through the DNS DB tree.
 
-(define (current-inexact-seconds)
-  (/ (current-inexact-milliseconds) 1000.0))
-
-(define (still-valid? expiry now)
-  (or (infinite-lifetime? expiry)
-      (>= expiry now)))
-
-;; CompiledZone DomainName -> Maybe<Set<RR>>
-(define (zone-ref db name)
-  (cond
-   [(hash-ref db name #f) =>
-    (lambda (expirymap)
-      (define now (current-inexact-seconds))
-      (for/set ([(resource expiry) expirymap] #:when (still-valid? expiry now))
-	(struct-copy rr resource [ttl (if (infinite-lifetime? expiry)
-					  (infinite-lifetime-ttl expiry)
-					  (inexact->exact (floor (- expiry now))))])))]
-   [else #f]))
-
-;; CompiledZone DomainName -> Boolean
-(define (zone-includes-name? db name)
-  (hash-has-key? db name))
-
-;; incorporate-rr : Maybe<AbsoluteSeconds> -> (RR CompiledZone -> CompiledZone)
-;;
-;; Incorporates the given RR into our database. If base-time is a
-;; number of seconds, we treat the RR as having a TTL that decreases
-;; as time goes by; otherwise base-time is #f, and we treat the RR as
-;; being non-expiring with an InfiniteLifetime.
-(define ((incorporate-rr base-time) resource0 db)
-  (define expiry (if base-time
-		     (+ base-time (rr-ttl resource0))
-		     (infinite-lifetime (rr-ttl resource0))))
-  (define resource (struct-copy rr resource0 [ttl 0]))
-  (define name (rr-name resource))
-  (define old-expirymap (hash-ref db name hash))
-  (define old-expiry (hash-ref old-expirymap resource 0))
-  (cond
-   [(infinite-lifetime? old-expiry) ;; don't update TTL: the existing record should live forever
-    db]
-   [(or (infinite-lifetime? expiry) (> expiry old-expiry)) ;; update TTL
-    (hash-set db name (hash-set old-expirymap resource expiry))]
-   [else ;; old record finite-lifetime but expiring after the new expiry: leave it alone
-    db]))
-
-;; Maybe<CompleteAnswer> CompiledZone -> (values CompiledZone Timers)
-(define (incorporate-complete-answer ans db)
-  (match ans
-    [#f
-     (values db (set))]
-    [(complete-answer ns us ds)
-     (define now (current-inexact-seconds))
-     (for/fold ([db db] [timers (set)])
-	 ([rr (in-sequences ns us ds)])
-       (values ((incorporate-rr now) rr db)
-	       (set-add timers (cons (rr-name rr) (rr-ttl rr)))))]))
-
-;; CompiledZone DomainName -> CompiledZone
-;; Checks the given name to see if there are any expiring records, and
-;; if so, removes them.
-(define (zone-expire-name db name now-seconds)
-  (define new-expirymap
-    (if (zone-includes-name? db name)
-	(for/hash ([(resource expiry) (hash-ref db name)] #:when (still-valid? expiry now-seconds))
-	  (values resource expiry))
-	(hash)))
-  (if (zero? (hash-count new-expirymap))
-      (hash-remove db name)
-      (hash-set db name new-expirymap)))
-
-;; CompiledZone -> (values CompiledZone Timers)
-;; Used to freshen a saved zone when it is loaded from disk.
-(define (zone-expire zone)
-  (define now-seconds (current-inexact-seconds))
-  (for/fold ([zone zone] [timers (set)])
-      ([name (hash-keys zone)])
-    (define new-zone (zone-expire-name zone name now-seconds))
-    (cond
-     [(hash-ref new-zone name #f) =>
-      (lambda (expirymap)
-	(values new-zone
-		(set-union (list->set
-			    (map (lambda (e) (cons name (- e now-seconds)))
-				 (filter (lambda (e) (not (infinite-lifetime? e)))
-					 (hash-values expirymap))))
-			   timers)))]
-     [else
-      (values new-zone timers)])))
-
-;; empty-zone-db : -> CompiledZone
-(define (empty-zone-db)
-  (make-immutable-hash))
+;; RR Hash -> Hash
+(define (incorporate-rr rr db)
+  (hash-set db (rr-name rr) (set-add (hash-ref db (rr-name rr) (set)) rr)))
 
 ;; compile-zone-db : ListOf<RR> -> CompiledZone
 ;; Builds an immutable hash table from the given RRs, suitable for
 ;; quickly looking up answers to queries.
 (define (compile-zone-db rrs)
-  (foldl (incorporate-rr #f) (empty-zone-db) rrs))
+  (foldl incorporate-rr (make-immutable-hash) rrs))
 
-(define (compiled-zone? z)
-  (hash? z)) ;; hm
-
-;; in-bailiwick? : DomainName DomainName -> Boolean
+;; in-bailiwick? : DomainName RR -> Boolean
 ;; Answers #t iff dn falls within the bailiwick of the zone with
-;; origin o.
-(define (in-bailiwick? dn o)
+;; origin rr.
+(define (in-bailiwick? dn rr)
   (cond
-   ((equal? dn o) #t)
-   ((domain-root? dn) #f)
-   (else (in-bailiwick? (domain-parent dn) o))))
+   ((equal? dn (rr-name rr)) #t)
+   ((null? dn) #f)
+   (else (in-bailiwick? (cdr dn) rr))))
 
 ;; set-filter : (X -> Boolean) SetOf<X> -> SetOf<X>
 ;; Retains only those elements of its argument for which the predicate
@@ -168,7 +54,7 @@
 (define (filter-by-type rrset type)
   (set-filter (lambda (rr) (eqv? (rr-type rr) type)) rrset))
 
-;; filter-rrs : SetOf<RR> QueryType QueryClass -> SetOf<RR>
+;; filter-rrs : SetOf<RR> QueryType QueryClass
 ;; Returns a set like its argument with RRs not matching the given
 ;; type and class removed.
 (define (filter-rrs rrs qtype qclass)
@@ -185,74 +71,6 @@
 ;; rr-set->list : SetOf<RR> -> ListOf<RR>
 ;; Like set->list, but places all CNAME records first.
 ;; This is apparently to work around bugs in old versions of BIND?
-;;
-;; The CNAMEs even need to be in topologically-sorted order.
-;; http://homepage.ntlworld.com./jonathan.deboynepollard/FGA/dns-response-taxonomy.html
-;; has this to say on this topic:
-;;   "A content DNS server following the algorithm in § 4.3.2 of RFC
-;;    1034 will insert this chain in first-to-last order in the
-;;    response. The response parsing code in most resolving proxy DNS
-;;    servers and DNS client libraries expects this order. However,
-;;    the actual text of RFC 1034 itself does not guarantee it."
-;; Sure enough, the resolver in Firefox seems not to be able to handle
-;; CNAMEs in any order other than strictly causal. While we could be
-;; more careful about retaining the ordering of RRs all the way
-;; through the resolution and CNAME expansion processes, that would
-;; pollute the logic with a bunch of noise about RR order which isn't
-;; even supposed to be relevant. So we *recover* the order here, which
-;; is a bit expensive.
 (define (rr-set->list rrs)
-  (append (cname-sort (set->list (filter-by-type rrs 'cname)))
+  (append (set->list (filter-by-type rrs 'cname))
 	  (set->list (set-filter (lambda (rr) (not (eqv? (rr-type rr) 'cname))) rrs))))
-
-;; cname-sort : ListOf<RR<CNAME>> -> ListOf<RR<CNAME>>
-;; Produce an ordering of the CNAMEs given that respects their
-;; "causality". For example, if a CNAME b and b CNAME c, then the RRs
-;; will be presented in that order (and not the other order, with b
-;; CNAME c first).
-(define (cname-sort cnames)
-  (define lhss (list->set (map rr-name cnames)))
-  (define rhss (list->set (map rr-rdata cnames)))
-  (define roots (set->list (set-subtract lhss rhss))) ;; Nodes not the targets of some edge.
-  (define (targets-of name) (for/list [(rr cnames) #:when (equal? (rr-name rr) name)] rr))
-  (let iterate ((remaining roots)
-		(seen (set))
-		(acc '()))
-    (if (null? remaining)
-	(reverse acc)
-	(let ((source (car remaining)))
-	  (if (set-member? seen source)
-	      (iterate (cdr remaining) seen acc)
-	      (let* ((rrs (targets-of source))
-		     (targets (map rr-rdata rrs)))
-		(iterate (append targets (cdr remaining))
-			 (set-add seen source)
-			 (append rrs acc))))))))
-
-;; CompiledZone -> Bitstring
-;; Produces a serialized form of the zone suitable for saving to disk.
-(define (zone->bit-string zone)
-  (for*/fold ([acc (bit-string)])
-      ([(name rrmap) zone] [(rr expiry) rrmap])
-    (bit-string-append
-     acc
-     (match expiry
-       [(infinite-lifetime ttl)
-	(bit-string (rr :: (t:rr)) 1 (ttl :: bits 32))]
-       [expirytime
-	(bit-string (rr :: (t:rr)) 0 ((truncate (inexact->exact expirytime)) :: bits 32))]))))
-
-;; Bitstring -> CompiledZone
-;; Produces a deserialized form of the zone. Suitable for use in loading from disk.
-(define (bit-string->zone bs)
-  (define now (current-inexact-seconds))
-  (define empty-packet (bytes))
-  (let loop ((db (empty-zone-db))
-	     (bs bs))
-    (bit-string-case bs
-      ([ ]
-       db)
-      ([ (rr0 :: (t:rr empty-packet)) (= 1) (ttl :: bits 32) (rest :: binary) ]
-       (loop ((incorporate-rr #f) (struct-copy rr rr0 [ttl ttl]) db) rest))
-      ([ (rr0 :: (t:rr empty-packet)) (= 0) (expirytime :: bits 32) (rest :: binary) ]
-       (loop ((incorporate-rr now) (struct-copy rr rr0 [ttl (- expirytime now)]) db) rest)))))