#:prefab -> #:transparent

.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 typed-matrix's struct-map
+;; See also Racket PR 13593.
+
+(require racket-typed-matrix/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)
+	 RData
-	 (struct-out minfo)
+	 (struct-out rdata)
-	 (struct-out mx)
+	 (struct-out rdata-domain)
-	 (struct-out soa)
+	 (struct-out rdata-ipv4)
-	 (struct-out wks)
+	 (struct-out rdata-ipv6)
-	 (struct-out srv)
+	 (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)
-
+(require racket-typed-matrix)
-;; (These utilities need to be defined ahead of the domain struct
+(require racket-typed-matrix/struct-map)
-;; definition.)
+(require racket-typed-matrix/support/pseudo-substruct)
-(define (domain=? a b recursive-equal?)
-  (recursive-equal? (domain-downcased-labels a)
-		    (domain-downcased-labels b)))
-
-(define (domain-hash-1/2 d recursive-hash)
-  (recursive-hash (domain-downcased-labels d)))
 
 ;; A DomainName is a (domain ListOf<Bytes>), representing a domain
 ;; name. The head of the list is the leftmost label; for example,
 ;; www.google.com is represented as '(#"www" #"google" #"com").
-(struct domain (labels downcased-labels)
+(require/typed "api-untyped.rkt"
-	#:transparent
+	       [#:struct domain ([labels : (Listof Bytes)]
-	#:property prop:equal+hash (list domain=? domain-hash-1/2 domain-hash-1/2))
+				 [downcased-labels : (Listof Bytes)])])
-
+(define-type DomainName domain)
-(require "../racket-matrix/struct-map.rkt")
-(install-struct-mapper! struct:domain
-			(lambda (f seed x)
-			  (let-values (((labels seed) (f (domain-labels x) seed)))
-			    (values (make-domain labels) seed))))
 
 ;; A 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: subquestion ([parent : Question]) #:transparent)
-(struct cname-subq subquestion () #:prefab)
+(struct: cname-subq subquestion () #:transparent)
-(struct ns-subq subquestion () #:prefab)
+(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: rdata ([type : RRType]) #:transparent)
-(struct minfo (rmailbx emailbx) #:prefab)
+(struct: rdata-domain rdata ([name : DomainName]) #:transparent)
-(struct mx (preference exchange) #:prefab)
+(struct: rdata-ipv4 rdata ([address : IPv4]) #:transparent)
-(struct soa (mname rname serial refresh retry expire minimum) #:prefab)
+(struct: rdata-ipv6 rdata ([address : IPv6]) #:transparent)
-(struct wks (address protocol bitmap) #:prefab)
+(struct: rdata-hinfo rdata ([cpu : Bytes] [os : Bytes]) #:transparent)
-(struct srv (priority weight port target) #:prefab)
+(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))
+		(ips ((inst set IPv4)))
-		(seen (set)))
+		(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))
+		 (let ((a-data (filter rdata-ipv4? (filter (rdata-type-pred 'a) data)))
-		       (cname-records (filter (lambda (rr) (equal? 'cname (rr-type rr))) records)))
+		       (cname-data (filter rdata-domain? (filter (rdata-type-pred 'cname) data))))
-		   (loop (append (map rr-rdata cname-records) (cdr names))
+		   (loop (append (map rdata-domain-name cname-data) (cdr names))
-			 (set-union ips (list->set (map rr-rdata a-records)))
+			 (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 racket-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
+(struct: dns-message ([id : Nonnegative-Integer]
-		     direction
+		      [direction : Direction]
-		     opcode
+		      [opcode : Opcode]
-		     authoritative
+		      [authoritative : Authoritativeness]
-		     truncated
+		      [truncated : Truncatedness]
-		     recursion-desired
+		      [recursion-desired : RecursionDesired]
-		     recursion-available
+		      [recursion-available : RecursionAvailable]
-		     response-code
+		      [response-code : ResponseCode]
-		     questions
+		      [questions : (Listof Question)]
-		     answers
+		      [answers : (Listof RR)]
-		     authorities
+		      [authorities : (Listof RR)]
-		     additional)
+		      [additional : (Listof RR)])
-	#:prefab)
+	 #: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-case input ([ len (vals :: (t:ntimes Integer len bits 32)) ] vals))
-;;   (bit-string (vals :: (t:ntimes bits 32)))
+;;   (bit-string (vals :: (t:ntimes Integer bits 32)))
 (define-syntax t:ntimes
   (syntax-rules ()
-    ((_ #t times-to-repeat option ...)
+    ((_ #t input0 ks kf Type times-to-repeat option ...)
-     (lambda (input ks kf)
+     (let ()
-       (let loop ((count times-to-repeat)
+       ;; A simple loop without multiple-values or #f is much cleaner
-		  (acc '())
+       ;; here, but I can't find a way of expressing the types
-		  (input input))
+       ;; 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
-	  (else (ks (reverse acc) input))))))
+				(values #f input))))
-    ((_ #f option ...)
+	  (else (values (reverse acc) input))))
-     (t:listof #f option ...))))
+       (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-case input ([ (vals :: (t:listof Integer bits 32)) ] vals))
-;;   (bit-string (vals :: (t:listof bits 32)))
+;;   (bit-string (vals :: (t:listof Integer bits 32)))
 (define-syntax t:listof
   (syntax-rules ()
-    ((_ #t option ...)
+    ((_ #t input0 ks kf Type option ...)
-     (lambda (input ks kf)
+     ;; The loop is unrolled once here to let Typed Racket propagate
-       (let loop ((acc '())
+     ;; the type of v0 into the type of acc in the loop. When not
-		  (input input))
+     ;; unrolled, it gives acc type (Listof Any).
-	 (bit-string-case input
+     ;; TODO: come up with some other way of doing this that avoids the duplication.
-	   ([ (v :: option ...) (rest :: binary) ]
+     (bit-string-case input0
-	    (loop (cons v acc) rest))
+       ([ (v0 :: option ...) (input1 :: binary) ]
-	   ([]
+	(let loop ((acc (list v0))
-	    (ks (reverse acc) #""))
+		   (input input1))
-	   (else
+	  (bit-string-case input
-	    (kf))))))
+	    ([ (v :: option ...) (rest :: binary) ]
-    ((_ #f option ...)
+	     (loop (cons v acc) rest))
-     (lambda (vs)
+	    ([]
-       (let loop ((vs vs))
+	     (ks (reverse acc) #""))
-	 (cond
+	    (else
-	  ((pair? vs) (bit-string ((car vs) :: option ...)
+	     (kf)))))
-				  ((loop (cdr vs)) :: binary)))
+       ([]
-	  (else (bit-string))))))))
+	(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)))
+       (q-section :: (t:ntimes Question qdcount (t:question packet)))
-       (a-section :: (t:ntimes ancount (t:rr packet)))
+       (a-section :: (t:ntimes RR ancount (t:rr packet)))
-       (auth-section :: (t:ntimes nscount (t:rr packet)))
+       (auth-section :: (t:ntimes RR nscount (t:rr packet)))
-       (additional-section :: (t:ntimes arcount (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-questions m) :: (t:ntimes Question (t:question)))
-	       ((dns-message-answers m) :: (t:ntimes (t:rr)))
+	       ((dns-message-answers m) :: (t:ntimes RR (t:rr)))
-	       ((dns-message-authorities m) :: (t:ntimes (t:rr)))
+	       ((dns-message-authorities m) :: (t:ntimes RR (t:rr)))
-	       ((dns-message-additional m) :: (t:ntimes (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)
+    ((_ #t input ks kf name0 name1)
-			  (bit-string-case input
+     (bit-string-case input
-			    ([ (v :: bits 1) (rest :: binary) ]
+       ([ (v :: bits 1) (rest :: binary) ]
-			     (ks (if (zero? v) name0 name1) rest))
+	(ks (if (zero? v) name0 name1) rest))
-			    (else (kf)))))
+       (else (kf))))
-    ((_ #f name0 name1) (lambda (v)
+    ((_ #f v name0 name1)
-			  (cond
+     (cond
-			   ((eq? v name1) (bit-string (1 :: bits 1)))
+      ((eq? v name1) (bit-string (1 :: bits 1)))
-			   ((eq? v name0) (bit-string (0 :: bits 1)))
+      ((eq? v name0) (bit-string (0 :: bits 1)))
-			   (else (error 't:named-bit
+      (else (error 't:named-bit
-					"Value supplied is neither ~v nor ~v: ~v"
+		   "Value supplied is neither ~v nor ~v: ~v"
-					name0 name1 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)
+    ((_ #t input ks kf whole-packet)
-     (lambda (input ks kf)
+     (let-values (((name rest) (parse-domain-name whole-packet input '())))
-       (let-values (((name rest) (parse-domain-name whole-packet input '())))
+       (ks (domain name) rest)))
-	 (ks (domain name) rest))))
+    ((_ #f val)
-    ((_ #f)
+     (encode-domain-name val))))
-     encode-domain-name)))
 
-;; 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)
+    ((_ #t input ks kf)
-     (lambda (input ks kf)
+     (bit-string-case input
-       (bit-string-case input
+       ([ len (body :: binary bytes len) (rest :: binary) ]
-	 ([ len (body :: binary bytes len) (rest :: binary) ]
+	(ks (bit-string->bytes body) rest))
-	  (ks (bit-string->bytes body) rest))
+       (else (kf))))
-	 (else (kf)))))
+    ((_ #f val)
-    ((_ #f)
+     (t:pascal-string #f val "Character-string" 256))
-     (t:pascal-string #f "Character-string" 256))
+    ((_ #f val string-kind length-limit)
-    ((_ #f string-kind length-limit)
+     (let: ([s : Bytes val])
-     (lambda (s)
        (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)
+    ((_ #t input ks kf whole-packet)
-     (lambda (input ks kf)
+     (bit-string-case input
-       (bit-string-case input
+       ([ (qname :: (t:domain-name whole-packet))
-	 ([ (qname :: (t:domain-name whole-packet))
+	  (qtype :: bits 16)
-	    (qtype :: bits 16)
+	  (qclass :: bits 16)
-	    (qclass :: bits 16)
+	  (tail :: binary) ]
-	    (tail :: binary) ]
+	(ks (question qname
-	  (ks (question qname
+		      (value->qtype qtype)
-			(value->qtype qtype)
+		      (value->qclass qclass)
-			(value->qclass qclass)
+		      #f)
-			#f)
+	    tail))))
-	      tail)))))
+    ((_ #f val)
-    ((_ #f)
+     (let: ([q : Question val])
-     (lambda (q)
+       (bit-string ((question-repr-name q) :: (t:domain-name))
-       (bit-string ((question-name q) :: (t:domain-name))
+		   ((qtype->value (question-repr-type q)) :: bits 16)
-		   ((qtype->value (question-type q)) :: bits 16)
+		   ((qclass->value (question-repr-class q)) :: bits 16))))))
-		   ((qclass->value (question-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)
+    ((_ #t input ks kf whole-packet0)
-     (lambda (input ks kf)
+     (let ((whole-packet whole-packet0))
-       (decode-rr whole-packet input ks kf)))
+       (bit-string-case input
-    ((_ #f)
+	 ([ (name :: (t:domain-name whole-packet))
-     encode-rr)))
+	    (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
+(: decode-rdata : BitString RRType BitString -> RData)
-;; 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 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))))
+	     (rdata-mx type preference exchange))))
-    ((null) (bit-string->bytes rdata))
+    ((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 :: (t:listof Bytes (t:pascal-string))) ]
-	      strs)))
+	      (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) ]
+	      ([ a b c d e f g h i j k l m n o p ]
-	       (list->vector (bytes->list (bit-string->bytes ipv6-addr))))))
+	       (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))))
+	      (rdata-srv type priority weight port target))))
-    (else (bit-string->bytes rdata))))
+    (else (rdata-raw type (bit-string->bytes rdata)))))
 
-;; RRType RData -> Bitstring
+(: encode-rdata : RData -> BitString)
-;; Encode RData according to the RRType.
+;; Encode RData according to its RRType.
-(define (encode-rdata type rdata)
+(define (encode-rdata rdata)
-  (case type
+  (match rdata
-    ((cname mb md mf mg mr ns ptr) (encode-domain-name rdata))
+    [(rdata-domain _ name) (encode-domain-name name)]
-    ((hinfo) (bit-string ((hinfo-cpu rdata) :: (t:pascal-string))
+    [(rdata-hinfo _ cpu os) (bit-string (cpu :: (t:pascal-string))
-			 ((hinfo-os rdata) :: (t:pascal-string))))
+					(os :: (t:pascal-string)))]
-    ((minfo) (bit-string ((minfo-rmailbx rdata) :: (t:domain-name))
+    [(rdata-minfo _ rmailbx emailbx) (bit-string (rmailbx :: (t:domain-name))
-			 ((minfo-emailbx rdata) :: (t:domain-name))))
+						 (emailbx :: (t:domain-name)))]
-    ((mx) (bit-string ((mx-preference rdata) :: bits 16)
+    [(rdata-mx _ preference exchange) (bit-string (preference :: bits 16)
-		      ((mx-exchange rdata) :: (t:domain-name))))
+						  (exchange :: (t:domain-name)))]
-    ((null) rdata)
+    [(rdata-soa _ mname rname serial refresh retry expire minimum)
-    ((soa) (bit-string ((soa-mname rdata) :: (t:domain-name))
+     (bit-string (mname :: (t:domain-name))
-		       ((soa-rname rdata) :: (t:domain-name))
+		 (rname :: (t:domain-name))
-		       ((soa-serial rdata) :: bits 32)
+		 (serial :: bits 32)
-		       ((soa-refresh rdata) :: bits 32)
+		 (refresh :: bits 32)
-		       ((soa-retry rdata) :: bits 32)
+		 (retry :: bits 32)
-		       ((soa-expire rdata) :: bits 32)
+		 (expire :: bits 32)
-		       ((soa-minimum rdata) :: bits 32)))
+		 (minimum :: bits 32))]
-    ((txt) (bit-string (rdata :: (t:listof (t:pascal-string)))))
+    [(rdata-txt _ strings) (bit-string (strings :: (t:listof Bytes (t:pascal-string))))]
-    ((a) (match rdata ((vector a b c d) (bit-string a b c d))))
+    [(rdata-ipv4 _ (vector a b c d)) (bit-string a b c d)]
-    ((aaaa) (bit-string ((list->bytes (vector->list rdata)) :: binary bits 128)))
+    [(rdata-ipv6 _ aaaa) (bit-string ((list->bytes (vector->list aaaa)) :: binary bits 128))]
-    ((wks) (match (wks-address rdata)
+    [(rdata-wks _ (vector a b c d) protocol bitmap)
-	     ((vector a b c d)
+     (bit-string a b c d protocol (bitmap :: binary))]
-	      (bit-string a b c d (wks-protocol rdata) ((wks-bitmap rdata) :: binary)))))
+    [(rdata-srv _ priority weight port target)
-    ((srv) (bit-string ((srv-priority rdata) :: bits 16)
+     (bit-string (priority :: bits 16)
-		       ((srv-weight rdata) :: bits 16)
+		 (weight :: bits 16)
-		       ((srv-port rdata) :: bits 16)
+		 (port :: bits 16)
-		       ((srv-target rdata) :: (t:domain-name))))
+		 (target :: (t:domain-name)))]
-    (else rdata)))
+    [(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 racket-bitsyntax)
 (require "api.rkt")
 (require "codec.rkt")
 (require "zonedb.rkt")
 (require "resolver.rkt")
-(require "../racket-matrix/os2.rkt")
+(require racket-typed-matrix/sugar-typed)
-(require "../racket-matrix/os2-udp.rkt")
+(require racket-typed-matrix/support/spy)
-(require "os2-dns.rkt")
+(require racket-typed-matrix/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
+  (ground-vm: ((inst udp-driver Void))
-   (transition 'no-state
+	      ((inst generic-spy Void) 'UDP)
-     ;; (spawn udp-spy #:debug-name 'udp-spy)
+	      (nested-vm: : Void
-     (spawn udp-driver #:debug-name 'udp-driver)
+	       (spawn: #:parent : Void #:child : Void (dns-spy))
-     (spawn (nested-vm #:debug-name 'dns-vm
+	       (spawn: #:parent : Void #:child : Void (dns-read-driver local-addr))
-	     (transition 'no-state
+	       (spawn: #:parent : Void #:child : Void (dns-write-driver local-addr))
-	       (spawn dns-spy #:debug-name 'dns-spy)
+	       (endpoint: : Void #:subscriber (bad-dns-packet (wild) (wild) (wild) (wild))
-	       (spawn (dns-read-driver local-addr) #:debug-name 'dns-read-driver)
+	       		  [p (begin (log-error (pretty-format p))
-	       (spawn (dns-write-driver local-addr) #:debug-name 'dns-write-driver)
+	       			    '())])
-	       (role (topic-subscriber (bad-dns-packet (wild) (wild) (wild) (wild)))
+	       (endpoint: : Void #:subscriber (dns-request (wild) (wild) (wild))
-		 [p (begin (log-error (pretty-format p))
+	       		  [(? dns-request? r)
-			   '())])
+			   (begin (define reply (handle-request soa-rr zone r))
-	       (role (topic-subscriber (dns-request (wild) (wild) (wild)))
+				  (when reply (send-message reply)))]))))
-		 [r (map send-message (handle-request soa-rr zone r))])))
-	    #:debug-name 'dns-vm))))
 
+(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?)
+	[(? complete-answer? c)
-	 (expand-cnames worklist
+	 (expand-cnames worklist (merge-answers c ans))]
-			(merge-answers this-answer 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)

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
+	 (cond
-	   ((lhs) 'rhs) ...
+	  ((eqv? l 'lhs) 'rhs) ...
-	   (else (fd l))))
+	  (else (fd l))))
        (define (bn r)
-	 (case r
+	 (cond
-	   ((rhs) 'lhs) ...
+	  ((eqv? r 'rhs) 'lhs) ...
-	   (else (bd r))))))))
+	  (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-typed-matrix/sugar-typed)
-(require "../racket-matrix/os2-udp.rkt")
+(require racket-typed-matrix/drivers/udp)
-(require "../racket-matrix/os2-timer.rkt")
+(require racket-typed-matrix/drivers/timer)
-(require "os2-dns.rkt")
+(require racket-typed-matrix/support/pseudo-substruct)
+(require "tk-dns.rkt")
+(require (rename-in racket-typed-matrix/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
+(struct: network-request ([client-socket : UdpAddress]
-			 question
+			  [question : Question]
-			 zone-origin
+			  [zone-origin : DomainName]
-			 server-names
+			  [server-names : (Listof DomainName)]
-			 unique-id)
+			  [unique-id : Any])
-	#:prefab)
+	 #: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
+(struct: network-query-state ([request : NetworkRequest]
-			     timeout
+			      [timeout : (Option Natural)]
-			     known-addresses
+			      [known-addresses : (HashTable DomainName (Listof UdpAddress))]
-			     remaining-addresses
+			      [remaining-addresses : (Listof UdpAddress)]
-			     current-name
+			      [current-name : (Option DomainName)]
-			     remaining-names)
+			      [remaining-names : (Listof DomainName)])
-	#:prefab)
+	 #:transparent)
+(define-type NetworkQueryState network-query-state)
 
-;; seconds -> Maybe<seconds>
+(: next-timeout : Natural -> (Option Natural))
 (define (next-timeout timeout)
-  (case timeout
+  (cond
-    ((3) 11)
+   [(equal? timeout 3) 11]
-    ((11) 45)
+   [(equal? timeout 11) 45]
-    ((45) #f)))
+   [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
+(define-type CheckedAnswer (U (Option CompleteAnswer) 'bad-answer 'lame-delegation))
-;;   -> (or Maybe<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)
+       (filter (lambda: ([rr : RR]) (and (eqv? (rdata-type (rr-rdata rr)) 'ns)
-				 (or (equal? (rr-name rr) zone-origin)
+					 (or (equal? (rr-name rr) zone-origin)
-				     (not (in-bailiwick? (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)
+  (spawn: #:debug-name (list 'network-query q)
-    (try-next-server (network-query-state (network-request s q zone-origin server-names unique-id)
+	  #:parent : ParentState
-					  first-timeout
+	  #:child : NetworkQueryState
-					  (hash)
+	  (try-next-server
-					  '()
+	   (network-query-state (network-request s q zone-origin server-names unique-id)
-					  #f
+				first-timeout
-					  server-names))))
+				(ann #hash() (HashTable DomainName (Listof UdpAddress)))
+				'()
+				#f
+				server-names))))
 
+(: try-next-server : NetworkQueryState -> (Transition NetworkQueryState))
 (define (try-next-server w)
-  (match w
+  (define timeout (network-query-state-timeout w))
-    [(network-query-state _ #f _ _ _ _)
+  (if (not timeout)
-     ;; No more timeouts to try, so give up.
+      ;; No more timeouts to try, so give up.
-     (on-answer w (empty-complete-answer) #f)]
+      (on-answer w (empty-complete-answer) #f)
-    [(network-query-state req timeout _ '() _ '())
+      (match w
-     ;; No more addresses to try with this timeout. Refill the list
+	[(network-query-state req _ _ '() _ '())
-     ;; and bump the timeout and retry.
+	 ;; No more addresses to try with this timeout. Refill the list
-     ;; TODO: randomize ordering of servers in list. (Don't forget the initial fill.)
+	 ;; and bump the timeout and retry.
-     (try-next-server (struct-copy network-query-state w
+	 ;; TODO: randomize ordering of servers in list. (Don't forget the initial fill.)
-				   [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
+			    [timeout (next-timeout timeout)]
-								      current-name)]
+			    [remaining-addresses '()]
-				       [current-name current-name]
+			    [current-name #f]
-				       [remaining-names remaining-names]))
+			    [remaining-names (network-request-server-names req)]))]
-	 (let ((subq (ns-question current-name (network-request-question req))))
+	[(network-query-state req _ known-addresses '() _ (cons current-name remaining-names))
-	   (transition (struct-copy network-query-state w
+	 (if (hash-has-key? known-addresses current-name)
-				    [current-name current-name]
+	     (try-next-server (struct-copy network-query-state w
-				    [remaining-names remaining-names])
+				[remaining-addresses (hash-ref known-addresses current-name)]
-	     (send-message subq)
+				[current-name current-name]
-	     (role/fresh subq-id (topic-subscriber (answered-question subq (wild)))
+				[remaining-names remaining-names]))
-	       #:state w
+	     (let ((subq (ns-question current-name (network-request-question req))))
-	       [(answered-question (== subq) ans)
+	       (transition: (struct-copy network-query-state w
-		(define ips
+			      [current-name current-name]
-		  (map make-dns-address (set->list (extract-addresses current-name ans))))
+			      [remaining-names remaining-names]) : NetworkQueryState
-		(sequence-actions
+		 (send-message subq)
-		    (try-next-server (struct-copy network-query-state w
+		 (endpoint: w : NetworkQueryState
-						  [known-addresses (hash-set known-addresses
+		   #:subscriber (answered-question subq (wild))
-									     current-name
+		   #:let-name subq-id
-									     ips)]
+		   [(answered-question (== subq) ans)
-						  [remaining-addresses ips]))
+		    (let ((ips (map make-dns-address
-		  (delete-role subq-id))]))))]
+				    (set->list (extract-addresses current-name ans)))))
-    [(network-query-state req timeout _ (cons current-ip remaining-ips) _ _)
+		      (sequence-actions
-     (define rpc-id (gensym 'network-query/allocate-query-id))
+		       (try-next-server (struct-copy network-query-state w
-     (transition w
+					  [known-addresses (hash-set known-addresses
-       (send-message `(request ,rpc-id allocate-query-id))
+								     current-name
-       (role (topic-subscriber `(reply ,rpc-id ,(wild)))
+								     ips)]
-	 #:name rpc-id
+					  [remaining-addresses ips]))
-	 #:state w
+		       (delete-endpoint subq-id)))]))))]
-	 [`(reply ,(== rpc-id) ,id)
+	[(network-query-state req _ _ (cons current-ip remaining-ips) _ _)
-	  (sequence-actions (send-request (struct-copy network-query-state w
+	 (define rpc-id (gensym 'network-query/allocate-query-id))
-						       [remaining-addresses remaining-ips])
+	 (transition: w : NetworkQueryState
-					  id
+	   (send-message `(request ,rpc-id allocate-query-id))
-					  timeout
+	   (endpoint: w : NetworkQueryState
-					  current-ip)
+	     #:subscriber `(reply ,rpc-id ,(wild))
-	    (delete-role rpc-id))]))]))
+	     #: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 (if (and current-name server-ip)
-     (try-next-server (struct-copy network-query-state w
+			  ;; Actually remove the offending IP address so it's never tried again.
-				   [known-addresses (hash-update known-addresses
+			  (struct-copy network-query-state w
-								 current-name
+			    [known-addresses (hash-update known-addresses
-								 (lambda (addrs)
+							  current-name
-								   (remove server-ip addrs)))]))]
+							  (lambda: ([addrs : (Listof
-    [else
+									      UdpAddress)])
-     (transition w
+							    (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))
+    (send-message (set-timer timeout-id (* timeout 1000) 'relative))
-    (role (set (topic-subscriber (timer-expired subscription-id (wild)))
+    ;; TODO: Restore this to a "join" when proper pattern-unions are implemented
-	       (topic-subscriber (dns-reply (wild) (wild) s)))
+    (endpoint: w : NetworkQueryState
-      #:name subscription-id
+	       #:subscriber (timer-expired timeout-id (wild))
-      #:state w
+	       #:name timeout-id
-      [(timer-expired (== subscription-id) _)
+     [(timer-expired (== timeout-id) _)
-       (log-debug (format "Timed out ~v ~v to ~v ~v after ~v seconds"
+      (begin
-			  q query-id
+	(log-debug (format "Timed out ~v ~v to ~v ~v after ~v seconds"
-			  zone-origin server-ip
+			   q query-id
-			  timeout))
+			   zone-origin server-ip
-       (sequence-actions (try-next-server w)
+			   timeout))
-	 (delete-role subscription-id)
+	(sequence-actions (try-next-server w)
-	 (send-message (list 'release-query-id query-id)))]
+			  (delete-endpoint timeout-id)
-      [(dns-reply reply-message source (== s))
+			  (delete-endpoint reply-wait-id)
-       ;; TODO: maybe receive only specifically from the queried IP address?
+			  (send-message (list 'release-query-id query-id))))])
-       (log-debug
+    (endpoint: w : NetworkQueryState
-	(format
+	       #:subscriber (dns-reply (wild) (wild) s)
-	 "Answer to ~v from ~v ~v in ~v ms~n-- Answers: ~v~n-- Authorities: ~v~n-- Additional: ~v"
+	       #:name reply-wait-id
-	 q zone-origin server-ip
+     [(dns-reply reply-message source (== s))
-	 (inexact->exact (round (- (current-inexact-milliseconds) start-time)))
+      ;; TODO: maybe receive only specifically from the queried IP address?
-	 (dns-message-answers reply-message)
+      (begin
-	 (dns-message-authorities reply-message)
+	(log-debug
-	 (dns-message-additional reply-message)))
+	 (format
-       (if (not (= (dns-message-id reply-message) (dns-message-id query)))
+	  "Answer to ~v from ~v ~v in ~v ms~n-- Answers: ~v~n-- Authorities: ~v~n-- Additional: ~v"
-	   (transition w)
+	  q zone-origin server-ip
-	   (sequence-actions (on-answer w
+	  (inexact->exact (round (- (current-inexact-milliseconds) start-time)))
-					(filter-dns-reply q reply-message zone-origin)
+	  (dns-message-answers reply-message)
-					server-ip)
+	  (dns-message-authorities reply-message)
-	     (delete-role subscription-id)
+	  (dns-message-additional reply-message)))
-	     (send-message (list 'release-query-id query-id))))])))
+	(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)])))

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 racket-bitsyntax)
 (require "api.rkt")
 (require "codec.rkt")
 (require "zonedb.rkt")
 (require "network-query.rkt")
 (require "resolver.rkt")
-(require "../racket-matrix/os2.rkt")
+(require racket-typed-matrix/sugar-typed)
-(require "../racket-matrix/os2-udp.rkt")
+(require racket-typed-matrix/support/spy)
-(require "../racket-matrix/os2-timer.rkt")
+(require racket-typed-matrix/drivers/timer)
-(require "os2-dns.rkt")
+(require racket-typed-matrix/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
+  (ground-vm:
-   (transition 'no-state
+   ((inst generic-spy Void) 'UDP)
-     ;;(spawn udp-spy)
+   ((inst udp-driver Void))
-     (spawn udp-driver #:debug-name 'udp-driver)
+   ((inst timer-driver Void))
-     (spawn (timer-driver 'timer-driver) #:debug-name 'timer-driver)
+   (nested-vm: : Void
-     (spawn (nested-vm #:debug-name 'dns-vm
+	       #:debug-name 'dns-vm
-	     (transition 'no-state
+	       (spawn: #:debug-name 'dns-spy #:parent : Void #:child : Void (dns-spy))
-	       (spawn dns-spy #:debug-name 'dns-spy)
+	       ((inst timer-relay Void) 'timer-relay:dns)
-	       (spawn (timer-relay 'timer-relay:dns) #:debug-name 'timer-relay)
+	       (spawn: #:debug-name 'query-id-allocator #:parent : Void
-	       (spawn (query-id-allocator) #:debug-name 'query-id-allocator)
+		       #:child : (Setof Natural)
-	       (spawn (dns-read-driver server-addr) #:debug-name 'server-dns-reader)
+		       (query-id-allocator))
-	       (spawn (dns-write-driver server-addr) #:debug-name 'server-dns-writer)
+	       (spawn: #:debug-name 'server-dns-reader #:parent : Void
-	       (spawn (dns-read-driver client-addr) #:debug-name 'client-dns-reader)
+		       #:child : Void (dns-read-driver server-addr))
-	       (spawn (dns-write-driver client-addr) #:debug-name 'client-dns-writer)
+	       (spawn: #:debug-name 'server-dns-writer #:parent : Void
-	       (spawn (packet-dispatcher server-addr) #:debug-name 'packet-dispatcher)
+		       #:child : Void (dns-write-driver server-addr))
-	       (spawn (question-dispatcher zone roots-only client-addr)
+	       (spawn: #:debug-name 'client-dns-reader #:parent : Void
-		      #:debug-name 'question-dispatcher)))
+		       #:child : Void (dns-read-driver client-addr))
-	    #:debug-name 'dns-vm))))
+	       (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
+  (transition: ((inst set Natural)) : (Setof Natural) ;; all active query IDs
-    (role (topic-subscriber `(request ,(wild) allocate-query-id))
+    (endpoint: allocated : (Setof Natural)
-      #:state allocated
+	       #:subscriber `(request ,(wild) allocate-query-id)
-      [`(request ,reply-addr allocate-query-id)
+     [`(request ,reply-addr allocate-query-id)
-       (let recheck ()
+      (let: recheck : (Transition (Setof Natural)) ()
-	 (define n (random 65536))
+	(define n (random 65536))
-	 (if (set-member? allocated n)
+	(if (set-member? allocated n)
-	     (recheck)
+	    (recheck)
-	     (transition (set-add allocated n)
+	    (transition: (set-add allocated n) : (Setof Natural)
-	       (send-message `(reply ,reply-addr ,n)))))])
+	      (send-message `(reply ,reply-addr ,n)))))])
-    (role (topic-subscriber `(release-query-id ,(wild)))
+    (endpoint: allocated : (Setof Natural)
-      #:state allocated
+	       #:subscriber `(release-query-id ,(wild))
-      [`(release-query-id ,n)
+     [`(release-query-id ,(? exact-nonnegative-integer? n))
-       (transition (set-remove allocated n))])))
+      (transition: (set-remove allocated n) : (Setof Natural))])))
 
+(: packet-dispatcher : UdpAddress -> (Transition (Setof ActiveRequest)))
 (define (packet-dispatcher s)
-  (transition (set) ;; SetOf<ActiveRequest>
+  (transition: ((inst set ActiveRequest)) : (Setof ActiveRequest)
-    (role (topic-subscriber (bad-dns-packet (wild) (wild) (wild) (wild)))
+    (endpoint: : (Setof ActiveRequest)
-      #:state old-active-requests
+	       #:subscriber (bad-dns-packet-pattern (wild) (wild) (wild) (wild))
-      [p
+     [p (begin (log-error (pretty-format p)) '())])
-       (log-error (pretty-format p))
+    (endpoint: old-active-requests : (Setof ActiveRequest)
-       ;; TODO: ^ perhaps use metalevel events? perhaps don't bother though
+	       #:subscriber (dns-request-pattern (wild) (wild) s)
-       (transition old-active-requests)])
+     [(and r (dns-request m source (== s)))
-    (role (topic-subscriber (dns-request (wild) (wild) s))
+      ;; ^ We only listen for requests on our server socket
-      #:state old-active-requests
+      (let ((req-id (active-request source (dns-message-id m))))
-      [(and r (dns-request m source (== s))) ;; We only listen for requests on our server socket
+	;; TODO: when we have presence/error-handling, remove req-id
-       (define req-id (active-request source (dns-message-id m)))
+	;; from active requests once request-handler pseudothread exits.
-       ;; TODO: when we have presence/error-handling, remove req-id
+	(if (set-member? old-active-requests req-id)
-       ;; from active requests once request-handler pseudothread exits.
+	    (transition: old-active-requests : (Setof ActiveRequest))
-       (if (set-member? old-active-requests req-id)
+	    ;; ^ ignore retransmitted duplicates
-	   (transition old-active-requests) ;; ignore retransmitted duplicates
+	    (transition: (set-add old-active-requests req-id) : (Setof ActiveRequest)
-	   (transition (set-add old-active-requests req-id)
+	      (spawn: #:debug-name (list 'packet-relay req-id)
-	     (spawn (packet-relay req-id r) #:debug-name (list 'packet-relay req-id))))])
+		      #:parent : (Setof ActiveRequest)
-    (role (topic-subscriber (dns-reply (wild) s (wild)))
+		      #:child : Void (packet-relay req-id r)))))])
-      #:state old-active-requests
+    (endpoint: old-active-requests : (Setof ActiveRequest)
-      [(and r (dns-reply m (== s) sink))
+	       #:subscriber (dns-reply-pattern (wild) s (wild))
-       (define req-id (active-request sink (dns-message-id m)))
+     [(and r (dns-reply m (== s) sink))
-       (transition (set-remove old-active-requests req-id))])))
+      (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)
+    (dns-reply
-			    'response
+     (dns-message (dns-message-id request-message)
-			    'query
+		  'response
-			    'non-authoritative
+		  'query
-			    'not-truncated
+		  'non-authoritative
-			    (dns-message-recursion-desired request-message)
+		  'not-truncated
-			    'recursion-available
+		  (dns-message-recursion-desired request-message)
-			    response-code
+		  'recursion-available
-			    (if q (list q) '())
+		  response-code
-			    ns
+		  (if q (list q) '())
-			    us
+		  ns
-			    ds)
+		  us
-	       request-sink
+		  ds)
-	       request-source))
+     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)))
+       (endpoint: : Void
-	 #:state w
+		  #:subscriber (answered-question-pattern original-question (wild))
-	 [(answered-question (== original-question) answer)
+		  #:let-name wait-id
-	  (log-debug (format "Final answer to ~v with query id ~v is ~v"
+	[(answered-question (== original-question) answer)
-			     original-question
+	 (begin (log-debug (format "Final answer to ~v with query id ~v is ~v"
-			     (dns-message-id request-message)
+				   original-question
-			     answer))
+				   (dns-message-id request-message)
-	  (transition w
+				   answer))
-	    (delete-role wait-id)
+		(list (delete-endpoint wait-id)
-	    (send-message (answer->reply original-question answer)))]))]))
+		      (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
+  (transition/no-state
-    (role/fresh relay (topic-subscriber (answered-question restarted-question (wild)))
+    (endpoint: : Void
-      #:state w
+	       #: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
+       (list (delete-endpoint relay)
-	 (delete-role relay)
+	     (send-message (answered-question q ans)))])
-	 (send-message (answered-question q ans)))])
+    (spawn: #:debug-name (list 'glueless-question-handler-inner restarted-question)
-    (spawn (question-handler roots-only-zone restarted-question client-sock)
+	    #:parent : Void
-	   #:debug-name (list 'glueless-question-handler-inner restarted-question))))
+	    #: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
+    (transition: new-zone : CompiledZone
-      (for/list ([timerspec timers])
+      (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))
+    (endpoint: zone : CompiledZone
-      #:state zone
+	       #:subscriber `(debug-dump)
-      [`(debug-dump)
+     [`(debug-dump)
-       (with-output-to-file "zone-proxy.zone"
+      (begin
-	 (lambda ()
+	(with-output-to-file "zone-proxy.zone"
-	   (write-bytes (bit-string->bytes (zone->bit-string zone))))
+	  (lambda ()
-	 #:mode 'binary
+	    (write-bytes (bit-string->bytes (zone->bit-string zone))))
-	 #:exists 'replace)
+	  #:mode 'binary
-       (with-output-to-file "zone-proxy.dump"
+	  #:exists 'replace)
-	 (lambda ()
+	(with-output-to-file "zone-proxy.dump"
-	   (display "----------------------------------------------------------------------\n")
+	  (lambda ()
-	   (display (seconds->date (current-seconds)))
+	    (display "----------------------------------------------------------------------\n")
-	   (newline)
+	    (display (seconds->date (current-seconds)))
-	   (for* ([(name rrmap) zone] [(rr expiry) rrmap])
+	    (newline)
-	     (write (list rr expiry))
+	    (for: ([name (in-hash-keys zone)])
-	     (newline))
+	      (define rrmap (hash-ref zone name))
-	   (newline))
+	      (for: ([rr (in-hash-keys rrmap)])
-	 #:mode 'text
+		(define expiry (hash-ref rrmap rr))
-	 #:exists 'append)
+		(write (list rr expiry))
-       (with-output-to-file "zone-proxy.debug"
+		(newline)))
-	 (lambda ()
+	    (newline))
-	   (display "----------------------------------------------------------------------\n")
+	  #:mode 'text
-	   (display (seconds->date (current-seconds)))
+	  #:exists 'append)
-	   (newline)
+	;; (with-output-to-file "zone-proxy.debug"
-	   (pretty-write current-ground-transition))
+	;;   (lambda ()
-	 #:mode 'text
+	;;     (display "----------------------------------------------------------------------\n")
-	 #:exists 'append)
+	;;     (display (seconds->date (current-seconds)))
-       (transition zone)])
+	;;     (newline)
-    (role (topic-subscriber (question (wild) (wild) (wild) (wild)))
+	;;     (pretty-write current-ground-transition))
-      #:state zone
+	;;   #:mode 'text
-      [(? question? q)
+	;;   #:exists 'append)
-       (transition zone
+	(transition: zone : CompiledZone))])
-	 (cond
+    (endpoint: zone : CompiledZone
-	  [(question-cyclic? q)
+	       #:subscriber (question-pattern (wild) (wild) (wild) (wild))
-	   (log-warning (format "Cyclic question ~v" q))
+     [(? question? q)
-	   (send-message (answered-question q (empty-complete-answer)))]
+      (transition: zone : CompiledZone
-	  [(question-too-glueless? q)
+	(cond
-	   (log-warning (format "Overly-glueless question ~v" q))
+	 [(question-cyclic? q)
-	   (spawn (glueless-question-handler roots-only q client-sock)
+	  (log-warning (format "Cyclic question ~v" q))
-		  #:debug-name (list 'glueless-question-handler-outer q))]
+	  (send-message (answered-question q (empty-complete-answer)))]
-	  [else
+	 [(question-too-glueless? q)
-	   (spawn (question-handler zone q client-sock)
+	  (log-warning (format "Overly-glueless question ~v" q))
-		  #:debug-name (list 'question-handler q))]))])
+	  (spawn: #:debug-name (list 'glueless-question-handler-outer q)
-    (role (topic-subscriber (network-reply (wild) (wild)))
+		  #:parent : CompiledZone
-      #:state zone
+		  #:child : Void
-      [(network-reply _ answer)
+		  (glueless-question-handler roots-only q client-sock))]
-       (define-values (new-zone timers) (incorporate-complete-answer answer zone))
+	 [else
-       (transition-and-set-timers new-zone timers)])
+	  (spawn: #:debug-name (list 'question-handler q)
-    (role (topic-subscriber (timer-expired (list 'check-dns-expiry (wild)) (wild)))
+		  #:parent : CompiledZone
-      #:state zone
+		  #:child : QHState
-      [(timer-expired (list 'check-dns-expiry name) now-msec)
+		  (question-handler zone q client-sock))]))])
-       (transition (zone-expire-name zone name (/ now-msec 1000.0)))])))
+    (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: question-state ([zone : CompiledZone]
-(struct expanding-cnames (q accumulator remaining-count) #:prefab)
+			 [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))))
+			   (map domain-labels (set-map nameserver-rrs rr-rdata-domain-name))))
-	(transition w
+	(transition: w : QHState
-	  (spawn (network-query client-sock
+	  ((inst network-query QHState) client-sock
-				q
+	                                q
-				zone-origin
+					zone-origin
-				(map rr-rdata (set->list nameserver-rrs))
+					(map rr-rdata-domain-name (set->list nameserver-rrs))
-				referral-id)
+					referral-id)
-		 #:debug-name (list 'network-query q))
+	  (endpoint: w : QHState
-	  (role (topic-subscriber (network-reply referral-id (wild)))
+		     #:subscriber (network-reply-pattern referral-id (wild))
-	    #:name referral-id
+		     #:name referral-id
-	    #:state w
+	   [(network-reply (== referral-id) #f) ;; name-error/NXDOMAIN
-	    [(network-reply (== referral-id) #f) ;; name-error/NXDOMAIN
+	    (transition: w : QHState
-	     (transition w
+	      (delete-endpoint referral-id)
-	       (delete-role referral-id)
+	      (send-message (answered-question q #f)))]
-	       (send-message (answered-question q #f)))]
+	   [(network-reply (== referral-id) ans)
-	    [(network-reply (== referral-id) ans)
+	    (let-values (((new-zone ignored-timers) (incorporate-complete-answer ans zone #f)))
-	     (define-values (new-zone ignored-timers) (incorporate-complete-answer ans zone))
+	      (when (log-level? (current-logger) 'debug)
-	     (when (log-level? (current-logger) 'debug)
+		(log-debug (format "Referral ~v results in origin ~v:~n"
-	       (log-debug (format "Referral ~v results in origin ~v:~n"
+				   referral-id zone-origin))
-				  referral-id zone-origin))
+		(for ([k (set-union (list->set (hash-keys zone))
-	       (for ([k (set-union (list->set (hash-keys zone))
+				    (list->set (hash-keys new-zone)))]
-				   (list->set (hash-keys new-zone)))]
+		      #:when (in-bailiwick? k zone-origin))
-		     #:when (in-bailiwick? k zone-origin))
+		  (log-debug (format "Old ~v ~v~nNew ~v ~v"
-		 (log-debug (format "Old ~v ~v~nNew ~v ~v"
+				     k (hash-ref zone k (lambda () 'missing))
-				    k (hash-ref zone k 'missing)
+				     k (hash-ref new-zone k (lambda () 'missing)))))
-				    k (hash-ref new-zone k 'missing))))
+		(log-debug "=-=-=-=-=-="))
-	       (log-debug "=-=-=-=-=-="))
+	      (define nameserver-names
-	     (define nameserver-names (for/set ([rr nameserver-rrs]) (rr-rdata rr)))
+		(list->set
-	     (sequence-actions
+		 (for/list: : (Listof DomainName) ([rr nameserver-rrs]) (rr-rdata-domain-name rr))))
-		 (retry-question (struct-copy question-state w
+	      (sequence-actions
-					      [nameservers-tried (set-union nameservers-tried
+	       (retry-question (struct-copy question-state w
-									    nameserver-names)]
+				 [nameservers-tried (set-union nameservers-tried
-					      [zone new-zone]
+							       nameserver-names)]
-					      [retry-count (+ old-retry-count 1)]))
+				 [zone new-zone]
-	       (delete-role referral-id))]))]
+				 [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))
+	(transition: (expanding-cnames q base (length cnames)) : QHState
-	  (map (lambda (cname)
+	  ((inst map (ActionTree QHState) DomainName)
-		 ;; TODO: record chains of CNAMEs to avoid pathologically-long chains
+	   (lambda: ([cname : DomainName])
-		 (define cname-q (cname-question cname q))
+	     ;; TODO: record chains of CNAMEs to avoid pathologically-long chains
-		 (list (send-message cname-q)
+	     (define cname-q (cname-question cname q))
-		       (role/fresh subscription-id
+	     (list (send-message cname-q)
-			   (topic-subscriber (answered-question cname-q (wild)))
+		   (endpoint: (expanding-cnames q acc remaining) : QHState
-			 #:state (expanding-cnames q acc remaining)
+			      #:subscriber (answered-question-pattern cname-q (wild))
-			 [(answered-question (== cname-q) ans)
+			      #:let-name subscription-id
-			  (define new-acc (if ans (merge-answers acc ans) acc))
+		    [(answered-question (== cname-q) ans)
-			  (define new-remaining (- remaining 1))
+		     (let ()
-			  (define new-w (expanding-cnames q new-acc new-remaining))
+		       (define new-acc (if ans (merge-answers acc ans) acc))
-			  (transition new-w
+		       (define new-remaining (- remaining 1))
-			    (delete-role subscription-id)
+		       (define new-w (expanding-cnames q new-acc new-remaining))
-			    (if (zero? new-remaining)
+		       (transition: new-w : QHState
-				(send-message (answered-question q new-acc))
+			 (delete-endpoint subscription-id)
-				'()))])))
+			 (if (zero? new-remaining)
-	       cnames))])]))
+			     (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
+	   (in-bailiwick? (question-repr-name q) (rr-name start-of-authority))
-	   (not (zone-includes-name? zone (question-name q)))) ;; there are no RRs at all for this q
+	   ;; ^ 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))
+		      (set-filter (lambda: ([rr : RR])
-						    (eqv? (rr-class rr) 'in)))
+				    (and (memv (rdata-type (rr-rdata rr)) '(a aaaa))
-				  (or (zone-ref zone name) (set)))))
+					 (eqv? (rr-class rr) 'in)))
-	 (set)
+				  (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

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

simplified-driver.rkt

@@ -6,7 +6,7 @@
 (require racket/match)
 (require racket/set)
 (require racket/bool)
-(require "../racket-bitsyntax/main.rkt")
+(require racket-bitsyntax)
 (require "api.rkt")
 (require "codec.rkt")
 (require "zonedb.rkt")

stress.rkt

@@ -5,7 +5,7 @@
 
 (require racket/udp)
 (require racket/set)
-(require "../racket-bitsyntax/main.rkt")
+(require racket-bitsyntax)
 (require "api.rkt")
 (require "codec.rkt")
 (require "test-rrs.rkt")

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
+  (rr (domain '(#"example")) 'in 30
-      (soa (domain '(#"ns" #"example"))
+      (rdata-soa 'soa
-	   (domain '(#"tonyg" #"example"))
+		 (domain '(#"ns" #"example"))
-	   1
+		 (domain '(#"tonyg" #"example"))
-	   24
+		 1
-	   24
+		 24
-	   30
+		 24
-	   10)))
+		 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))
+  (list (A '(#"localhost" #"example") '#(127 0 0 1))
-	(rr (domain '(#"example")) 'mx 'in 30 (mx 5 (domain '(#"localhost" #"example"))))
+	(MX '(#"example") 5 '(#"localhost" #"example"))
-	(rr (domain '(#"example")) 'mx 'in 30 (mx 10 (domain '(#"subns" #"example"))))
+	(MX '(#"example") 10 '(#"subns" #"example"))
-	(rr (domain '(#"google" #"example")) 'cname 'in 30 (domain '(#"www" #"google" #"com")))
+	(CNAME '(#"google" #"example")'(#"www" #"google" #"com"))
-	(rr (domain '(#"roar" #"example")) 'a 'in 30 '#(192 168 1 1))
+	(A '(#"roar" #"example") '#(192 168 1 1))
-	(rr (domain '(#"alias" #"example")) 'cname 'in 30 (domain '(#"roar" #"example")))
+	(CNAME '(#"alias" #"example") '(#"roar" #"example"))
-	(rr (domain '(#"ns" #"example")) 'a 'in 30 '#(127 0 0 1))
+	(A '(#"ns" #"example") '#(127 0 0 1))
-	(rr (domain '(#"hello" #"example")) 'txt 'in 30 '(#"Hello CRASH"))
+	(TXT '(#"hello" #"example") '(#"Hello CRASH"))
-	(rr (domain '(#"subzone" #"example")) 'ns 'in 30 (domain '(#"subns" #"example")))
+	(NS '(#"subzone" #"example") '(#"subns" #"example"))
-	(rr (domain '(#"subns" #"example")) 'a 'in 30 '#(127 0 0 2))))
+	(A '(#"subns" #"example") '#(127 0 0 2))))
-
-;; (define test-roots
-;;   (list (rr (domain '()) 'ns 'in 30 (domain '(#"f" #"root-servers" #"net")))
-;; 	(rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(198 41 0 4))
-;; 	(rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(192 228 79 201))
-;; 	(rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(192 33 4 12))
-;; 	(rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(192 203 230 10))
-;; 	(rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(192 112 36 4))
-;; 	(rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(128 63 2 53))
-;; 	(rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(192 58 128 30))
-;; 	(rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(193 0 14 129))))
 
 (define test-roots
-  (list (rr (domain '(#"a" #"root-servers" #"net")) 'a 'in 3600000 '#(198 41 0 4))
+  (list (A/ttl '(#"a" #"root-servers" #"net") '#(198 41 0 4) 3600000)
-	(rr (domain '(#"b" #"root-servers" #"net")) 'a 'in 3600000 '#(192 228 79 201))
+	(A/ttl '(#"b" #"root-servers" #"net") '#(192 228 79 201) 3600000)
-	(rr (domain '(#"c" #"root-servers" #"net")) 'a 'in 3600000 '#(192 33 4 12))
+	(A/ttl '(#"c" #"root-servers" #"net") '#(192 33 4 12) 3600000)
-	(rr (domain '(#"d" #"root-servers" #"net")) 'a 'in 3600000 '#(128 8 10 90))
+	(A/ttl '(#"d" #"root-servers" #"net") '#(199 7 91 13) 3600000)
-	(rr (domain '(#"e" #"root-servers" #"net")) 'a 'in 3600000 '#(192 203 230 10))
+	(A/ttl '(#"e" #"root-servers" #"net") '#(192 203 230 10) 3600000)
-	(rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 3600000 '#(192 5 5 241))
+	(A/ttl '(#"f" #"root-servers" #"net") '#(192 5 5 241) 3600000)
-	(rr (domain '(#"g" #"root-servers" #"net")) 'a 'in 3600000 '#(192 112 36 4))
+	(A/ttl '(#"g" #"root-servers" #"net") '#(192 112 36 4) 3600000)
-	(rr (domain '(#"h" #"root-servers" #"net")) 'a 'in 3600000 '#(128 63 2 53))
+	(A/ttl '(#"h" #"root-servers" #"net") '#(128 63 2 53) 3600000)
-	(rr (domain '(#"i" #"root-servers" #"net")) 'a 'in 3600000 '#(192 36 148 17))
+	(A/ttl '(#"i" #"root-servers" #"net") '#(192 36 148 17) 3600000)
-	(rr (domain '(#"j" #"root-servers" #"net")) 'a 'in 3600000 '#(192 58 128 30))
+	(A/ttl '(#"j" #"root-servers" #"net") '#(192 58 128 30) 3600000)
-	(rr (domain '(#"k" #"root-servers" #"net")) 'a 'in 3600000 '#(193 0 14 129))
+	(A/ttl '(#"k" #"root-servers" #"net") '#(193 0 14 129) 3600000)
-	(rr (domain '(#"l" #"root-servers" #"net")) 'a 'in 3600000 '#(199 7 83 42))
+	(A/ttl '(#"l" #"root-servers" #"net") '#(199 7 83 42) 3600000)
-	(rr (domain '(#"m" #"root-servers" #"net")) 'a 'in 3600000 '#(202 12 27 33))
+	(A/ttl '(#"m" #"root-servers" #"net") '#(202 12 27 33) 3600000)
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"a" #"root-servers" #"net")))
+	(NS/ttl '() '(#"a" #"root-servers" #"net") 3600000)
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"b" #"root-servers" #"net")))
+	(NS/ttl '() '(#"b" #"root-servers" #"net") 3600000)
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"c" #"root-servers" #"net")))
+	(NS/ttl '() '(#"c" #"root-servers" #"net") 3600000)
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"d" #"root-servers" #"net")))
+	(NS/ttl '() '(#"d" #"root-servers" #"net") 3600000)
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"e" #"root-servers" #"net")))
+	(NS/ttl '() '(#"e" #"root-servers" #"net") 3600000)
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"f" #"root-servers" #"net")))
+	(NS/ttl '() '(#"f" #"root-servers" #"net") 3600000)
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"g" #"root-servers" #"net")))
+	(NS/ttl '() '(#"g" #"root-servers" #"net") 3600000)
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"h" #"root-servers" #"net")))
+	(NS/ttl '() '(#"h" #"root-servers" #"net") 3600000)
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"i" #"root-servers" #"net")))
+	(NS/ttl '() '(#"i" #"root-servers" #"net") 3600000)
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"j" #"root-servers" #"net")))
+	(NS/ttl '() '(#"j" #"root-servers" #"net") 3600000)
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"k" #"root-servers" #"net")))
+	(NS/ttl '() '(#"k" #"root-servers" #"net") 3600000)
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"l" #"root-servers" #"net")))
+	(NS/ttl '() '(#"l" #"root-servers" #"net") 3600000)
-	(rr (domain '()) 'ns 'in 3600000 (domain '(#"m" #"root-servers" #"net")))))
+	(NS/ttl '() '(#"m" #"root-servers" #"net") 3600000)))
 
 (define pathological-roots
-  (list (rr (domain '(#"a")) 'ns 'in 30 (domain '(#"ns" #"b")))
+  (list (NS '(#"a") '(#"ns" #"b"))
-	(rr (domain '(#"b")) 'ns 'in 30 (domain '(#"ns" #"a")))))
+	(NS '(#"b") '(#"ns" #"a"))))
 
+(: test-port-number : -> Nonnegative-Integer)
 (define (test-port-number)
-  (string->number
+  (define p
-   (or (getenv "DNSPORT")
+    (string->number
-       (error 'test-port-number "Please set your DNSPORT environment variable."))))
+     (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 racket-typed-matrix.
+
+(require racket/set)
+(require racket/match)
+(require "codec.rkt")
+(require racket-typed-matrix/sugar-typed)
+(require racket-typed-matrix/drivers/udp)
+(require racket-typed-matrix/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 racket-bitsyntax)
+(require (rename-in racket-typed-matrix/tr-struct-copy [tr-struct-copy struct-copy])) ;; PR13149
 
-(provide zone-ref
+(provide CompiledZone
+	 zone-ref
 	 zone-includes-name?
 	 incorporate-complete-answer
 	 zone-expire-name
 	 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
+  (define expirymap (hash-ref db name (lambda () #f)))
-   [(hash-ref db name #f) =>
+  (and expirymap
-    (lambda (expirymap)
+       (let ((now (current-inexact-seconds)))
-      (define now (current-inexact-seconds))
+	 (for/fold: ([acc : (Setof RR) (set)])
-      (for/set ([(resource expiry) expirymap] #:when (still-valid? expiry now))
+	     ([resource : RR (in-hash-keys expirymap)])
-	(struct-copy rr resource [ttl (if (infinite-lifetime? expiry)
+	   (define expiry (hash-ref expirymap resource))
-					  (infinite-lifetime-ttl expiry)
+	   (if (still-valid? expiry now)
-					  (inexact->exact (floor (- expiry now))))])))]
+	       (let ((new-ttl (if (infinite-lifetime? expiry)
-   [else #f]))
+				  (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-expirymap (hash-ref db name (lambda () (ann #hash() (HashTable rr Expiry)))))
-  (define old-expiry (hash-ref old-expirymap resource 0))
+  (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)
+(: incorporate-complete-answer :
-(define (incorporate-complete-answer ans db)
+   (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)])
+     (for/fold ([db db] [timers ((inst set Timer))])
-	 ([rr (in-sequences ns us ds)])
+	 ([rr (in-list (append (set->list ns)
-       (values ((incorporate-rr now) rr db)
+			       (set->list us)
-	       (set-add timers (cons (rr-name rr) (rr-ttl rr)))))]))
+			       (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/fold: ([acc : (HashTable RR Expiry) empty-expirymap])
-	(for/hash ([(resource expiry) (hash-ref db name)] #:when (still-valid? expiry now-seconds))
+	([resource : RR (in-hash-keys old-expirymap)])
-	  (values resource expiry))
+      (define expiry (hash-ref old-expirymap resource))
-	(hash)))
+      (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)])
+  (for/fold: ([zone : CompiledZone zone] [timers : Timers (set)])
-      ([name (hash-keys zone)])
+      ([name : DomainName (in-hash-keys zone)])
     (define new-zone (zone-expire-name zone name now-seconds))
-    (cond
+    (define expirymap (hash-ref new-zone name (lambda () #f)))
-     [(hash-ref new-zone name #f) =>
+    (values new-zone
-      (lambda (expirymap)
+	    (if expirymap
-	(values new-zone
 		(set-union (list->set
-			    (map (lambda (e) (cons name (- e now-seconds)))
+			    (map (lambda: ([e : AbsoluteSeconds]) (cons name (- e now-seconds)))
-				 (filter (lambda (e) (not (infinite-lifetime? e)))
+				 (filter absolute-seconds? (hash-values expirymap))))
-					 (hash-values expirymap))))
+			   timers)
-			   timers)))]
+		timers))))
-     [else
-      (values new-zone 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)
+(: in-bailiwick? : DomainName DomainName -> Boolean)
-  (hash? z)) ;; hm
-
-;; 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
+  (or (equal? dn o)
-   ((equal? dn o) #t)
+      (let ((p (domain-parent dn)))
-   ((domain-root? dn) #f)
+	(and p (in-bailiwick? p o)))))
-   (else (in-bailiwick? (domain-parent dn) 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)]
+  (for/fold: ([acc : (Setof X) (set)]) ([x : X (in-list (set->list in))])
-	    #:when (predicate x))
+    (if (predicate x) (set-add acc x) acc)))
-	   x))
 
-;; 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
+    (cond
-      ((*) rrs)
+     ((eq? qtype '*) rrs)
-      (else (filter-by-type rrs qtype))))
+     ((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)))
+  (define cnames (filter-by-type rrs 'cname))
-	  (set->list (set-filter (lambda (rr) (not (eqv? (rr-type rr) 'cname))) rrs))))
+  (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))
+  (: targets-of : DomainName -> (Listof RR))
-  (let iterate ((remaining roots)
+  (define (targets-of name) (filter (lambda: ([rr : RR]) (equal? (rr-name rr) name)) cnames))
-		(seen (set))
+  (let: iterate ((remaining : (Listof DomainName) roots)
-		(acc '()))
+		 (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)])
+  (for/fold: ([acc : BitString (bit-string)]) ([name : DomainName (in-hash-keys zone)])
-      ([(name rrmap) zone] [(rr expiry) rrmap])
+    (define rrmap (hash-ref zone name))
-    (bit-string-append
+    (for/fold: ([acc : BitString acc]) ([rr : RR (in-hash-keys rrmap)])
-     acc
+      (define expiry (hash-ref rrmap rr))
-     (match expiry
+      (bit-string-append
-       [(infinite-lifetime ttl)
+       acc
-	(bit-string (rr :: (t:rr)) 1 (ttl :: bits 32))]
+       (cond
-       [expirytime
+	[(infinite-lifetime? expiry)
-	(bit-string (rr :: (t:rr)) 0 ((truncate (inexact->exact expirytime)) :: bits 32))]))))
+	 (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))))))