Final TR conversion of driver

2013-03-18 15:45:55 -04:00 · 2013-03-18 15:45:55 -04:00 · bdafaa6199
parent 9f79a9b831
commit bdafaa6199
6 changed files with 173 additions and 131 deletions
--- a/codec.rkt
+++ b/codec.rkt
@ -25,8 +25,6 @@
 (require "api.rkt")
 (require "mapping.rkt")

-(domain (list #"hello"))
-
 (require racket/match)

 (require racket-bitsyntax)
--- a/driver.rkt
+++ b/driver.rkt
@ -1,4 +1,4 @@
-#lang racket/base
+#lang typed/racket/base

 ;; DNS server using os-big-bang.rkt and os-udp.rkt.

@ -10,9 +10,9 @@
 (require "codec.rkt")
 (require "zonedb.rkt")
 (require "resolver.rkt")
-(require racket-typed-matrix/sugar-untyped)
+(require racket-typed-matrix/sugar-typed)
 (require racket-typed-matrix/support/spy)
-(require racket-typed-matrix/drivers/udp-untyped)
+(require racket-typed-matrix/drivers/udp)
 (require "tk-dns.rkt")

 ;; Instantiated with a SOA record for the zone it is serving as well
@ -28,7 +28,7 @@
 ;;    determines subzones based on the RRs it is configured with at
 ;;    startup.

-;; start-server : UInt16 RR ListOf<RR> -> Void
+(: start-server : Nonnegative-Integer 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
 ;; in the soa-rr given.
@ -40,21 +40,27 @@

  (display ";; Ready.\n")

-  (ground-vm (udp-driver)
-	     (generic-spy 'UDP)
-	     (nested-vm
-	      (dns-spy)
-	      (spawn #:child (dns-read-driver local-addr))
-	      (spawn #:child (dns-write-driver local-addr))
-	      (endpoint #:subscriber (bad-dns-packet (wild) (wild) (wild) (wild))
-			[p (begin (log-error (pretty-format p))
-				  '())])
-	      (endpoint #:subscriber (dns-request (wild) (wild) (wild))
-			[r (map send-message (handle-request soa-rr zone r))]))))
+  (ground-vm: ((inst udp-driver Void))
+	      ((inst generic-spy Void) 'UDP)
+	      (nested-vm: : Void
+	       ((inst dns-spy Void))
+	       ((inst dns-read-driver Void) local-addr)
+	       ((inst dns-write-driver Void) local-addr)
+	       (endpoint: : Void #:subscriber (bad-dns-packet (wild) (wild) (wild) (wild))
+	       		  [p (begin (log-error (pretty-format p))
+	       			    '())])
+	       (endpoint: : Void #:subscriber (dns-request (wild) (wild) (wild))
+	       		  [(? dns-request? r)
+			   (begin (define reply (handle-request soa-rr zone r))
+				  (when reply (send-message reply)))]))))

+(define-type ReplyMaker (DomainName Boolean (Setof RR) (Setof RR) (Setof RR) -> DNSMessage))
+
+(: handle-request : RR CompiledZone dns-request -> (Option dns-reply))
 (define (handle-request soa-rr zone request)
  (match-define (dns-request request-message request-source request-sink) request)

+  (: make-reply : ReplyMaker)
  (define (make-reply name send-name-error? answers authorities additional)
    (dns-message (dns-message-id request-message)
 		 'response
@ -69,6 +75,7 @@
 		 (rr-set->list authorities)
 		 (rr-set->list additional)))

+  (: answer-question : Question ReplyMaker -> DNSMessage)
  (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
@ -86,23 +93,24 @@
    ;; here. Reexamine the rules for doing so.
    (match-define (question qname qtype qclass #f) q)

+    (: expand-cnames : (Listof DomainName) CompleteAnswer -> DNSMessage)
    (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)))
+	 (define a (resolve-from-zone (cname-question next-cname q) zone soa-rr (set)))
 	 (incorporate-answer a rest ans)]))

+    (: incorporate-answer : Answer (Listof DomainName) CompleteAnswer -> DNSMessage)
    (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))]
+	[(? complete-answer? c)
+	 (expand-cnames worklist (merge-answers c ans))]
 	[_ ;; #f or a referral
 	 (expand-cnames worklist ans)]))

@ -117,9 +125,9 @@
  ;; TODO: check opcode and direction in request
  ;; TODO: think again about multiple questions in one packet
  (match (dns-message-questions request-message)
-    ['() '()]
+    ['() #f]
    [(cons q _)
-     (list (dns-reply (answer-question q make-reply) request-sink request-source))]))
+     (dns-reply (answer-question q make-reply) request-sink request-source)]))

 (require "test-rrs.rkt")
 (start-server (test-port-number) test-soa-rr test-rrs)
--- a/resolver.rkt
+++ b/resolver.rkt
@ -1,4 +1,4 @@
-#lang racket/base
+#lang typed/racket/base

 (require racket/pretty)

@ -9,7 +9,10 @@
 (require "codec.rkt")
 (require "zonedb.rkt")

-(provide (struct-out partial-answer)
+(provide PartialAnswer
+	 Referral
+	 Answer
+	 (struct-out partial-answer)
 	 (struct-out referral)

 	 resolve-from-zone)
@ -46,21 +49,27 @@
 ;; -- 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).
+(define-type Answer (U CompleteAnswer PartialAnswer Referral #f))

 ;; 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)
+(struct: partial-answer ([base : CompleteAnswer] [cnames : (Listof DomainName)]) #:prefab)
+(define-type PartialAnswer partial-answer)

 ;; A Referral is a (referral DomainName Set<RR> Set<RR>)
-(struct referral (zone-origin nameserver-rrs additional) #:prefab)
+(struct: referral ([zone-origin : DomainName]
+		   [nameserver-rrs : (Setof RR)]
+		   [additional : (Setof RR)]) #:prefab)
+(define-type Referral referral)

+(: answer-from-zone : Question CompiledZone (Option RR) -> Answer)
 ;; 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: rrset : (Setof RR) (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))
@ -76,11 +85,15 @@
   [(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))]))
+    (partial-answer base (set-map cnames rr-rdata-domain-name))]))

+(: closest-nameservers : DomainName CompiledZone -> (Setof RR))
 (define (closest-nameservers name zone)
-  (let search ((name name))
+  (let: search ((name : (Option DomainName) name))
    (cond
+     ((not name)
+      ;; We've walked up the tree past the root. Give up.
+      (set))
     ((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.
@ -89,19 +102,21 @@
 	(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))))))

+(: closest-untried-nameservers : Question CompiledZone (Setof DomainName) -> (Setof RR))
 ;; 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))
+  (list->set
+   (for/list: : (Listof RR) ([rr : RR ns-rrset]
+			     #:when (not (set-member? nameservers-tried (rr-rdata rr))))
+	      rr)))

+(: empty-answer : Question CompiledZone (Option RR) -> (Option CompleteAnswer))
 (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
@ -111,21 +126,23 @@
      ;; A normal no-answers packet otherwise.
      (empty-complete-answer)))

-;; additional-section/a : CompiledZone ListOf<DomainName> -> Set<RR>
+(: additional-section/a : CompiledZone (Listof DomainName) -> (Setof 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)
+  (foldl (lambda: ([name : DomainName] [section : (Setof RR)])
 	   (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)
+		      (set-filter (lambda: ([rr : RR])
+				    (and (memv (rdata-type (rr-rdata rr)) '(a aaaa))
+					 (eqv? (rr-class rr) 'in)))
+				  (or (zone-ref zone name) ((inst set RR))))))
+	 ((inst set RR))
 	 names))

+(: resolve-from-zone : Question CompiledZone (Option RR) (Setof DomainName) -> Answer)
 (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)))
@ -134,4 +151,5 @@
 	    (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))))))))
+			(additional-section/a zone (set-map best-nameservers
+							    rr-rdata-domain-name))))))))
--- a/test-rrs.rkt
+++ b/test-rrs.rkt
@ -1,77 +1,86 @@
-#lang racket/base
+#lang typed/racket/base

 (require "api.rkt")

 (provide (all-defined-out))

 (define test-soa-rr
-  (rr (domain '(#"example")) 'soa 'in 30
-      (soa (domain '(#"ns" #"example"))
-	   (domain '(#"tonyg" #"example"))
-	   1
-	   24
-	   24
-	   30
-	   10)))
+  (rr (domain '(#"example")) 'in 30
+      (rdata-soa 'soa
+		 (domain '(#"ns" #"example"))
+		 (domain '(#"tonyg" #"example"))
+		 1
+		 24
+		 24
+		 30
+		 10)))
+
+(: A      : (Listof Bytes) (Vector Integer Integer Integer Integer) -> RR)
+(: A/ttl  : (Listof Bytes) (Vector Integer Integer Integer Integer) Nonnegative-Integer -> RR)
+(: MX     : (Listof Bytes) Nonnegative-Integer (Listof Bytes) -> RR)
+(: CNAME  : (Listof Bytes) (Listof Bytes) -> RR)
+(: NS     : (Listof Bytes) (Listof Bytes) -> RR)
+(: NS/ttl : (Listof Bytes) (Listof Bytes) Nonnegative-Integer -> RR)
+(: TXT    : (Listof Bytes) (Listof Bytes) -> RR)
+
+(define (A n ip) (A/ttl n ip 30))
+(define (A/ttl n ip ttl) (rr (domain n) 'in ttl (rdata-ipv4 'a (cast ip IPv4))))
+(define (MX n p t) (rr (domain n) 'in 30 (rdata-mx 'mx p (domain t))))
+(define (CNAME n1 n2) (rr (domain n1) 'in 30 (rdata-domain 'cname (domain n2))))
+(define (NS n1 n2) (NS/ttl n1 n2 30))
+(define (NS/ttl n1 n2 ttl) (rr (domain n1) 'in ttl (rdata-domain 'ns (domain n2))))
+(define (TXT n strs) (rr (domain n) 'in 30 (rdata-txt 'txt strs)))

 (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))))
+  (list (A '(#"localhost" #"example") '#(127 0 0 1))
+	(MX '(#"example") 5 '(#"localhost" #"example"))
+	(MX '(#"example") 10 '(#"subns" #"example"))
+	(CNAME '(#"google" #"example")'(#"www" #"google" #"com"))
+	(A '(#"roar" #"example") '#(192 168 1 1))
+	(CNAME '(#"alias" #"example") '(#"roar" #"example"))
+	(A '(#"ns" #"example") '#(127 0 0 1))
+	(TXT '(#"hello" #"example") '(#"Hello CRASH"))
+	(NS '(#"subzone" #"example") '(#"subns" #"example"))
+	(A '(#"subns" #"example") '#(127 0 0 2))))

 (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))
-	;; ^ changed on 1 Jan 2013 to the below:
-	(rr (domain '(#"d" #"root-servers" #"net")) 'a 'in 3600000 '#(199 7 91 13))
-	(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")))))
+  (list (A/ttl '(#"a" #"root-servers" #"net") '#(198 41 0 4) 3600000)
+	(A/ttl '(#"b" #"root-servers" #"net") '#(192 228 79 201) 3600000)
+	(A/ttl '(#"c" #"root-servers" #"net") '#(192 33 4 12) 3600000)
+	(A/ttl '(#"d" #"root-servers" #"net") '#(199 7 91 13) 3600000)
+	(A/ttl '(#"e" #"root-servers" #"net") '#(192 203 230 10) 3600000)
+	(A/ttl '(#"f" #"root-servers" #"net") '#(192 5 5 241) 3600000)
+	(A/ttl '(#"g" #"root-servers" #"net") '#(192 112 36 4) 3600000)
+	(A/ttl '(#"h" #"root-servers" #"net") '#(128 63 2 53) 3600000)
+	(A/ttl '(#"i" #"root-servers" #"net") '#(192 36 148 17) 3600000)
+	(A/ttl '(#"j" #"root-servers" #"net") '#(192 58 128 30) 3600000)
+	(A/ttl '(#"k" #"root-servers" #"net") '#(193 0 14 129) 3600000)
+	(A/ttl '(#"l" #"root-servers" #"net") '#(199 7 83 42) 3600000)
+	(A/ttl '(#"m" #"root-servers" #"net") '#(202 12 27 33) 3600000)
+	(NS/ttl '() '(#"a" #"root-servers" #"net") 3600000)
+	(NS/ttl '() '(#"b" #"root-servers" #"net") 3600000)
+	(NS/ttl '() '(#"c" #"root-servers" #"net") 3600000)
+	(NS/ttl '() '(#"d" #"root-servers" #"net") 3600000)
+	(NS/ttl '() '(#"e" #"root-servers" #"net") 3600000)
+	(NS/ttl '() '(#"f" #"root-servers" #"net") 3600000)
+	(NS/ttl '() '(#"g" #"root-servers" #"net") 3600000)
+	(NS/ttl '() '(#"h" #"root-servers" #"net") 3600000)
+	(NS/ttl '() '(#"i" #"root-servers" #"net") 3600000)
+	(NS/ttl '() '(#"j" #"root-servers" #"net") 3600000)
+	(NS/ttl '() '(#"k" #"root-servers" #"net") 3600000)
+	(NS/ttl '() '(#"l" #"root-servers" #"net") 3600000)
+	(NS/ttl '() '(#"m" #"root-servers" #"net") 3600000)))

 (define pathological-roots
-  (list (rr (domain '(#"a")) 'ns 'in 30 (domain '(#"ns" #"b")))
-	(rr (domain '(#"b")) 'ns 'in 30 (domain '(#"ns" #"a")))))
+  (list (NS '(#"a") '(#"ns" #"b"))
+	(NS '(#"b") '(#"ns" #"a"))))

+(: test-port-number : -> Nonnegative-Integer)
 (define (test-port-number)
-  (string->number
-   (or (getenv "DNSPORT")
-       (error 'test-port-number "Please set your DNSPORT environment variable."))))
+  (define p
+    (string->number
+     (or (getenv "DNSPORT")
+	 (error 'test-port-number "Please set your DNSPORT environment variable."))))
+  (if (or (not p) (not (exact? p)) (not (integer? p)) (negative? p))
+      (error 'test-port-number "Invalid DNSPORT setting.")
+      p))
--- a/tk-dns.rkt
+++ b/tk-dns.rkt
@ -19,36 +19,43 @@
 (struct: dns-request ([message : DNSMessage] [source : UdpAddress] [sink : UdpAddress]) #:prefab)
 (struct: dns-reply ([message : DNSMessage] [source : UdpAddress] [sink : UdpAddress]) #:prefab)

+(: dns-read-driver : (All (ParentState) UdpAddress -> (Action ParentState)))
 (define (dns-read-driver s)
-  (transition: (void) : Void
-    (at-meta-level
-     (endpoint: : Void
-		#:subscriber (udp-packet-pattern (wild) s (wild))
-		[(udp-packet source (== s) #"")
-		 (begin (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)))))]))))
+  (spawn: #:parent : ParentState
+	  #:child : Void
+	  (transition: (void) : Void
+	    (at-meta-level
+	     (endpoint: : Void
+			#:subscriber (udp-packet-pattern (wild) s (wild))
+			[(udp-packet source (== s) #"")
+			 (begin (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)))))])))))

+(: dns-write-driver : (All (ParentState) UdpAddress -> (Action ParentState)))
 (define (dns-write-driver s)
+  (: translate : DNSMessage UdpAddress -> (ActionTree Void))
  (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: (void) : Void
-    (endpoint: : Void
-	       #:subscriber (dns-request (wild) s (wild))
-	       [(dns-request message (== s) sink) (translate message sink)])
-    (endpoint: : Void
-	       #:subscriber (dns-reply   (wild) s (wild))
-	       [(dns-reply   message (== s) sink) (translate message sink)])))
+  (spawn: #:parent : ParentState
+	  #:child : Void
+	  (transition: (void) : Void
+	    (endpoint: : Void
+		       #:subscriber (dns-request (wild) s (wild))
+		       [(dns-request message (== s) sink) (translate message sink)])
+	    (endpoint: : Void
+		       #:subscriber (dns-reply   (wild) s (wild))
+		       [(dns-reply   message (== s) sink) (translate message sink)]))))

 (: dns-spy : (All (ParentState) -> (Action ParentState)))
 (define (dns-spy)
--- a/zonedb.rkt
+++ b/zonedb.rkt
@ -10,7 +10,8 @@
 (require racket-bitsyntax)
 (require (rename-in racket-typed-matrix/tr-struct-copy [tr-struct-copy struct-copy])) ;; PR13149

-(provide zone-ref
+(provide CompiledZone
+	 zone-ref
 	 zone-includes-name?
 	 incorporate-complete-answer
 	 zone-expire-name
@ -22,6 +23,7 @@
 	 filter-by-type
 	 filter-rrs
 	 rr-set->list
+	 rr-rdata-domain-name
 	 cname-sort ;; provided for unit tests
 	 zone->bit-string
 	 bit-string->zone)
@ -245,8 +247,8 @@
  (append (cname-sort (set->list cnames))
 	  (set->list (set-subtract rrs cnames))))

-(: cname-target : RR -> DomainName)
-(define (cname-target rr)
+(: rr-rdata-domain-name : RR -> DomainName)
+(define (rr-rdata-domain-name rr)
  (rdata-domain-name (cast (rr-rdata rr) rdata-domain)))

 (: cname-sort : (Listof RR) -> (Listof RR))
@ -256,7 +258,7 @@
 ;; CNAME c first).
 (define (cname-sort cnames)
  (define lhss (list->set (map rr-name cnames)))
-  (define rhss (list->set (map cname-target cnames)))
+  (define rhss (list->set (map rr-rdata-domain-name cnames)))
  (define roots (set->list (set-subtract lhss rhss))) ;; Nodes not the targets of some edge.
  (: targets-of : DomainName -> (Listof RR))
  (define (targets-of name) (filter (lambda: ([rr : RR]) (equal? (rr-name rr) name)) cnames))
@ -269,7 +271,7 @@
 	  (if (set-member? seen source)
 	      (iterate (cdr remaining) seen acc)
 	      (let* ((rrs (targets-of source))
-		     (targets (map cname-target rrs)))
+		     (targets (map rr-rdata-domain-name rrs)))
 		(iterate (append targets (cdr remaining))
 			 (set-add seen source)
 			 (append rrs acc))))))))