Merge branch 'typeless' into syndicate

README.md

@@ -2,7 +2,7 @@
 
 This is a [Racket](http://racket-lang.org/) implementation of a DNS
 server and iterative resolver. It's written to work with
-[Marketplace](https://github.com/tonyg/marketplace), but could readily
+[Syndicate](https://github.com/tonyg/syndicate), but could readily
 be adapted to work with other I/O substrates. (It originally used
 Racket's `sync` and events directly.)
 
@@ -18,9 +18,9 @@ equal to Racket 6.0 should work. Racket releases can be downloaded
 
 Once you have Racket installed,
 
-    raco pkg install marketplace bitsyntax
+    raco pkg install syndicate bitsyntax
 
-to install Marketplace (note: will take a long time) and
+to install Syndicate and
 [bitsyntax](https://github.com/tonyg/racket-bitsyntax/), and then
 
     raco make driver.rkt proxy.rkt

api-untyped.rkt

@@ -20,9 +20,9 @@
 ;;; along with marketplace-dns. If not, see
 ;;; <http://www.gnu.org/licenses/>.
 
-(require marketplace/struct-map)
+(provide (struct-out domain)
-
+	 downcase-labels
-(provide (struct-out domain))
+	 make-domain)
 
 ;; (These utilities need to be defined ahead of the domain struct
 ;; definition.)
@@ -35,10 +35,7 @@
 
 (struct domain (labels downcased-labels)
 	#:transparent
-	#:property prop:equal+hash (list domain=? domain-hash-1/2 domain-hash-1/2)
+	#: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

api.rkt

@@ -1,4 +1,4 @@
-#lang typed/racket/base
+#lang racket/base
 ;; Definitions for use in the API to the functionality of the library.
 ;;
 ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@@ -19,18 +19,12 @@
 ;;; along with marketplace-dns. If not, see
 ;;; <http://www.gnu.org/licenses/>.
 
-(provide DomainName
+(provide (except-out (struct-out domain) domain)
-	 (except-out (struct-out domain) domain)
 	 (rename-out [make-domain domain])
 	 domain-root?
 	 domain-parent
 
-	 IPv4
+	 (struct-out question)
-	 IPv6
-
-	 (struct-out question-repr)
-	 Question question question?
-	 QuestionPattern question-pattern question-pattern?
 
 	 question-cyclic?
 	 question-too-glueless?
@@ -39,19 +33,14 @@
 	 cname-question
 	 ns-question
 
-	 (struct-out answered-question-repr)
+	 (struct-out answered-question)
-	 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
 
-	 RData
 	 (struct-out rdata)
 	 (struct-out rdata-domain)
 	 (struct-out rdata-ipv4)
@@ -66,10 +55,6 @@
 	 (struct-out rdata-raw)
 	 rdata-type-pred
 
-	 RRType
-	 QueryType
-	 RRClass
-	 QueryClass
 	 type->value value->type
 	 qtype->value value->qtype
 	 class->value value->class
@@ -78,50 +63,30 @@
 (require "mapping.rkt")
 (require racket/set)
 (require racket/match)
-(require marketplace)
+(require syndicate)
-(require marketplace/struct-map)
-(require marketplace/support/pseudo-substruct)
 
 ;; A DomainName is a (domain ListOf<Bytes>), representing a domain
 ;; name. The head of the list is the leftmost label; for example,
 ;; www.google.com is represented as '(#"www" #"google" #"com").
-(require/typed "api-untyped.rkt"
+(require "api-untyped.rkt")
-	       [#:struct domain ([labels : (Listof Bytes)]
-				 [downcased-labels : (Listof Bytes)])])
-(define-type DomainName domain)
 
 ;; A ShortString is a String with length 255 or shorter.
 
 ;; An IPv4 is a (vector Byte Byte Byte Byte), representing an IPv4
 ;; address. For example, 127.0.0.1 is represented as (vector 127 0 0
 ;; 1).
-(define-type IPv4 (Vector Byte Byte Byte Byte))
 
 ;; An IPv6 is a Vector of length 16 containing Bytes, representing an
 ;; IPv6 address. For example, 2001:0db8:85a3:0000:0000:8a2e:0370:7334
 ;; is represented as (vector #x20 #x01 #x0d #xb8 #x85 #xa3 #x00 #x00
 ;; #x00 #x00 #x8a #x2e #x03 #x70 #x73 #x34).
-(define-type IPv6 (Vector Byte Byte Byte Byte
-			  Byte Byte Byte Byte
-			  Byte Byte Byte Byte
-			  Byte Byte Byte Byte))
 
 ;; A Question is a (question DomainName QueryType QueryClass
 ;; QuestionContext), representing a DNS question: "What are the RRs
 ;; for the given name, type and class?" as well as a possible parent
 ;; question that the answer to this question is to contribute to the
 ;; answer to.
-(struct: (TName TType TClass TContext)
+(struct question (name type class context) #:transparent)
-	 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
@@ -134,33 +99,20 @@
 ;; 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 : Question]) #:transparent)
+(struct subquestion (parent) #:transparent)
-(struct: cname-subq subquestion () #:transparent)
+(struct cname-subq subquestion () #:transparent)
-(struct: ns-subq subquestion () #:transparent)
+(struct ns-subq subquestion () #:transparent)
-(define-type QuestionContext (U subquestion cname-subq ns-subq False 'restart))
 
 ;; An AnsweredQuestion is an (answered-question Question
 ;; Maybe<CompleteAnswer>).
-(struct: (TQ TA) answered-question-repr ([q : TQ] [a : TA]) #:transparent)
+(struct answered-question (q a) #: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
+(struct complete-answer (rrs authorities additional) #:transparent)
-	 ([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),
+;; An RR is a (rr DomainName RRClass Uint32 RData),
 ;; representing a resource record.
-(struct: rr ([name : DomainName]
+(struct rr (name class ttl rdata) #:transparent)
-	     [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
@@ -181,30 +133,20 @@
 ;;
 ;; Many of these variants are obsolete in today's DNS database (marked
 ;; [O] above).
-(struct: rdata ([type : RRType]) #:transparent)
+(struct rdata (type) #:transparent)
-(struct: rdata-domain rdata ([name : DomainName]) #:transparent)
+(struct rdata-domain rdata (name) #:transparent)
-(struct: rdata-ipv4 rdata ([address : IPv4]) #:transparent)
+(struct rdata-ipv4 rdata (address) #:transparent)
-(struct: rdata-ipv6 rdata ([address : IPv6]) #:transparent)
+(struct rdata-ipv6 rdata (address) #:transparent)
-(struct: rdata-hinfo rdata ([cpu : Bytes] [os : Bytes]) #:transparent)
+(struct rdata-hinfo rdata (cpu os) #:transparent)
-(struct: rdata-minfo rdata ([rmailbx : DomainName] [emailbx : DomainName]) #:transparent)
+(struct rdata-minfo rdata (rmailbx emailbx) #:transparent)
-(struct: rdata-mx rdata ([preference : Nonnegative-Integer] [exchange : DomainName]) #:transparent)
+(struct rdata-mx rdata (preference exchange) #:transparent)
-(struct: rdata-soa rdata ([mname : DomainName]
+(struct rdata-soa rdata (mname rname serial refresh retry expire minimum) #:transparent)
-			  [rname : DomainName]
+(struct rdata-wks rdata (address protocol bitmap) #:transparent)
-			  [serial : Nonnegative-Integer]
+(struct rdata-srv rdata (priority weight port target) #:transparent)
-			  [refresh : Nonnegative-Integer]
+(struct rdata-txt rdata (strings) #:transparent)
-			  [retry : Nonnegative-Integer]
+(struct rdata-raw rdata (body) #:transparent)
-			  [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))
+;; (: rdata-type-pred : RRType -> (RData -> Boolean))
 (define ((rdata-type-pred t) d)
   (eq? (rdata-type d) t))
 
@@ -212,12 +154,8 @@
 ;; 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
+;; (: type->value : RRType -> Nonnegative-Integer)
-		       'mr 'null 'wks 'ptr 'hinfo 'minfo 'mx 'txt
+;; (: value->type : Nonnegative-Integer -> RRType)
-		       '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
@@ -243,9 +181,8 @@
 ;; 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)
-(: qtype->value : QueryType -> Nonnegative-Integer)
+;; (: value->qtype : Nonnegative-Integer -> QueryType)
-(: value->qtype : Nonnegative-Integer -> QueryType)
 (define-mapping qtype->value value->qtype
   #:forward-default type->value
   #:backward-default value->type
@@ -258,9 +195,8 @@
 ;; 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)
-(: class->value : RRClass -> Nonnegative-Integer)
+;; (: value->class : Nonnegative-Integer -> RRClass)
-(: value->class : Nonnegative-Integer -> RRClass)
 (define-mapping class->value value->class
   #:forward-default values
   #:backward-default values
@@ -272,48 +208,28 @@
 ;; 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)
-(: qclass->value : QueryClass -> Nonnegative-Integer)
+;; (: value->qclass : Nonnegative-Integer -> QueryClass)
-(: value->qclass : Nonnegative-Integer -> QueryClass)
 (define-mapping qclass->value value->qclass
   #:forward-default class->value
   #:backward-default value->class
   (* 255))
 
-;; ListOf<Bytes> -> ListOf<Bytes>
+;; (: domain-root? : DomainName -> Boolean)
-;; 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)))
-    (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.
-(: make-domain : (Listof Bytes) -> DomainName)
-(define (make-domain labels)
-  (domain labels (downcase-labels labels)))
-
-(: domain-root? : DomainName -> Boolean)
 (define (domain-root? d)
   (null? (domain-labels d)))
 
-(: domain-parent : DomainName -> (Option 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)))))
 
-(: empty-complete-answer : -> CompleteAnswer)
+;; (: empty-complete-answer : -> CompleteAnswer)
 (define (empty-complete-answer)
   (complete-answer (set) (set) (set)))
 
-(: merge-answers : 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)
@@ -321,7 +237,7 @@
 		   (set-union u1 u2)
 		   (set-union d1 d2)))
 
-(: extract-addresses : DomainName (Option 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.
@@ -329,12 +245,12 @@
     [(complete-answer ns us ds)
      (define rrs (set->list (set-union ns us ds)))
      (let loop ((names (list name))
-		(ips ((inst set IPv4)))
+		(ips (set))
-		(seen ((inst set DomainName))))
+		(seen (set)))
        (if (null? names)
 	   ips
 	   (let* ((name (car names))
-		  (records (filter (lambda: ([rr : RR]) (equal? name (rr-name rr))) rrs))
+		  (records (filter (lambda (rr) (equal? name (rr-name rr))) rrs))
 		  (data (map rr-rdata records)))
 	     (if (set-member? seen name)
 		 (loop (cdr names) ips seen)
@@ -348,10 +264,10 @@
 ;; #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)
+;; (: question-cyclic? : Question -> Boolean)
 (define (question-cyclic? q)
   (match-define (question name type class parent) q)
-  (let: search : Boolean ((ancestor : QuestionContext parent))
+  (let search ((ancestor parent))
     (match ancestor
       [(subquestion (question (== name) (== type) (== class) _)) #t] ;; uh-oh! A cycle!
       [(subquestion (question _ _ _ ancestor-parent)) (search ancestor-parent)] ;; recursive case
@@ -363,10 +279,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)
+;; (: question-too-glueless? : Question -> Boolean)
 (define (question-too-glueless? q)
   (define count
-    (let: search : Integer ((q : Question q) (acc : Integer 0))
+    (let search ((q q) (acc 0))
       (match-define (question _ _ _ parent) q)
       (cond
        [(ns-subq? parent) (search (subquestion-parent parent) (+ acc 1))]
@@ -382,7 +298,7 @@
 ;; Question -> Boolean
 ;; #t iff this question is being asked in the context of some
 ;; excessively glueless subquestion.
-(: question-restarted? : Question -> Boolean)
+;; (: question-restarted? : Question -> Boolean)
 (define (question-restarted? q)
   (match-define (question name type class parent) q)
   (let search ((ancestor parent))
@@ -394,19 +310,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)
+;; (: restart-question : Question -> Question)
 (define (restart-question q)
-  (struct-copy question-repr q [context 'restart]))
+  (struct-copy question q [context 'restart]))
 
 ;; DomainName Question -> Question
 ;; Produces a new question with CNAME context.
-(: cname-question : DomainName Question -> Question)
+;; (: 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)
+;; (: ns-question : DomainName Question -> Question)
 (define (ns-question name q)
   (question name 'a 'in (ns-subq q))) ;; TODO: 'aaaa ?

codec.rkt

@@ -1,4 +1,4 @@
-#lang typed/racket/base
+#lang racket/base
 ;; DNS wire-protocol codec.
 ;;
 ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@@ -19,17 +19,9 @@
 ;;; along with marketplace-dns. If not, see
 ;;; <http://www.gnu.org/licenses/>.
 
-(provide Opcode
+(provide value->query-opcode query-opcode->value
-	 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
@@ -50,9 +42,8 @@
 ;; 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)
-(: value->query-opcode : Nonnegative-Integer -> Opcode)
+;; (: query-opcode->value : Opcode -> Nonnegative-Integer)
-(: query-opcode->value : Opcode -> Nonnegative-Integer)
 (define-mapping value->query-opcode query-opcode->value
   #:forward-default values
   #:backward-default values
@@ -63,11 +54,8 @@
 ;; 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
+;; (: value->query-response-code : Nonnegative-Integer -> ResponseCode)
-			     'name-error 'not-implemented 'refused
+;; (: query-response-code->value : ResponseCode -> Nonnegative-Integer)
-			     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)
@@ -83,25 +71,24 @@
 ;;
 ;; Interpreted as either a DNS request or reply, depending on the
 ;; Direction.
-(struct: dns-message ([id : Nonnegative-Integer]
+(struct dns-message (id
-		      [direction : Direction]
+		     direction
-		      [opcode : Opcode]
+		     opcode
-		      [authoritative : Authoritativeness]
+		     authoritative
-		      [truncated : Truncatedness]
+		     truncated
-		      [recursion-desired : RecursionDesired]
+		     recursion-desired
-		      [recursion-available : RecursionAvailable]
+		     recursion-available
-		      [response-code : ResponseCode]
+		     response-code
-		      [questions : (Listof Question)]
+		     questions
-		      [answers : (Listof RR)]
+		     answers
-		      [authorities : (Listof RR)]
+		     authorities
-		      [additional : (Listof RR)])
+		     additional)
-	 #:transparent)
+	#:transparent)
-(define-type DNSMessage dns-message)
+;; (define-type Direction (U 'request 'response))
-(define-type Direction (U 'request 'response))
+;; (define-type Authoritativeness (U 'non-authoritative 'authoritative))
-(define-type Authoritativeness (U 'non-authoritative 'authoritative))
+;; (define-type Truncatedness (U 'not-truncated 'truncated))
-(define-type Truncatedness (U 'not-truncated 'truncated))
+;; (define-type RecursionDesired (U 'no-recursion-desired 'recursion-desired))
-(define-type RecursionDesired (U 'no-recursion-desired 'recursion-desired))
+;; (define-type RecursionAvailable (U 'no-recursion-available 'recursion-available))
-(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:
@@ -115,7 +102,7 @@
        ;; here, but I can't find a way of expressing the types
        ;; required while making that work. This way, we avoid needing
        ;; to mention the type of the result of calls to ks.
-       (: loop : Integer (Listof Type) BitString -> (Values (Option (Listof Type)) BitString))
+       ;; (: loop : Integer (Listof Type) BitString -> (Values (Option (Listof Type)) BitString))
        (define (loop count acc input)
 	 (cond
 	  ((positive? count) (bit-string-case input
@@ -158,7 +145,7 @@
        (else
 	(kf))))
     ((_ #f vs Type option ...)
-     (let: loop : BitString ((vs : (Listof Type) vs))
+     (let loop ((vs vs))
        (cond
 	((pair? vs) (bit-string ((car vs) :: option ...)
 				((loop (cdr vs)) :: binary)))
@@ -202,7 +189,7 @@
 ;;     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
 ;; </rfc1035>
 
-(: packet->dns-message : BitString -> 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)
@@ -232,7 +219,7 @@
 		  (value->query-response-code rcode)
 		  q-section a-section auth-section additional-section))))
 
-(: dns-message->packet : 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
@@ -288,14 +275,14 @@
     ((_ #f val)
      (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 Bytes (t:pascal-string "Label" 64)))
 	      (0 :: integer bytes 1))) ;; end of list of labels!
 
-(: parse-domain-name :
+;; (: parse-domain-name :
-   BitString BitString (Listof Natural) -> (Values (Listof Bytes) BitString))
+;;    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
@@ -337,7 +324,7 @@
     ((_ #f val)
      (t:pascal-string #f val "Character-string" 256))
     ((_ #f val string-kind length-limit)
-     (let: ([s : Bytes val])
+     (let ([s val])
        (let ((len (bytes-length s)))
 	 (when (>= len length-limit)
 	   (error 't:pascal-string "~s too long: ~v" string-kind s))
@@ -377,10 +364,10 @@
 		      #f)
 	    tail))))
     ((_ #f val)
-     (let: ([q : Question val])
+     (let ([q val])
-       (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:
@@ -429,7 +416,7 @@
 		tail)))
 	 (else (kf)))))
     ((_ #f val)
-     (let: ([rr : RR val])
+     (let ([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)
@@ -438,7 +425,7 @@
 		     ((quotient (bit-string-length encoded-rdata) 8) :: bits 16)
 		     (encoded-rdata :: binary)))))))
 
-(: decode-rdata : BitString RRType BitString -> RData)
+;; (: decode-rdata : BitString RRType BitString -> RData)
 ;; Decode RData according to the RRType. Takes the whole packet for
 ;; the same reason as t:rr does.
 (define (decode-rdata whole-packet type rdata)
@@ -487,7 +474,7 @@
 	      (rdata-srv type priority weight port target))))
     (else (rdata-raw type (bit-string->bytes rdata)))))
 
-(: encode-rdata : RData -> BitString)
+;; (: encode-rdata : RData -> BitString)
 ;; Encode RData according to its RRType.
 (define (encode-rdata rdata)
   (match rdata
@@ -519,5 +506,5 @@
     [(rdata-raw _ bs) bs]))
 
 ;; UInt32
-(: max-ttl : Nonnegative-Integer)
+;; (: max-ttl : Nonnegative-Integer)
 (define max-ttl #xffffffff)

driver.rkt

@@ -1,4 +1,4 @@
-#lang typed/racket/base
+#lang racket/base
 ;; DNS server using os-big-bang.rkt and os-udp.rkt.
 ;;
 ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@@ -28,9 +28,9 @@
 (require "codec.rkt")
 (require "zonedb.rkt")
 (require "resolver.rkt")
-(require marketplace/sugar-typed)
+(require syndicate/ground)
-(require marketplace/support/spy)
+(require syndicate/actor)
-(require marketplace/drivers/udp)
+(require syndicate/drivers/udp)
 (require "tk-dns.rkt")
 
 ;; Instantiated with a SOA record for the zone it is serving as well
@@ -46,7 +46,7 @@
 ;;    determines subzones based on the RRs it is configured with at
 ;;    startup.
 
-(: start-server : Nonnegative-Integer 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.
@@ -58,26 +58,24 @@
 
   (display ";; Ready.\n")
 
-  (ground-vm: ((inst udp-driver Void))
+  (run-ground (spawn-udp-driver)
-	      ((inst generic-spy Void) 'UDP)
+              (dataspace (dns-spy)
-	      (spawn-vm: : Void
+                         (dns-read-driver local-addr)
-	       (spawn: #:parent : Void #:child : Void (dns-spy))
+                         (dns-write-driver local-addr)
-	       (spawn: #:parent : Void #:child : Void (dns-read-driver local-addr))
+                         (forever
-	       (spawn: #:parent : Void #:child : Void (dns-write-driver local-addr))
+                          (on (message ($ p (bad-dns-packet _ _ _ _)))
-	       (subscriber: Void (bad-dns-packet-pattern (wild) (wild) (wild) (wild))
+                              (log-error (pretty-format p)))
-		 (on-message [p (begin (log-error (pretty-format p)) '())]))
+                          (on (message ($ r (dns-request _ _ _)))
-	       (subscriber: Void (dns-request-pattern (wild) (wild) (wild))
+                              (let ((reply (handle-request soa-rr zone r)))
-		 (on-message [(? dns-request? r)
+                                (when reply (send! reply))))))))
-			      (let ((reply (handle-request soa-rr zone r)))
-				(when reply (send-message reply)))])))))
 
-(define-type ReplyMaker (DomainName Boolean (Setof RR) (Setof RR) (Setof RR) -> DNSMessage))
+;; (define-type ReplyMaker (DomainName Boolean (Setof RR) (Setof RR) (Setof RR) -> DNSMessage))
 
-(: handle-request : RR CompiledZone DNSRequest -> (Option DNSReply))
+;; (: 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)
+  ;; (: make-reply : ReplyMaker)
   (define (make-reply name send-name-error? answers authorities additional)
     (dns-message (dns-message-id request-message)
 		 'response
@@ -92,7 +90,7 @@
 		 (rr-set->list authorities)
 		 (rr-set->list additional)))
 
-  (: answer-question : Question ReplyMaker -> DNSMessage)
+  ;; (: 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
@@ -110,7 +108,7 @@
     ;; here. Reexamine the rules for doing so.
     (match-define (question qname qtype qclass #f) q)
 
-    (: expand-cnames : (Listof DomainName) CompleteAnswer -> DNSMessage)
+    ;; (: expand-cnames : (Listof DomainName) CompleteAnswer -> DNSMessage)
     (define (expand-cnames worklist ans)
       (match worklist
 	['()
@@ -120,7 +118,7 @@
 	 (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)
+    ;; (: incorporate-answer : Answer (Listof DomainName) CompleteAnswer -> DNSMessage)
     (define (incorporate-answer this-answer worklist ans)
       (match this-answer
 	[(partial-answer new-info more-cnames)

fetch-root-zone.rkt

@@ -0,0 +1,41 @@
+#lang racket
+
+(require net/url)
+
+(define records
+  (map (lambda (r) (string-split r "\t"))
+       (string-split (port->string
+                      (get-pure-port
+                       (string->url "http://www.internic.net/domain/root.zone")))
+                     "\n")))
+
+(define (split-host-str s)
+  (map string->bytes/utf-8 (string-split s ".")))
+
+(define (split-ip-str s)
+  (list->vector (map string->number (string-split s "."))))
+
+(pretty-write
+ `(list
+   ,@(filter values
+             (for/list [(r records)]
+               (match r
+                 [(list "."
+                        ""
+                        ""
+                        ttl-str
+                        "IN"
+                        "NS"
+                        (regexp #px"^(.+)\\.$" (list _ host-str)))
+                  `(NS/ttl '()
+                           ',(split-host-str host-str)
+                           ,(string->number ttl-str))]
+                 [(list (regexp #px"^([^.]+\\.root-servers\\.net)\\.$" (list _ host-str))
+                        ttl-str
+                        "IN"
+                        "A"
+                        ip-str)
+                  `(A/ttl ',(split-host-str host-str)
+                          ',(split-ip-str ip-str)
+                          ,(string->number ttl-str))]
+                 [_ #f])))))

mapping.rkt

@@ -1,4 +1,4 @@
-#lang typed/racket/base
+#lang racket/base
 ;; Macros for defining weak and extensible mappings between sets of values
 ;;
 ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>

network-query.rkt

@@ -1,4 +1,4 @@
-#lang typed/racket/base
+#lang racket/base
 ;;
 ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
 ;;;
@@ -23,17 +23,13 @@
 (require "api.rkt")
 (require "codec.rkt")
 (require "zonedb.rkt")
-(require marketplace/sugar-typed)
+(require syndicate/actor)
-(require marketplace/drivers/udp)
+(require syndicate/drivers/udp)
-(require marketplace/drivers/timer)
+(require syndicate/drivers/timer)
-(require marketplace/support/pseudo-substruct)
 (require "tk-dns.rkt")
-(require (rename-in marketplace/tr-struct-copy [tr-struct-copy struct-copy])) ;; PR13149
 
 (provide network-query
-	 (struct-out network-reply-repr)
+	 (struct-out network-reply))
-	 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
@@ -127,48 +123,18 @@
 
 (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 : UdpAddress]
-			  [question : Question]
-			  [zone-origin : DomainName]
-			  [server-names : (Listof DomainName)]
-			  [unique-id : Any])
-	 #:transparent)
-(define-type NetworkRequest network-request)
-
 ;; A NetworkReply is a (network-reply UniqueID Maybe<CompleteAnswer>)
 ;; representing the final result of a network query.
-(struct: (TId TAnswer)
+(struct network-reply (unique-id answer) #:transparent)
-	 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
+;; (: next-timeout : Natural -> (Option Natural))
-;; Integer Map<DomainName,ListOf<UdpAddress>> ListOf<UdpAddress>
-;; Maybe<DomainName> ListOf<DomainName>), representing an in-progress
-;; DNS network query.
-(struct: network-query-state ([request : NetworkRequest]
-			      [timeout : (Option Natural)]
-			      [known-addresses : (HashTable DomainName (Listof UdpAddress))]
-			      [remaining-addresses : (Listof UdpAddress)]
-			      [current-name : (Option DomainName)]
-			      [remaining-names : (Listof DomainName)])
-	 #:transparent)
-(define-type NetworkQueryState network-query-state)
-
-(: next-timeout : Natural -> (Option Natural))
 (define (next-timeout timeout)
   (cond
    [(equal? timeout 3) 11]
    [(equal? timeout 11) 45]
    [else #f]))
 
-(: make-dns-query-message : Question Nonnegative-Integer -> DNSMessage)
+;; (: make-dns-query-message : Question Nonnegative-Integer -> DNSMessage)
 (define (make-dns-query-message q query-id)
   (dns-message query-id
 	       'request
@@ -183,9 +149,9 @@
 	       '()
 	       '()))
 
-(define-type CheckedAnswer (U (Option CompleteAnswer) 'bad-answer 'lame-delegation))
+;; (define-type CheckedAnswer (U (Option CompleteAnswer) 'bad-answer 'lame-delegation))
 
-(: filter-dns-reply : Question DNSMessage DomainName -> CheckedAnswer)
+;; (: 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
@@ -200,25 +166,24 @@
 (define (filter-dns-reply q message zone-origin)
   (case (dns-message-response-code message)
     [(no-error)
-     (: f : (Listof RR) -> (Setof RR))
+     ;; (: f : (Listof RR) -> (Setof RR))
      (define (f l)
-       (list->set (filter (lambda: ([claim-rr : RR])
+       (list->set (filter (lambda (claim-rr) (in-bailiwick? (rr-name claim-rr) zone-origin)) l)))
-			    (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 : RR]) (and (eqv? (rdata-type (rr-rdata rr)) 'ns)
+       (filter (lambda (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 : RR]) (equal? (rr-name rr) (question-repr-name q))) answers))
+       (set-filter (lambda (rr) (equal? (rr-name rr) (question-name q))) answers))
      (define lame?
        (and (set-empty? (filter-by-type answers-to-q 'cname))
-	    (set-empty? (filter-rrs answers-to-q (question-repr-type q) (question-repr-class q)))
+	    (set-empty? (filter-rrs answers-to-q (question-type q) (question-class q)))
 	    (set-empty? (filter-by-type authorities 'soa))
 	    (not (null? non-subzone-ns-rrs))))
      (if lame?
@@ -228,171 +193,129 @@
 			  (f (dns-message-additional message))))]
     [(name-error) #f]
     [else
-     (log-info (format "Abnormal response-code ~v in response to questions ~v"
+     (log-info "Abnormal response-code ~v in response to questions ~v"
-		       (dns-message-response-code message)
+               (dns-message-response-code message)
-		       (dns-message-questions message)))
+               (dns-message-questions message))
      'bad-answer]))
 
-(: ip->host-name : 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)
+;; (: make-dns-address : IPv4 -> UdpAddress)
 (define (make-dns-address ip-address)
   (udp-remote-address (ip->host-name ip-address) 53))
 
-(: network-query : (All (ParentState)
+;; (: network-query : (All (ParentState)
-			UdpAddress Question DomainName (Listof DomainName) Any ->
+;; 			UdpAddress Question DomainName (Listof DomainName) Any ->
-			(Action ParentState)))
+;; 			Void))
 (define (network-query s q zone-origin server-names unique-id)
-  (name-process (list 'network-query q)
+  (spawn*
-    (spawn: #:parent : ParentState
+   #:name (list 'network-query q)
-	    #:child : NetworkQueryState
+   (field [timeout first-timeout]
-	    (try-next-server
+          [known-addresses #hash()] ;; Hash DomainName (Listof UdpAddress)
-	     (network-query-state (network-request s q zone-origin server-names unique-id)
+          [remaining-addresses '()] ;; Listof UdpAddress
-				  first-timeout
+          [current-name #f] ;; Option DomainName
-				  (ann #hash() (HashTable DomainName (Listof UdpAddress)))
+          [remaining-names server-names]) ;; Listof DomainName
-				  '()
-				  #f
-				  server-names)))))
 
-(: try-next-server : NetworkQueryState -> (Transition NetworkQueryState))
+   (define (on-answer ans server-ip)
-(define (try-next-server w)
+     (match ans
-  (define timeout (network-query-state-timeout w))
+       ['bad-answer ;; can come from filter-dns-reply
-  (if (not timeout)
+        (try-next-server)]
-      ;; No more timeouts to try, so give up.
+       ['lame-delegation ;; can come from filter-dns-reply
-      (on-answer w (empty-complete-answer) #f)
+        (log-info "Lame delegation received from ~v (at ~v) in bailiwick ~v in response to ~v"
-      (match w
+                  (current-name)
-	[(network-query-state req _ _ '() _ '())
+                  server-ip
-	 ;; No more addresses to try with this timeout. Refill the list
+                  zone-origin
-	 ;; and bump the timeout and retry.
+                  q)
-	 ;; TODO: randomize ordering of servers in list. (Don't forget the initial fill.)
+        (when (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.
-			    [timeout (next-timeout timeout)]
+          (known-addresses (hash-update (known-addresses)
-			    [remaining-addresses '()]
+                                        (current-name)
-			    [current-name #f]
+                                        (lambda (addrs) (remove server-ip addrs)))))
-			    [remaining-names (network-request-server-names req)]))]
+        (try-next-server)]
-	[(network-query-state req _ known-addresses '() _ (cons current-name remaining-names))
+       [(and (or (? complete-answer?) #f) ans)
-	 (if (hash-has-key? known-addresses current-name)
+        (send! (network-reply unique-id ans))]))
-	     (try-next-server (struct-copy network-query-state w
-				[remaining-addresses (hash-ref known-addresses current-name)]
-				[current-name current-name]
-				[remaining-names remaining-names]))
-	     (let ((subq (ns-question current-name (network-request-question req))))
-	       (transition: (struct-copy network-query-state w
-			      [current-name current-name]
-			      [remaining-names remaining-names]) : NetworkQueryState
-		 (send-message subq)
-		 (let-fresh (subq-id)
-		   (name-endpoint subq-id
-		     (subscriber: NetworkQueryState (answered-question-pattern subq (wild))
-		       (match-state w
-			 (on-message
-			  [(answered-question (== subq) ans)
-			   (let ((ips (map make-dns-address
-					   (set->list (extract-addresses current-name ans)))))
-			     (sequence-actions
-			      (try-next-server (struct-copy network-query-state w
-						 [known-addresses (hash-set known-addresses
-									    current-name
-									    ips)]
-						 [remaining-addresses ips]))
-			      (delete-endpoint subq-id)))]))))))))]
-	[(network-query-state req _ _ (cons current-ip remaining-ips) _ _)
-	 (define rpc-id (gensym 'network-query/allocate-query-id))
-	 (transition: w : NetworkQueryState
-	   (send-message `(request ,rpc-id allocate-query-id))
-	   (name-endpoint rpc-id
-	     (subscriber: NetworkQueryState `(reply ,rpc-id ,(wild))
-	       (match-state w
-		 (on-message
-		  [`(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)
+   (define (try-next-server)
-   -> (Transition NetworkQueryState))
+     (if (not (timeout))
-(define (on-answer w ans server-ip)
+         ;; No more timeouts to try, so give up.
-  (match ans
+         (on-answer (empty-complete-answer) #f)
-    ['bad-answer ;; can come from filter-dns-reply
+         (match (remaining-addresses)
-     (try-next-server w)]
+           ['()
-    ['lame-delegation ;; can come from filter-dns-reply
+            (match (remaining-names)
-     (match-define (network-query-state req _ known-addresses _ current-name _) w)
+              ['()
-     (match-define (network-request _ q zone-origin _ _) req)
+               ;; No more addresses to try with this timeout. Refill the list
-     (log-info (format "Lame delegation received from ~v (at ~v) in bailiwick ~v in response to ~v"
+               ;; and bump the timeout and retry.
-		       current-name
+               ;; TODO: randomize ordering of servers in list. (Don't forget the initial fill.)
-		       server-ip
+               (timeout (next-timeout (timeout)))
-		       zone-origin
+               (current-name #f)
-		       q))
+               (remaining-names server-names)
-     (try-next-server (if (and current-name server-ip)
+               (try-next-server)]
-			  ;; Actually remove the offending IP address so it's never tried again.
+              [(cons next-name new-remaining-names)
-			  (struct-copy network-query-state w
+               (current-name next-name)
-			    [known-addresses (hash-update known-addresses
+               (remaining-names new-remaining-names)
-							  current-name
+               (if (hash-has-key? (known-addresses) next-name)
-							  (lambda: ([addrs : (Listof
+                   (begin (remaining-addresses (hash-ref (known-addresses) (current-name)))
-									      UdpAddress)])
+                          (try-next-server))
-							    (remove server-ip addrs)))])
+                   (let ((subq (ns-question next-name q)))
-			  w))]
+                     (react (on-start (send! subq))
-    [(and (or (? complete-answer?) #f) ans)
+                            (stop-when (message (answered-question subq $ans))
-     (transition: w : NetworkQueryState
+                                       (define ips
-       (send-message (network-reply (network-request-unique-id (network-query-state-request w))
+                                         (for/list [(a (extract-addresses next-name ans))]
-				    ans)))]))
+                                           (make-dns-address a)))
+                                       (known-addresses (hash-set (known-addresses) next-name ips))
+                                       (remaining-addresses ips)
+                                       (try-next-server)))))])]
+           [(cons current-ip new-remaining-ips)
+            (remaining-addresses new-remaining-ips)
+            (define rpc-id (gensym 'network-query/allocate-query-id))
+            (react (on-start (send! `(request ,rpc-id allocate-query-id)))
+                   (stop-when (message `(reply ,rpc-id ,(? exact-nonnegative-integer? $id)))
+                              (remaining-addresses new-remaining-ips)
+                              (send-request id current-ip)))])))
 
-(: send-request : NetworkQueryState Nonnegative-Integer Natural UdpAddress
+   (define (send-request query-id server-ip)
-   -> (Transition NetworkQueryState))
+     (define query (make-dns-query-message q query-id))
-(define (send-request w query-id timeout server-ip)
+     (define reply-wait-id (list s query-id 'reply-wait))
-  (match-define (network-request s q zone-origin _ _) (network-query-state-request w))
+     (define timeout-id (list s query-id 'timeout))
-  (define query (make-dns-query-message q query-id))
+     (define start-time (current-inexact-milliseconds))
-  (define reply-wait-id (list s query-id 'reply-wait))
+     (log-debug "Sending ~v ~v to ~v ~v with ~v seconds of timeout"
-  (define timeout-id (list s query-id 'timeout))
+                q query-id
-  (define start-time (current-inexact-milliseconds))
+                zone-origin server-ip
-  (log-debug (format "Sending ~v ~v to ~v ~v with ~v seconds of timeout"
+                (timeout))
-		     q query-id
+     ;; NB: ANALYSIS: Previous implementation of this used a
-		     zone-origin server-ip
+     ;; quasi-join, where one endpoint deleted the other. Here the two
-		     timeout))
+     ;; stop-when clauses do a similar job. Also, we can pull the
-  (transition: w : NetworkQueryState
+     ;; `release-query-id` send up to an on-stop clause.
-    (send-message (dns-request query s server-ip))
+     (react (on-start
-    (send-message (set-timer timeout-id (* timeout 1000) 'relative))
+             (send! (dns-request query s server-ip))
-    ;; TODO: Restore this to a "join" when proper pattern-unions are implemented
+             (send! (set-timer timeout-id (* (timeout) 1000) 'relative)))
-    (name-endpoint timeout-id
+            (on-stop
-      (subscriber: NetworkQueryState (timer-expired-pattern timeout-id (wild))
+             (send! (list 'release-query-id query-id)))
-	(match-state w
+            (stop-when (message (timer-expired timeout-id _))
-	  (on-message
+                       (log-debug "Timed out ~v ~v to ~v ~v after ~v seconds"
-	   [(timer-expired (== timeout-id) _)
+                                  q query-id
-	    (begin
+                                  zone-origin server-ip
-	      (log-debug (format "Timed out ~v ~v to ~v ~v after ~v seconds"
+                                  (timeout))
-				 q query-id
+                       (try-next-server))
-				 zone-origin server-ip
+            (stop-when (message (dns-reply
-				 timeout))
+                                 (? (lambda (m) (= (dns-message-id m)
-	      (sequence-actions (try-next-server w)
+                                                   (dns-message-id query)))
-				(delete-endpoint timeout-id)
+                                    $reply-message)
-				(delete-endpoint reply-wait-id)
+                                 $source
-				(send-message (list 'release-query-id query-id))))]))))
+                                 s))
-    (name-endpoint reply-wait-id
+                       ;; TODO: maybe receive only specifically from the queried IP address?
-      (subscriber: NetworkQueryState (dns-reply-pattern (wild) (wild) s)
+                       (log-debug "Answer to ~v from ~v ~v in ~v ms~n-- Answers: ~v~n-- Authorities: ~v~n-- Additional: ~v"
-	(match-state w
+                                  q zone-origin server-ip
-	  (on-message
+                                  (inexact->exact (round (- (current-inexact-milliseconds) start-time)))
-	   [(dns-reply reply-message source (== s))
+                                  (dns-message-answers reply-message)
-	    ;; TODO: maybe receive only specifically from the queried IP address?
+                                  (dns-message-authorities reply-message)
-	    (begin
+                                  (dns-message-additional reply-message))
-	      (log-debug
+                       (on-answer (filter-dns-reply q reply-message zone-origin) server-ip))))
-	       (format
+
-		"Answer to ~v from ~v ~v in ~v ms~n-- Answers: ~v~n-- Authorities: ~v~n-- Additional: ~v"
+   (try-next-server)))
-		q zone-origin server-ip
+
-		(inexact->exact (round (- (current-inexact-milliseconds) start-time)))
+(define ((dns-message-id-matches? expected) m)
-		(dns-message-answers reply-message)
+  (= (dns-message-id m) expected))
-		(dns-message-authorities reply-message)
-		(dns-message-additional reply-message)))
-	      (if (not (= (dns-message-id reply-message) (dns-message-id query)))
-		  (transition: w : NetworkQueryState)
-		  (sequence-actions (on-answer w
-					       (filter-dns-reply q reply-message zone-origin)
-					       server-ip)
-				    (delete-endpoint timeout-id)
-				    (delete-endpoint reply-wait-id)
-				    (send-message (list 'release-query-id query-id)))))]))))))

proxy.rkt

@@ -1,4 +1,4 @@
-#lang typed/racket/base
+#lang racket/base
 ;; DNS proxy using os-big-bang.rkt and os-udp.rkt.
 ;;
 ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@@ -28,10 +28,10 @@
 (require "zonedb.rkt")
 (require "network-query.rkt")
 (require "resolver.rkt")
-(require marketplace/sugar-typed)
+(require (except-in syndicate dataspace assert))
-(require marketplace/support/spy)
+(require syndicate/actor)
-(require marketplace/drivers/timer)
+(require syndicate/drivers/timer)
-(require marketplace/drivers/udp)
+(require syndicate/drivers/udp)
 (require "tk-dns.rkt")
 
 (require racket/pretty)
@@ -40,343 +40,262 @@
 ;; searches from. Performs recursive queries.
 
 ;; For discarding retransmitted requests that we're still working on.
-(struct: active-request ([source : UdpAddress] [id : Natural]) #:transparent)
+(struct active-request (source id) #:transparent)
-(define-type ActiveRequest active-request)
 
-(: start-proxy : Natural 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:
+  (run-ground
-   ((inst generic-spy Void) 'UDP)
+   (spawn-timer-driver)
-   ((inst udp-driver Void))
+   (spawn-udp-driver)
-   ((inst timer-driver Void))
+   (dataspace #:name 'dns-vm
-   (spawn-vm: : Void
+              (dns-spy)
-	      #:debug-name 'dns-vm
+              (spawn #:name 'timer-relay:dns
-	      (name-process 'dns-spy (spawn: #:parent : Void #:child : Void (dns-spy)))
+                     (on (message (inbound ($ m (timer-expired _ _)))) (send! m))
-	      ((inst timer-relay Void) 'timer-relay:dns)
+                     (on (message ($ m (set-timer _ _ _))) (send! (outbound m))))
-	      (name-process  'query-id-allocator (spawn: #:parent : Void #:child : (Setof Natural)
+              (query-id-allocator)
-							 (query-id-allocator)))
+              (dns-read-driver server-addr)
-	      (name-process 'server-dns-reader (spawn: #:parent : Void #:child : Void
+              (dns-write-driver server-addr)
-						       (dns-read-driver server-addr)))
+              (dns-read-driver client-addr)
-	      (name-process 'server-dns-writer (spawn: #:parent : Void #:child : Void
+              (dns-write-driver client-addr)
-						       (dns-write-driver server-addr)))
+              (packet-dispatcher server-addr)
-	      (name-process 'client-dns-reader (spawn: #:parent : Void #:child : Void
+              (question-dispatcher zone roots-only client-addr)
-						       (dns-read-driver client-addr)))
+              (forever))))
-	      (name-process 'client-dns-writer (spawn: #:parent : Void #:child : Void
-						       (dns-write-driver client-addr)))
-	      (name-process 'packet-dispatcher (spawn: #:parent : Void
-						       #:child : (Setof ActiveRequest)
-						       (packet-dispatcher server-addr)))
-	      (name-process 'question-dispatcher (spawn: #:parent : Void
-							 #:child : CompiledZone
-							 (question-dispatcher zone
-									      roots-only
-									      client-addr))))))
 
-(: query-id-allocator : -> (Transition (Setof Natural)))
+;; (: query-id-allocator : -> Void)
 (define (query-id-allocator)
   ;; TODO: track how many are allocated and throttle requests if too
   ;; many are in flight
-  (transition: ((inst set Natural)) : (Setof Natural) ;; all active query IDs
+  (spawn #:name 'query-id-allocator
-    (subscriber: (Setof Natural) `(request ,(wild) allocate-query-id)
+         (field [allocated (set)])
-      (match-state allocated
+         (on (message `(request ,$reply-addr allocate-query-id))
-	(on-message
+             (let recheck ()
-	 [`(request ,reply-addr allocate-query-id)
+               (define n (random 65536))
-	  (let: recheck : (Transition (Setof Natural)) ()
+               (if (set-member? (allocated) n)
-		(define n (random 65536))
+                   (recheck)
-		(if (set-member? allocated n)
+                   (begin (allocated (set-add (allocated) n))
-		    (recheck)
+                          (send! `(reply ,reply-addr ,n))))))
-		    (transition: (set-add allocated n) : (Setof Natural)
+         (on (message `(release-query-id ,(? exact-nonnegative-integer? $n)))
-		      (send-message `(reply ,reply-addr ,n)))))])))
+             (allocated (set-remove (allocated) n)))))
-    (subscriber: (Setof Natural) `(release-query-id ,(wild))
-      (match-state allocated
-	(on-message
-	 [`(release-query-id ,(? exact-nonnegative-integer? n))
-	  (transition: (set-remove allocated n) : (Setof Natural))])))))
 
-(: packet-dispatcher : UdpAddress -> (Transition (Setof ActiveRequest)))
+;; (: packet-dispatcher : UdpAddress -> Void)
 (define (packet-dispatcher s)
-  (transition: ((inst set ActiveRequest)) : (Setof ActiveRequest)
+  (spawn #:name 'packet-dispatcher
-    (subscriber: (Setof ActiveRequest) (bad-dns-packet-pattern (wild) (wild) (wild) (wild))
+         (field [old-active-requests (set)])
-      (on-message [p (begin (log-error (pretty-format p)) '())]))
+         (on (message ($ p (bad-dns-packet _ _ _ _)))
-    (subscriber: (Setof ActiveRequest) (dns-request-pattern (wild) (wild) s)
+             (log-error "~a" (pretty-format p)))
-      (match-state old-active-requests
+         (on (message ($ r (dns-request $m $source s)))
-	(on-message
+             ;; ^ We only listen for requests on our server socket
-	 [(and r (dns-request m source (== s)))
+             (define req-id (active-request source (dns-message-id m)))
-	  ;; ^ We only listen for requests on our server socket
+             ;; TODO: when we have presence/error-handling, remove req-id
-	  (let ((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
+             (when (not (set-member? (old-active-requests) req-id))
-	    ;; from active requests once request-handler pseudothread exits.
+               ;; ^ ignore retransmitted duplicates
-	    (if (set-member? old-active-requests req-id)
+               (old-active-requests (set-add (old-active-requests) req-id))
-		(transition: old-active-requests : (Setof ActiveRequest))
+               (packet-relay req-id r)))
-		;; ^ ignore retransmitted duplicates
+         (on (message ($ r (dns-reply $m s $sink)))
-		(transition: (set-add old-active-requests req-id) : (Setof ActiveRequest)
+             (define req-id (active-request sink (dns-message-id m)))
-		  (name-process (list 'packet-relay req-id)
+             (old-active-requests (set-remove (old-active-requests) req-id)))))
-		    (spawn: #:parent : (Setof ActiveRequest)
-			    #:child : Void (packet-relay req-id r))))))])))
-    (subscriber: (Setof ActiveRequest) (dns-reply-pattern (wild) s (wild))
-      (match-state old-active-requests
-	(on-message
-	 [(and r (dns-reply m (== s) sink))
-	  (let ((req-id (active-request sink (dns-message-id m))))
-	    (transition: (set-remove old-active-requests req-id) : (Setof ActiveRequest)))])))))
 
-(: packet-relay : ActiveRequest DNSRequest -> (Transition Void))
+;; (: packet-relay : ActiveRequest DNSRequest -> 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)
+
+  ;; (: answer->reply : (Option Question) (Option CompleteAnswer) -> DNSReply)
   (define (answer->reply q a)
     (define-values (response-code ns us ds)
       (match a
-	[#f
+        [#f
-	 (values 'name-error '() '() '())]
+         (values 'name-error '() '() '())]
-	[(complete-answer ns us ds)
+        [(complete-answer ns us ds)
-	 (values 'no-error (rr-set->list ns) (rr-set->list us) (rr-set->list ds))]))
+         (values 'no-error (rr-set->list ns) (rr-set->list us) (rr-set->list ds))]))
     (dns-reply
      (dns-message (dns-message-id request-message)
-		  'response
+                  'response
-		  'query
+                  'query
-		  'non-authoritative
+                  'non-authoritative
-		  'not-truncated
+                  'not-truncated
-		  (dns-message-recursion-desired request-message)
+                  (dns-message-recursion-desired request-message)
-		  'recursion-available
+                  'recursion-available
-		  response-code
+                  response-code
-		  (if q (list q) '())
+                  (if q (list q) '())
-		  ns
+                  ns
-		  us
+                  us
-		  ds)
+                  ds)
      request-sink
      request-source))
-  ;; TODO: pay attention to recursion-desired flag
-  (match (dns-message-questions request-message)
-    ['()
-     ;; No questions!
-     (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
-       (send-message original-question)
-       (let-fresh (wait-id)
-	 (name-endpoint wait-id
-	   (subscriber: Void (answered-question-pattern original-question (wild))
-	     (on-message
-	      [(answered-question (== original-question) answer)
-	       (begin (log-debug (format "Final answer to ~v with query id ~v is ~v"
-					 original-question
-					 (dns-message-id request-message)
-					 answer))
-		      (list (delete-endpoint wait-id)
-			    (send-message (answer->reply original-question answer))))])))))]))
 
-(: glueless-question-handler : CompiledZone Question UdpAddress -> (Transition Void))
+  (spawn*
+   #:name (list 'packet-relay req-id)
+
+   ;; TODO: pay attention to recursion-desired flag
+   (match (dns-message-questions request-message)
+     ['()
+      ;; No questions!
+      (send! (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)))
+      (send! original-question)
+      (react (stop-when (message (answered-question original-question $answer))
+                        (log-debug "Final answer to ~v with query id ~v is ~v"
+                                   original-question
+                                   (dns-message-id request-message)
+                                   answer)
+                        (send! (answer->reply original-question answer))))])))
+
+;; (: glueless-question-handler : CompiledZone Question UdpAddress -> 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
+  (spawn #:name (list 'glueless-question-handler q)
-    (let-fresh (relay)
+         (stop-when (message (answered-question restarted-question $ans))
-      (name-endpoint relay
+                    ;; We got the answer to our restarted question; now transform
-	(subscriber: Void (answered-question-pattern restarted-question (wild))
+                    ;; it into an answer to the original question, to unblock the
-	  (on-message
+                    ;; original questioner.
-	   [(answered-question (== restarted-question) ans)
+                    (send! (answered-question q ans)))
-	    ;; We got the answer to our restarted question; now transform
+         (on-start (question-handler roots-only-zone restarted-question client-sock))))
-	    ;; it into an answer to the original question, to unblock the
-	    ;; original questioner.
-	    (list (delete-endpoint relay)
-		  (send-message (answered-question q ans)))]))))
-    (name-process (list 'glueless-question-handler-inner restarted-question)
-      (spawn: #:parent : Void
-	      #:child : QHState
-	      (question-handler roots-only-zone restarted-question client-sock)))))
 
-(: question-dispatcher : CompiledZone CompiledZone UdpAddress -> (Transition CompiledZone))
+;; (: question-dispatcher : CompiledZone CompiledZone UdpAddress -> Void)
 (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 : CompiledZone
-      (for/list: : (Listof (Action CompiledZone)) ([timerspec timers])
-	(match-define (cons name ttl) timerspec)
-	(send-message (set-timer (list 'check-dns-expiry name) (* ttl 1000) 'relative)))))
   (define-values (cleaned-seed-zone initial-timers) (zone-expire seed-zone))
-  (sequence-actions (transition-and-set-timers cleaned-seed-zone initial-timers)
+  (spawn #:name 'question-dispatcher
-    ;; TODO: consider deduping questions here too?
+         (field [zone cleaned-seed-zone])
-    (subscriber: CompiledZone `(debug-dump)
+         (on-start (set-timers! initial-timers))
-      (match-state zone
-	(on-message
-	 [`(debug-dump)
-	  (begin
-	    (with-output-to-file "zone-proxy.zone"
-	      (lambda ()
-		(write-bytes (bit-string->bytes (zone->bit-string zone))))
-	      #:mode 'binary
-	      #:exists 'replace)
-	    (with-output-to-file "zone-proxy.dump"
-	      (lambda ()
-		(display "----------------------------------------------------------------------\n")
-		(display (seconds->date (current-seconds)))
-		(newline)
-		(for: ([name (in-hash-keys zone)])
-		  (define rrmap (hash-ref zone name))
-		  (for: ([rr (in-hash-keys rrmap)])
-		    (define expiry (hash-ref rrmap rr))
-		    (write (list rr expiry))
-		    (newline)))
-		(newline))
-	      #:mode 'text
-	      #:exists 'append)
-	    ;; (with-output-to-file "zone-proxy.debug"
-	    ;;   (lambda ()
-	    ;;     (display "----------------------------------------------------------------------\n")
-	    ;;     (display (seconds->date (current-seconds)))
-	    ;;     (newline)
-	    ;;     (pretty-write current-ground-transition))
-	    ;;   #:mode 'text
-	    ;;   #:exists 'append)
-	    (transition: zone : CompiledZone))])))
-    (subscriber: CompiledZone (question-pattern (wild) (wild) (wild) (wild))
-      (match-state zone
-	(on-message
-	 [(? question? q)
-	  (transition: zone : CompiledZone
-	    (cond
-	     [(question-cyclic? q)
-	      (log-warning (format "Cyclic question ~v" q))
-	      (send-message (answered-question q (empty-complete-answer)))]
-	     [(question-too-glueless? q)
-	      (log-warning (format "Overly-glueless question ~v" q))
-	      (name-process (list 'glueless-question-handler-outer q)
-		(spawn: #:parent : CompiledZone
-			#:child : Void
-			(glueless-question-handler roots-only q client-sock)))]
-	     [else
-	      (name-process (list 'question-handler q)
-		(spawn: #:parent : CompiledZone
-			#:child : QHState
-			(question-handler zone q client-sock)))]))])))
-    (subscriber: CompiledZone (network-reply-pattern (wild) (wild))
-      (match-state zone
-	(on-message
-	 [(network-reply _ answer)
-	  (let-values (((new-zone timers) (incorporate-complete-answer answer zone #t)))
-	    (transition-and-set-timers new-zone timers))])))
-    (subscriber: CompiledZone (timer-expired-pattern (list 'check-dns-expiry (wild)) (wild))
-      (match-state zone
-	(on-message
-	 [(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 : CompiledZone]
+         (define (set-timers! timers)
-			 [q : Question]
+           (for/list ([timerspec timers])
-			 [client-sock : UdpAddress]
+             (match-define (cons name ttl) timerspec)
-			 [nameservers-tried : (Setof DomainName)]
+             (send! (set-timer (list 'check-dns-expiry name) (* ttl 1000) 'relative))))
-			 [retry-count : Natural]) #:transparent)
-(define-type QuestionState question-state)
 
-(struct: expanding-cnames ([q : Question]
+         ;; TODO: consider deduping questions here too?
-			   [accumulator : CompleteAnswer]
-			   [remaining-count : Integer]) #:transparent)
-(define-type ExpandingCNAMEs expanding-cnames)
 
-(define-type QHState (U QuestionState ExpandingCNAMEs))
+         (on (message `(debug-dump))
+             (with-output-to-file "zone-proxy.zone"
+               (lambda ()
+                 (write-bytes (bit-string->bytes (zone->bit-string (zone)))))
+               #:mode 'binary
+               #:exists 'replace)
+             (with-output-to-file "zone-proxy.dump"
+               (lambda ()
+                 (display "----------------------------------------------------------------------\n")
+                 (display (seconds->date (current-seconds)))
+                 (newline)
+                 (for ([name (in-hash-keys (zone))])
+                   (define rrmap (hash-ref (zone) name))
+                   (for ([rr (in-hash-keys rrmap)])
+                     (define expiry (hash-ref rrmap rr))
+                     (write (list rr expiry))
+                     (newline)))
+                 (newline))
+               #:mode 'text
+               #:exists 'append)
+             ;; (with-output-to-file "zone-proxy.debug"
+             ;;   (lambda ()
+             ;;     (display "----------------------------------------------------------------------\n")
+             ;;     (display (seconds->date (current-seconds)))
+             ;;     (newline)
+             ;;     (pretty-write current-ground-transition))
+             ;;   #:mode 'text
+             ;;   #:exists 'append)
+             )
 
-(: question-handler : CompiledZone Question UdpAddress -> (Transition QHState))
+         (on (message ($ q (question _ _ _ _)))
-(define (question-handler zone q client-sock)
+             (cond
-  (retry-question (question-state zone q client-sock ((inst set DomainName)) 0)))
+               [(question-cyclic? q)
+                (log-warning (format "Cyclic question ~v" q))
+                (send! (answered-question q (empty-complete-answer)))]
+               [(question-too-glueless? q)
+                (log-warning (format "Overly-glueless question ~v" q))
+                (glueless-question-handler roots-only q client-sock)]
+               [else
+		(question-handler (zone) q client-sock)]))
 
-(: send-empty-reply : QHState Question -> (Transition QHState))
+         (on (message (network-reply _ $answer))
-(define (send-empty-reply w q)
+             (define-values (new-zone timers) (incorporate-complete-answer answer (zone) #t))
-  (transition w (send-message (answered-question q (empty-complete-answer)))))
+             (zone new-zone)
+             (set-timers! timers))
 
-(: retry-question : QHState -> (Transition QHState))
+         (on (message (timer-expired (list 'check-dns-expiry (? domain? $name))
-(define (retry-question w)
+                                     (? number? $now-msec)))
-  (match w
+             (zone (zone-expire-name (zone) name (/ now-msec 1000.0))))))
-    [(question-state _ q _ _ 20) ;; TODO: is this a sensible limit?
+
-     ;; Too many retries, i.e. too many referrals.
+;; (: send-empty-reply! : Question -> Void)
-     (log-error (format "Too many retries: ~v" w))
+(define (send-empty-reply! q)
-     (send-empty-reply w q)]
+  (send! (answered-question q (empty-complete-answer))))
-    [(question-state zone q client-sock nameservers-tried old-retry-count)
+
-     ;; Credit remaining. Try once more (perhaps for the first time, in fact).
+;; (: question-handler : CompiledZone Question UdpAddress -> Void)
-     (define resolution-result (resolve-from-zone q zone #f nameservers-tried))
+(define (question-handler zone0 q client-sock)
-     (log-debug (format "Resolution result: ~v" resolution-result))
+  (spawn*
-     (match resolution-result
+   #:name (list 'question-handler q)
-       [#f ;; We're not authoritative so this is just a signal that we can't answer usefully
+   (let retry-question ((zone zone0)
-	(send-empty-reply w q)]
+                        (nameservers-tried (set))
-       [(referral zone-origin nameserver-rrs _)
+                        (retry-count 0))
-	(define referral-id (gensym 'referral))
+     (if (= retry-count 20) ;; TODO: is this a sensible limit?
-	(log-debug (format "Referral for ~v id ~v to ~v servers ~v"
+         ;; Too many retries, i.e. too many referrals.
-			   q referral-id (domain-labels zone-origin)
+         (begin (log-error (format "Too many retries: ~v" q))
-			   (map domain-labels (set-map nameserver-rrs rr-rdata-domain-name))))
+                (send-empty-reply! q))
-	(transition: w : QHState
+         ;; Credit remaining. Try once more (perhaps for the first time, in fact).
-	  ((inst network-query QHState) client-sock
+         (let ((resolution-result (resolve-from-zone q zone #f nameservers-tried)))
-	                                q
+           (log-debug (format "Resolution result: ~v" resolution-result))
-					zone-origin
+
-					(map rr-rdata-domain-name (set->list nameserver-rrs))
+           (match resolution-result
-					referral-id)
+             [#f ;; We're not authoritative so this is just a signal that we can't answer usefully
-	  (name-endpoint referral-id
+              (send-empty-reply! q)]
-	    (subscriber: QHState (network-reply-pattern referral-id (wild))
+
-	      (match-state w
+             [(referral zone-origin nameserver-rrs _)
-		(on-message
+              (define referral-id (gensym 'referral))
-		 [(network-reply (== referral-id) #f) ;; name-error/NXDOMAIN
+              (log-debug (format "Referral for ~v id ~v to ~v servers ~v"
-		  (transition: w : QHState
+                                 q referral-id (domain-labels zone-origin)
-		    (delete-endpoint referral-id)
+                                 (map domain-labels (set-map nameserver-rrs rr-rdata-domain-name))))
-		    (send-message (answered-question q #f)))]
+              (network-query client-sock
-		 [(network-reply (== referral-id) ans)
+                             q
-		  (let-values (((new-zone ignored-timers)
+                             zone-origin
-				(incorporate-complete-answer ans zone #f)))
+                             (map rr-rdata-domain-name (set->list nameserver-rrs))
-		    (when (log-level? (current-logger) 'debug)
+                             referral-id)
-		      (log-debug (format "Referral ~v results in origin ~v:~n"
+              (react (stop-when
-					 referral-id zone-origin))
+                      (message (network-reply referral-id $ans))
-		      (for ([k (set-union (list->set (hash-keys zone))
+                      (cond [(not ans) ;; name-error/NXDOMAIN
-					  (list->set (hash-keys new-zone)))]
+                             (send! (answered-question q #f))]
-			    #:when (in-bailiwick? k zone-origin))
+                            [else
-			(log-debug (format "Old ~v ~v~nNew ~v ~v"
+                             (define-values (new-zone _ignored-timers)
-					   k (hash-ref zone k (lambda () 'missing))
+                               (incorporate-complete-answer ans zone #f))
-					   k (hash-ref new-zone k (lambda () 'missing)))))
+                             (when (log-level? (current-logger) 'debug)
-		      (log-debug "=-=-=-=-=-="))
+                               (log-debug "Referral ~v results in origin ~v:~n"
-		    (define nameserver-names
+                                          referral-id zone-origin)
-		      (list->set
+                               (for ([k (set-union (list->set (hash-keys zone))
-		       (for/list: : (Listof DomainName)
+                                                   (list->set (hash-keys new-zone)))]
-				  ([rr nameserver-rrs])
+                                     #:when (in-bailiwick? k zone-origin))
-				  (rr-rdata-domain-name rr))))
+                                 (log-debug "Old ~v ~v~nNew ~v ~v"
-		    (sequence-actions
+                                            k (hash-ref zone k (lambda () 'missing))
-			(retry-question (struct-copy question-state w
+                                            k (hash-ref new-zone k (lambda () 'missing))))
-					  [nameservers-tried (set-union nameservers-tried
+                               (log-debug "=-=-=-=-=-="))
-									nameserver-names)]
+                             (define nameserver-names
-					  [zone new-zone]
+                               (for/set ([rr nameserver-rrs]) (rr-rdata-domain-name rr)))
-					  [retry-count (+ old-retry-count 1)]))
+                             (retry-question new-zone
-		      (delete-endpoint referral-id)))])))))]
+                                             (set-union nameservers-tried nameserver-names)
-       [(? complete-answer? ans)
+                                             (+ retry-count 1))])))]
-	(transition: w : QHState (send-message (answered-question q ans)))]
+
-       [(partial-answer base cnames)
+             [(? complete-answer? ans)
-	(transition: (expanding-cnames q base (length cnames)) : QHState
+              (send!  (answered-question q ans))]
-	  ((inst map (ActionTree QHState) DomainName)
+
-	   (lambda: ([cname : DomainName])
+             [(partial-answer base cnames)
-	     ;; TODO: record chains of CNAMEs to avoid pathologically-long chains
+              ;; TODO: record chains of CNAMEs to avoid pathologically-long chains
-	     (define cname-q (cname-question cname q))
+              (react (field [acc base]
-	     (list (send-message cname-q)
+                            [remaining (length cnames)])
-		   (let-fresh (subscription-id)
+                     (on-start (for [(cname cnames)]
-		     (name-endpoint subscription-id
+                                 (define cname-q (cname-question cname q))
-		       (subscriber: QHState (answered-question-pattern cname-q (wild))
+                                 (react (on-start (send! cname-q))
-			 (match-state (expanding-cnames q acc remaining)
+                                        (stop-when (message (answered-question cname-q $ans))
-			   (on-message
+                                                   (acc (if ans (merge-answers (acc) ans) (acc)))
-			    [(answered-question (== cname-q) ans)
+                                                   (remaining (- (remaining) 1))))))
-			     (let ()
+                     (stop-when (rising-edge (zero? (remaining)))
-			       (define new-acc (if ans (merge-answers acc ans) acc))
+                                (send! (answered-question q (acc)))))]))))))
-			       (define new-remaining (- remaining 1))
-			       (define new-w (expanding-cnames q new-acc new-remaining))
-			       (transition: new-w : QHState
-				 (delete-endpoint subscription-id)
-				 (if (zero? new-remaining)
-				     (send-message (answered-question q new-acc))
-				     '())))])))))))
-	   cnames))])]))
 
 (require "test-rrs.rkt")
 (require racket/file)

resolver.rkt

@@ -1,4 +1,4 @@
-#lang typed/racket/base
+#lang racket/base
 ;;
 ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
 ;;;
@@ -27,12 +27,8 @@
 (require "codec.rkt")
 (require "zonedb.rkt")
 
-(provide PartialAnswer
+(provide (struct-out partial-answer)
-	 Referral
-	 Answer
-	 (struct-out partial-answer)
 	 (struct-out referral)
-
 	 resolve-from-zone)
 
 ;; Rules:
@@ -67,27 +63,22 @@
 ;; -- 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 : CompleteAnswer] [cnames : (Listof DomainName)]) #:transparent)
+(struct partial-answer (base cnames) #:transparent)
-(define-type PartialAnswer partial-answer)
 
 ;; A Referral is a (referral DomainName Set<RR> Set<RR>)
-(struct: referral ([zone-origin : DomainName]
+(struct referral (zone-origin nameserver-rrs additional) #:transparent)
-		   [nameserver-rrs : (Setof RR)]
-		   [additional : (Setof RR)]) #:transparent)
-(define-type Referral referral)
 
-(: answer-from-zone : Question CompiledZone (Option RR) -> Answer)
+;; (: 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 : (Setof RR) (or (zone-ref zone name) (set)))
+  (define rrset (or (zone-ref zone name) (set)))
   (define filtered-rrs (filter-rrs rrset qtype qclass))
   (define cnames (filter-by-type rrset 'cname)) ;; TODO: filter by class too??
   (define answer-set (set-union cnames filtered-rrs))
@@ -105,9 +96,9 @@
    [else ;; Kick off the algorithm for CNAME expansion from RFC 1034 4.3.2 step 3a
     (partial-answer base (set-map cnames rr-rdata-domain-name))]))
 
-(: closest-nameservers : DomainName CompiledZone -> (Setof RR))
+;; (: closest-nameservers : DomainName CompiledZone -> (Setof RR))
 (define (closest-nameservers name zone)
-  (let: search ((name : (Option DomainName) name))
+  (let search ((name name))
     (cond
      ((not name)
       ;; We've walked up the tree past the root. Give up.
@@ -124,45 +115,44 @@
       ;; Remove a label and keep looking.
       (search (domain-parent name))))))
 
-(: closest-untried-nameservers : Question CompiledZone (Setof DomainName) -> (Setof RR))
+;; (: 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-repr-name q))
+  (define name (question-name q))
   (define ns-rrset (closest-nameservers name zone))
   (list->set
-   (for/list: : (Listof RR) ([rr : RR ns-rrset]
+   (for/list ([rr ns-rrset] #:when (not (set-member? nameservers-tried (rr-rdata-domain-name rr))))
-			     #:when (not (set-member? nameservers-tried (rr-rdata-domain-name rr))))
+     rr)))
-	      rr)))
 
-(: empty-answer : Question CompiledZone (Option RR) -> (Option CompleteAnswer))
+;; (: 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-repr-name q) (rr-name start-of-authority))
+	   (in-bailiwick? (question-name q) (rr-name start-of-authority))
 	   ;; ^ for this in particular
-	   (not (zone-includes-name? zone (question-repr-name q))))
+	   (not (zone-includes-name? zone (question-name q))))
            ;; ^ there are no RRs at all for this q
       ;; NXDOMAIN/name-error: we definitely know there are no RRs at all for this q.
       #f
       ;; A normal no-answers packet otherwise.
       (empty-complete-answer)))
 
-(: additional-section/a : CompiledZone (Listof DomainName) -> (Setof 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 : DomainName] [section : (Setof RR)])
+  (foldl (lambda (name section)
 	   (set-union section
-		      (set-filter (lambda: ([rr : RR])
+		      (set-filter (lambda (rr)
 				    (and (memv (rdata-type (rr-rdata rr)) '(a aaaa))
 					 (eqv? (rr-class rr) 'in)))
-				  (or (zone-ref zone name) ((inst set RR))))))
+				  (or (zone-ref zone name) (set)))))
-	 ((inst set RR))
+	 (set)
 	 names))
 
-(: resolve-from-zone : Question CompiledZone (Option RR) (Setof DomainName) -> Answer)
+;; (: 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)))

test-dns.rkt

@@ -156,30 +156,30 @@
 	       'no-error
 	       (list (question (domain '(#"google" #"com")) '* 'in #f))
 	       (list
-		(rr (domain '(#"google" #"com")) 'txt 'in 3119 '(#"v=spf1 include:_netblocks.google.com ip4:216.73.93.70/31 ip4:216.73.93.72/31 ~all"))
+		(rr (domain '(#"google" #"com")) 'in 3119 (rdata-txt 'txt '(#"v=spf1 include:_netblocks.google.com ip4:216.73.93.70/31 ip4:216.73.93.72/31 ~all")))
-		(rr (domain '(#"google" #"com")) 'a 'in 285 '#(74 125 226 146))
+		(rr (domain '(#"google" #"com")) 'in 285 (rdata-ipv4 'a '#(74 125 226 146)))
-		(rr (domain '(#"google" #"com")) 'a 'in 285 '#(74 125 226 148))
+		(rr (domain '(#"google" #"com")) 'in 285 (rdata-ipv4 'a '#(74 125 226 148)))
-		(rr (domain '(#"google" #"com")) 'a 'in 285 '#(74 125 226 145))
+		(rr (domain '(#"google" #"com")) 'in 285 (rdata-ipv4 'a '#(74 125 226 145)))
-		(rr (domain '(#"google" #"com")) 'a 'in 285 '#(74 125 226 147))
+		(rr (domain '(#"google" #"com")) 'in 285 (rdata-ipv4 'a '#(74 125 226 147)))
-		(rr (domain '(#"google" #"com")) 'a 'in 285 '#(74 125 226 144))
+		(rr (domain '(#"google" #"com")) 'in 285 (rdata-ipv4 'a '#(74 125 226 144)))
-		(rr (domain '(#"google" #"com")) 'ns 'in 238877 (domain '(#"ns2" #"google" #"com")))
+		(rr (domain '(#"google" #"com")) 'in 238877 (rdata-domain 'ns (domain '(#"ns2" #"google" #"com"))))
-		(rr (domain '(#"google" #"com")) 'ns 'in 238877 (domain '(#"ns3" #"google" #"com")))
+		(rr (domain '(#"google" #"com")) 'in 238877 (rdata-domain 'ns (domain '(#"ns3" #"google" #"com"))))
-		(rr (domain '(#"google" #"com")) 'ns 'in 238877 (domain '(#"ns1" #"google" #"com")))
+		(rr (domain '(#"google" #"com")) 'in 238877 (rdata-domain 'ns (domain '(#"ns1" #"google" #"com"))))
-		(rr (domain '(#"google" #"com")) 'ns 'in 238877 (domain '(#"ns4" #"google" #"com")))
+		(rr (domain '(#"google" #"com")) 'in 238877 (rdata-domain 'ns (domain '(#"ns4" #"google" #"com"))))
-		(rr (domain '(#"google" #"com")) 'mx 'in 42 (mx 20 (domain '(#"alt1" #"aspmx" #"l" #"google" #"com"))))
+		(rr (domain '(#"google" #"com")) 'in 42 (rdata-mx 'mx 20 (domain '(#"alt1" #"aspmx" #"l" #"google" #"com"))))
-		(rr (domain '(#"google" #"com")) 'mx 'in 42 (mx 30 (domain '(#"alt2" #"aspmx" #"l" #"google" #"com"))))
+		(rr (domain '(#"google" #"com")) 'in 42 (rdata-mx 'mx 30 (domain '(#"alt2" #"aspmx" #"l" #"google" #"com"))))
-		(rr (domain '(#"google" #"com")) 'mx 'in 42 (mx 10 (domain '(#"aspmx" #"l" #"google" #"com"))))
+		(rr (domain '(#"google" #"com")) 'in 42 (rdata-mx 'mx 10 (domain '(#"aspmx" #"l" #"google" #"com"))))
-		(rr (domain '(#"google" #"com")) 'mx 'in 42 (mx 40 (domain '(#"alt3" #"aspmx" #"l" #"google" #"com"))))
+		(rr (domain '(#"google" #"com")) 'in 42 (rdata-mx 'mx 40 (domain '(#"alt3" #"aspmx" #"l" #"google" #"com"))))
-		(rr (domain '(#"google" #"com")) 'mx 'in 42 (mx 50 (domain '(#"alt4" #"aspmx" #"l" #"google" #"com")))))
+		(rr (domain '(#"google" #"com")) 'in 42 (rdata-mx 'mx 50 (domain '(#"alt4" #"aspmx" #"l" #"google" #"com")))))
 	       '()
 	       (list
-		(rr (domain '(#"ns3" #"google" #"com")) 'a 'in 238287 '#(216 239 36 10))
+		(rr (domain '(#"ns3" #"google" #"com")) 'in 238287 (rdata-ipv4 'a '#(216 239 36 10)))
-		(rr (domain '(#"ns1" #"google" #"com")) 'a 'in 238287 '#(216 239 32 10))
+		(rr (domain '(#"ns1" #"google" #"com")) 'in 238287 (rdata-ipv4 'a '#(216 239 32 10)))
-		(rr (domain '(#"ns4" #"google" #"com")) 'a 'in 238287 '#(216 239 38 10))
+		(rr (domain '(#"ns4" #"google" #"com")) 'in 238287 (rdata-ipv4 'a '#(216 239 38 10)))
-		(rr (domain '(#"ns2" #"google" #"com")) 'a 'in 238287 '#(216 239 34 10))
+		(rr (domain '(#"ns2" #"google" #"com")) 'in 238287 (rdata-ipv4 'a '#(216 239 34 10)))
-		(rr (domain '(#"alt2" #"aspmx" #"l" #"google" #"com")) 'a 'in 240 '#(74 125 39 27))
+		(rr (domain '(#"alt2" #"aspmx" #"l" #"google" #"com")) 'in 240 (rdata-ipv4 'a '#(74 125 39 27)))
-		(rr (domain '(#"aspmx" #"l" #"google" #"com")) 'a 'in 246 '#(74 125 115 27))
+		(rr (domain '(#"aspmx" #"l" #"google" #"com")) 'in 246 (rdata-ipv4 'a '#(74 125 115 27)))
-		(rr (domain '(#"alt1" #"aspmx" #"l" #"google" #"com")) 'a 'in 33 '#(74 125 77 27)))))
+		(rr (domain '(#"alt1" #"aspmx" #"l" #"google" #"com")) 'in 33 (rdata-ipv4 'a '#(74 125 77 27))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Roundtrip tests
@@ -271,7 +271,7 @@
 	      'no-error
 	      (list (question (domain '(#"google" #"com")) 'aaaa 'in #f))
 	      '()
-	      (list (rr (domain '(#"google" #"com")) 'soa 'in 594 (soa (domain '(#"ns1" #"google" #"com")) (domain '(#"dns-admin" #"google" #"com")) 1454883 7200 1800 1209600 300)))
+	      (list (rr (domain '(#"google" #"com")) 'in 594 (rdata-soa 'soa (domain '(#"ns1" #"google" #"com")) (domain '(#"dns-admin" #"google" #"com")) 1454883 7200 1800 1209600 300)))
 	      '()))
 
 ;; Wed Jun 29 21:05:03 2011 (4e0bcbbf): UDP: localhost sent 32 bytes:
@@ -318,7 +318,7 @@
 	      'no-recursion-available
 	      'no-error
 	      (list (question (domain '(#"www" #"google" #"com")) 'aaaa 'in #f))
-	      (list (rr (domain '(#"www" #"google" #"com")) 'cname 'in 604800 (domain '(#"www" #"l" #"google" #"com"))))
+	      (list (rr (domain '(#"www" #"google" #"com")) 'in 604800 (rdata-domain 'cname (domain '(#"www" #"l" #"google" #"com")))))
 	      '()
 	      '()))
 
@@ -348,8 +348,8 @@
 	      'no-recursion-available
 	      'no-error
 	      (list (question (domain '(#"ipv6" #"google" #"com")) 'aaaa 'in #f))
-	      (list (rr (domain '(#"ipv6" #"google" #"com")) 'cname 'in 604800 (domain '(#"ipv6" #"l" #"google" #"com")))
+	      (list (rr (domain '(#"ipv6" #"google" #"com")) 'in 604800 (rdata-domain 'cname (domain '(#"ipv6" #"l" #"google" #"com"))))
-		    (rr (domain '(#"ipv6" #"l" #"google" #"com")) 'aaaa 'in 300 '#(32 1 72 96 128 15 0 0 0 0 0 0 0 0 0 104)))
+		    (rr (domain '(#"ipv6" #"l" #"google" #"com")) 'in 300 (rdata-ipv6 'aaaa '#(32 1 72 96 128 15 0 0 0 0 0 0 0 0 0 104))))
 	      '()
 	      '()))
 
@@ -440,24 +440,24 @@
 		'recursion-available
 		'no-error
 		(list (question X 'srv 'in #f))
-		(list (rr X 'srv 'in 882 (srv 20 0 5269 (domain '(#"xmpp-server4" #"l" #"google" #"com"))))
+		(list (rr X 'in 882 (rdata-srv 'srv 20 0 5269 (domain '(#"xmpp-server4" #"l" #"google" #"com"))))
-		      (rr X 'srv 'in 882 (srv 5 0 5269 (domain '(#"xmpp-server" #"l" #"google" #"com"))))
+		      (rr X 'in 882 (rdata-srv 'srv 5 0 5269 (domain '(#"xmpp-server" #"l" #"google" #"com"))))
-		      (rr X 'srv 'in 882 (srv 20 0 5269 (domain '(#"xmpp-server1" #"l" #"google" #"com"))))
+		      (rr X 'in 882 (rdata-srv 'srv 20 0 5269 (domain '(#"xmpp-server1" #"l" #"google" #"com"))))
-		      (rr X 'srv 'in 882 (srv 20 0 5269 (domain '(#"xmpp-server2" #"l" #"google" #"com"))))
+		      (rr X 'in 882 (rdata-srv 'srv 20 0 5269 (domain '(#"xmpp-server2" #"l" #"google" #"com"))))
-		      (rr X 'srv 'in 882 (srv 20 0 5269 (domain '(#"xmpp-server3" #"l" #"google" #"com")))))
+		      (rr X 'in 882 (rdata-srv 'srv 20 0 5269 (domain '(#"xmpp-server3" #"l" #"google" #"com")))))
-		(list (rr (domain '(#"google" #"com")) 'ns 'in 87076 (domain '(#"ns3" #"google" #"com")))
+		(list (rr (domain '(#"google" #"com")) 'in 87076 (rdata-domain 'ns (domain '(#"ns3" #"google" #"com"))))
-		      (rr (domain '(#"google" #"com")) 'ns 'in 87076 (domain '(#"ns4" #"google" #"com")))
+		      (rr (domain '(#"google" #"com")) 'in 87076 (rdata-domain 'ns (domain '(#"ns4" #"google" #"com"))))
-		      (rr (domain '(#"google" #"com")) 'ns 'in 87076 (domain '(#"ns2" #"google" #"com")))
+		      (rr (domain '(#"google" #"com")) 'in 87076 (rdata-domain 'ns (domain '(#"ns2" #"google" #"com"))))
-		      (rr (domain '(#"google" #"com")) 'ns 'in 87076 (domain '(#"ns1" #"google" #"com"))))
+		      (rr (domain '(#"google" #"com")) 'in 87076 (rdata-domain 'ns (domain '(#"ns1" #"google" #"com")))))
-		(list (rr (domain '(#"xmpp-server" #"l" #"google" #"com")) 'a 'in 282 '#(74 125 153 125))
+		(list (rr (domain '(#"xmpp-server" #"l" #"google" #"com")) 'in 282 (rdata-ipv4 'a '#(74 125 153 125)))
-		      (rr (domain '(#"xmpp-server1" #"l" #"google" #"com")) 'a 'in 1782 '#(74 125 53 125))
+		      (rr (domain '(#"xmpp-server1" #"l" #"google" #"com")) 'in 1782 (rdata-ipv4 'a '#(74 125 53 125)))
-		      (rr (domain '(#"xmpp-server2" #"l" #"google" #"com")) 'a 'in 1782 '#(74 125 47 125))
+		      (rr (domain '(#"xmpp-server2" #"l" #"google" #"com")) 'in 1782 (rdata-ipv4 'a '#(74 125 47 125)))
-		      (rr (domain '(#"xmpp-server3" #"l" #"google" #"com")) 'a 'in 1782 '#(74 125 45 125))
+		      (rr (domain '(#"xmpp-server3" #"l" #"google" #"com")) 'in 1782 (rdata-ipv4 'a '#(74 125 45 125)))
-		      (rr (domain '(#"xmpp-server4" #"l" #"google" #"com")) 'a 'in 1782 '#(74 125 45 125))
+		      (rr (domain '(#"xmpp-server4" #"l" #"google" #"com")) 'in 1782 (rdata-ipv4 'a '#(74 125 45 125)))
-		      (rr (domain '(#"ns1" #"google" #"com")) 'a 'in 2737 '#(216 239 32 10))
+		      (rr (domain '(#"ns1" #"google" #"com")) 'in 2737 (rdata-ipv4 'a '#(216 239 32 10)))
-		      (rr (domain '(#"ns2" #"google" #"com")) 'a 'in 2737 '#(216 239 34 10))
+		      (rr (domain '(#"ns2" #"google" #"com")) 'in 2737 (rdata-ipv4 'a '#(216 239 34 10)))
-		      (rr (domain '(#"ns3" #"google" #"com")) 'a 'in 2737 '#(216 239 36 10))
+		      (rr (domain '(#"ns3" #"google" #"com")) 'in 2737 (rdata-ipv4 'a '#(216 239 36 10)))
-		      (rr (domain '(#"ns4" #"google" #"com")) 'a 'in 2737 '#(216 239 38 10))))))
+		      (rr (domain '(#"ns4" #"google" #"com")) 'in 2737 (rdata-ipv4 'a '#(216 239 38 10)))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Zone saving/loading.
@@ -473,9 +473,9 @@
 
 (let ()
   (define rrs
-    (list (rr (domain '(#"a")) 'cname 'in 30 (domain '(#"b")))
+    (list (rr (domain '(#"a")) 'in 30 (rdata-domain 'cname (domain '(#"b"))))
-	  (rr (domain '(#"b")) 'cname 'in 30 (domain '(#"c")))
+	  (rr (domain '(#"b")) 'in 30 (rdata-domain 'cname (domain '(#"c"))))
-	  (rr (domain '(#"c")) 'cname 'in 30 (domain '(#"d")))))
+	  (rr (domain '(#"c")) 'in 30 (rdata-domain 'cname (domain '(#"d"))))))
   (define (check-transpose ns)
     (define permuted (map (lambda (i) (list-ref rrs i)) ns))
     (check-equal? (cname-sort permuted) rrs))

test-rrs.rkt

@@ -1,4 +1,4 @@
-#lang typed/racket/base
+#lang racket/base
 ;;
 ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
 ;;;
@@ -33,16 +33,16 @@
 		 30
 		 10)))
 
-(: A      : (Listof Bytes) (Vector Integer Integer Integer Integer) -> RR)
+;; (: A      : (Listof Bytes) (Vector Integer Integer Integer Integer) -> RR)
-(: A/ttl  : (Listof Bytes) (Vector Integer Integer Integer Integer) Nonnegative-Integer -> RR)
+;; (: A/ttl  : (Listof Bytes) (Vector Integer Integer Integer Integer) Nonnegative-Integer -> RR)
-(: MX     : (Listof Bytes) Nonnegative-Integer (Listof Bytes) -> RR)
+;; (: MX     : (Listof Bytes) Nonnegative-Integer (Listof Bytes) -> RR)
-(: CNAME  : (Listof Bytes) (Listof Bytes) -> RR)
+;; (: CNAME  : (Listof Bytes) (Listof Bytes) -> RR)
-(: NS     : (Listof Bytes) (Listof Bytes) -> RR)
+;; (: NS     : (Listof Bytes) (Listof Bytes) -> RR)
-(: NS/ttl : (Listof Bytes) (Listof Bytes) Nonnegative-Integer -> RR)
+;; (: NS/ttl : (Listof Bytes) (Listof Bytes) Nonnegative-Integer -> RR)
-(: TXT    : (Listof Bytes) (Listof Bytes) -> 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 (A/ttl n ip ttl) (rr (domain n) 'in ttl (rdata-ipv4 'a ip)))
 (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))
@@ -62,38 +62,38 @@
 	(A '(#"subns" #"example") '#(127 0 0 2))))
 
 (define test-roots
-  (list (A/ttl '(#"a" #"root-servers" #"net") '#(198 41 0 4) 3600000)
+  (list (NS/ttl '() '(#"a" #"root-servers" #"net") 518400)
-	(A/ttl '(#"b" #"root-servers" #"net") '#(192 228 79 201) 3600000)
+        (NS/ttl '() '(#"b" #"root-servers" #"net") 518400)
-	(A/ttl '(#"c" #"root-servers" #"net") '#(192 33 4 12) 3600000)
+        (NS/ttl '() '(#"c" #"root-servers" #"net") 518400)
-	(A/ttl '(#"d" #"root-servers" #"net") '#(199 7 91 13) 3600000)
+        (NS/ttl '() '(#"d" #"root-servers" #"net") 518400)
-	(A/ttl '(#"e" #"root-servers" #"net") '#(192 203 230 10) 3600000)
+        (NS/ttl '() '(#"e" #"root-servers" #"net") 518400)
-	(A/ttl '(#"f" #"root-servers" #"net") '#(192 5 5 241) 3600000)
+        (NS/ttl '() '(#"f" #"root-servers" #"net") 518400)
-	(A/ttl '(#"g" #"root-servers" #"net") '#(192 112 36 4) 3600000)
+        (NS/ttl '() '(#"g" #"root-servers" #"net") 518400)
-	(A/ttl '(#"h" #"root-servers" #"net") '#(128 63 2 53) 3600000)
+        (NS/ttl '() '(#"h" #"root-servers" #"net") 518400)
-	(A/ttl '(#"i" #"root-servers" #"net") '#(192 36 148 17) 3600000)
+        (NS/ttl '() '(#"i" #"root-servers" #"net") 518400)
-	(A/ttl '(#"j" #"root-servers" #"net") '#(192 58 128 30) 3600000)
+        (NS/ttl '() '(#"j" #"root-servers" #"net") 518400)
-	(A/ttl '(#"k" #"root-servers" #"net") '#(193 0 14 129) 3600000)
+        (NS/ttl '() '(#"k" #"root-servers" #"net") 518400)
-	(A/ttl '(#"l" #"root-servers" #"net") '#(199 7 83 42) 3600000)
+        (NS/ttl '() '(#"l" #"root-servers" #"net") 518400)
-	(A/ttl '(#"m" #"root-servers" #"net") '#(202 12 27 33) 3600000)
+        (NS/ttl '() '(#"m" #"root-servers" #"net") 518400)
-	(NS/ttl '() '(#"a" #"root-servers" #"net") 3600000)
+        (A/ttl '(#"a" #"root-servers" #"net") '#(198 41 0 4) 518400)
-	(NS/ttl '() '(#"b" #"root-servers" #"net") 3600000)
+        (A/ttl '(#"b" #"root-servers" #"net") '#(192 228 79 201) 518400)
-	(NS/ttl '() '(#"c" #"root-servers" #"net") 3600000)
+        (A/ttl '(#"c" #"root-servers" #"net") '#(192 33 4 12) 518400)
-	(NS/ttl '() '(#"d" #"root-servers" #"net") 3600000)
+        (A/ttl '(#"d" #"root-servers" #"net") '#(199 7 91 13) 518400)
-	(NS/ttl '() '(#"e" #"root-servers" #"net") 3600000)
+        (A/ttl '(#"e" #"root-servers" #"net") '#(192 203 230 10) 518400)
-	(NS/ttl '() '(#"f" #"root-servers" #"net") 3600000)
+        (A/ttl '(#"f" #"root-servers" #"net") '#(192 5 5 241) 518400)
-	(NS/ttl '() '(#"g" #"root-servers" #"net") 3600000)
+        (A/ttl '(#"g" #"root-servers" #"net") '#(192 112 36 4) 518400)
-	(NS/ttl '() '(#"h" #"root-servers" #"net") 3600000)
+        (A/ttl '(#"h" #"root-servers" #"net") '#(198 97 190 53) 518400)
-	(NS/ttl '() '(#"i" #"root-servers" #"net") 3600000)
+        (A/ttl '(#"i" #"root-servers" #"net") '#(192 36 148 17) 518400)
-	(NS/ttl '() '(#"j" #"root-servers" #"net") 3600000)
+        (A/ttl '(#"j" #"root-servers" #"net") '#(192 58 128 30) 518400)
-	(NS/ttl '() '(#"k" #"root-servers" #"net") 3600000)
+        (A/ttl '(#"k" #"root-servers" #"net") '#(193 0 14 129) 518400)
-	(NS/ttl '() '(#"l" #"root-servers" #"net") 3600000)
+        (A/ttl '(#"l" #"root-servers" #"net") '#(199 7 83 42) 518400)
-	(NS/ttl '() '(#"m" #"root-servers" #"net") 3600000)))
+        (A/ttl '(#"m" #"root-servers" #"net") '#(202 12 27 33) 518400)))
 
 (define pathological-roots
   (list (NS '(#"a") '(#"ns" #"b"))
 	(NS '(#"b") '(#"ns" #"a"))))
 
-(: test-port-number : -> Nonnegative-Integer)
+;; (: test-port-number : -> Nonnegative-Integer)
 (define (test-port-number)
   (define p
     (string->number

tk-dns.rkt

@@ -1,4 +1,4 @@
-#lang typed/racket/base
+#lang racket/base
 ;; DNS drivers using marketplace.
 ;;
 ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@@ -22,106 +22,55 @@
 (require racket/set)
 (require racket/match)
 (require "codec.rkt")
-(require marketplace/sugar-typed)
+(require syndicate/actor)
-(require marketplace/drivers/udp)
+(require syndicate/protocol/standard-relay)
-(require marketplace/support/pseudo-substruct)
+(require syndicate/drivers/udp)
-
-(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?
 
+(provide (struct-out bad-dns-packet)
+	 (struct-out dns-request)
+	 (struct-out dns-reply)
 	 dns-read-driver
 	 dns-write-driver
 	 dns-spy)
 
-(struct: (TDetail TSource TSink TReason)
+(struct bad-dns-packet (detail source sink reason) #:transparent)
-	 bad-dns-packet-repr
+(struct dns-request (message source sink) #:transparent)
-	 ([detail : TDetail] [source : TSource] [sink : TSink] [reason : TReason]) #:transparent)
+(struct dns-reply (message source sink) #: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
+  (spawn
-    (at-meta-level: Void
+   #:name (list 'dns-read-driver s)
-     (subscriber: Void (udp-packet-pattern (wild) s (wild))
+   (on (message (inbound (udp-packet $source s #"")))
-       (on-message
+       (log-info "Debug dump packet received")
-	[(udp-packet source (== s) #"")
+       (send! `(debug-dump)))
-	 (begin (log-info "Debug dump packet received")
+   (on (message (inbound (udp-packet $source s $body)))
-		(send-message `(debug-dump)))]
+       (when (positive? (bytes-length body))
-	[(udp-packet source (== s) body)
+         (send!
-	 (send-message
+          (with-handlers ((exn:fail? (lambda (e)
-	  (with-handlers ((exn:fail? (lambda (e)
+                                       (bad-dns-packet body source s 'unparseable))))
-				       (bad-dns-packet body source s 'unparseable))))
+            (define message (packet->dns-message body))
-	    (define message (packet->dns-message body))
+            (case (dns-message-direction message)
-	    (case (dns-message-direction message)
+              ((request) (dns-request message source s))
-	      ((request) (dns-request message source s))
+              ((response) (dns-reply message source s)))))))))
-	      ((response) (dns-reply message source s)))))])))))
+
+(define (translate message s sink)
+  (with-handlers ((exn:fail? (lambda (e) (bad-dns-packet message s sink 'unencodable))))
+    (outbound (udp-packet s sink (dns-message->packet message)))))
 
-(: dns-write-driver : UdpAddress -> (Transition Void))
 (define (dns-write-driver s)
-  (: translate : DNSMessage UdpAddress -> (ActionTree Void))
+  (spawn #:name (list 'dns-write-driver s)
-  (define (translate message sink)
+         (on (message (dns-request $message s $sink))
-    (with-handlers ((exn:fail? (lambda (e)
+             (send! (translate message s sink)))
-				 (send-message (bad-dns-packet message s sink 'unencodable)))))
+         (on (message (dns-reply $message s $sink))
-      (at-meta-level: Void
+             (send! (translate message s sink)))))
-       (send-message (udp-packet s sink (dns-message->packet message))))))
-  (transition: (void) : Void
-    (subscriber: Void (dns-request-pattern (wild) s (wild))
-      (on-message
-       [(dns-request message (== s) sink) (translate message sink)]))
-    (subscriber: Void (dns-reply-pattern   (wild) s (wild))
-      (on-message
-       [(dns-reply   message (== s) sink) (translate message sink)]))))
 
-(: dns-spy : -> (Transition Void))
 (define (dns-spy)
-  (transition: (void) : Void
+  (spawn #:name 'dns-spy
-    (observe-publishers: Void (wild)
+         (on (message (dns-request $message $source $sink))
-      (on-message
+             (log-info (format "DNS: ~v asks ~v ~v~n   : ~v"
-       [(dns-request message source sink)
+                               source sink (dns-message-id message)
-	(begin (log-info (format "DNS: ~v asks ~v ~v~n   : ~v"
+                               (dns-message-questions message))))
-				 source sink (dns-message-id message)
+         (on (message (dns-reply $message $source $sink))
-				 (dns-message-questions message)))
+             (log-info (format "DNS: ~v answers ~v~n   : ~v"
-	       (void))]
+                               source sink
-       [(dns-reply message source sink)
+                               message)))))
-	(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,4 +1,4 @@
-#lang typed/racket/base
+#lang racket/base
 ;; Noddy representation of a zone, and various zone and RRSet utilities.
 ;;
 ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@@ -25,10 +25,8 @@
 (require "api.rkt")
 (require "codec.rkt")
 (require bitsyntax)
-(require (rename-in marketplace/tr-struct-copy [tr-struct-copy struct-copy])) ;; PR13149
 
-(provide CompiledZone
+(provide zone-ref
-	 zone-ref
 	 zone-includes-name?
 	 incorporate-complete-answer
 	 zone-expire-name
@@ -45,52 +43,47 @@
 	 zone->bit-string
 	 bit-string->zone)
 
-(define-type RelativeSeconds Real)
+;; (define-type RelativeSeconds Real)
-(define-type AbsoluteSeconds Real)
+;; (define-type AbsoluteSeconds Real)
-(define-predicate absolute-seconds? AbsoluteSeconds)
+;; (define-predicate absolute-seconds? AbsoluteSeconds)
+(define absolute-seconds? real?)
 
 ;; 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 : RelativeSeconds]) #:transparent)
+(struct infinite-lifetime (ttl) #: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 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)
+;; (: current-inexact-seconds : -> AbsoluteSeconds)
 (define (current-inexact-seconds)
   (/ (current-inexact-milliseconds) 1000.0))
 
-(: still-valid? : Expiry AbsoluteSeconds -> Boolean)
+;; (: still-valid? : Expiry AbsoluteSeconds -> Boolean)
 (define (still-valid? expiry now)
   (or (infinite-lifetime? expiry)
       (>= expiry now)))
 
-(: zone-ref : CompiledZone DomainName -> (Option (Setof RR)))
+;; (: zone-ref : CompiledZone DomainName -> (Option (Setof RR)))
 (define (zone-ref db name)
   (define expirymap (hash-ref db name (lambda () #f)))
   (and expirymap
        (let ((now (current-inexact-seconds)))
-	 (for/fold: ([acc : (Setof RR) (set)])
+	 (for/fold ([acc (set)]) ([resource (in-hash-keys expirymap)])
-	     ([resource : RR (in-hash-keys expirymap)])
 	   (define expiry (hash-ref expirymap resource))
 	   (if (still-valid? expiry now)
 	       (let ((new-ttl (if (infinite-lifetime? expiry)
@@ -98,14 +91,14 @@
 				  (- expiry now))))
 		 (set-add acc
 			  (struct-copy rr resource
-			    [ttl (cast (exact-floor new-ttl) Nonnegative-Integer)])))
+			    [ttl (exact-floor new-ttl)])))
 	       acc)))))
 
-(: zone-includes-name? : CompiledZone DomainName -> Boolean)
+;; (: zone-includes-name? : CompiledZone DomainName -> Boolean)
 (define (zone-includes-name? db name)
   (hash-has-key? db name))
 
-(: incorporate-rr : (Option 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
@@ -129,7 +122,7 @@
 		     (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 (lambda () (ann #hash() (HashTable rr Expiry)))))
+  (define old-expirymap (hash-ref db name (lambda () #hash())))
   (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
@@ -139,15 +132,15 @@
    [else ;; old record finite-lifetime but expiring after the new expiry: leave it alone
     db]))
 
-(: incorporate-complete-answer :
+;; (: incorporate-complete-answer :
-   (Option CompleteAnswer) CompiledZone Boolean -> (Values CompiledZone Timers))
+;;    (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 ((inst set Timer))])
+     (for/fold ([db db] [timers (set)])
 	 ([rr (in-list (append (set->list ns)
 			       (set->list us)
 			       (set->list ds)))]) ;; no in-sequences in typed racket
@@ -156,15 +149,14 @@
 	   (values ((incorporate-rr now) rr db)
 		   (set-add timers (cons (rr-name rr) (rr-ttl rr))))))]))
 
-(: zone-expire-name : CompiledZone DomainName AbsoluteSeconds -> 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 empty-expirymap #hash())
   (define old-expirymap (hash-ref db name (lambda () empty-expirymap)))
   (define new-expirymap
-    (for/fold: ([acc : (HashTable RR Expiry) empty-expirymap])
+    (for/fold ([acc empty-expirymap]) ([resource (in-hash-keys old-expirymap)])
-	([resource : RR (in-hash-keys old-expirymap)])
       (define expiry (hash-ref old-expirymap resource))
       (if (still-valid? expiry now-seconds)
 	  (hash-set acc resource expiry)
@@ -173,33 +165,33 @@
       (hash-remove db name)
       (hash-set db name new-expirymap)))
 
-(: zone-expire : 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 : CompiledZone zone] [timers : Timers (set)])
+  (for/fold ([zone zone] [timers (set)])
-      ([name : DomainName (in-hash-keys zone)])
+      ([name (in-hash-keys zone)])
     (define new-zone (zone-expire-name zone name now-seconds))
     (define expirymap (hash-ref new-zone name (lambda () #f)))
     (values new-zone
 	    (if expirymap
 		(set-union (list->set
-			    (map (lambda: ([e : AbsoluteSeconds]) (cons name (- e now-seconds)))
+			    (map (lambda (e) (cons name (- e now-seconds)))
 				 (filter absolute-seconds? (hash-values expirymap))))
 			   timers)
 		timers))))
 
-(: empty-zone-db : -> CompiledZone)
+;; (: empty-zone-db : -> CompiledZone)
 (define (empty-zone-db)
   (make-immutable-hash))
 
-(: compile-zone-db : (Listof RR) -> CompiledZone)
+;; (: compile-zone-db : (Listof RR) -> CompiledZone)
 ;; Builds an immutable hash table from the given RRs, suitable for
 ;; quickly looking up answers to queries.
 (define (compile-zone-db rrs)
   (foldl (incorporate-rr #f) (empty-zone-db) rrs))
 
-(: in-bailiwick? : DomainName DomainName -> Boolean)
+;; (: in-bailiwick? : DomainName DomainName -> Boolean)
 ;; Answers #t iff dn falls within the bailiwick of the zone with
 ;; origin o.
 (define (in-bailiwick? dn o)
@@ -207,23 +199,23 @@
       (let ((p (domain-parent dn)))
 	(and p (in-bailiwick? p o)))))
 
-(: set-filter : (All (X) (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/fold: ([acc : (Setof X) (set)]) ([x : X (in-list (set->list in))])
+  (for/fold ([acc (set)]) ([x (in-list (set->list in))])
     (if (predicate x) (set-add acc x) acc)))
 
-(: filter-by-type : (Setof RR) RRType -> (Setof RR))
+;; (: filter-by-type : (Setof RR) RRType -> (Setof RR))
 ;; Selects only those members of rrset having rr-type type.
 (define (filter-by-type rrset type)
   (define p? (rdata-type-pred type))
-  (set-filter (lambda: ([rr : RR]) (p? (rr-rdata rr))) rrset))
+  (set-filter (lambda (rr) (p? (rr-rdata rr))) rrset))
 
-(: no-rrs : (Setof RR))
+;; (: no-rrs : (Setof RR))
 (define no-rrs (set))
 
-(: filter-rrs : (Setof RR) QueryType QueryClass -> (Setof RR))
+;; (: 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)
@@ -237,10 +229,10 @@
   (define filtered-by-type-and-class
     (case qclass
       ((*) filtered-by-type)
-      (else (set-filter (lambda: ([rr : RR]) (eqv? (rr-class rr) qclass)) filtered-by-type))))
+      (else (set-filter (lambda (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?
 ;;
@@ -264,11 +256,11 @@
   (append (cname-sort (set->list cnames))
 	  (set->list (set-subtract rrs cnames))))
 
-(: rr-rdata-domain-name : RR -> DomainName)
+;; (: rr-rdata-domain-name : RR -> DomainName)
 (define (rr-rdata-domain-name rr)
-  (rdata-domain-name (cast (rr-rdata rr) rdata-domain)))
+  (rdata-domain-name (rr-rdata rr)))
 
-(: cname-sort : (Listof RR) -> (Listof RR))
+;; (: 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
@@ -277,11 +269,9 @@
   (define lhss (list->set (map rr-name cnames)))
   (define rhss (list->set (map rr-rdata-domain-name cnames)))
   (define roots (set->list (set-subtract lhss rhss))) ;; Nodes not the targets of some edge.
-  (: targets-of : DomainName -> (Listof RR))
+  ;; (: targets-of : DomainName -> (Listof RR))
-  (define (targets-of name) (filter (lambda: ([rr : RR]) (equal? (rr-name rr) name)) cnames))
+  (define (targets-of name) (filter (lambda (rr) (equal? (rr-name rr) name)) cnames))
-  (let: iterate ((remaining : (Listof DomainName) roots)
+  (let iterate ((remaining roots) (seen (set)) (acc '()))
-		 (seen : (Setof DomainName) (set))
-		 (acc : (Listof RR) '()))
     (if (null? remaining)
 	(reverse acc)
 	(let ((source (car remaining)))
@@ -293,12 +283,12 @@
 			 (set-add seen source)
 			 (append rrs acc))))))))
 
-(: zone->bit-string : 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 : BitString (bit-string)]) ([name : DomainName (in-hash-keys zone)])
+  (for/fold ([acc (bit-string)]) ([name (in-hash-keys zone)])
     (define rrmap (hash-ref zone name))
-    (for/fold: ([acc : BitString acc]) ([rr : RR (in-hash-keys rrmap)])
+    (for/fold ([acc acc]) ([rr (in-hash-keys rrmap)])
       (define expiry (hash-ref rrmap rr))
       (bit-string-append
        acc
@@ -308,7 +298,7 @@
 	[else
 	 (bit-string (rr :: (t:rr)) 0 ((exact-truncate expiry) :: bits 32))])))))
 
-(: bit-string->zone : 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))