Remove clutter

.gitignore

@@ -0,0 +1 @@
+compiled/

TODO

@@ -1,8 +1,5 @@
 ## DNS
 
-Make RData and RRType the same thing so it becomes impossible to make
-a mistake.
-
 Tests needed:
  - encode and decode of each kind of RR
     - so far, have: txt, a, ns, mx, soa, cname, aaaa, srv.
@@ -34,50 +31,3 @@ doesn't make sense to apply there.
 
 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-untyped.rkt

@@ -0,0 +1,40 @@
+#lang racket/base
+;; Untyped struct definitions required to interoperate with marketplace's struct-map
+;; See also Racket PR 13593.
+
+(require marketplace/struct-map)
+
+(provide (struct-out domain))
+
+;; (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)))
+
+(struct domain (labels downcased-labels)
+	#:transparent
+	#:property prop:equal+hash (list domain=? domain-hash-1/2 domain-hash-1/2)
+	#:property prop:struct-map (lambda (f seed x)
+				     (let-values (((labels seed) (f (domain-labels x) seed)))
+				       (values (make-domain labels) seed))))
+
+;; 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)))

api.rkt

@@ -1,12 +1,19 @@
-#lang racket/base
+#lang typed/racket/base
 ;; Definitions for use in the API to the functionality of the library.
 
-(provide (except-out (struct-out domain) domain)
+(provide DomainName
+	 (except-out (struct-out domain) domain)
 	 (rename-out [make-domain domain])
 	 domain-root?
 	 domain-parent
 
-	 (struct-out question)
+	 IPv4
+	 IPv6
+
+	 (struct-out question-repr)
+	 Question question question?
+	 QuestionPattern question-pattern question-pattern?
+
 	 question-cyclic?
 	 question-too-glueless?
 	 question-restarted?
@@ -14,21 +21,37 @@
 	 cname-question
 	 ns-question
 
-	 (struct-out answered-question)
+	 (struct-out answered-question-repr)
+	 AnsweredQuestion answered-question answered-question?
+	 AnsweredQuestionPattern answered-question-pattern answered-question-pattern?
 	 (struct-out rr)
+	 RR
 
+	 CompleteAnswer
 	 (struct-out complete-answer)
 	 empty-complete-answer
 	 merge-answers
 	 extract-addresses
 
-	 (struct-out hinfo)
-	 (struct-out minfo)
-	 (struct-out mx)
-	 (struct-out soa)
-	 (struct-out wks)
-	 (struct-out srv)
+	 RData
+	 (struct-out rdata)
+	 (struct-out rdata-domain)
+	 (struct-out rdata-ipv4)
+	 (struct-out rdata-ipv6)
+	 (struct-out rdata-hinfo)
+	 (struct-out rdata-minfo)
+	 (struct-out rdata-mx)
+	 (struct-out rdata-soa)
+	 (struct-out rdata-wks)
+	 (struct-out rdata-srv)
+	 (struct-out rdata-txt)
+	 (struct-out rdata-raw)
+	 rdata-type-pred
 
+	 RRType
+	 QueryType
+	 RRClass
+	 QueryClass
 	 type->value value->type
 	 qtype->value value->qtype
 	 class->value value->class
@@ -37,46 +60,50 @@
 (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)))
+(require marketplace)
+(require marketplace/struct-map)
+(require marketplace/support/pseudo-substruct)
 
 ;; 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))))
+(require/typed "api-untyped.rkt"
+	       [#:struct domain ([labels : (Listof Bytes)]
+				 [downcased-labels : (Listof Bytes)])])
+(define-type DomainName domain)
 
 ;; A ShortString is a String with length 255 or shorter.
 
 ;; An IPv4 is a (vector Byte Byte Byte Byte), representing an IPv4
 ;; address. For example, 127.0.0.1 is represented as (vector 127 0 0
 ;; 1).
+(define-type IPv4 (Vector Byte Byte Byte Byte))
 
 ;; An IPv6 is a Vector of length 16 containing Bytes, representing an
 ;; IPv6 address. For example, 2001:0db8:85a3:0000:0000:8a2e:0370:7334
 ;; is represented as (vector #x20 #x01 #x0d #xb8 #x85 #xa3 #x00 #x00
 ;; #x00 #x00 #x8a #x2e #x03 #x70 #x73 #x34).
+(define-type IPv6 (Vector Byte Byte Byte Byte
+			  Byte Byte Byte Byte
+			  Byte Byte Byte Byte
+			  Byte Byte Byte Byte))
 
 ;; 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)
+(struct: (TName TType TClass TContext)
+	 question-repr
+	 ([name : TName] [type : TType] [class : TClass] [context : TContext])
+	 #:transparent)
+(pseudo-substruct: (question-repr DomainName QueryType QueryClass QuestionContext)
+		   Question question question?)
+(pseudo-substruct: (question-repr (U Wild DomainName)
+				  (U Wild QueryType)
+				  (U Wild QueryClass)
+				  (U Wild QuestionContext))
+		   QuestionPattern question-pattern question-pattern?)
 
 ;; A QuestionContext is one of
 ;; -- (cname-subq Question), resulting from the expansion of a CNAME
@@ -89,32 +116,46 @@
 ;; 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)
+(struct: subquestion ([parent : Question]) #:transparent)
+(struct: cname-subq subquestion () #:transparent)
+(struct: ns-subq subquestion () #:transparent)
+(define-type QuestionContext (U subquestion cname-subq ns-subq False 'restart))
 
 ;; An AnsweredQuestion is an (answered-question Question
 ;; Maybe<CompleteAnswer>).
-(struct answered-question (q a) #:prefab)
+(struct: (TQ TA) answered-question-repr ([q : TQ] [a : TA]) #:transparent)
+(pseudo-substruct: (answered-question-repr Question (Option CompleteAnswer))
+		   AnsweredQuestion answered-question answered-question?)
+(pseudo-substruct: (answered-question-repr (U Wild Question) (U Wild (Option CompleteAnswer)))
+		   AnsweredQuestionPattern answered-question-pattern answered-question-pattern?)
 
 ;; A CompleteAnswer is a (complete-answer Set<RR> Set<RR> Set<RR>)
-(struct complete-answer (rrs authorities additional) #:prefab)
+(struct: complete-answer
+	 ([rrs : (Setof RR)] [authorities : (Setof RR)] [additional : (Setof RR)])
+	 #:transparent)
+(define-type CompleteAnswer complete-answer)
 
 ;; 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 : DomainName]
+	     [class : RRClass]
+	     [ttl : Nonnegative-Integer]
+	     [rdata : RData])
+	 #:transparent)
+(define-type RR rr)
 
 ;; An RData is one of
 ;; - a DomainName, for CNAME, MB, MD, MF, MG, MR, NS and PTR records
 ;; - an IPv4, an "A" record
 ;; - an IPv6, an "AAAA" record
-;; - (hinfo ShortString ShortString), a host information record [O]
+;; - (hinfo Bytes Bytes), a host information record [O]
 ;; - (minfo DomainName DomainName), a mailbox information record [O]
 ;; - (mx Uint16 DomainName), a mail exchanger record
 ;; - (soa DomainName DomainName Uint32 Uint32 Uint32 Uint32 Uint32), a
 ;;   start-of-authority record
 ;; - (wks IPv4 Byte Bytes), a Well-Known Service [O]
 ;; - (srv Uint16 Uint16 Uint16 DomainName), an "SRV" record
+;; - a ListOf<Bytes>, a txt record
 ;; - a Bytes, either a 'null type RR or any unrecognised RR type.
 ;;
 ;; In each case, the RData's variant MUST line up correctly with the
@@ -122,17 +163,43 @@
 ;;
 ;; 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: rdata ([type : RRType]) #:transparent)
+(struct: rdata-domain rdata ([name : DomainName]) #:transparent)
+(struct: rdata-ipv4 rdata ([address : IPv4]) #:transparent)
+(struct: rdata-ipv6 rdata ([address : IPv6]) #:transparent)
+(struct: rdata-hinfo rdata ([cpu : Bytes] [os : Bytes]) #:transparent)
+(struct: rdata-minfo rdata ([rmailbx : DomainName] [emailbx : DomainName]) #:transparent)
+(struct: rdata-mx rdata ([preference : Nonnegative-Integer] [exchange : DomainName]) #:transparent)
+(struct: rdata-soa rdata ([mname : DomainName]
+			  [rname : DomainName]
+			  [serial : Nonnegative-Integer]
+			  [refresh : Nonnegative-Integer]
+			  [retry : Nonnegative-Integer]
+			  [expire : Nonnegative-Integer]
+			  [minimum : Nonnegative-Integer]) #:transparent)
+(struct: rdata-wks rdata ([address : IPv4] [protocol : Byte] [bitmap : Bytes]) #:transparent)
+(struct: rdata-srv rdata ([priority : Nonnegative-Integer]
+			  [weight : Nonnegative-Integer]
+			  [port : Nonnegative-Integer]
+			  [target : DomainName]) #:transparent)
+(struct: rdata-txt rdata ([strings : (Listof Bytes)]) #:transparent)
+(struct: rdata-raw rdata ([body : Bytes]) #:transparent)
+(define-type RData rdata)
+
+(: rdata-type-pred : RRType -> (RData -> Boolean))
+(define ((rdata-type-pred t) d)
+  (eq? (rdata-type d) t))
 
 ;; An RRType is a Symbol or a Number, one of the possibilities given
 ;; in the following define-mapping. It represents the type of an
 ;; RR. When used in an RR with an RData, the RRType and the RData
 ;; variant must correspond.
+(define-type RRType (U 'a 'ns 'md 'mf 'cname 'soa 'mb 'mg
+		       'mr 'null 'wks 'ptr 'hinfo 'minfo 'mx 'txt
+		       'aaaa 'srv
+		       Nonnegative-Integer))
+(: type->value : RRType -> Nonnegative-Integer)
+(: value->type : Nonnegative-Integer -> RRType)
 (define-mapping type->value value->type
   #:forward-default values
   #:backward-default values
@@ -158,6 +225,9 @@
 ;; A QueryType is a Symbol or Number (as given in the following
 ;; define-mapping) or an RRType. It specifies the kinds of records
 ;; being sought after in a DNS query.
+(define-type QueryType (U RRType 'axfr 'mailb 'maila '*))
+(: qtype->value : QueryType -> Nonnegative-Integer)
+(: value->qtype : Nonnegative-Integer -> QueryType)
 (define-mapping qtype->value value->qtype
   #:forward-default type->value
   #:backward-default value->type
@@ -170,6 +240,9 @@
 ;; in the following define-mapping. It represents the "class" of DNS
 ;; records being discussed. All classes except 'in are obsolete in
 ;; today's DNS databases.
+(define-type RRClass (U 'in 'cs 'ch 'hs Nonnegative-Integer))
+(: class->value : RRClass -> Nonnegative-Integer)
+(: value->class : Nonnegative-Integer -> RRClass)
 (define-mapping class->value value->class
   #:forward-default values
   #:backward-default values
@@ -181,6 +254,9 @@
 ;; A QueryClass is a Symbol or Number (as given in the following
 ;; define-mapping) or an RRClass. It specifies the "class" of records
 ;; being sought after in a DNS query.
+(define-type QueryClass (U RRClass '*))
+(: qclass->value : QueryClass -> Nonnegative-Integer)
+(: value->qclass : Nonnegative-Integer -> QueryClass)
 (define-mapping qclass->value value->qclass
   #:forward-default class->value
   #:backward-default value->class
@@ -189,6 +265,7 @@
 ;; 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.
+(: downcase-labels : (Listof Bytes) -> (Listof Bytes))
 (define (downcase-labels labels)
   (for/list ([label labels])
     (define b (make-bytes (bytes-length label)))
@@ -200,24 +277,25 @@
 ;; ListOf<Bytes> -> DomainName
 ;; Replacement constructor for domain structs. Automatically downcases
 ;; labels appropriately.
+(: make-domain : (Listof Bytes) -> DomainName)
 (define (make-domain labels)
   (domain labels (downcase-labels labels)))
 
-;; DomainName -> Boolean
+(: domain-root? : DomainName -> Boolean)
 (define (domain-root? d)
   (null? (domain-labels d)))
 
-;; DomainName -> Maybe<DomainName>
+(: domain-parent : DomainName -> (Option DomainName))
 (define (domain-parent d)
   (and (pair? (domain-labels d))
        (domain (cdr (domain-labels d))
 	       (cdr (domain-downcased-labels d)))))
 
-;; -> CompleteAnswer
+(: empty-complete-answer : -> CompleteAnswer)
 (define (empty-complete-answer)
   (complete-answer (set) (set) (set)))
 
-;; CompleteAnswer CompleteAnswer -> CompleteAnswer
+(: merge-answers : CompleteAnswer CompleteAnswer -> CompleteAnswer)
 (define (merge-answers a1 a2)
   (match-define (complete-answer n1 u1 d1) a1)
   (match-define (complete-answer n2 u2 d2) a2)
@@ -225,7 +303,7 @@
 		   (set-union u1 u2)
 		   (set-union d1 d2)))
 
-;; DomainName Maybe<CompleteAnswer> -> SetOf<IPv4>
+(: extract-addresses : DomainName (Option CompleteAnswer) -> (Setof IPv4))
 (define (extract-addresses name ans)
   (match ans
     [#f ;; name-error/NXDOMAIN, so definitely no addresses.
@@ -233,27 +311,29 @@
     [(complete-answer ns us ds)
      (define rrs (set->list (set-union ns us ds)))
      (let loop ((names (list name))
-		(ips (set))
-		(seen (set)))
+		(ips ((inst set IPv4)))
+		(seen ((inst set DomainName))))
        (if (null? names)
 	   ips
 	   (let* ((name (car names))
-		  (records (filter (lambda (rr) (equal? name (rr-name rr))) rrs)))
+		  (records (filter (lambda: ([rr : RR]) (equal? name (rr-name rr))) rrs))
+		  (data (map rr-rdata records)))
 	     (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)))
+		 (let ((a-data (filter rdata-ipv4? (filter (rdata-type-pred 'a) data)))
+		       (cname-data (filter rdata-domain? (filter (rdata-type-pred 'cname) data))))
+		   (loop (append (map rdata-domain-name cname-data) (cdr names))
+			 (set-union ips (list->set (map rdata-ipv4-address a-data)))
 			 (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.
+(: question-cyclic? : Question -> Boolean)
 (define (question-cyclic? q)
   (match-define (question name type class parent) q)
-  (let search ((ancestor parent))
+  (let: search : Boolean ((ancestor : QuestionContext parent))
     (match ancestor
       [(subquestion (question (== name) (== type) (== class) _)) #t] ;; uh-oh! A cycle!
       [(subquestion (question _ _ _ ancestor-parent)) (search ancestor-parent)] ;; recursive case
@@ -265,9 +345,10 @@
 ;; from the outside world, then that's too glueless.  See
 ;; http://cr.yp.to/djbdns/notes.html in the sections "Gluelessness"
 ;; and "Expiring glue".
+(: question-too-glueless? : Question -> Boolean)
 (define (question-too-glueless? q)
   (define count
-    (let search ((q q) (acc 0))
+    (let: search : Integer ((q : Question q) (acc : Integer 0))
       (match-define (question _ _ _ parent) q)
       (cond
        [(ns-subq? parent) (search (subquestion-parent parent) (+ acc 1))]
@@ -283,6 +364,7 @@
 ;; Question -> Boolean
 ;; #t iff this question is being asked in the context of some
 ;; excessively glueless subquestion.
+(: question-restarted? : Question -> Boolean)
 (define (question-restarted? q)
   (match-define (question name type class parent) q)
   (let search ((ancestor parent))
@@ -294,16 +376,19 @@
 ;; Question -> Question
 ;; Returns a question equivalent to q, but in a 'restart context, for
 ;; retracing from the roots in cases of excessive gluelessness.
+(: restart-question : Question -> Question)
 (define (restart-question q)
-  (struct-copy question q [context 'restart]))
+  (struct-copy question-repr q [context 'restart]))
 
 ;; DomainName Question -> Question
 ;; Produces a new question with CNAME context.
+(: cname-question : DomainName Question -> Question)
 (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.
+(: ns-question : DomainName Question -> Question)
 (define (ns-question name q)
   (question name 'a 'in (ns-subq q))) ;; TODO: 'aaaa ?

codec.rkt

@@ -1,9 +1,17 @@
-#lang racket/base
+#lang typed/racket/base
 ;; DNS wire-protocol codec.
 
-(provide value->query-opcode query-opcode->value
+(provide Opcode
+	 ResponseCode
+	 value->query-opcode query-opcode->value
 	 value->query-response-code query-response-code->value
 
+	 DNSMessage
+	 Direction
+	 Authoritativeness
+	 Truncatedness
+	 RecursionDesired
+	 RecursionAvailable
 	 (struct-out dns-message)
 
 	 packet->dns-message
@@ -18,11 +26,15 @@
 (require "mapping.rkt")
 
 (require racket/match)
-(require "../racket-bitsyntax/main.rkt")
+
+(require (planet tonyg/bitsyntax))
 
 ;; An Opcode is a Symbol or a Number, one of the possibilities given
 ;; in the following define-mapping. It represents a DNS message
 ;; operation; see the RFC for details.
+(define-type Opcode (U 'query 'iquery 'status Nonnegative-Integer))
+(: value->query-opcode : Nonnegative-Integer -> Opcode)
+(: query-opcode->value : Opcode -> Nonnegative-Integer)
 (define-mapping value->query-opcode query-opcode->value
   #:forward-default values
   #:backward-default values
@@ -33,6 +45,11 @@
 ;; A ResponseCode is a Symbol or a Number, one of the possibilities
 ;; given in the following define-mapping. It represents the outcome of
 ;; a DNS query.
+(define-type ResponseCode (U 'no-error 'format-error 'server-failure
+			     'name-error 'not-implemented 'refused
+			     Nonnegative-Integer))
+(: value->query-response-code : Nonnegative-Integer -> ResponseCode)
+(: query-response-code->value : ResponseCode -> Nonnegative-Integer)
 (define-mapping value->query-response-code query-response-code->value
   (0 no-error)
   (1 format-error)
@@ -48,64 +65,86 @@
 ;;
 ;; Interpreted as either a DNS request or reply, depending on the
 ;; Direction.
-(struct dns-message (id
-		     direction
-		     opcode
-		     authoritative
-		     truncated
-		     recursion-desired
-		     recursion-available
-		     response-code
-		     questions
-		     answers
-		     authorities
-		     additional)
-	#:prefab)
+(struct: dns-message ([id : Nonnegative-Integer]
+		      [direction : Direction]
+		      [opcode : Opcode]
+		      [authoritative : Authoritativeness]
+		      [truncated : Truncatedness]
+		      [recursion-desired : RecursionDesired]
+		      [recursion-available : RecursionAvailable]
+		      [response-code : ResponseCode]
+		      [questions : (Listof Question)]
+		      [answers : (Listof RR)]
+		      [authorities : (Listof RR)]
+		      [additional : (Listof RR)])
+	 #:transparent)
+(define-type DNSMessage dns-message)
+(define-type Direction (U 'request 'response))
+(define-type Authoritativeness (U 'non-authoritative 'authoritative))
+(define-type Truncatedness (U 'not-truncated 'truncated))
+(define-type RecursionDesired (U 'no-recursion-desired 'recursion-desired))
+(define-type RecursionAvailable (U 'no-recursion-available 'recursion-available))
 
 ;; Bit-syntax type for counted repeats of a value.
 ;; Example: Length-prefixed list of 32-bit unsigned words:
-;;   (bit-string-case input ([ len (vals :: (t:ntimes len bits 32)) ] vals))
-;;   (bit-string (vals :: (t:ntimes bits 32)))
+;;   (bit-string-case input ([ len (vals :: (t:ntimes Integer len bits 32)) ] vals))
+;;   (bit-string (vals :: (t:ntimes Integer bits 32)))
 (define-syntax t:ntimes
   (syntax-rules ()
-    ((_ #t times-to-repeat option ...)
-     (lambda (input ks kf)
-       (let loop ((count times-to-repeat)
-		  (acc '())
-		  (input input))
+    ((_ #t input0 ks kf Type times-to-repeat option ...)
+     (let ()
+       ;; A simple loop without multiple-values or #f is much cleaner
+       ;; here, but I can't find a way of expressing the types
+       ;; required while making that work. This way, we avoid needing
+       ;; to mention the type of the result of calls to ks.
+       (: loop : Integer (Listof Type) BitString -> (Values (Option (Listof Type)) BitString))
+       (define (loop count acc 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 ...))))
+			       (else
+				(values #f input))))
+	  (else (values (reverse acc) input))))
+       (let-values (((vs rest) (loop times-to-repeat '() input0)))
+	 (if vs
+	     (ks vs rest)
+	     (kf)))))
+    ((_ #f val Type option ...)
+     (t:listof #f val Type option ...))))
 
 ;; Bit-syntax type for repeats of a value until no more input available.
 ;; Example: List of 32-bit unsigned words:
-;;   (bit-string-case input ([ (vals :: (t:listof bits 32)) ] vals))
-;;   (bit-string (vals :: (t:listof bits 32)))
+;;   (bit-string-case input ([ (vals :: (t:listof Integer bits 32)) ] vals))
+;;   (bit-string (vals :: (t:listof Integer bits 32)))
 (define-syntax t:listof
   (syntax-rules ()
-    ((_ #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))))))))
+    ((_ #t input0 ks kf Type option ...)
+     ;; The loop is unrolled once here to let Typed Racket propagate
+     ;; the type of v0 into the type of acc in the loop. When not
+     ;; unrolled, it gives acc type (Listof Any).
+     ;; TODO: come up with some other way of doing this that avoids the duplication.
+     (bit-string-case input0
+       ([ (v0 :: option ...) (input1 :: binary) ]
+	(let loop ((acc (list v0))
+		   (input input1))
+	  (bit-string-case input
+	    ([ (v :: option ...) (rest :: binary) ]
+	     (loop (cons v acc) rest))
+	    ([]
+	     (ks (reverse acc) #""))
+	    (else
+	     (kf)))))
+       ([]
+	(ks '() #""))
+       (else
+	(kf))))
+    ((_ #f vs Type option ...)
+     (let: loop : BitString ((vs : (Listof Type) 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
@@ -145,7 +184,7 @@
 ;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
 ;; </rfc1035>
 
-;; Bytes -> DNSMessage
+(: packet->dns-message : BitString -> DNSMessage)
 ;; Parse an encoded DNS message packet into the corresponding Racket
 ;; structure. Raises an exception on failure.
 (define (packet->dns-message packet)
@@ -166,16 +205,16 @@
        (ancount :: bits 16)
        (nscount :: bits 16)
        (arcount :: bits 16)
-       (q-section :: (t:ntimes qdcount (t:question packet)))
-       (a-section :: (t:ntimes ancount (t:rr packet)))
-       (auth-section :: (t:ntimes nscount (t:rr packet)))
-       (additional-section :: (t:ntimes arcount (t:rr packet))) ]
+       (q-section :: (t:ntimes Question qdcount (t:question packet)))
+       (a-section :: (t:ntimes RR ancount (t:rr packet)))
+       (auth-section :: (t:ntimes RR nscount (t:rr packet)))
+       (additional-section :: (t:ntimes RR arcount (t:rr packet))) ]
      (dns-message id qr (value->query-opcode opcode)
 		  aa tc rd ra
 		  (value->query-response-code rcode)
 		  q-section a-section auth-section additional-section))))
 
-;; DNSMessage -> Bytes
+(: dns-message->packet : DNSMessage -> Bytes)
 ;; Render a Racket structured DNS message using the DNS binary encoding.
 (define (dns-message->packet m)
   (bit-string->bytes
@@ -194,10 +233,10 @@
 	       ((length (dns-message-answers m)) :: bits 16)
 	       ((length (dns-message-authorities m)) :: bits 16)
 	       ((length (dns-message-additional m)) :: bits 16)
-	       ((dns-message-questions m) :: (t:ntimes (t:question)))
-	       ((dns-message-answers m) :: (t:ntimes (t:rr)))
-	       ((dns-message-authorities m) :: (t:ntimes (t:rr)))
-	       ((dns-message-additional m) :: (t:ntimes (t:rr))))))
+	       ((dns-message-questions m) :: (t:ntimes Question (t:question)))
+	       ((dns-message-answers m) :: (t:ntimes RR (t:rr)))
+	       ((dns-message-authorities m) :: (t:ntimes RR (t:rr)))
+	       ((dns-message-additional m) :: (t:ntimes RR (t:rr))))))
 
 ;; Bit-syntax type for a single bit, represented in Racket as one of
 ;; two possible symbolic values.
@@ -206,18 +245,18 @@
 ;;   (bit-string (v :: (t:named-bit 'zero 'one)))
 (define-syntax t:named-bit
   (syntax-rules ()
-    ((_ #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)))))))
+    ((_ #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))))))
 
 ;; Bit-syntax type for a DomainName. When decoding (but not when
 ;; encoding!), we support DNS's weird compressed domain-name syntax;
@@ -225,20 +264,20 @@
 ;; let it refer to random substrings within the packet.
 (define-syntax t:domain-name
   (syntax-rules ()
-    ((_ #t whole-packet)
-     (lambda (input ks kf)
-       (let-values (((name rest) (parse-domain-name whole-packet input '())))
-	 (ks (domain name) rest))))
-    ((_ #f)
-     encode-domain-name)))
+    ((_ #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))))
 
-;; DomainName -> Bitstring
+(: encode-domain-name : DomainName -> BitString)
 (define (encode-domain-name name)
   (define labels (domain-labels name))
-  (bit-string (labels :: (t:listof (t:pascal-string "Label" 64)))
+  (bit-string (labels :: (t:listof Bytes (t:pascal-string "Label" 64)))
 	      (0 :: integer bytes 1))) ;; end of list of labels!
 
-;; Bytes Bytes ListOf<Natural> -> ListOf<Bytes>
+(: parse-domain-name :
+   BitString BitString (Listof Natural) -> (Values (Listof Bytes) BitString))
 ;; 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
@@ -272,16 +311,15 @@
 ;; the given maximum, an error is signalled.
 (define-syntax t:pascal-string
   (syntax-rules ()
-    ((_ #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)
+    ((_ #t input ks kf)
+     (bit-string-case input
+       ([ len (body :: binary bytes len) (rest :: binary) ]
+	(ks (bit-string->bytes body) rest))
+       (else (kf))))
+    ((_ #f val)
+     (t:pascal-string #f val "Character-string" 256))
+    ((_ #f val string-kind length-limit)
+     (let: ([s : Bytes val])
        (let ((len (bytes-length s)))
 	 (when (>= len length-limit)
 	   (error 't:pascal-string "~s too long: ~v" string-kind s))
@@ -309,23 +347,22 @@
 ;; whole packet because the question may contain nested domain-names.
 (define-syntax t:question
   (syntax-rules ()
-    ((_ #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)
-			#f)
-	      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))))))
+    ((_ #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 val)
+     (let: ([q : Question val])
+       (bit-string ((question-repr-name q) :: (t:domain-name))
+		   ((qtype->value (question-repr-type q)) :: bits 16)
+		   ((qclass->value (question-repr-class q)) :: bits 16))))))
 
 ;; <rfc1035>
 ;; All RRs have the same top level format shown below:
@@ -356,62 +393,53 @@
 ;; packet because the RR may contain nested domain-names.
 (define-syntax t:rr
   (syntax-rules ()
-    ((_ #t whole-packet)
-     (lambda (input ks kf)
-       (decode-rr whole-packet input ks kf)))
-    ((_ #f)
-     encode-rr)))
+    ((_ #t input ks kf whole-packet0)
+     (let ((whole-packet whole-packet0))
+       (bit-string-case input
+	 ([ (name :: (t:domain-name whole-packet))
+	    (type-number :: bits 16)
+	    (class :: bits 16)
+	    (ttl :: bits 32)
+	    (rdlength :: bits 16)
+	    (rdata :: binary bytes rdlength)
+	    (tail :: binary) ]
+	  (let ((type (value->type type-number)))
+	    (ks (rr name
+		    (value->class class)
+		    ttl
+		    (decode-rdata whole-packet type rdata))
+		tail)))
+	 (else (kf)))))
+    ((_ #f val)
+     (let: ([rr : RR val])
+       (let ((encoded-rdata (encode-rdata (rr-rdata rr))))
+	 (bit-string ((rr-name rr) :: (t:domain-name))
+		     ((type->value (rdata-type (rr-rdata rr))) :: bits 16)
+		     ((class->value (rr-class rr)) :: bits 16)
+		     ((rr-ttl rr) :: bits 32)
+		     ((quotient (bit-string-length encoded-rdata) 8) :: bits 16)
+		     (encoded-rdata :: binary)))))))
 
-;; Bytes Bytes (RR Bytes -> A) ( -> A) -> A
-;; Helper for t:rr.
-(define (decode-rr whole-packet input ks kf)
-  (bit-string-case input
-    ([ (name :: (t:domain-name whole-packet))
-       (type-number :: bits 16)
-       (class :: bits 16)
-       (ttl :: bits 32)
-       (rdlength :: bits 16)
-       (rdata :: binary bytes rdlength)
-       (tail :: binary) ]
-     (let ((type (value->type type-number)))
-       (ks (rr name
-	       type
-	       (value->class class)
-	       ttl
-	       (decode-rdata whole-packet type rdata))
-	   tail)))
-    (else (kf))))
-
-;; RR -> Bitstring
-;; Helper for t:rr.
-(define (encode-rr rr)
-  (let ((encoded-rdata (encode-rdata (rr-type rr) (rr-rdata rr))))
-    (bit-string ((rr-name rr) :: (t:domain-name))
-		((type->value (rr-type rr)) :: bits 16)
-		((class->value (rr-class rr)) :: bits 16)
-		((rr-ttl rr) :: bits 32)
-		((/ (bit-string-length encoded-rdata) 8) :: bits 16)
-		(encoded-rdata :: binary))))
-
-;; Bytes RRType Bytes -> RData
+(: decode-rdata : BitString RRType BitString -> RData)
 ;; Decode RData according to the RRType. Takes the whole packet for
 ;; the same reason as t:rr does.
 (define (decode-rdata whole-packet type rdata)
   (case type
     ((cname mb md mf mg mr ns ptr) (bit-string-case rdata
-				     ([ (name :: (t:domain-name whole-packet)) ] name)))
+				     ([ (name :: (t:domain-name whole-packet)) ]
+				      (rdata-domain type name))))
     ((hinfo) (bit-string-case rdata
 	       ([ (cpu :: (t:pascal-string)) (os :: (t:pascal-string)) ]
-		(hinfo cpu os))))
+		(rdata-hinfo type cpu os))))
     ((minfo) (bit-string-case rdata
 	       ([ (rmailbx :: (t:domain-name whole-packet))
 		  (emailbx :: (t:domain-name whole-packet)) ]
-		(minfo rmailbx emailbx))))
+		(rdata-minfo type rmailbx emailbx))))
     ((mx) (bit-string-case rdata
 	    ([ (preference :: bits 16)
 	       (exchange :: (t:domain-name whole-packet)) ]
-	     (mx preference exchange))))
-    ((null) (bit-string->bytes rdata))
+	     (rdata-mx type preference exchange))))
+    ((null) (rdata-raw type (bit-string->bytes rdata)))
     ((soa) (bit-string-case rdata
 	     ([ (mname :: (t:domain-name whole-packet))
 		(rname :: (t:domain-name whole-packet))
@@ -420,57 +448,58 @@
 		(retry :: bits 32)
 		(expire :: bits 32)
 		(minimum :: bits 32) ]
-	      (soa mname rname serial refresh retry expire minimum))))
+	      (rdata-soa type mname rname serial refresh retry expire minimum))))
     ((txt) (bit-string-case rdata
-	     ([ (strs :: (t:listof (t:pascal-string))) ]
-	      strs)))
+	     ([ (strs :: (t:listof Bytes (t:pascal-string))) ]
+	      (rdata-txt type strs))))
     ((a) (bit-string-case rdata
 	   ([ a b c d ]
-	    (vector a b c d))))
+	    (rdata-ipv4 type (vector a b c d)))))
     ((aaaa) (bit-string-case rdata
-	      ([ (ipv6-addr :: binary bits 128) ]
-	       (list->vector (bytes->list (bit-string->bytes ipv6-addr))))))
+	      ([ a b c d e f g h i j k l m n o p ]
+	       (rdata-ipv6 type (vector a b c d e f g h i j k l m n o p)))))
     ((wks) (bit-string-case rdata
 	     ([ a b c d protocol (bitmap :: binary) ]
-	      (wks (vector a b c d) protocol bitmap))))
+	      (rdata-wks type (vector a b c d) protocol (bit-string->bytes bitmap)))))
     ((srv) (bit-string-case rdata
 	     ([ (priority :: bits 16)
 		(weight :: bits 16)
 		(port :: bits 16)
 		(target :: (t:domain-name whole-packet)) ]
-	      (srv priority weight port target))))
-    (else (bit-string->bytes rdata))))
+	      (rdata-srv type priority weight port target))))
+    (else (rdata-raw type (bit-string->bytes rdata)))))
 
-;; RRType RData -> Bitstring
-;; Encode RData according to the RRType.
-(define (encode-rdata type rdata)
-  (case type
-    ((cname mb md mf mg mr ns ptr) (encode-domain-name rdata))
-    ((hinfo) (bit-string ((hinfo-cpu rdata) :: (t:pascal-string))
-			 ((hinfo-os rdata) :: (t:pascal-string))))
-    ((minfo) (bit-string ((minfo-rmailbx rdata) :: (t:domain-name))
-			 ((minfo-emailbx rdata) :: (t:domain-name))))
-    ((mx) (bit-string ((mx-preference rdata) :: bits 16)
-		      ((mx-exchange rdata) :: (t:domain-name))))
-    ((null) rdata)
-    ((soa) (bit-string ((soa-mname rdata) :: (t:domain-name))
-		       ((soa-rname rdata) :: (t:domain-name))
-		       ((soa-serial rdata) :: bits 32)
-		       ((soa-refresh rdata) :: bits 32)
-		       ((soa-retry rdata) :: bits 32)
-		       ((soa-expire rdata) :: bits 32)
-		       ((soa-minimum rdata) :: bits 32)))
-    ((txt) (bit-string (rdata :: (t:listof (t:pascal-string)))))
-    ((a) (match rdata ((vector a b c d) (bit-string a b c d))))
-    ((aaaa) (bit-string ((list->bytes (vector->list rdata)) :: binary bits 128)))
-    ((wks) (match (wks-address rdata)
-	     ((vector a b c d)
-	      (bit-string a b c d (wks-protocol rdata) ((wks-bitmap rdata) :: binary)))))
-    ((srv) (bit-string ((srv-priority rdata) :: bits 16)
-		       ((srv-weight rdata) :: bits 16)
-		       ((srv-port rdata) :: bits 16)
-		       ((srv-target rdata) :: (t:domain-name))))
-    (else rdata)))
+(: encode-rdata : RData -> BitString)
+;; Encode RData according to its RRType.
+(define (encode-rdata rdata)
+  (match rdata
+    [(rdata-domain _ name) (encode-domain-name name)]
+    [(rdata-hinfo _ cpu os) (bit-string (cpu :: (t:pascal-string))
+					(os :: (t:pascal-string)))]
+    [(rdata-minfo _ rmailbx emailbx) (bit-string (rmailbx :: (t:domain-name))
+						 (emailbx :: (t:domain-name)))]
+    [(rdata-mx _ preference exchange) (bit-string (preference :: bits 16)
+						  (exchange :: (t:domain-name)))]
+    [(rdata-soa _ mname rname serial refresh retry expire minimum)
+     (bit-string (mname :: (t:domain-name))
+		 (rname :: (t:domain-name))
+		 (serial :: bits 32)
+		 (refresh :: bits 32)
+		 (retry :: bits 32)
+		 (expire :: bits 32)
+		 (minimum :: bits 32))]
+    [(rdata-txt _ strings) (bit-string (strings :: (t:listof Bytes (t:pascal-string))))]
+    [(rdata-ipv4 _ (vector a b c d)) (bit-string a b c d)]
+    [(rdata-ipv6 _ aaaa) (bit-string ((list->bytes (vector->list aaaa)) :: binary bits 128))]
+    [(rdata-wks _ (vector a b c d) protocol bitmap)
+     (bit-string a b c d protocol (bitmap :: binary))]
+    [(rdata-srv _ priority weight port target)
+     (bit-string (priority :: bits 16)
+		 (weight :: bits 16)
+		 (port :: bits 16)
+		 (target :: (t:domain-name)))]
+    [(rdata-raw _ bs) bs]))
 
 ;; UInt32
+(: max-ttl : Nonnegative-Integer)
 (define max-ttl #xffffffff)

driver.rkt

@@ -1,18 +1,19 @@
-#lang racket/base
+#lang typed/racket/base
 
 ;; DNS server using os-big-bang.rkt and os-udp.rkt.
 
 (require racket/match)
 (require racket/set)
 (require racket/bool)
-(require "../racket-bitsyntax/main.rkt")
+(require (planet tonyg/bitsyntax))
 (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 marketplace/sugar-typed)
+(require marketplace/support/spy)
+(require marketplace/drivers/udp)
+(require "tk-dns.rkt")
 
 ;; Instantiated with a SOA record for the zone it is serving as well
 ;; as a zone's worth of DNS data which is used to answer queries
@@ -27,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.
@@ -39,25 +40,27 @@
 
   (display ";; Ready.\n")
 
-  (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))))
+  (ground-vm: ((inst udp-driver Void))
+	      ((inst generic-spy Void) 'UDP)
+	      (nested-vm: : Void
+	       (spawn: #:parent : Void #:child : Void (dns-spy))
+	       (spawn: #:parent : Void #:child : Void (dns-read-driver local-addr))
+	       (spawn: #:parent : Void #:child : Void (dns-write-driver 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 DNSRequest -> (Option DNSReply))
 (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
@@ -72,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
@@ -89,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)]))
 
@@ -120,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)

experiments/edls.rkt

@@ -1,242 +0,0 @@
-#lang racket/base
-;; Extensible Denotational Language Specifications
-
-;; The paper "Extensible Denotational Language Specifications", by
-;; Cartwright & Felleisen (1994), henceforth "EDLS", presents a
-;; picture of an extensible interpreter for programming languages. The
-;; interpreter can be extended with new syntactic forms (and their
-;; meanings), new actions (and their effects), and new kinds of
-;; resources to be placed under its control.
-
-;; Rather than interpreting an extensible collection of syntax here,
-;; we call Racket code directly. Extension at the syntactic level is
-;; provided by Racket's macros. The purpose of this code is to provide
-;; a structured model of the extensible actions and extensible
-;; resource-management facets of the EDLS design. We use delimited
-;; continuations to transfer control between the "pure" facet (the
-;; interpretation of programs) and the impure or operational facets
-;; (the performing of actions, and management of resources).
-
-;; TODO: investigate continuation barriers, to avoid throws out
-;; through the current interpreter/VM. Actually, think harder about
-;; what even needs protecting - it's not clear.
-
-;; TODO: what happens when an interactor, performing an action, raises
-;; an exception? What should happen? In some sense it's the fault of
-;; the invoker of the action, isn't it? Consider binding a UDP socket
-;; to a port already in use. Alternatively, consider some internal
-;; error in the interactor: then it's not the fault of the invoker at
-;; all.
-
-;; TODO: pull in scheduler and event-stream ideas from Olin's papers
-
-;; TODO: consider splitting lookup from apply in
-;; action-handlers. Consider, for instance, replicating action
-;; streams: you might want to check for DNU before replicating the
-;; pending action.
-
-;; TODO: think about using a private prompt tag, and what the
-;; consequences for cross-virtual-level interaction are if multiple
-;; prompt tags are in play. This will force some thinking about
-;; continuation barriers, too.
-
-;; TODO: think about how a weak table might be exposed as a
-;; resource. Its implementation depends on primitive weakness! (Or on
-;; a transitively-provided weak service.)
-
-#|
-
-Things that can wake up some continuations:
-
- - external events (CML-style, timeouts)
- - internal events (completion of a write or similar)
- - unguarded continuations (spawned threads, basically)
-
-
-Are these containery things the conversation/chatrooms of racket-ssh?
-
-|#
-
-;; From the fine manual: "The protocol for vs supplied to an abort is
-;; specific to the prompt-tag. When abort-current-continuation is used
-;; with (default-continuation-prompt-tag), generally, a single thunk
-;; should be supplied that is suitable for use with the default prompt
-;; handler. Similarly, when call-with-continuation-prompt is used with
-;; (default-continuation-prompt-tag), the associated handler should
-;; generally accept a single thunk argument."
-
-;; Semantic framework from EDLS:
-;;
-;;   computation : (+ (make-value value) (make-effect action (-> value computation)))
-;;   program-meaning : (-> program (* (+ value error) resources)
-;;   expression-meaning : (-> expr env computation)
-;;   admin : (-> (* computation resources) (* (+ value error) resources))
-;;   handler : (-> computation (-> value computation) computation)
-;;
-;; Handler is used to stitch stack frames together into a composed
-;; continuation, something that we're doing here natively with
-;; Racket's composable continuations.
-;;
-;; If we're going to make values self-representing, then we need to
-;; ensure that all effects are disjoint from values. The way to do
-;; that is to control the abort/prompt-tag protocol closely, so that
-;; regular values returned are distinguished from actions thrown. That
-;; way, no value is forbidden to the userland, including descriptions
-;; of actions.
-
-;; Can we say that the *communications facility* in EDLS is
-;; underpowered? It's point-to-point and relies on noninterference
-;; between action-handling extensions. Since each extension is
-;; logically managing its own resources, it feels like we have a kind
-;; of network-layer here IF we enforce separation of the managed
-;; resources so there are no cross-channels.
-;;
-;; The reason I'm interested in this approach is to get some kind of
-;; objcap-oriented interface not only to the substrate but to the
-;; extensions embedded in the substrate. Consider the DNS-server case,
-;; where a socket needs to be opened and then straight-line
-;; interactions with the socket take place. Now consider the DNS-proxy
-;; case, where not only does a socket (or more than one!) need to be
-;; created, but complex conversional contexts are built up as each
-;; query arrives and is processed. As DJB observes, a single query can
-;; in principle result in unbounded recursion as "glue" records are
-;; looked up. It kind of makes sense to have each conversational
-;; context as a separate entity, managing its own resources, embedded
-;; in the substrate.
-
-(require racket/match)
-(require racket/class)
-
-(define interactor<%>
-  (interface ()
-    perform-action))
-
-(define action-prompt (make-continuation-prompt-tag 'interactor-action))
-
-(define (perform-action . action-pieces)
-  (call-with-composable-continuation
-   (lambda (k)
-     (abort-current-continuation action-prompt
-       (lambda () (values action-pieces k))))
-   action-prompt))
-
-(define (run/interactor boot interactor)
-  (call-with-continuation-barrier
-   (lambda ()
-     (let loop ((next-step-thunk (lambda () (values (boot) #f)))
-		(interactor interactor))
-       (define-values (computation-step-result computation-step-continuation)
-	 (call-with-continuation-prompt next-step-thunk action-prompt))
-       (cond
-	((eq? computation-step-continuation #f)
-	 ;; The computation is finished, and has yielded a result.
-	 computation-step-result)
-	(else
-	 ;; The computation is not finished, but is waiting for an
-	 ;; action to complete.
-	 (send interactor perform-action
-	       computation-step-result
-	       (lambda (action-result-value new-interactor)
-		 (loop (lambda () (computation-step-continuation action-result-value))
-		       new-interactor))
-	       (lambda ()
-		 (error 'run/interactor "Action not interpretable by context: ~v"
-			computation-step-result)))))))))
-
-(define cells%
-  (class* object% (interactor<%>)
-    (init-field next-name)
-    (init-field mapping)
-    (super-new)
-    (define/public (perform-action action k-ok k-dnu)
-      (match action
-	(`(new ,initial-value)
-	 (k-ok next-name (make-object cells%
-				      (+ next-name 1)
-				      (hash-set mapping next-name initial-value))))
-	(`(get ,n)
-	 (if (hash-has-key? mapping n)
-	     (k-ok (hash-ref mapping n) this)
-	     (error 'cells% "Cell name ~v not found (on get)" n)))
-	(`(set ,n ,new-value)
-	 (if (hash-has-key? mapping n)
-	     (k-ok new-value (make-object cells%
-					  next-name
-					  (hash-set mapping n new-value)))
-	     (error 'cells% "Cell name ~v not found (on set)" n)))
-	(else
-	 (k-dnu))))))
-
-(define (new-cell [initial-value (void)])
-  (perform-action 'new initial-value))
-
-(define (get-cell c)
-  (perform-action 'get c))
-
-(define (set-cell! c v)
-  (perform-action 'set c v))
-
-(define (empty-cells)
-  (make-object cells% 0 (hash)))
-
-(define combine%
-  (class* object% (interactor<%>)
-    (init-field children)
-    (super-new)
-    (define/public (perform-action action k-ok k-dnu)
-      (let search ((remaining children)
-		   (examined '()))
-	(cond
-	 ((null? remaining) (k-dnu))
-	 (else
-	  (define child (car remaining))
-	  (define rest (cdr remaining))
-	  (send child perform-action
-		action
-		(lambda (result new-child)
-		  (k-ok result
-			(make-object combine% (append (reverse examined) (cons new-child rest)))))
-		(lambda ()
-		  (search rest (cons child examined))))))))))
-
-(define (combine-interactors is)
-  (make-object combine% is))
-
-(define udp%
-  (class* object% (interactor<%>)
-    (struct handle (socket)) ;; generative: new predicate etc. per udp% instance!
-    (super-new)
-    (define/public (perform-action action k-ok k-dnu)
-      (match action
-	(`(new)
-	 (k-ok (handle (udp-open-socket #f #f)) this))
-	(`(bind ,(handle s) ,port)
-	 (k-ok (udp-bind! s #f port) this))
-	(`(send ,(handle s) ,host ,port ,packet)
-	 (k-ok (udp-send-to s host port packet) this))
-	(`(recv ,(handle s) ,packet-size-limit)
-	 (define buffer (make-bytes packet-size-limit))
-	 (define-values (packet-length source-hostname source-port)
-	   (udp-receive! s buffer))
-	 (k-ok (list source-hostname source-port (subbytes buffer 0 packet-length)) this))
-	(else (k-dnu))))))
-
-(run/interactor (lambda () 1234)
-		(empty-cells))
-
-(run/interactor (lambda ()
-		  (let ((x (new-cell)))
-		    (set-cell! x 1)
-		    (set-cell! x (+ 1 (get-cell x)))
-		    (+ 1000 (get-cell x))))
-		(empty-cells))
-
-(run/interactor (lambda ()
-		  (let ((x (new-cell 'initial-x-value))
-			(y (new-cell 'initial-y-value)))
-		    (set-cell! x 1)
-		    (set-cell! y 1000)
-		    (set-cell! x (+ 1 (get-cell x)))
-		    (+ (get-cell x)
-		       (get-cell y))))
-		(combine-interactors (list (empty-cells))))

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

mapping.rkt

@@ -1,4 +1,4 @@
-#lang racket/base
+#lang typed/racket/base
 ;; Macros for defining weak and extensible mappings between sets of values
 
 (provide define-mapping)
@@ -13,13 +13,13 @@
     ((_ fn bn fd bd (lhs rhs) ...)
      (begin
        (define (fn l)
-	 (case l
-	   ((lhs) 'rhs) ...
-	   (else (fd l))))
+	 (cond
+	  ((eqv? l 'lhs) 'rhs) ...
+	  (else (fd l))))
        (define (bn r)
-	 (case r
-	   ((rhs) 'lhs) ...
-	   (else (bd r))))))))
+	 (cond
+	  ((eqv? r 'rhs) 'lhs) ...
+	  (else (bd r))))))))
 
 ;; Symbol -> raised exn:fail:contract
 ;; Used by default to complain when no specific mapping is found.

network-query.rkt

@@ -1,17 +1,21 @@
-#lang racket/base
+#lang typed/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")
+(require marketplace/sugar-typed)
+(require marketplace/drivers/udp)
+(require marketplace/drivers/timer)
+(require marketplace/support/pseudo-substruct)
+(require "tk-dns.rkt")
+(require (rename-in marketplace/tr-struct-copy [tr-struct-copy struct-copy])) ;; PR13149
 
 (provide network-query
-	 (struct-out network-reply))
+	 (struct-out network-reply-repr)
+	 NetworkReply network-reply network-reply?
+	 NetworkReplyPattern network-reply-pattern network-reply-pattern?)
 
 ;; DJB's rules for handling DNS responses. Some of these are handled
 ;; here (specifically, rules 2 through 5, in the action of
@@ -103,45 +107,50 @@
 
 ;;---------------------------------------------------------------------------
 
-;; 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)
+(struct: network-request ([client-socket : UdpAddress]
+			  [question : Question]
+			  [zone-origin : DomainName]
+			  [server-names : (Listof DomainName)]
+			  [unique-id : Any])
+	 #:transparent)
+(define-type NetworkRequest network-request)
 
 ;; A NetworkReply is a (network-reply UniqueID Maybe<CompleteAnswer>)
 ;; representing the final result of a network query.
-(struct network-reply (unique-id answer) #:prefab)
+(struct: (TId TAnswer)
+	 network-reply-repr
+	 ([unique-id : TId] [answer : TAnswer]) #:transparent)
+(pseudo-substruct: (network-reply-repr Any (Option CompleteAnswer))
+		   NetworkReply network-reply network-reply?)
+(pseudo-substruct: (network-reply-repr (U Wild Any) (U Wild (Option CompleteAnswer)))
+		   NetworkReplyPattern network-reply-pattern network-reply-pattern?)
 
 ;; 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)
+(struct: network-query-state ([request : NetworkRequest]
+			      [timeout : (Option Natural)]
+			      [known-addresses : (HashTable DomainName (Listof UdpAddress))]
+			      [remaining-addresses : (Listof UdpAddress)]
+			      [current-name : (Option DomainName)]
+			      [remaining-names : (Listof DomainName)])
+	 #:transparent)
+(define-type NetworkQueryState network-query-state)
 
-;; seconds -> Maybe<seconds>
+(: next-timeout : Natural -> (Option Natural))
 (define (next-timeout timeout)
-  (case timeout
-    ((3) 11)
-    ((11) 45)
-    ((45) #f)))
+  (cond
+   [(equal? timeout 3) 11]
+   [(equal? timeout 11) 45]
+   [else #f]))
 
+(: make-dns-query-message : Question Nonnegative-Integer -> DNSMessage)
 (define (make-dns-query-message q query-id)
   (dns-message query-id
 	       'request
@@ -156,9 +165,9 @@
 	       '()
 	       '()))
 
-;; filter-dns-reply : Question DNSMessage DomainName
-;;   -> (or Maybe<CompleteAnswer> 'bad-answer 'lame-delegation)
-;;
+(define-type CheckedAnswer (U (Option CompleteAnswer) 'bad-answer 'lame-delegation))
+
+(: filter-dns-reply : Question DNSMessage DomainName -> CheckedAnswer)
 ;; 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
@@ -173,23 +182,25 @@
 (define (filter-dns-reply q message zone-origin)
   (case (dns-message-response-code message)
     [(no-error)
+     (: f : (Listof RR) -> (Setof RR))
      (define (f l)
-       (list->set (filter (lambda (claim-rr) (in-bailiwick? (rr-name claim-rr) zone-origin)) l)))
+       (list->set (filter (lambda: ([claim-rr : 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)))))
+       (filter (lambda: ([rr : RR]) (and (eqv? (rdata-type (rr-rdata 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))
+       (set-filter (lambda: ([rr : RR]) (equal? (rr-name rr) (question-repr-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-rrs answers-to-q (question-repr-type q) (question-repr-class q)))
 	    (set-empty? (filter-by-type authorities 'soa))
 	    (not (null? non-subzone-ns-rrs))))
      (if lame?
@@ -204,77 +215,87 @@
 		       (dns-message-questions message)))
      'bad-answer]))
 
-;; IPv4 -> String
+(: ip->host-name : 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))
 
+(: make-dns-address : IPv4 -> UdpAddress)
 (define (make-dns-address ip-address)
-  (udp-address (ip->host-name ip-address) 53))
+  (udp-remote-address (ip->host-name ip-address) 53))
 
-;; network-query : UdpAddress Question DomainName NEListOf<DomainName> UniqueId -> BootK
+(: network-query : (All (ParentState)
+			UdpAddress Question DomainName (Listof DomainName) Any ->
+			(Action ParentState)))
 (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))))
+  (spawn: #:debug-name (list 'network-query q)
+	  #:parent : ParentState
+	  #:child : NetworkQueryState
+	  (try-next-server
+	   (network-query-state (network-request s q zone-origin server-names unique-id)
+				first-timeout
+				(ann #hash() (HashTable DomainName (Listof UdpAddress)))
+				'()
+				#f
+				server-names))))
 
+(: try-next-server : NetworkQueryState -> (Transition NetworkQueryState))
 (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)
+  (define timeout (network-query-state-timeout w))
+  (if (not timeout)
+      ;; No more timeouts to try, so give up.
+      (on-answer w (empty-complete-answer) #f)
+      (match w
+	[(network-query-state req _ _ '() _ '())
+	 ;; 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
-				       [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))]))]))
+			    [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]) : NetworkQueryState
+		 (send-message subq)
+		 (endpoint: w : NetworkQueryState
+		   #:subscriber (answered-question subq (wild))
+		   #:let-name subq-id
+		   [(answered-question (== subq) ans)
+		    (let ((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-endpoint subq-id)))]))))]
+	[(network-query-state req _ _ (cons current-ip remaining-ips) _ _)
+	 (define rpc-id (gensym 'network-query/allocate-query-id))
+	 (transition: w : NetworkQueryState
+	   (send-message `(request ,rpc-id allocate-query-id))
+	   (endpoint: w : NetworkQueryState
+	     #:subscriber `(reply ,rpc-id ,(wild))
+	     #:name rpc-id
+	     [`(reply ,(== rpc-id) ,(? exact-nonnegative-integer? id))
+	      (sequence-actions (send-request (struct-copy network-query-state w
+						[remaining-addresses remaining-ips])
+					      id
+					      timeout
+					      current-ip)
+				(delete-endpoint rpc-id))]))])))
 
+(: on-answer : NetworkQueryState CheckedAnswer (Option UdpAddress)
+   -> (Transition NetworkQueryState))
 (define (on-answer w ans server-ip)
   (match ans
     ['bad-answer ;; can come from filter-dns-reply
@@ -287,55 +308,68 @@
 		       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
+     (try-next-server (if (and current-name server-ip)
+			  ;; Actually remove the offending IP address so it's never tried again.
+			  (struct-copy network-query-state w
+			    [known-addresses (hash-update known-addresses
+							  current-name
+							  (lambda: ([addrs : (Listof
+									      UdpAddress)])
+							    (remove server-ip addrs)))])
+			  w))]
+    [(and (or (? complete-answer?) #f) ans)
+     (transition: w : NetworkQueryState
        (send-message (network-reply (network-request-unique-id (network-query-state-request w))
 				    ans)))]))
 
+(: send-request : NetworkQueryState Nonnegative-Integer Natural UdpAddress
+   -> (Transition NetworkQueryState))
 (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 reply-wait-id (list s query-id 'reply-wait))
+  (define timeout-id (list s query-id 'timeout))
   (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
+  (transition: w : NetworkQueryState
     (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))))])))
+    (send-message (set-timer timeout-id (* timeout 1000) 'relative))
+    ;; TODO: Restore this to a "join" when proper pattern-unions are implemented
+    (endpoint: w : NetworkQueryState
+	       #:subscriber (timer-expired timeout-id (wild))
+	       #:name timeout-id
+     [(timer-expired (== timeout-id) _)
+      (begin
+	(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-endpoint timeout-id)
+			  (delete-endpoint reply-wait-id)
+			  (send-message (list 'release-query-id query-id))))])
+    (endpoint: w : NetworkQueryState
+	       #:subscriber (dns-reply (wild) (wild) s)
+	       #:name reply-wait-id
+     [(dns-reply reply-message source (== s))
+      ;; TODO: maybe receive only specifically from the queried IP address?
+      (begin
+	(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 : NetworkQueryState)
+	    (sequence-actions (on-answer w
+					 (filter-dns-reply q reply-message zone-origin)
+					 server-ip)
+			      (delete-endpoint timeout-id)
+			      (delete-endpoint reply-wait-id)
+			      (send-message (list 'release-query-id query-id)))))])))

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

prototype/dns.rkt

@@ -1,619 +0,0 @@
-#lang racket/base
-
-(require (planet tonyg/bitsyntax))
-(require racket/udp)
-(require racket/match)
-
-(require "mapping.rkt")
-
-;; Protocol data taken from RFC-1035. (See also RFC-1034.)
-;; Blocks of text inside <rfc1035>...</rfc1035> also from RFC-1035.
-;; RFC-3596 specifies "DNS Extensions to Support IP Version 6".
-
-;; RFC-2782 specifies the DNS SRV record, though weirdly it omits a
-;; wire-level definition of the format! Presumably people have just
-;; copied what they see everyone else do here!
-
-(provide (struct-out dns-message)
-	 (struct-out question)
-	 (struct-out rr)
-	 (struct-out hinfo)
-	 (struct-out minfo)
-	 (struct-out mx)
-	 (struct-out soa)
-	 (struct-out wks)
-	 (struct-out srv)
-
-	 value->query-opcode query-opcode->value
-	 value->query-response-code query-response-code->value
-	 type->value value->type
-	 qtype->value value->qtype
-	 class->value value->class
-	 qclass->value value->qclass
-
-	 packet->dns-message
-	 dns-message->packet
-
-	 make-dns-query
-	 make-dns-response
-
-	 raw-dns-query)
-
-;;---------------------------------------------------------------------------
-;; Data definitions
-
-;; 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.
-
-;; An IPv4 is a (vector Byte Byte Byte Byte), representing an IPv4
-;; address. For example, 127.0.0.1 is represented as (vector 127 0 0
-;; 1).
-
-;; An IPv6 is a Vector of length 16 containing Bytes, representing an
-;; IPv6 address. For example, 2001:0db8:85a3:0000:0000:8a2e:0370:7334
-;; is represented as (vector #x20 #x01 #x0d #xb8 #x85 #xa3 #x00 #x00
-;; #x00 #x00 #x8a #x2e #x03 #x70 #x73 #x34).
-
-;; A DNSMessage is a
-;; (dns-message Uint16 Direction Opcode Authoritativeness
-;; Truncatedness RecursionDesired RecursionAvailable ResponseCode
-;; ListOf<Question> ListOf<RR> ListOf<RR> ListOf<RR>).
-;;
-;; Interpreted as either a DNS request or reply, depending on the
-;; Direction.
-(struct dns-message (id
-		     direction
-		     opcode
-		     authoritative
-		     truncated
-		     recursion-desired
-		     recursion-available
-		     response-code
-		     questions
-		     answers
-		     authorities
-		     additional)
-	#:transparent)
-
-;; 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)
-
-;; An RR is a (rr DomainName RRType RRClass Uint32 RData),
-;; representing a resource record.
-(struct rr (name type class ttl rdata) #:transparent)
-
-;; An RData is one of
-;; - an IPv4, an "A" record
-;; - an IPv6, an "AAAA" record
-;; - (hinfo ShortString ShortString), a host information record [O]
-;; - (minfo DomainName DomainName), a mailbox information record [O]
-;; - (mx Uint16 DomainName), a mail exchanger record
-;; - (soa DomainName DomainName Uint32 Uint32 Uint32 Uint32 Uint32), a
-;;   start-of-authority record
-;; - (wks IPv4 Byte Bytes), a Well-Known Service [O]
-;; - (srv Uint16 Uint16 Uint16 DomainName), an "SRV" record
-;;
-;; In each case, the RData's variant MUST line up correctly with the
-;; type field of any RR containing it.
-;;
-;; Many of these variants are obsolete in today's DNS database (marked
-;; [O] above).
-(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 Opcode is a Symbol or a Number, one of the possibilities given
-;; in the following define-mapping. It represents a DNS message
-;; operation; see the RFC for details.
-(define-mapping value->query-opcode query-opcode->value
-  #:forward-default values
-  #:backward-default values
-  (0 query)
-  (1 iquery)
-  (2 status))
-
-;; A ResponseCode is a Symbol or a Number, one of the possibilities
-;; given in the following define-mapping. It represents the outcome of
-;; a DNS query.
-(define-mapping value->query-response-code query-response-code->value
-  (0 no-error)
-  (1 format-error)
-  (2 server-failure)
-  (3 name-error)
-  (4 not-implemented)
-  (5 refused))
-
-;; An RRType is a Symbol or a Number, one of the possibilities given
-;; in the following define-mapping. It represents the type of an
-;; RR. When used in an RR with an RData, the RRType and the RData
-;; variant must correspond.
-(define-mapping type->value value->type
-  #:forward-default values
-  #:backward-default values
-  (a 1)
-  (ns 2)
-  (md 3)
-  (mf 4)
-  (cname 5)
-  (soa 6)
-  (mb 7)
-  (mg 8)
-  (mr 9)
-  (null 10)
-  (wks 11)
-  (ptr 12)
-  (hinfo 13)
-  (minfo 14)
-  (mx 15)
-  (txt 16)
-  (aaaa 28)
-  (srv 33))
-
-;; A QueryType is a Symbol or Number (as given in the following
-;; define-mapping) or an RRType. It specifies the kinds of records
-;; being sought after in a DNS query.
-(define-mapping qtype->value value->qtype
-  #:forward-default type->value
-  #:backward-default value->type
-  (axfr 252)
-  (mailb 253)
-  (maila 254)
-  (* 255))
-
-;; An RRClass is a Symbol or a Number, one of the possibilities given
-;; in the following define-mapping. It represents the "class" of DNS
-;; records being discussed. All classes except 'in are obsolete in
-;; today's DNS databases.
-(define-mapping class->value value->class
-  #:forward-default values
-  #:backward-default values
-  (in 1)
-  (cs 2)
-  (ch 3)
-  (hs 4))
-
-;; A QueryClass is a Symbol or Number (as given in the following
-;; define-mapping) or an RRClass. It specifies the "class" of records
-;; being sought after in a DNS query.
-(define-mapping qclass->value value->qclass
-  #:forward-default class->value
-  #:backward-default value->class
-  (* 255))
-
-;;---------------------------------------------------------------------------
-;; DNS message codec
-
-;; <rfc1035>
-;; All communications inside of the domain protocol are carried in a single
-;; format called a message.  The top level format of message is divided
-;; into 5 sections (some of which are empty in certain cases) shown below:
-;;
-;;     +---------------------+
-;;     |        Header       |
-;;     +---------------------+
-;;     |       Question      | the question for the name server
-;;     +---------------------+
-;;     |        Answer       | RRs answering the question
-;;     +---------------------+
-;;     |      Authority      | RRs pointing toward an authority
-;;     +---------------------+
-;;     |      Additional     | RRs holding additional information
-;;     +---------------------+
-;; </rfc1035>
-
-;; <rfc1035>
-;; The header contains the following fields:
-;;
-;;                                     1  1  1  1  1  1
-;;       0  1  2  3  4  5  6  7  8  9  0  1  2  3  4  5
-;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;;     |                      ID                       |
-;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;;     |QR|   Opcode  |AA|TC|RD|RA|   Z    |   RCODE   |
-;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;;     |                    QDCOUNT                    |
-;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;;     |                    ANCOUNT                    |
-;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;;     |                    NSCOUNT                    |
-;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;;     |                    ARCOUNT                    |
-;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;; </rfc1035>
-
-(define (bit->value n if0 if1)
-  (if (positive? n) if1 if0))
-
-(define (value->bit b if0 if1)
-  (cond
-   ((eq? b if0) 0)
-   ((eq? b if1) 1)
-   (else (error 'value->bit "Value supplied is neither ~v nor ~v: ~v" if0 if1 b))))
-
-(define (packet->dns-message packet)
-  (bit-string-case packet
-    ([ (id :: bits 16)
-       (qr :: bits 1)
-       (opcode :: bits 4)
-       (aa :: bits 1)
-       (tc :: bits 1)
-       (rd :: bits 1)
-       (ra :: bits 1)
-       (= 0 :: bits 3)
-       (rcode :: bits 4)
-       (qdcount :: bits 16)
-       (ancount :: bits 16)
-       (nscount :: bits 16)
-       (arcount :: bits 16)
-       (sections4 :: binary) ]
-     (let*-values (((q-section sections3)
-		    (parse-section packet decode-question qdcount sections4))
-		   ((a-section sections2)
-		    (parse-section packet decode-rr ancount sections3))
-		   ((auth-section sections1)
-		    (parse-section packet decode-rr nscount sections2))
-		   ((additional-section sections0)
-		    (parse-section packet decode-rr arcount sections1)))
-       (when (not (zero? (bit-string-length sections0)))
-	 (error 'packet->dns-message "Packet too long"))
-       (dns-message id
-		    (bit->value qr 'request 'response)
-		    (value->query-opcode opcode)
-		    (bit->value aa 'non-authoritative 'authoritative)
-		    (bit->value tc 'not-truncated 'truncated)
-		    (bit->value rd 'no-recursion-desired 'recursion-desired)
-		    (bit->value ra 'no-recursion-available 'recursion-available)
-		    (value->query-response-code rcode)
-		    q-section
-		    a-section
-		    auth-section
-		    additional-section)))))
-
-(define (dns-message->packet m)
-  (bit-string->bytes
-   (bit-string ((dns-message-id m) :: bits 16)
-	       ((value->bit (dns-message-direction m)
-			    'request 'response) :: bits 1)
-	       ((query-opcode->value (dns-message-opcode m)) :: bits 4)
-	       ((value->bit (dns-message-authoritative m)
-			    'non-authoritative 'authoritative) :: bits 1)
-	       ((value->bit (dns-message-truncated m)
-			    'not-truncated 'truncated) :: bits 1)
-	       ((value->bit (dns-message-recursion-desired m)
-			    'no-recursion-desired 'recursion-desired) :: bits 1)
-	       ((value->bit (dns-message-recursion-available m)
-			    'no-recursion-available 'recursion-available) :: bits 1)
-	       (0 :: bits 3)
-	       ((query-response-code->value (dns-message-response-code m)) :: bits 4)
-	       ((length (dns-message-questions m)) :: bits 16)
-	       ((length (dns-message-answers m)) :: bits 16)
-	       ((length (dns-message-authorities m)) :: bits 16)
-	       ((length (dns-message-additional m)) :: bits 16)
-	       ((bit-string-append
-		 (encode-section encode-question (dns-message-questions m))
-		 (encode-section encode-rr (dns-message-answers m))
-		 (encode-section encode-rr (dns-message-authorities m))
-		 (encode-section encode-rr (dns-message-additional m))) :: binary))))
-
-(define (parse-section packet parser remaining-records input)
-  (let loop ((count remaining-records)
-	     (input input))
-    (cond
-     ((positive? count)
-      (let*-values (((record remainder) (parser packet input))
-		    ((records final-remainder) (loop (sub1 count) remainder)))
-	(values (cons record records) final-remainder)))
-     (else
-      (values '() input)))))
-
-(define (encode-section encoder records)
-  (cond
-   ((null? records) (bytes))
-   ((null? (cdr records)) (encoder (car records)))
-   (else (bit-string-append (encoder (car records))
-			    (encode-section encoder (cdr records))))))
-
-;; Domain-names use a strange "compressed" encoding.
-;; We have to be careful not to get stuck in a pointer loop here.
-
-(define (parse-domain-name whole-packet input pointers-followed)
-  (bit-string-case input
-
-    ([(= 3 :: bits 2) (offset :: bits 14) (rest :: binary)]
-     (if (member offset pointers-followed)
-	 (error 'parse-domain-name "DNS compressed-pointer loop detected")
-	 (let-values (((lhs rhs) (bit-string-split-at whole-packet (* 8 offset))))
-	   (let-values (((labels ignored-tail)
-			 (parse-domain-name whole-packet rhs (cons offset pointers-followed))))
-	     (values labels rest)))))
-
-    ([(= 0 :: bits 8) (rest :: binary)]
-     (values '() rest))
-
-    ([(= 0 :: bits 2) (len :: bits 6) (label :: binary bytes len) (rest :: binary)]
-     ;; TODO: validate labels: make sure they conform to the prescribed syntax
-     (let-values (((labels leftover)
-		   (parse-domain-name whole-packet rest pointers-followed)))
-       (values (cons (bit-string->bytes label) labels) leftover)))))
-
-(define (parse-single-domain-name whole-packet input)
-  (let-values (((name remainder) (parse-domain-name whole-packet input '())))
-    (if (bit-string-empty? remainder)
-	name
-	(error 'parse-single-domain-name
-	       "Expected just the one name, but got some trailing junk"))))
-
-(define (extract-domain-names whole-packet input)
-  (if (bit-string-empty? input)
-      (let-values (((name remainder) (parse-domain-name whole-packet input '())))
-	(cons name (extract-domain-names whole-packet remainder)))
-      '()))
-
-(define (encode-domain-name labels)
-  (cond
-   ((null? labels) (bytes 0))
-   (else (bit-string-append (encode-label (car labels))
-			    (encode-domain-name (cdr labels))))))
-
-(define (encode-label label)
-  (encode-pascal-string "Label" 64 label))
-
-(define (encode-pascal-string string-kind length-limit s)
-  (let ((len (bytes-length s)))
-    (when (>= len length-limit)
-      (error 'encode-pascal-string "~s too long: ~v" string-kind s))
-    (bytes-append (bytes len) s)))
-
-;; Character strings are pascal-style length-byte-prefixed strings.
-
-(define (extract-character-strings input)
-  (bit-string-case input
-    ([]
-     '())
-    ([len (body :: binary bytes len) (rest :: binary)]
-     (cons (bit-string->bytes body)
-	   (extract-character-strings rest)))))
-
-(define (encode-character-string bs)
-  (encode-pascal-string "Character-string" 256 bs))
-
-;; <rfc1035>
-;; The question section is used to carry the "question" in most queries,
-;; i.e., the parameters that define what is being asked.  The section
-;; contains QDCOUNT (usually 1) entries, each of the following format:
-;;
-;;                                     1  1  1  1  1  1
-;;       0  1  2  3  4  5  6  7  8  9  0  1  2  3  4  5
-;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;;     |                                               |
-;;     /                     QNAME                     /
-;;     /                                               /
-;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;;     |                     QTYPE                     |
-;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;;     |                     QCLASS                    |
-;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;; </rfc1035>
-
-(define (decode-question whole-packet input)
-  (let-values (((qname remainder) (parse-domain-name whole-packet input '())))
-    (bit-string-case remainder
-      ([(qtype :: bits 16)
-	(qclass :: bits 16)
-	(tail :: binary)]
-       (values (question qname
-			 (value->qtype qtype)
-			 (value->qclass qclass))
-	       tail)))))
-
-(define (encode-question q)
-  (bit-string-append (encode-domain-name (question-name q))
-		     (bit-string ((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:
-;;
-;;                                     1  1  1  1  1  1
-;;       0  1  2  3  4  5  6  7  8  9  0  1  2  3  4  5
-;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;;     |                                               |
-;;     /                                               /
-;;     /                      NAME                     /
-;;     |                                               |
-;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;;     |                      TYPE                     |
-;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;;     |                     CLASS                     |
-;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;;     |                      TTL                      |
-;;     |                                               |
-;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;;     |                   RDLENGTH                    |
-;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--|
-;;     /                     RDATA                     /
-;;     /                                               /
-;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
-;; </rfc1035>
-
-(define (decode-rr whole-packet input)
-  (let-values (((name remainder) (parse-domain-name whole-packet input '())))
-    (bit-string-case remainder
-      ([(type-number :: bits 16)
-	(class :: bits 16)
-	(ttl :: bits 32)
-	(rdlength :: bits 16)
-	(rdata :: binary bytes rdlength)
-	(tail :: binary)]
-       (let ((type (value->type type-number)))
-	 (values (rr name
-		     type
-		     (value->class class)
-		     ttl
-		     (decode-rdata whole-packet type rdata))
-		 tail))))))
-
-(define (decode-rdata whole-packet type rdata)
-  (case type
-    ((cname mb md mf mg mr ns ptr) (parse-single-domain-name whole-packet rdata))
-    ((hinfo) (apply hinfo (extract-character-strings rdata)))
-    ((minfo) (apply minfo (extract-domain-names whole-packet rdata)))
-    ((mx) (bit-string-case rdata
-	    ([(preference :: bits 16) (exchange :: binary)]
-	     (mx preference (parse-single-domain-name whole-packet exchange)))))
-    ((null) (bit-string->bytes rdata))
-    ((soa) (let*-values (((mname rdata1) (parse-domain-name whole-packet rdata '()))
-			 ((rname rdata2) (parse-domain-name whole-packet rdata1 '())))
-	     (bit-string-case rdata2
-	       ([(serial :: bits 32)
-		 (refresh :: bits 32)
-		 (retry :: bits 32)
-		 (expire :: bits 32)
-		 (minimum :: bits 32)]
-		(soa mname rname serial refresh retry expire minimum)))))
-    ((txt) (extract-character-strings rdata))
-    ((a) (bit-string-case rdata
-	   ([a b c d]
-	    (vector a b c d))))
-    ((aaaa) (bit-string-case rdata
-	      ([(ipv6-addr :: binary bits 128)]
-	       (list->vector (bytes->list (bit-string->bytes ipv6-addr))))))
-    ((wks) (bit-string-case rdata
-	     ([a b c d protocol (bitmap :: binary)]
-	      (wks (vector a b c d) protocol bitmap))))
-    ((srv) (bit-string-case rdata
-	     ([(priority :: bits 16)
-	       (weight :: bits 16)
-	       (port :: bits 16)
-	       (target :: binary)]
-	      (srv priority weight port (parse-single-domain-name whole-packet target)))))
-    (else (bit-string->bytes rdata))))
-
-(define (encode-rr rr)
-  (let ((encoded-rdata (encode-rdata (rr-type rr) (rr-rdata rr))))
-    (bit-string-append (encode-domain-name (rr-name rr))
-		       (bit-string ((type->value (rr-type rr)) :: bits 16)
-				   ((class->value (rr-class rr)) :: bits 16)
-				   ((rr-ttl rr) :: bits 32)
-				   ((/ (bit-string-length encoded-rdata) 8) :: bits 16)
-				   (encoded-rdata :: binary)))))
-
-(define (encode-rdata type rdata)
-  (case type
-    ((cname mb md mf mg mr ns ptr) (encode-domain-name rdata))
-    ((hinfo) (bit-string-append (encode-character-string (hinfo-cpu rdata))
-				(encode-character-string (hinfo-os rdata))))
-    ((minfo) (bit-string-append (encode-character-string (minfo-rmailbx rdata))
-				(encode-character-string (minfo-emailbx rdata))))
-    ((mx) (bit-string ((mx-preference rdata) :: bits 16)
-		      ((encode-domain-name (mx-exchange rdata)) :: binary)))
-    ((null) rdata)
-    ((soa) (bit-string-append (encode-domain-name (soa-mname rdata))
-			      (encode-domain-name (soa-rname rdata))
-			      (bit-string ((soa-serial rdata) :: bits 32)
-					  ((soa-refresh rdata) :: bits 32)
-					  ((soa-retry rdata) :: bits 32)
-					  ((soa-expire rdata) :: bits 32)
-					  ((soa-minimum rdata) :: bits 32))))
-    ((txt)
-     ;; TODO: write and use bit-string-append* instead of using apply here
-     (foldl (lambda (s acc) (bit-string-append acc (encode-character-string s)))
-	    (car rdata)
-	    (cdr rdata)))
-    ((a) (match rdata ((vector a b c d) (bit-string a b c d))))
-    ((aaaa) (bit-string ((list->bytes (vector->list rdata)) :: binary bits 128)))
-    ((wks) (match (wks-address rdata)
-	     ((vector a b c d)
-	      (bit-string a b c d (wks-protocol rdata) ((wks-bitmap rdata) :: binary)))))
-    ((srv) (bit-string ((srv-priority rdata) :: bits 16)
-		       ((srv-weight rdata) :: bits 16)
-		       ((srv-port rdata) :: bits 16)
-		       ((encode-domain-name (srv-target rdata)) :: binary)))
-    (else rdata)))
-
-;;---------------------------------------------------------------------------
-
-(define (make-dns-query questions
-			[recursion-desired 'no-recursion-desired])
-  (dns-message (random 65536)
-	       'request
-	       'query
-	       'non-authoritative
-	       'not-truncated
-	       recursion-desired
-	       'no-recursion-available
-	       'no-error
-	       questions
-	       '()
-	       '()
-	       '()))
-
-(define (make-dns-response query response-code answers authoritative
-			   [recursion-available 'no-recursion-available]
-			   [authorities '()]
-			   [additional '()])
-  (dns-message (dns-message-id query)
-	       'response
-	       (dns-message-opcode query)
-	       authoritative
-	       'not-truncated
-	       (dns-message-recursion-desired query)
-	       recursion-available
-	       response-code
-	       (dns-message-questions query)
-	       answers
-	       authorities
-	       additional))
-
-(define (next-timeout timeout)
-  (case timeout
-    ((3) 11)
-    ((11) 45)
-    ((45) #f)))
-
-(define *total-port-finding-attempts* 100) ;; TODO: eliminate arbitrary 100?
-
-(define (bind-to-random-port! s)
-  (let find-a-port ((remaining-tries *total-port-finding-attempts*))
-    (if (zero? remaining-tries)
-	(error 'bind-to-random-port! "Could not find a free UDP port in ~v tries"
-	       *total-port-finding-attempts*)
-	(let ((port-number (+ 1024 (random (- 65536 1024)))))
-	  (with-handlers [(exn:fail:network?
-			   (lambda (e)
-			     ;; Bind failure. Port in use?
-			     (find-a-port (- remaining-tries 1))))]
-	    (udp-bind! s #f port-number))))))
-
-(define (raw-dns-query query [servers '("127.0.0.1")])
-  (let ((s (udp-open-socket #f #f)))
-    (bind-to-random-port! s)
-    ;; TODO: randomize ordering of servers in list.
-    (let search ((timeout 3)
-		 (remaining-servers servers))
-      (if (null? remaining-servers)
-	  (let ((new-timeout (next-timeout timeout)))
-	    (if new-timeout
-		(search new-timeout servers)
-		#f))
-	  (let ((server (car remaining-servers)))
-	    (let ((server-hostname (if (string? server) server (car server)))
-		  (server-port (if (string? server) 53 (cadr server))))
-	      ;;(write `(querying ,server-hostname ,server-port with timeout ,timeout)) (newline)
-	      (udp-send-to s server-hostname server-port (dns-message->packet query))
-	      (let ((buffer (make-bytes 512))) ;; maximum DNS reply length
-		(let ((result (sync/timeout timeout (udp-receive!-evt s buffer))))
-		  ;; TODO: maybe receive only specifically from the queried IP address?
-		  ;;(write `(response ,result)) (newline)
-		  (if result
-		      (let ((reply-length (car result)))
-			(packet->dns-message (sub-bit-string buffer 0 (* 8 reply-length))))
-		      (search timeout (cdr remaining-servers)))))))))))

prototype/mapping.rkt

@@ -1,35 +0,0 @@
-#lang racket/base
-
-(provide define-mapping)
-
-(define-syntax check-defaults
-  (syntax-rules ()
-    ((_ fn bn fd bd #:forward-default new-fd rest ...)
-     (check-defaults fn bn new-fd bd rest ...))
-    ((_ fn bn fd bd #:backward-default new-bd rest ...)
-     (check-defaults fn bn fd new-bd rest ...))
-    ((_ fn bn fd bd (lhs rhs) ...)
-     (begin
-       (define (fn l)
-	 (case l
-	   ((lhs) 'rhs) ...
-	   (else (fd l))))
-       (define (bn r)
-	 (case r
-	   ((rhs) 'lhs) ...
-	   (else (bd r))))))))
-
-(define (die-with-mapping-name n)
-  (lambda (v)
-    (raise (exn:fail:contract
-	    (format "~v: Mapping not found for ~v" n v)
-	    (current-continuation-marks)))))
-
-(define-syntax define-mapping
-  (syntax-rules ()
-    ((_ forward-name backward-name rest ...)
-     (check-defaults forward-name
-		     backward-name
-		     (die-with-mapping-name 'forward-name)
-		     (die-with-mapping-name 'backward-name)
-		     rest ...))))

prototype/test-dns.rkt

@@ -1,248 +0,0 @@
-#lang racket/base
-
-(require "dns.rkt")
-
-;; Wed Jun 29 16:33:58 2011 (4e0b8c36): UDP: localhost sent 28 bytes:
-;; 00000000: 66 3A 01 00 00 01 00 00 : 00 00 00 00 06 67 6F 6F  f:...........goo
-;; 00000010: 67 6C 65 03 63 6F 6D 00 : 00 FF 00 01              gle.com.....
-;; 0000001C:
-
-(define (q-google-in-any)
-  (bytes #x66 #x3A #x01 #x00 #x00 #x01 #x00 #x00
-	 #x00 #x00 #x00 #x00 #x06 #x67 #x6F #x6F
-	 #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00
-	 #x00 #xFF #x00 #x01))
-
-;; Wed Jun 29 16:33:58 2011 (4e0b8c36): UDP: dslrouter.westell.com sent 494 bytes:
-;; 00000000: 66 3A 81 80 00 01 00 0F : 00 00 00 07 06 67 6F 6F  f:...........goo
-;; 00000010: 67 6C 65 03 63 6F 6D 00 : 00 FF 00 01 C0 0C 00 10  gle.com.........
-;; 00000020: 00 01 00 00 0C 2F 00 52 : 51 76 3D 73 70 66 31 20  ...../.RQv=spf1 
-;; 00000030: 69 6E 63 6C 75 64 65 3A : 5F 6E 65 74 62 6C 6F 63  include:_netbloc
-;; 00000040: 6B 73 2E 67 6F 6F 67 6C : 65 2E 63 6F 6D 20 69 70  ks.google.com ip
-;; 00000050: 34 3A 32 31 36 2E 37 33 : 2E 39 33 2E 37 30 2F 33  4:216.73.93.70/3
-;; 00000060: 31 20 69 70 34 3A 32 31 : 36 2E 37 33 2E 39 33 2E  1 ip4:216.73.93.
-;; 00000070: 37 32 2F 33 31 20 7E 61 : 6C 6C C0 0C 00 01 00 01  72/31 ~all......
-;; 00000080: 00 00 01 1D 00 04 4A 7D : E2 92 C0 0C 00 01 00 01  ......J}........
-;; 00000090: 00 00 01 1D 00 04 4A 7D : E2 94 C0 0C 00 01 00 01  ......J}........
-;; 000000A0: 00 00 01 1D 00 04 4A 7D : E2 91 C0 0C 00 01 00 01  ......J}........
-;; 000000B0: 00 00 01 1D 00 04 4A 7D : E2 93 C0 0C 00 01 00 01  ......J}........
-;; 000000C0: 00 00 01 1D 00 04 4A 7D : E2 90 C0 0C 00 02 00 01  ......J}........
-;; 000000D0: 00 03 A5 1D 00 06 03 6E : 73 32 C0 0C C0 0C 00 02  .......ns2......
-;; 000000E0: 00 01 00 03 A5 1D 00 06 : 03 6E 73 33 C0 0C C0 0C  .........ns3....
-;; 000000F0: 00 02 00 01 00 03 A5 1D : 00 06 03 6E 73 31 C0 0C  ...........ns1..
-;; 00000100: C0 0C 00 02 00 01 00 03 : A5 1D 00 06 03 6E 73 34  .............ns4
-;; 00000110: C0 0C C0 0C 00 0F 00 01 : 00 00 00 2A 00 11 00 14  ...........*....
-;; 00000120: 04 61 6C 74 31 05 61 73 : 70 6D 78 01 6C C0 0C C0  .alt1.aspmx.l...
-;; 00000130: 0C 00 0F 00 01 00 00 00 : 2A 00 09 00 1E 04 61 6C  ........*.....al
-;; 00000140: 74 32 C1 25 C0 0C 00 0F : 00 01 00 00 00 2A 00 04  t2.%.........*..
-;; 00000150: 00 0A C1 25 C0 0C 00 0F : 00 01 00 00 00 2A 00 09  ...%.........*..
-;; 00000160: 00 28 04 61 6C 74 33 C1 : 25 C0 0C 00 0F 00 01 00  .(.alt3.%.......
-;; 00000170: 00 00 2A 00 09 00 32 04 : 61 6C 74 34 C1 25 C0 E8  ..*...2.alt4.%..
-;; 00000180: 00 01 00 01 00 03 A2 CF : 00 04 D8 EF 24 0A C0 FA  ............$...
-;; 00000190: 00 01 00 01 00 03 A2 CF : 00 04 D8 EF 20 0A C1 0C  ............ ...
-;; 000001A0: 00 01 00 01 00 03 A2 CF : 00 04 D8 EF 26 0A C0 D6  ............&...
-;; 000001B0: 00 01 00 01 00 03 A2 CF : 00 04 D8 EF 22 0A C1 3D  ............"..=
-;; 000001C0: 00 01 00 01 00 00 00 F0 : 00 04 4A 7D 27 1B C1 25  ..........J}'..%
-;; 000001D0: 00 01 00 01 00 00 00 F6 : 00 04 4A 7D 73 1B C1 20  ..........J}s.. 
-;; 000001E0: 00 01 00 01 00 00 00 21 : 00 04 4A 7D 4D 1B        .......!..J}M.
-;; 000001EE:
-
-(define (a-google-in-any)
-  (bytes
-   #x66 #x3A #x81 #x80 #x00 #x01 #x00 #x0F #x00 #x00 #x00 #x07 #x06 #x67 #x6F #x6F
-   #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #xFF #x00 #x01 #xC0 #x0C #x00 #x10
-   #x00 #x01 #x00 #x00 #x0C #x2F #x00 #x52 #x51 #x76 #x3D #x73 #x70 #x66 #x31 #x20
-   #x69 #x6E #x63 #x6C #x75 #x64 #x65 #x3A #x5F #x6E #x65 #x74 #x62 #x6C #x6F #x63
-   #x6B #x73 #x2E #x67 #x6F #x6F #x67 #x6C #x65 #x2E #x63 #x6F #x6D #x20 #x69 #x70
-   #x34 #x3A #x32 #x31 #x36 #x2E #x37 #x33 #x2E #x39 #x33 #x2E #x37 #x30 #x2F #x33
-   #x31 #x20 #x69 #x70 #x34 #x3A #x32 #x31 #x36 #x2E #x37 #x33 #x2E #x39 #x33 #x2E
-   #x37 #x32 #x2F #x33 #x31 #x20 #x7E #x61 #x6C #x6C #xC0 #x0C #x00 #x01 #x00 #x01
-   #x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x92 #xC0 #x0C #x00 #x01 #x00 #x01
-   #x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x94 #xC0 #x0C #x00 #x01 #x00 #x01
-   #x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x91 #xC0 #x0C #x00 #x01 #x00 #x01
-   #x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x93 #xC0 #x0C #x00 #x01 #x00 #x01
-   #x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x90 #xC0 #x0C #x00 #x02 #x00 #x01
-   #x00 #x03 #xA5 #x1D #x00 #x06 #x03 #x6E #x73 #x32 #xC0 #x0C #xC0 #x0C #x00 #x02
-   #x00 #x01 #x00 #x03 #xA5 #x1D #x00 #x06 #x03 #x6E #x73 #x33 #xC0 #x0C #xC0 #x0C
-   #x00 #x02 #x00 #x01 #x00 #x03 #xA5 #x1D #x00 #x06 #x03 #x6E #x73 #x31 #xC0 #x0C
-   #xC0 #x0C #x00 #x02 #x00 #x01 #x00 #x03 #xA5 #x1D #x00 #x06 #x03 #x6E #x73 #x34
-   #xC0 #x0C #xC0 #x0C #x00 #x0F #x00 #x01 #x00 #x00 #x00 #x2A #x00 #x11 #x00 #x14
-   #x04 #x61 #x6C #x74 #x31 #x05 #x61 #x73 #x70 #x6D #x78 #x01 #x6C #xC0 #x0C #xC0
-   #x0C #x00 #x0F #x00 #x01 #x00 #x00 #x00 #x2A #x00 #x09 #x00 #x1E #x04 #x61 #x6C
-   #x74 #x32 #xC1 #x25 #xC0 #x0C #x00 #x0F #x00 #x01 #x00 #x00 #x00 #x2A #x00 #x04
-   #x00 #x0A #xC1 #x25 #xC0 #x0C #x00 #x0F #x00 #x01 #x00 #x00 #x00 #x2A #x00 #x09
-   #x00 #x28 #x04 #x61 #x6C #x74 #x33 #xC1 #x25 #xC0 #x0C #x00 #x0F #x00 #x01 #x00
-   #x00 #x00 #x2A #x00 #x09 #x00 #x32 #x04 #x61 #x6C #x74 #x34 #xC1 #x25 #xC0 #xE8
-   #x00 #x01 #x00 #x01 #x00 #x03 #xA2 #xCF #x00 #x04 #xD8 #xEF #x24 #x0A #xC0 #xFA
-   #x00 #x01 #x00 #x01 #x00 #x03 #xA2 #xCF #x00 #x04 #xD8 #xEF #x20 #x0A #xC1 #x0C
-   #x00 #x01 #x00 #x01 #x00 #x03 #xA2 #xCF #x00 #x04 #xD8 #xEF #x26 #x0A #xC0 #xD6
-   #x00 #x01 #x00 #x01 #x00 #x03 #xA2 #xCF #x00 #x04 #xD8 #xEF #x22 #x0A #xC1 #x3D
-   #x00 #x01 #x00 #x01 #x00 #x00 #x00 #xF0 #x00 #x04 #x4A #x7D #x27 #x1B #xC1 #x25
-   #x00 #x01 #x00 #x01 #x00 #x00 #x00 #xF6 #x00 #x04 #x4A #x7D #x73 #x1B #xC1 #x20
-   #x00 #x01 #x00 #x01 #x00 #x00 #x00 #x21 #x00 #x04 #x4A #x7D #x4D #x1B))
-
-(require racket/pretty)
-(pretty-print (packet->dns-message (q-google-in-any)))
-(pretty-print (packet->dns-message (a-google-in-any)))
-
-(pretty-print (dns-message->packet (packet->dns-message (a-google-in-any))))
-
-;; Wed Jun 29 20:59:17 2011 (4e0bca65): UDP: localhost sent 28 bytes:
-;; 00000000: 47 16 01 00 00 01 00 00 : 00 00 00 00 06 67 6F 6F  G............goo
-;; 00000010: 67 6C 65 03 63 6F 6D 00 : 00 1C 00 01              gle.com.....
-;; 0000001C:
-;; Wed Jun 29 20:59:17 2011 (4e0bca65): UDP: pass through succeeded
-;; Wed Jun 29 20:59:17 2011 (4e0bca65): UDP: google-public-dns-a.google.com sent 78 bytes:
-;; 00000000: 47 16 81 80 00 01 00 00 : 00 01 00 00 06 67 6F 6F  G............goo
-;; 00000010: 67 6C 65 03 63 6F 6D 00 : 00 1C 00 01 C0 0C 00 06  gle.com.........
-;; 00000020: 00 01 00 00 02 52 00 26 : 03 6E 73 31 C0 0C 09 64  .....R.&.ns1...d
-;; 00000030: 6E 73 2D 61 64 6D 69 6E : C0 0C 00 16 33 23 00 00  ns-admin....3#..
-;; 00000040: 1C 20 00 00 07 08 00 12 : 75 00 00 00 01 2C        . ......u....,
-;; 0000004E:
-
-(pretty-print
- (packet->dns-message
-  (bytes
-   #x47 #x16 #x01 #x00 #x00 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x06 #x67 #x6F #x6F
-   #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00 #x01)))
-
-(pretty-print
- (packet->dns-message
-  (bytes
-   #x47 #x16 #x81 #x80 #x00 #x01 #x00 #x00 #x00 #x01 #x00 #x00 #x06 #x67 #x6F #x6F
-   #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00 #x01 #xC0 #x0C #x00 #x06
-   #x00 #x01 #x00 #x00 #x02 #x52 #x00 #x26 #x03 #x6E #x73 #x31 #xC0 #x0C #x09 #x64
-   #x6E #x73 #x2D #x61 #x64 #x6D #x69 #x6E #xC0 #x0C #x00 #x16 #x33 #x23 #x00 #x00
-   #x1C #x20 #x00 #x00 #x07 #x08 #x00 #x12 #x75 #x00 #x00 #x00 #x01 #x2C)))
-
-;; Wed Jun 29 21:05:03 2011 (4e0bcbbf): UDP: localhost sent 32 bytes:
-;; 00000000: 12 70 01 00 00 01 00 00 : 00 00 00 00 03 77 77 77  .p...........www
-;; 00000010: 06 67 6F 6F 67 6C 65 03 : 63 6F 6D 00 00 1C 00 01  .google.com.....
-;; 00000020:
-;; Wed Jun 29 21:05:03 2011 (4e0bcbbf): UDP: pass through succeeded
-;; Wed Jun 29 21:05:03 2011 (4e0bcbbf): UDP: ns1.google.com sent 52 bytes:
-;; 00000000: 12 70 85 00 00 01 00 01 : 00 00 00 00 03 77 77 77  .p...........www
-;; 00000010: 06 67 6F 6F 67 6C 65 03 : 63 6F 6D 00 00 1C 00 01  .google.com.....
-;; 00000020: C0 0C 00 05 00 01 00 09 : 3A 80 00 08 03 77 77 77  ........:....www
-;; 00000030: 01 6C C0 10             :                          .l..
-;; 00000034:
-
-(pretty-print
- (packet->dns-message
-  (bytes
-   #x12 #x70 #x01 #x00 #x00 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x03 #x77 #x77 #x77
-   #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00 #x01)))
-
-(pretty-print
- (packet->dns-message
-  (bytes
-   #x12 #x70 #x85 #x00 #x00 #x01 #x00 #x01 #x00 #x00 #x00 #x00 #x03 #x77 #x77 #x77
-   #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00 #x01
-   #xC0 #x0C #x00 #x05 #x00 #x01 #x00 #x09 #x3A #x80 #x00 #x08 #x03 #x77 #x77 #x77
-   #x01 #x6C #xC0 #x10)))
-
-;; Wed Jun 29 21:07:46 2011 (4e0bcc62): UDP: ns1.google.com sent 82 bytes:
-;; 00000000: 23 79 85 00 00 01 00 02 : 00 00 00 00 04 69 70 76  #y...........ipv
-;; 00000010: 36 06 67 6F 6F 67 6C 65 : 03 63 6F 6D 00 00 1C 00  6.google.com....
-;; 00000020: 01 C0 0C 00 05 00 01 00 : 09 3A 80 00 09 04 69 70  .........:....ip
-;; 00000030: 76 36 01 6C C0 11 C0 2D : 00 1C 00 01 00 00 01 2C  v6.l...-.......,
-;; 00000040: 00 10 20 01 48 60 80 0F : 00 00 00 00 00 00 00 00  .. .H`..........
-;; 00000050: 00 68                   :                          .h
-;; 00000052:
-
-(pretty-print
- (packet->dns-message
-  (bytes
-   #x23 #x79 #x85 #x00 #x00 #x01 #x00 #x02 #x00 #x00 #x00 #x00 #x04 #x69 #x70 #x76
-   #x36 #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00
-   #x01 #xC0 #x0C #x00 #x05 #x00 #x01 #x00 #x09 #x3A #x80 #x00 #x09 #x04 #x69 #x70
-   #x76 #x36 #x01 #x6C #xC0 #x11 #xC0 #x2D #x00 #x1C #x00 #x01 #x00 #x00 #x01 #x2C
-   #x00 #x10 #x20 #x01 #x48 #x60 #x80 #x0F #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
-   #x00 #x68)))
-
-(pretty-print
- (dns-message->packet
-  (packet->dns-message
-   (bytes
-    #x23 #x79 #x85 #x00 #x00 #x01 #x00 #x02 #x00 #x00 #x00 #x00 #x04 #x69 #x70 #x76
-    #x36 #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00
-    #x01 #xC0 #x0C #x00 #x05 #x00 #x01 #x00 #x09 #x3A #x80 #x00 #x09 #x04 #x69 #x70
-    #x76 #x36 #x01 #x6C #xC0 #x11 #xC0 #x2D #x00 #x1C #x00 #x01 #x00 #x00 #x01 #x2C
-    #x00 #x10 #x20 #x01 #x48 #x60 #x80 #x0F #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
-    #x00 #x68))))
-
-;; Thu Jun 30 15:12:45 2011 (4e0ccaad): UDP: asgard.ccs.neu.edu sent 486 bytes:
-;; 00000000: 13 CA 81 80 00 01 00 05 : 00 04 00 09 0C 5F 78 6D  ............._xm
-;; 00000010: 70 70 2D 73 65 72 76 65 : 72 04 5F 74 63 70 06 67  pp-server._tcp.g
-;; 00000020: 6F 6F 67 6C 65 03 63 6F : 6D 00 00 21 00 01 C0 0C  oogle.com..!....
-;; 00000030: 00 21 00 01 00 00 03 72 : 00 21 00 14 00 00 14 95  .!.....r.!......
-;; 00000040: 0C 78 6D 70 70 2D 73 65 : 72 76 65 72 34 01 6C 06  .xmpp-server4.l.
-;; 00000050: 67 6F 6F 67 6C 65 03 63 : 6F 6D 00 C0 0C 00 21 00  google.com....!.
-;; 00000060: 01 00 00 03 72 00 20 00 : 05 00 00 14 95 0B 78 6D  ....r. .......xm
-;; 00000070: 70 70 2D 73 65 72 76 65 : 72 01 6C 06 67 6F 6F 67  pp-server.l.goog
-;; 00000080: 6C 65 03 63 6F 6D 00 C0 : 0C 00 21 00 01 00 00 03  le.com....!.....
-;; 00000090: 72 00 21 00 14 00 00 14 : 95 0C 78 6D 70 70 2D 73  r.!.......xmpp-s
-;; 000000A0: 65 72 76 65 72 31 01 6C : 06 67 6F 6F 67 6C 65 03  erver1.l.google.
-;; 000000B0: 63 6F 6D 00 C0 0C 00 21 : 00 01 00 00 03 72 00 21  com....!.....r.!
-;; 000000C0: 00 14 00 00 14 95 0C 78 : 6D 70 70 2D 73 65 72 76  .......xmpp-serv
-;; 000000D0: 65 72 32 01 6C 06 67 6F : 6F 67 6C 65 03 63 6F 6D  er2.l.google.com
-;; 000000E0: 00 C0 0C 00 21 00 01 00 : 00 03 72 00 21 00 14 00  ....!.....r.!...
-;; 000000F0: 00 14 95 0C 78 6D 70 70 : 2D 73 65 72 76 65 72 33  ....xmpp-server3
-;; 00000100: 01 6C 06 67 6F 6F 67 6C : 65 03 63 6F 6D 00 C1 02  .l.google.com...
-;; 00000110: 00 02 00 01 00 01 54 24 : 00 06 03 6E 73 33 C1 02  ......T$...ns3..
-;; 00000120: C1 02 00 02 00 01 00 01 : 54 24 00 06 03 6E 73 34  ........T$...ns4
-;; 00000130: C1 02 C1 02 00 02 00 01 : 00 01 54 24 00 06 03 6E  ..........T$...n
-;; 00000140: 73 32 C1 02 C1 02 00 02 : 00 01 00 01 54 24 00 06  s2..........T$..
-;; 00000150: 03 6E 73 31 C1 02 C0 6D : 00 01 00 01 00 00 01 1A  .ns1...m........
-;; 00000160: 00 04 4A 7D 99 7D C0 99 : 00 01 00 01 00 00 06 F6  ..J}.}..........
-;; 00000170: 00 04 4A 7D 35 7D C0 C6 : 00 01 00 01 00 00 06 F6  ..J}5}..........
-;; 00000180: 00 04 4A 7D 2F 7D C0 F3 : 00 01 00 01 00 00 06 F6  ..J}/}..........
-;; 00000190: 00 04 4A 7D 2D 7D C0 40 : 00 01 00 01 00 00 06 F6  ..J}-}.@........
-;; 000001A0: 00 04 4A 7D 2D 7D C1 50 : 00 01 00 01 00 00 0A B1  ..J}-}.P........
-;; 000001B0: 00 04 D8 EF 20 0A C1 3E : 00 01 00 01 00 00 0A B1  .... ..>........
-;; 000001C0: 00 04 D8 EF 22 0A C1 1A : 00 01 00 01 00 00 0A B1  ...."...........
-;; 000001D0: 00 04 D8 EF 24 0A C1 2C : 00 01 00 01 00 00 0A B1  ....$..,........
-;; 000001E0: 00 04 D8 EF 26 0A       :                          ....&.
-;; 000001E6:
-
-;; ANSWER SECTION:
-;;_xmpp-server._tcp.google.com. 900 IN    SRV     5 0 5269 xmpp-server.l.google.com.
-;;_xmpp-server._tcp.google.com. 900 IN    SRV     20 0 5269 xmpp-server1.l.google.com.
-;;_xmpp-server._tcp.google.com. 900 IN    SRV     20 0 5269 xmpp-server2.l.google.com.
-;;_xmpp-server._tcp.google.com. 900 IN    SRV     20 0 5269 xmpp-server3.l.google.com.
-;;_xmpp-server._tcp.google.com. 900 IN    SRV     20 0 5269 xmpp-server4.l.google.com.
-
-(pretty-print
- (packet->dns-message
-  (bytes
-   #x13 #xCA #x81 #x80 #x00 #x01 #x00 #x05 #x00 #x04 #x00 #x09 #x0C #x5F #x78 #x6D
-   #x70 #x70 #x2D #x73 #x65 #x72 #x76 #x65 #x72 #x04 #x5F #x74 #x63 #x70 #x06 #x67
-   #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x21 #x00 #x01 #xC0 #x0C
-   #x00 #x21 #x00 #x01 #x00 #x00 #x03 #x72 #x00 #x21 #x00 #x14 #x00 #x00 #x14 #x95
-   #x0C #x78 #x6D #x70 #x70 #x2D #x73 #x65 #x72 #x76 #x65 #x72 #x34 #x01 #x6C #x06
-   #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #xC0 #x0C #x00 #x21 #x00
-   #x01 #x00 #x00 #x03 #x72 #x00 #x20 #x00 #x05 #x00 #x00 #x14 #x95 #x0B #x78 #x6D
-   #x70 #x70 #x2D #x73 #x65 #x72 #x76 #x65 #x72 #x01 #x6C #x06 #x67 #x6F #x6F #x67
-   #x6C #x65 #x03 #x63 #x6F #x6D #x00 #xC0 #x0C #x00 #x21 #x00 #x01 #x00 #x00 #x03
-   #x72 #x00 #x21 #x00 #x14 #x00 #x00 #x14 #x95 #x0C #x78 #x6D #x70 #x70 #x2D #x73
-   #x65 #x72 #x76 #x65 #x72 #x31 #x01 #x6C #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03
-   #x63 #x6F #x6D #x00 #xC0 #x0C #x00 #x21 #x00 #x01 #x00 #x00 #x03 #x72 #x00 #x21
-   #x00 #x14 #x00 #x00 #x14 #x95 #x0C #x78 #x6D #x70 #x70 #x2D #x73 #x65 #x72 #x76
-   #x65 #x72 #x32 #x01 #x6C #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D
-   #x00 #xC0 #x0C #x00 #x21 #x00 #x01 #x00 #x00 #x03 #x72 #x00 #x21 #x00 #x14 #x00
-   #x00 #x14 #x95 #x0C #x78 #x6D #x70 #x70 #x2D #x73 #x65 #x72 #x76 #x65 #x72 #x33
-   #x01 #x6C #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #xC1 #x02
-   #x00 #x02 #x00 #x01 #x00 #x01 #x54 #x24 #x00 #x06 #x03 #x6E #x73 #x33 #xC1 #x02
-   #xC1 #x02 #x00 #x02 #x00 #x01 #x00 #x01 #x54 #x24 #x00 #x06 #x03 #x6E #x73 #x34
-   #xC1 #x02 #xC1 #x02 #x00 #x02 #x00 #x01 #x00 #x01 #x54 #x24 #x00 #x06 #x03 #x6E
-   #x73 #x32 #xC1 #x02 #xC1 #x02 #x00 #x02 #x00 #x01 #x00 #x01 #x54 #x24 #x00 #x06
-   #x03 #x6E #x73 #x31 #xC1 #x02 #xC0 #x6D #x00 #x01 #x00 #x01 #x00 #x00 #x01 #x1A
-   #x00 #x04 #x4A #x7D #x99 #x7D #xC0 #x99 #x00 #x01 #x00 #x01 #x00 #x00 #x06 #xF6
-   #x00 #x04 #x4A #x7D #x35 #x7D #xC0 #xC6 #x00 #x01 #x00 #x01 #x00 #x00 #x06 #xF6
-   #x00 #x04 #x4A #x7D #x2F #x7D #xC0 #xF3 #x00 #x01 #x00 #x01 #x00 #x00 #x06 #xF6
-   #x00 #x04 #x4A #x7D #x2D #x7D #xC0 #x40 #x00 #x01 #x00 #x01 #x00 #x00 #x06 #xF6
-   #x00 #x04 #x4A #x7D #x2D #x7D #xC1 #x50 #x00 #x01 #x00 #x01 #x00 #x00 #x0A #xB1
-   #x00 #x04 #xD8 #xEF #x20 #x0A #xC1 #x3E #x00 #x01 #x00 #x01 #x00 #x00 #x0A #xB1
-   #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)))

prototype/test-mapping.rkt

@@ -1,25 +0,0 @@
-#lang racket/base
-
-(require "mapping.rkt")
-(require rackunit)
-
-(define-mapping a->b b->a
-  (a b))
-
-(check-equal? (a->b 'a) 'b)
-(check-equal? (b->a 'b) 'a)
-(check-exn exn:fail:contract? (lambda () (a->b 123)))
-(check-exn exn:fail:contract? (lambda () (a->b 'b)))
-(check-exn exn:fail:contract? (lambda () (b->a 123)))
-(check-exn exn:fail:contract? (lambda () (b->a 'a)))
-
-(define-mapping c->d d->c
-  #:forward-default (lambda (x) 'default-d)
-  #:backward-default (lambda (x) 'default-c)
-  (c 123)
-  (e 234))
-
-(check-equal? (c->d 'c) 123)
-(check-equal? (d->c 234) 'e)
-(check-equal? (c->d 'other) 'default-d)
-(check-equal? (d->c '235) 'default-c)

proxy.rkt

@@ -1,20 +1,21 @@
-#lang racket/base
+#lang typed/racket/base
 
 ;; DNS proxy using os-big-bang.rkt and os-udp.rkt.
 
 (require racket/match)
 (require racket/set)
 (require racket/bool)
-(require "../racket-bitsyntax/main.rkt")
+(require (planet tonyg/bitsyntax))
 (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 marketplace/sugar-typed)
+(require marketplace/support/spy)
+(require marketplace/drivers/timer)
+(require marketplace/drivers/udp)
+(require "tk-dns.rkt")
 
 (require racket/pretty)
 
@@ -22,78 +23,89 @@
 ;; searches from. Performs recursive queries.
 
 ;; For discarding retransmitted requests that we're still working on.
-(struct active-request (source id) #:prefab)
+(struct: active-request ([source : UdpAddress] [id : Natural]) #:transparent)
+(define-type ActiveRequest active-request)
 
-;; start-proxy : UInt16 CompiledZone CompiledZone -> Void
+(: start-proxy : Natural 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))
 
   (log-info "Ready.")
 
-  (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))))
+  (ground-vm:
+   ((inst generic-spy Void) 'UDP)
+   ((inst udp-driver Void))
+   ((inst timer-driver Void))
+   (nested-vm: : Void
+	       #:debug-name 'dns-vm
+	       (spawn: #:debug-name 'dns-spy #:parent : Void #:child : Void (dns-spy))
+	       ((inst timer-relay Void) 'timer-relay:dns)
+	       (spawn: #:debug-name 'query-id-allocator #:parent : Void
+		       #:child : (Setof Natural)
+		       (query-id-allocator))
+	       (spawn: #:debug-name 'server-dns-reader #:parent : Void
+		       #:child : Void (dns-read-driver server-addr))
+	       (spawn: #:debug-name 'server-dns-writer #:parent : Void
+		       #:child : Void (dns-write-driver server-addr))
+	       (spawn: #:debug-name 'client-dns-reader #:parent : Void
+		       #:child : Void (dns-read-driver client-addr))
+	       (spawn: #:debug-name 'client-dns-writer #:parent : Void
+		       #:child : Void (dns-write-driver client-addr))
+	       (spawn: #:debug-name 'packet-dispatcher #:parent : Void
+		       #:child : (Setof ActiveRequest) (packet-dispatcher server-addr))
+	       (spawn: #:debug-name 'question-dispatcher #:parent : Void
+		       #:child : CompiledZone (question-dispatcher zone roots-only client-addr)))))
 
+(: query-id-allocator : -> (Transition (Setof Natural)))
 (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))])))
+  (transition: ((inst set Natural)) : (Setof Natural) ;; all active query IDs
+    (endpoint: allocated : (Setof Natural)
+	       #:subscriber `(request ,(wild) allocate-query-id)
+     [`(request ,reply-addr allocate-query-id)
+      (let: recheck : (Transition (Setof Natural)) ()
+	(define n (random 65536))
+	(if (set-member? allocated n)
+	    (recheck)
+	    (transition: (set-add allocated n) : (Setof Natural)
+	      (send-message `(reply ,reply-addr ,n)))))])
+    (endpoint: allocated : (Setof Natural)
+	       #:subscriber `(release-query-id ,(wild))
+     [`(release-query-id ,(? exact-nonnegative-integer? n))
+      (transition: (set-remove allocated n) : (Setof Natural))])))
 
+(: packet-dispatcher : UdpAddress -> (Transition (Setof ActiveRequest)))
 (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))])))
+  (transition: ((inst set ActiveRequest)) : (Setof ActiveRequest)
+    (endpoint: : (Setof ActiveRequest)
+	       #:subscriber (bad-dns-packet-pattern (wild) (wild) (wild) (wild))
+     [p (begin (log-error (pretty-format p)) '())])
+    (endpoint: old-active-requests : (Setof ActiveRequest)
+	       #:subscriber (dns-request-pattern (wild) (wild) s)
+     [(and r (dns-request m source (== s)))
+      ;; ^ We only listen for requests on our server socket
+      (let ((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 : (Setof ActiveRequest))
+	    ;; ^ ignore retransmitted duplicates
+	    (transition: (set-add old-active-requests req-id) : (Setof ActiveRequest)
+	      (spawn: #:debug-name (list 'packet-relay req-id)
+		      #:parent : (Setof ActiveRequest)
+		      #:child : Void (packet-relay req-id r)))))])
+    (endpoint: old-active-requests : (Setof ActiveRequest)
+	       #:subscriber (dns-reply-pattern (wild) s (wild))
+     [(and r (dns-reply m (== s) sink))
+      (let ((req-id (active-request sink (dns-message-id m))))
+	(transition: (set-remove old-active-requests req-id) : (Setof ActiveRequest)))])))
 
+(: packet-relay : ActiveRequest DNSRequest -> (Transition Void))
 (define (packet-relay req-id request)
   (match-define (dns-request request-message request-source request-sink) request)
+  (: answer->reply : (Option Question) (Option CompleteAnswer) -> DNSReply)
   (define (answer->reply q a)
     (define-values (response-code ns us ds)
       (match a
@@ -101,130 +113,159 @@
 	 (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))
+    (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
+     (transition/no-state
        (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
+     (transition/no-state
        (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)))]))]))
+       (endpoint: : Void
+		  #:subscriber (answered-question-pattern original-question (wild))
+		  #:let-name wait-id
+	[(answered-question (== original-question) answer)
+	 (begin (log-debug (format "Final answer to ~v with query id ~v is ~v"
+				   original-question
+				   (dns-message-id request-message)
+				   answer))
+		(list (delete-endpoint wait-id)
+		      (send-message (answer->reply original-question answer))))]))]))
 
+(: glueless-question-handler : CompiledZone Question UdpAddress -> (Transition Void))
 (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
+  (transition/no-state
+    (endpoint: : Void
+	       #:subscriber (answered-question-pattern restarted-question (wild))
+	       #:let-name relay
       [(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))))
+       (list (delete-endpoint relay)
+	     (send-message (answered-question q ans)))])
+    (spawn: #:debug-name (list 'glueless-question-handler-inner restarted-question)
+	    #:parent : Void
+	    #:child : QHState
+	    (question-handler roots-only-zone restarted-question client-sock))))
 
+(: question-dispatcher : CompiledZone CompiledZone UdpAddress -> (Transition CompiledZone))
 (define (question-dispatcher seed-zone roots-only client-sock)
+  (: transition-and-set-timers : CompiledZone (Setof (Pairof DomainName Real))
+     -> (Transition CompiledZone))
   (define (transition-and-set-timers new-zone timers)
-    (transition new-zone
-      (for/list ([timerspec timers])
+    (transition: new-zone : CompiledZone
+      (for/list: : (Listof (Action CompiledZone)) ([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)))])))
+    (endpoint: zone : CompiledZone
+	       #:subscriber `(debug-dump)
+     [`(debug-dump)
+      (begin
+	(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 (in-hash-keys zone)])
+	      (define rrmap (hash-ref zone name))
+	      (for: ([rr (in-hash-keys rrmap)])
+		(define expiry (hash-ref rrmap rr))
+		(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 : CompiledZone))])
+    (endpoint: zone : CompiledZone
+	       #:subscriber (question-pattern (wild) (wild) (wild) (wild))
+     [(? question? q)
+      (transition: zone : CompiledZone
+	(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: #:debug-name (list 'glueless-question-handler-outer q)
+		  #:parent : CompiledZone
+		  #:child : Void
+		  (glueless-question-handler roots-only q client-sock))]
+	 [else
+	  (spawn: #:debug-name (list 'question-handler q)
+		  #:parent : CompiledZone
+		  #:child : QHState
+		  (question-handler zone q client-sock))]))])
+    (endpoint: zone : CompiledZone
+	       #:subscriber (network-reply-pattern (wild) (wild))
+     [(network-reply _ answer)
+      (let-values (((new-zone timers) (incorporate-complete-answer answer zone #t)))
+	(transition-and-set-timers new-zone timers))])
+    (endpoint: zone : CompiledZone
+	       #:subscriber (timer-expired (list 'check-dns-expiry (wild)) (wild))
+     [(timer-expired (list 'check-dns-expiry (? domain? name)) (? number? now-msec))
+      (transition: (zone-expire-name zone name (/ now-msec 1000.0)) : CompiledZone)])))
 
-(struct question-state (zone q client-sock nameservers-tried retry-count) #:prefab)
-(struct expanding-cnames (q accumulator remaining-count) #:prefab)
+(struct: question-state ([zone : CompiledZone]
+			 [q : Question]
+			 [client-sock : UdpAddress]
+			 [nameservers-tried : (Setof DomainName)]
+			 [retry-count : Natural]) #:transparent)
+(define-type QuestionState question-state)
 
+(struct: expanding-cnames ([q : Question]
+			   [accumulator : CompleteAnswer]
+			   [remaining-count : Integer]) #:transparent)
+(define-type ExpandingCNAMEs expanding-cnames)
+
+(define-type QHState (U QuestionState ExpandingCNAMEs))
+
+(: question-handler : CompiledZone Question UdpAddress -> (Transition QHState))
 (define (question-handler zone q client-sock)
-  (retry-question (question-state zone q client-sock (set) 0)))
+  (retry-question (question-state zone q client-sock ((inst set DomainName)) 0)))
 
+(: send-empty-reply : QHState Question -> (Transition QHState))
 (define (send-empty-reply w q)
   (transition w (send-message (answered-question q (empty-complete-answer)))))
 
+(: retry-question : QHState -> (Transition QHState))
 (define (retry-question w)
   (match w
     [(question-state _ q _ _ 20) ;; TODO: is this a sensible limit?
@@ -242,62 +283,65 @@
 	(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))]))]
+			   (map domain-labels (set-map nameserver-rrs rr-rdata-domain-name))))
+	(transition: w : QHState
+	  ((inst network-query QHState) client-sock
+	                                q
+					zone-origin
+					(map rr-rdata-domain-name (set->list nameserver-rrs))
+					referral-id)
+	  (endpoint: w : QHState
+		     #:subscriber (network-reply-pattern referral-id (wild))
+		     #:name referral-id
+	   [(network-reply (== referral-id) #f) ;; name-error/NXDOMAIN
+	    (transition: w : QHState
+	      (delete-endpoint referral-id)
+	      (send-message (answered-question q #f)))]
+	   [(network-reply (== referral-id) ans)
+	    (let-values (((new-zone ignored-timers) (incorporate-complete-answer ans zone #f)))
+	      (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 (lambda () 'missing))
+				     k (hash-ref new-zone k (lambda () 'missing)))))
+		(log-debug "=-=-=-=-=-="))
+	      (define nameserver-names
+		(list->set
+		 (for/list: : (Listof DomainName) ([rr nameserver-rrs]) (rr-rdata-domain-name 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-endpoint referral-id)))]))]
        [(? complete-answer? ans)
-	(transition w (send-message (answered-question q ans)))]
+	(transition: w : QHState (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))])]))
+	(transition: (expanding-cnames q base (length cnames)) : QHState
+	  ((inst map (ActionTree QHState) DomainName)
+	   (lambda: ([cname : DomainName])
+	     ;; TODO: record chains of CNAMEs to avoid pathologically-long chains
+	     (define cname-q (cname-question cname q))
+	     (list (send-message cname-q)
+		   (endpoint: (expanding-cnames q acc remaining) : QHState
+			      #:subscriber (answered-question-pattern cname-q (wild))
+			      #:let-name subscription-id
+		    [(answered-question (== cname-q) ans)
+		     (let ()
+		       (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 : QHState
+			 (delete-endpoint subscription-id)
+			 (if (zero? new-remaining)
+			     (send-message (answered-question q new-acc))
+			     '())))])))
+	   cnames))])]))
 
 (require "test-rrs.rkt")
 (require racket/file)

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)]) #:transparent)
+(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)]) #:transparent)
+(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,43 +102,49 @@
 	(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 name (question-repr-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-domain-name 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
-	   (not (zone-includes-name? zone (question-name q)))) ;; there are no RRs at all for this q
+	   (in-bailiwick? (question-repr-name q) (rr-name start-of-authority))
+	   ;; ^ for this in particular
+	   (not (zone-includes-name? zone (question-repr-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>
+(: 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 +153,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))))))))

simple-udp-service.rkt

@@ -1,97 +0,0 @@
-#lang racket/base
-
-;; Simple imperative UDP server harness.
-
-(require racket/match)
-(require racket/udp)
-(require (only-in srfi/1 append-reverse))
-(require "../racket-matrix/dump-bytes.rkt")
-
-(provide (struct-out udp-packet)
-	 message-handlers
-	 start-udp-service)
-
-;; A UdpPacket is a (udp-packet Bytes String Uint16), and represents
-;; either a received UDP packet and the source of the packet, or a UDP
-;; packet ready to be sent along with the address to which it should
-;; be sent.
-(struct udp-packet (body host port) #:prefab)
-
-;; TODO: Should packet->message be permitted to examine (or possibly
-;; even transform!) the ServerState?
-
-;; A Handler is a Message ServerState -> ListOf<Message> ServerState.
-
-(define-syntax message-handlers
-  (syntax-rules ()
-    ((_ old-state-var (pattern body ...) ...)
-     (list (cons (match-lambda (pattern #t) (_ #f))
-		 (lambda (v old-state-var)
-		   (match v
-		     (pattern body ...))))
-	   ...))))
-
-;; Starts a generic request/reply UDP server on the given port.
-(define (start-udp-service
-	 port-number ;; Uint16
-	 packet->message ;; UdpPacket -> Message
-	 ;;--------------------------------------------------
-	 outbound-message? ;; Message -> Boolean
-	 message->packet ;; Message -> UdpPacket
-	 ;;--------------------------------------------------
-	 message-handlers ;; ListOf<Pair<Message -> Boolean, Handler>>
-	 default-handler ;; Handler
-	 initial-state ;; ServerState
-	 #:packet-size-limit
-	 [packet-size-limit 65536])
-  (define s (udp-open-socket #f #f)) ;; the server socket
-  (udp-bind! s #f port-number) ;; bind it to the port we were given
-
-  (set! message-handlers ;; TEMPORARY while I figure out I/O
-	(cons (cons outbound-message?
-		    (lambda (message state)
-		      (define p (message->packet message))
-		      (match-define (udp-packet body host port) p)
-		      (printf "<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~n~v~n" body)
-		      (dump-bytes! body (bytes-length body))
-		      (flush-output)
-		      (udp-send-to s host port body)
-		      (values '() state)))
-	      message-handlers))
-
-  (define (dispatch-messages messages next-messages-rev old-state)
-    (if (null? messages)
-	(check-for-io (reverse next-messages-rev) old-state)
-	(let ((message (car messages)))
-	  (define-values (new-messages new-state)
-	    (let search ((handlers message-handlers))
-	      (cond
-	       [(null? handlers) (default-handler message old-state)]
-	       [((caar handlers) message) ((cdar handlers) message old-state)]
-	       [else (search (cdr handlers))])))
-	  (dispatch-messages (cdr messages)
-			     (append-reverse new-messages next-messages-rev)
-			     new-state))))
-
-  (define (check-for-io pending-messages old-state)
-    (define buffer (make-bytes packet-size-limit))
-    (define new-messages
-      (sync (handle-evt (udp-receive!-evt s buffer)
-			(match-lambda
-			 [(list packet-length source-hostname source-port)
-			  (define packet (subbytes buffer 0 packet-length))
-			  (printf ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>~n~v~n" packet)
-			  (dump-bytes! buffer packet-length)
-			  (flush-output)
-
-			  (define packet-and-source
-			    (udp-packet packet source-hostname source-port))
-			  (define message (packet->message packet-and-source))
-			  (list message)]))
-	    (if (null? pending-messages)
-		never-evt ;; Nothing waiting to be done, don't wake up until sth external arrives
-		(handle-evt (system-idle-evt)
-			    (lambda (dummy) '())))))
-    (dispatch-messages (append new-messages pending-messages) '() old-state))
-
-  (check-for-io '() initial-state))

simplified-driver.rkt

@@ -1,156 +0,0 @@
-#lang racket/base
-
-;; DNS server using simple-udp-service.rkt.
-
-(require racket/unit)
-(require racket/match)
-(require racket/set)
-(require racket/bool)
-(require "../racket-bitsyntax/main.rkt")
-(require "api.rkt")
-(require "codec.rkt")
-(require "zonedb.rkt")
-(require "resolver.rkt")
-(require "simple-udp-service.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
-;; authoritatively. Never caches information, never performs recursive
-;; queries.
-
-;; Rules:
-
-;;  - Answers authoritative NXDOMAIN answers for queries falling within
-;;    its zone. (This is the only responder entitled to answer NXDOMAIN!)
-;;  - Answers with referrals for queries falling in subzones. It
-;;    determines subzones based on the RRs it is configured with at
-;;    startup.
-
-(struct bad-dns-packet (detail host port reason) #:prefab)
-(struct dns-request (message host port) #:prefab)
-(struct dns-reply (message host port) #:prefab)
-
-;; 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
-;; in the soa-rr given.
-(require racket/pretty)
-(define (start-server port-number soa-rr rrs)
-  ;; Compile the zone hash table
-  (define zone (compile-zone-db (cons soa-rr rrs)))
-  (pretty-print zone)
-
-  (start-udp-service
-   port-number
-   udp-packet->dns-message
-   dns-reply?
-   dns-reply->udp-packet
-   (message-handlers old-state
-		     [(? bad-dns-packet? p)
-		      (pretty-print p)
-		      (values '() old-state)]
-		     [(? dns-request? r)
-		      (values (handle-request soa-rr zone r) old-state)])
-   (lambda (unhandled state)
-     (error 'dns-server "Unhandled packet ~v" unhandled))
-   #f
-   #:packet-size-limit 512))
-
-(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))))
-    (define message (packet->dns-message body))
-    (case (dns-message-direction message)
-      ((request) (dns-request message host port))
-      ((response) (bad-dns-packet message host port 'unexpected-dns-response)))))
-
-;; TODO: dns-reply->udp-packet may fail! The server may supply some
-;; value that isn't a proper DNSMessage. In that case we might like to
-;; not send a UDP packet, but instead send out a bad-dns-packet local
-;; message for logging etc. (Glossing over the issue of identifying
-;; the direction of the message for now.)
-;;
-;; Once we move to pluggable external-event-sources/relays this will
-;; go away: they'll be handlers like anything else, that just happen
-;; to have a side effect in some containing (or if not containing, at
-;; least *in-scope*) network.
-
-(define (dns-reply->udp-packet r)
-  (match-define (dns-reply message host port) r)
-  (udp-packet (dns-message->packet message) host port))
-
-(define (first-only xs)
-  (if (null? xs)
-      xs
-      (cons (car xs) '())))
-
-(define (handle-request soa-rr zone request)
-  (match-define (dns-request request-message request-host request-port) request)
-
-  (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 (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)
-
-    (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
-  (map (lambda (q)
-	 (dns-reply (answer-question q make-reply) request-host request-port))
-       (first-only (dns-message-questions request-message))))
-
-(require "test-rrs.rkt")
-(start-server (test-port-number) test-soa-rr test-rrs)

stress.rkt

@@ -1,75 +0,0 @@
-#lang racket/base
-
-;; Simple stress-tester and performance measurement tool for DNS
-;; implementations.
-
-(require racket/udp)
-(require racket/set)
-(require "../racket-bitsyntax/main.rkt")
-(require "api.rkt")
-(require "codec.rkt")
-(require "test-rrs.rkt")
-
-(require racket/pretty)
-
-(define latencies (make-vector 200 0))
-(define latency-pos 0)
-(define (record-latency-ms! ms)
-  (vector-set! latencies latency-pos ms)
-  (set! latency-pos (modulo (+ latency-pos 1) (vector-length latencies)))
-  (when (zero? latency-pos)
-    (for-each display (list ";; Mean latency "(/ (for/fold
-						     ((sum 0))
-						     ((i latencies))
-						   (+ sum i))
-						 (vector-length latencies))"ms\n"))))
-
-(define (stress hostname port-number count rate)
-  (define s (udp-open-socket #f #f))
-
-  (define start-time (current-inexact-milliseconds))
-  (let loop ((remaining count))
-    (define request-message (dns-message (random 65536)
-					 'request
-					 'query
-					 'non-authoritative
-					 'not-truncated
-					 'recursion-desired
-					 'no-recursion-available
-					 'no-error
-					 (list (question (domain '(#"www" #"google" #"com"))
-							 'a
-							 'in
-							 #f))
-					 '()
-					 '()
-					 '()))
-
-    (define now (current-inexact-milliseconds))
-    (define sent-count (- count remaining))
-    (define delta-ms (- now start-time))
-    (define current-rate (/ sent-count (/ delta-ms 1000.0)))
-
-    (when (> current-rate rate)
-      (define target-delta-sec (/ sent-count rate))
-      (sleep (- target-delta-sec (/ delta-ms 1000))))
-
-    (when (zero? (modulo sent-count rate))
-      (for-each display (list ";; Sent "sent-count" at target "rate"Hz, actual "
-			      current-rate"Hz, in "delta-ms"ms\n")))
-
-    (when (positive? remaining)
-      (define sent-time (current-inexact-milliseconds))
-      (udp-send-to s hostname port-number (dns-message->packet request-message))
-
-      (define buffer (make-bytes 512))
-      (define-values (packet-length source-hostname source-port)
-	(udp-receive! s buffer))
-      (define received-time (current-inexact-milliseconds))
-      (define reply (packet->dns-message (sub-bit-string buffer 0 (* 8 packet-length))))
-
-      ;;(pretty-print reply)
-      (record-latency-ms! (- received-time sent-time))
-      (loop (- remaining 1)))))
-
-(stress "localhost" (test-port-number) 100000 500)

test-rrs.rkt

@@ -1,75 +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))
-	(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))

tk-dns.rkt

@@ -0,0 +1,109 @@
+#lang typed/racket/base
+;; DNS drivers using marketplace.
+
+(require racket/set)
+(require racket/match)
+(require "codec.rkt")
+(require marketplace/sugar-typed)
+(require marketplace/drivers/udp)
+(require marketplace/support/pseudo-substruct)
+
+(provide (struct-out bad-dns-packet-repr)
+	 BadDnsPacket bad-dns-packet bad-dns-packet?
+	 BadDnsPacketPattern bad-dns-packet-pattern bad-dns-packet-pattern?
+
+	 (struct-out dns-request-repr)
+	 DNSRequest dns-request dns-request?
+	 DNSRequestPattern dns-request-pattern dns-request-pattern?
+
+	 (struct-out dns-reply-repr)
+	 DNSReply dns-reply dns-reply?
+	 DNSReplyPattern dns-reply-pattern dns-reply-pattern?
+
+	 dns-read-driver
+	 dns-write-driver
+	 dns-spy)
+
+(struct: (TDetail TSource TSink TReason)
+	 bad-dns-packet-repr
+	 ([detail : TDetail] [source : TSource] [sink : TSink] [reason : TReason]) #:transparent)
+(pseudo-substruct: (bad-dns-packet-repr Any UdpAddress UdpAddress Symbol)
+		   BadDnsPacket bad-dns-packet bad-dns-packet?)
+(pseudo-substruct: (bad-dns-packet-repr Any
+					(U Wild UdpAddressPattern)
+					(U Wild UdpAddressPattern)
+					(U Wild Symbol))
+		   BadDnsPacketPattern bad-dns-packet-pattern bad-dns-packet-pattern?)
+
+(struct: (TMessage TSource TSink)
+	 dns-request-repr
+	 ([message : TMessage] [source : TSource] [sink : TSink]) #:transparent)
+(pseudo-substruct: (dns-request-repr DNSMessage UdpAddress UdpAddress)
+		   DNSRequest dns-request dns-request?)
+(pseudo-substruct: (dns-request-repr (U Wild DNSMessage)
+				     (U Wild UdpAddressPattern)
+				     (U Wild UdpAddressPattern))
+		   DNSRequestPattern dns-request-pattern dns-request-pattern?)
+
+(struct: (TMessage TSource TSink)
+	 dns-reply-repr
+	 ([message : TMessage] [source : TSource] [sink : TSink]) #:transparent)
+(pseudo-substruct: (dns-reply-repr DNSMessage UdpAddress UdpAddress)
+		   DNSReply dns-reply dns-reply?)
+(pseudo-substruct: (dns-reply-repr (U Wild DNSMessage)
+				   (U Wild UdpAddressPattern)
+				   (U Wild UdpAddressPattern))
+		   DNSReplyPattern dns-reply-pattern dns-reply-pattern?)
+
+(: dns-read-driver : UdpAddress -> (Transition Void))
+(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)))))]))))
+
+(: dns-write-driver : UdpAddress -> (Transition Void))
+(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)])))
+
+(: dns-spy : -> (Transition Void))
+(define (dns-spy)
+  (transition: (void) : Void
+    (endpoint: : Void
+	       #:subscriber (wild) #:observer
+	       [(dns-request message source sink)
+		(begin (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)
+		(begin (log-info (format "DNS: ~v answers ~v~n   : ~v"
+					 source sink
+					 message))
+		       (void))]
+	       [x
+		(begin (log-info (format "DNS: ~v" x))
+		       (void))])))

zonedb.rkt

@@ -1,86 +1,119 @@
-#lang racket/base
+#lang typed/racket/base
 
 ;; Noddy representation of a zone, and various zone and RRSet utilities.
 
 (require racket/set)
 (require racket/match)
+(require (only-in racket/math exact-floor exact-truncate))
 (require "api.rkt")
 (require "codec.rkt")
-(require "../racket-bitsyntax/main.rkt")
+(require (planet tonyg/bitsyntax))
+(require (rename-in marketplace/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
 	 zone-expire
 	 empty-zone-db
 	 compile-zone-db
-	 compiled-zone?
 	 in-bailiwick?
 	 set-filter
 	 filter-by-type
 	 filter-rrs
 	 rr-set->list
+	 rr-rdata-domain-name
 	 cname-sort ;; provided for unit tests
 	 zone->bit-string
 	 bit-string->zone)
 
+(define-type RelativeSeconds Real)
+(define-type AbsoluteSeconds Real)
+(define-predicate absolute-seconds? AbsoluteSeconds)
+
 ;; 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)
+(struct: infinite-lifetime ([ttl : RelativeSeconds]) #:transparent)
+(define-type InfiniteLifetime infinite-lifetime)
+
+;; An Expiry is either an AbsoluteSeconds or an InfiniteLifetime.
+(define-type Expiry (U AbsoluteSeconds InfiniteLifetime))
 
 ;; 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.
+(define-type CompiledZone (HashTable DomainName (HashTable RR Expiry)))
 
-;; A Timers is a SetOf<(cons DomainName AbsoluteSeconds)>,
+;; A Timers is a SetOf<(cons DomainName RelativeSeconds)>,
 ;; representing a collection of timeouts that should be set against
 ;; names to to see if their associated RRs have expired.
+(define-type Timer (Pairof DomainName RelativeSeconds))
+(define-type Timers (Setof Timer))
 
 ;; 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.
 
+(: current-inexact-seconds : -> AbsoluteSeconds)
 (define (current-inexact-seconds)
   (/ (current-inexact-milliseconds) 1000.0))
 
+(: still-valid? : Expiry AbsoluteSeconds -> Boolean)
 (define (still-valid? expiry now)
   (or (infinite-lifetime? expiry)
       (>= expiry now)))
 
-;; CompiledZone DomainName -> Maybe<Set<RR>>
+(: zone-ref : CompiledZone DomainName -> (Option (Setof 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]))
+  (define expirymap (hash-ref db name (lambda () #f)))
+  (and expirymap
+       (let ((now (current-inexact-seconds)))
+	 (for/fold: ([acc : (Setof RR) (set)])
+	     ([resource : RR (in-hash-keys expirymap)])
+	   (define expiry (hash-ref expirymap resource))
+	   (if (still-valid? expiry now)
+	       (let ((new-ttl (if (infinite-lifetime? expiry)
+				  (infinite-lifetime-ttl expiry)
+				  (- expiry now))))
+		 (set-add acc
+			  (struct-copy rr resource
+			    [ttl (cast (exact-floor new-ttl) Nonnegative-Integer)])))
+	       acc)))))
 
-;; CompiledZone DomainName -> Boolean
+(: zone-includes-name? : CompiledZone DomainName -> Boolean)
 (define (zone-includes-name? db name)
   (hash-has-key? db name))
 
-;; incorporate-rr : Maybe<AbsoluteSeconds> -> (RR CompiledZone -> CompiledZone)
-;;
+(: incorporate-rr : (Option 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))
+		     (if (zero? (rr-ttl resource0))
+			 ;; We are definitely not caching this
+			 ;; resource then, because we are not even
+			 ;; called by incorporate-complete-answer in
+			 ;; case of 0-TTL and the cache. This record
+			 ;; is transient and used just for the current
+			 ;; resolution. Storing it with a real 0-TTL
+			 ;; would mean it immediately is ignored,
+			 ;; which is silly, so store it with an
+			 ;; infinite-lifetime instead.
+			 (infinite-lifetime 0)
+			 ;; Otherwise it has a normal TTL, which we
+			 ;; honour.
+			 (+ 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))
+  (define old-expirymap (hash-ref db name (lambda () (ann #hash() (HashTable rr Expiry)))))
+  (define old-expiry (hash-ref old-expirymap resource (lambda () 0)))
   (cond
    [(infinite-lifetime? old-expiry) ;; don't update TTL: the existing record should live forever
     db]
@@ -89,100 +122,108 @@
    [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)
+(: incorporate-complete-answer :
+   (Option CompleteAnswer) CompiledZone Boolean -> (Values CompiledZone Timers))
+(define (incorporate-complete-answer ans db is-cache?)
   (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)))))]))
+     (for/fold ([db db] [timers ((inst set Timer))])
+	 ([rr (in-list (append (set->list ns)
+			       (set->list us)
+			       (set->list ds)))]) ;; no in-sequences in typed racket
+       (if (and is-cache? (zero? (rr-ttl rr))) ;; Do not *cache* 0-TTL RRs (RFC 1034 3.6)
+	   (values db timers)
+	   (values ((incorporate-rr now) rr db)
+		   (set-add timers (cons (rr-name rr) (rr-ttl rr))))))]))
 
-;; CompiledZone DomainName -> CompiledZone
+(: zone-expire-name : CompiledZone DomainName AbsoluteSeconds -> 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 empty-expirymap (ann #hash() (HashTable RR Expiry)))
+  (define old-expirymap (hash-ref db name (lambda () empty-expirymap)))
   (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)))
+    (for/fold: ([acc : (HashTable RR Expiry) empty-expirymap])
+	([resource : RR (in-hash-keys old-expirymap)])
+      (define expiry (hash-ref old-expirymap resource))
+      (if (still-valid? expiry now-seconds)
+	  (hash-set acc resource expiry)
+	  acc)))
   (if (zero? (hash-count new-expirymap))
       (hash-remove db name)
       (hash-set db name new-expirymap)))
 
-;; CompiledZone -> (values CompiledZone Timers)
+(: zone-expire : 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)])
+  (for/fold: ([zone : CompiledZone zone] [timers : Timers (set)])
+      ([name : DomainName (in-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
+    (define expirymap (hash-ref new-zone name (lambda () #f)))
+    (values new-zone
+	    (if expirymap
 		(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)])))
+			    (map (lambda: ([e : AbsoluteSeconds]) (cons name (- e now-seconds)))
+				 (filter absolute-seconds? (hash-values expirymap))))
+			   timers)
+		timers))))
 
-;; empty-zone-db : -> CompiledZone
+(: empty-zone-db : -> CompiledZone)
 (define (empty-zone-db)
   (make-immutable-hash))
 
-;; compile-zone-db : ListOf<RR> -> CompiledZone
+(: 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))
 
-(define (compiled-zone? z)
-  (hash? z)) ;; hm
-
-;; in-bailiwick? : DomainName DomainName -> Boolean
+(: in-bailiwick? : DomainName DomainName -> Boolean)
 ;; Answers #t iff dn falls within the bailiwick of the zone with
 ;; origin o.
 (define (in-bailiwick? dn o)
-  (cond
-   ((equal? dn o) #t)
-   ((domain-root? dn) #f)
-   (else (in-bailiwick? (domain-parent dn) o))))
+  (or (equal? dn o)
+      (let ((p (domain-parent dn)))
+	(and p (in-bailiwick? p o)))))
 
-;; set-filter : (X -> Boolean) SetOf<X> -> SetOf<X>
+(: set-filter : (All (X) (X -> Boolean) (Setof X) -> (Setof X)))
 ;; Retains only those elements of its argument for which the predicate
 ;; answers #t.
 (define (set-filter predicate in)
-  (for/set ([x (in-set in)]
-	    #:when (predicate x))
-	   x))
+  (for/fold: ([acc : (Setof X) (set)]) ([x : X (in-list (set->list in))])
+    (if (predicate x) (set-add acc x) acc)))
 
-;; filter-by-type : SetOf<RR> RRType -> SetOf<RR>
+(: filter-by-type : (Setof RR) RRType -> (Setof RR))
 ;; Selects only those members of rrset having rr-type type.
 (define (filter-by-type rrset type)
-  (set-filter (lambda (rr) (eqv? (rr-type rr) type)) rrset))
+  (define p? (rdata-type-pred type))
+  (set-filter (lambda: ([rr : RR]) (p? (rr-rdata rr))) rrset))
 
-;; filter-rrs : SetOf<RR> QueryType QueryClass -> SetOf<RR>
+(: no-rrs : (Setof RR))
+(define no-rrs (set))
+
+(: filter-rrs : (Setof RR) QueryType QueryClass -> (Setof RR))
 ;; Returns a set like its argument with RRs not matching the given
 ;; type and class removed.
 (define (filter-rrs rrs qtype qclass)
   (define filtered-by-type
-    (case qtype
-      ((*) rrs)
-      (else (filter-by-type rrs qtype))))
+    (cond
+     ((eq? qtype '*) rrs)
+     ((eq? qtype 'axfr) no-rrs) ;; TODO: warn? error? AXFR is not currently supported.
+     ((eq? qtype 'mailb) no-rrs) ;; TODO: warn? error? MAILB is not currently supported.
+     ((eq? qtype 'maila) no-rrs) ;; TODO: warn? error? MAILA is not currently supported.
+     (else (filter-by-type rrs qtype))))
   (define filtered-by-type-and-class
     (case qclass
       ((*) filtered-by-type)
-      (else (set-filter (lambda (rr) (eqv? (rr-class rr) qclass)) filtered-by-type))))
+      (else (set-filter (lambda: ([rr : RR]) (eqv? (rr-class rr) qclass)) filtered-by-type))))
   filtered-by-type-and-class)
 
-;; rr-set->list : SetOf<RR> -> ListOf<RR>
+(: 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?
 ;;
@@ -202,47 +243,55 @@
 ;; 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)))
-	  (set->list (set-filter (lambda (rr) (not (eqv? (rr-type rr) 'cname))) rrs))))
+  (define cnames (filter-by-type rrs 'cname))
+  (append (cname-sort (set->list cnames))
+	  (set->list (set-subtract rrs cnames))))
 
-;; cname-sort : ListOf<RR<CNAME>> -> ListOf<RR<CNAME>>
+(: 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))
 ;; 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 rhss (list->set (map rr-rdata-domain-name 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 '()))
+  (: targets-of : DomainName -> (Listof RR))
+  (define (targets-of name) (filter (lambda: ([rr : RR]) (equal? (rr-name rr) name)) cnames))
+  (let: iterate ((remaining : (Listof DomainName) roots)
+		 (seen : (Setof DomainName) (set))
+		 (acc : (Listof RR) '()))
     (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)))
+		     (targets (map rr-rdata-domain-name rrs)))
 		(iterate (append targets (cdr remaining))
 			 (set-add seen source)
 			 (append rrs acc))))))))
 
-;; CompiledZone -> Bitstring
+(: zone->bit-string : 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))]))))
+  (for/fold: ([acc : BitString (bit-string)]) ([name : DomainName (in-hash-keys zone)])
+    (define rrmap (hash-ref zone name))
+    (for/fold: ([acc : BitString acc]) ([rr : RR (in-hash-keys rrmap)])
+      (define expiry (hash-ref rrmap rr))
+      (bit-string-append
+       acc
+       (cond
+	[(infinite-lifetime? expiry)
+	 (bit-string (rr :: (t:rr)) 1 ((exact-truncate (infinite-lifetime-ttl expiry)) :: bits 32))]
+	[else
+	 (bit-string (rr :: (t:rr)) 0 ((exact-truncate expiry) :: bits 32))])))))
 
-;; Bitstring -> CompiledZone
+(: bit-string->zone : 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))
@@ -255,4 +304,7 @@
       ([ (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)))))
+       (define new-ttl (exact-floor (- expirytime now)))
+       (if (negative? new-ttl)
+	   (loop db rest)
+	   (loop ((incorporate-rr now) (struct-copy rr rr0 [ttl new-ttl]) db) rest))))))