First pass conversion of zonedb to TR

zonedb.rkt

@@ -1,12 +1,14 @@
-#lang racket/base
+#lang typed/racket/base
 
 ;; Noddy representation of a zone, and various zone and RRSet utilities.
 
 (require racket/set)
 (require racket/match)
+(require (only-in racket/math exact-floor exact-truncate))
 (require "api.rkt")
 (require "codec.rkt")
 (require racket-bitsyntax)
+(require (rename-in racket-typed-matrix/tr-struct-copy [tr-struct-copy struct-copy])) ;; PR13149
 
 (provide zone-ref
 	 zone-includes-name?
@@ -15,7 +17,6 @@
 	 zone-expire
 	 empty-zone-db
 	 compile-zone-db
-	 compiled-zone?
 	 in-bailiwick?
 	 set-filter
 	 filter-by-type
@@ -25,50 +26,67 @@
 	 zone->bit-string
 	 bit-string->zone)
 
+(define-type RelativeSeconds Real)
+(define-type AbsoluteSeconds Nonnegative-Real)
+(define-predicate absolute-seconds? AbsoluteSeconds)
+
 ;; An InfiniteLifetime is an (infinite-lifetime RelativeSeconds), a
 ;; specification of the TTL to use when sending a non-expiring RR to a
 ;; peer.
-(struct infinite-lifetime (ttl) #:prefab)
+(struct: infinite-lifetime ([ttl : RelativeSeconds]) #:prefab)
+(define-type InfiniteLifetime infinite-lifetime)
+
+;; An Expiry is either an AbsoluteSeconds or an InfiniteLifetime.
+(define-type Expiry (U AbsoluteSeconds InfiniteLifetime))
 
 ;; A CompiledZone is a Hash<DomainName,Hash<RR,(or AbsoluteSeconds
 ;; InfiniteLifetime)>>, representing a collection of DNS RRSets
 ;; indexed by DomainName. Each RR in an RRSet either has an expiry
 ;; time associated with it or has an InfiniteLifetime associated with
 ;; it, in which case it should not expire.
+(define-type CompiledZone (HashTable DomainName (HashTable RR Expiry)))
 
-;; A Timers is a SetOf<(cons DomainName AbsoluteSeconds)>,
+;; A Timers is a SetOf<(cons DomainName RelativeSeconds)>,
 ;; representing a collection of timeouts that should be set against
 ;; names to to see if their associated RRs have expired.
+(define-type Timer (Pairof DomainName RelativeSeconds))
+(define-type Timers (Setof Timer))
 
 ;; TODO: maybe store domain names big-end first? It'd make bailiwick
 ;; and subzone checks into prefix rather than suffix checks. It makes
 ;; domain names into paths through the DNS DB tree.
 
+(: current-inexact-seconds : -> AbsoluteSeconds)
 (define (current-inexact-seconds)
-  (/ (current-inexact-milliseconds) 1000.0))
+  (cast (/ (current-inexact-milliseconds) 1000.0) AbsoluteSeconds))
 
+(: still-valid? : Expiry AbsoluteSeconds -> Boolean)
 (define (still-valid? expiry now)
   (or (infinite-lifetime? expiry)
       (>= expiry now)))
 
-;; CompiledZone DomainName -> Maybe<Set<RR>>
+(: zone-ref : CompiledZone DomainName -> (Option (Setof RR)))
 (define (zone-ref db name)
-  (cond
+  (define expirymap (hash-ref db name (lambda () #f)))
-   [(hash-ref db name #f) =>
+  (and expirymap
-    (lambda (expirymap)
+       (let ((now (current-inexact-seconds)))
-      (define now (current-inexact-seconds))
+	 (for/fold: ([acc : (Setof RR) (set)])
-      (for/set ([(resource expiry) expirymap] #:when (still-valid? expiry now))
+	     ([resource : RR (in-hash-keys expirymap)])
-	(struct-copy rr resource [ttl (if (infinite-lifetime? expiry)
+	   (define expiry (hash-ref expirymap resource))
-					  (infinite-lifetime-ttl expiry)
+	   (if (still-valid? expiry now)
-					  (inexact->exact (floor (- expiry now))))])))]
+	       (let ((new-ttl (if (infinite-lifetime? expiry)
-   [else #f]))
+				  (infinite-lifetime-ttl expiry)
+				  (- expiry now))))
+		 (set-add acc
+			  (struct-copy rr resource
+			    [ttl (cast (exact-floor new-ttl) Nonnegative-Integer)])))
+	       acc)))))
 
-;; CompiledZone DomainName -> Boolean
+(: zone-includes-name? : CompiledZone DomainName -> Boolean)
 (define (zone-includes-name? db name)
   (hash-has-key? db name))
 
-;; incorporate-rr : Maybe<AbsoluteSeconds> -> (RR CompiledZone -> CompiledZone)
+(: incorporate-rr : (Option AbsoluteSeconds) -> (RR CompiledZone -> CompiledZone))
-;;
 ;; Incorporates the given RR into our database. If base-time is a
 ;; number of seconds, we treat the RR as having a TTL that decreases
 ;; as time goes by; otherwise base-time is #f, and we treat the RR as
@@ -92,8 +110,8 @@
 		     (infinite-lifetime (rr-ttl resource0))))
   (define resource (struct-copy rr resource0 [ttl 0]))
   (define name (rr-name resource))
-  (define old-expirymap (hash-ref db name hash))
+  (define old-expirymap (hash-ref db name (lambda () (ann #hash() (HashTable rr Expiry)))))
-  (define old-expiry (hash-ref old-expirymap resource 0))
+  (define old-expiry (hash-ref old-expirymap resource (lambda () 0)))
   (cond
    [(infinite-lifetime? old-expiry) ;; don't update TTL: the existing record should live forever
     db]
@@ -102,102 +120,108 @@
    [else ;; old record finite-lifetime but expiring after the new expiry: leave it alone
     db]))
 
-;; Maybe<CompleteAnswer> CompiledZone Boolean -> (values CompiledZone Timers)
+(: incorporate-complete-answer :
+   (Option CompleteAnswer) CompiledZone Boolean -> (Values CompiledZone Timers))
 (define (incorporate-complete-answer ans db is-cache?)
   (match ans
     [#f
      (values db (set))]
     [(complete-answer ns us ds)
      (define now (current-inexact-seconds))
-     (for/fold ([db db] [timers (set)])
+     (for/fold ([db db] [timers ((inst set Timer))])
-	 ([rr (in-sequences ns us ds)])
+	 ([rr (in-list (append (set->list ns)
+			       (set->list us)
+			       (set->list ds)))]) ;; no in-sequences in typed racket
        (if (and is-cache? (zero? (rr-ttl rr))) ;; Do not *cache* 0-TTL RRs (RFC 1034 3.6)
 	   (values db timers)
 	   (values ((incorporate-rr now) rr db)
 		   (set-add timers (cons (rr-name rr) (rr-ttl rr))))))]))
 
-;; CompiledZone DomainName -> CompiledZone
+(: zone-expire-name : CompiledZone DomainName AbsoluteSeconds -> CompiledZone)
 ;; Checks the given name to see if there are any expiring records, and
 ;; if so, removes them.
 (define (zone-expire-name db name now-seconds)
+  (define empty-expirymap (ann #hash() (HashTable RR Expiry)))
+  (define old-expirymap (hash-ref db name (lambda () empty-expirymap)))
   (define new-expirymap
-    (if (zone-includes-name? db name)
+    (for/fold: ([acc : (HashTable RR Expiry) empty-expirymap])
-	(for/hash ([(resource expiry) (hash-ref db name)] #:when (still-valid? expiry now-seconds))
+	([resource : RR (in-hash-keys old-expirymap)])
-	  (values resource expiry))
+      (define expiry (hash-ref old-expirymap resource))
-	(hash)))
+      (if (still-valid? expiry now-seconds)
+	  (hash-set acc resource expiry)
+	  acc)))
   (if (zero? (hash-count new-expirymap))
       (hash-remove db name)
       (hash-set db name new-expirymap)))
 
-;; CompiledZone -> (values CompiledZone Timers)
+(: zone-expire : CompiledZone -> (Values CompiledZone Timers))
 ;; Used to freshen a saved zone when it is loaded from disk.
 (define (zone-expire zone)
   (define now-seconds (current-inexact-seconds))
-  (for/fold ([zone zone] [timers (set)])
+  (for/fold: ([zone : CompiledZone zone] [timers : Timers (set)])
-      ([name (hash-keys zone)])
+      ([name : DomainName (in-hash-keys zone)])
     (define new-zone (zone-expire-name zone name now-seconds))
-    (cond
+    (define expirymap (hash-ref new-zone name (lambda () #f)))
-     [(hash-ref new-zone name #f) =>
+    (values new-zone
-      (lambda (expirymap)
+	    (if expirymap
-	(values new-zone
 		(set-union (list->set
-			    (map (lambda (e) (cons name (- e now-seconds)))
+			    (map (lambda: ([e : AbsoluteSeconds]) (cons name (- e now-seconds)))
-				 (filter (lambda (e) (not (infinite-lifetime? e)))
+				 (filter absolute-seconds? (hash-values expirymap))))
-					 (hash-values expirymap))))
+			   timers)
-			   timers)))]
+		timers))))
-     [else
-      (values new-zone timers)])))
 
-;; empty-zone-db : -> CompiledZone
+(: empty-zone-db : -> CompiledZone)
 (define (empty-zone-db)
   (make-immutable-hash))
 
-;; compile-zone-db : ListOf<RR> -> CompiledZone
+(: compile-zone-db : (Listof RR) -> CompiledZone)
 ;; Builds an immutable hash table from the given RRs, suitable for
 ;; quickly looking up answers to queries.
 (define (compile-zone-db rrs)
   (foldl (incorporate-rr #f) (empty-zone-db) rrs))
 
-(define (compiled-zone? z)
+(: in-bailiwick? : DomainName DomainName -> Boolean)
-  (hash? z)) ;; hm
-
-;; in-bailiwick? : DomainName DomainName -> Boolean
 ;; Answers #t iff dn falls within the bailiwick of the zone with
 ;; origin o.
 (define (in-bailiwick? dn o)
-  (cond
+  (or (equal? dn o)
-   ((equal? dn o) #t)
+      (let ((p (domain-parent dn)))
-   ((domain-root? dn) #f)
+	(and p (in-bailiwick? p o)))))
-   (else (in-bailiwick? (domain-parent dn) o))))
 
-;; set-filter : (X -> Boolean) SetOf<X> -> SetOf<X>
+(: set-filter : (All (X) (X -> Boolean) (Setof X) -> (Setof X)))
 ;; Retains only those elements of its argument for which the predicate
 ;; answers #t.
 (define (set-filter predicate in)
-  (for/set ([x (in-set in)]
+  (for/fold: ([acc : (Setof X) (set)]) ([x : X (in-list (set->list in))])
-	    #:when (predicate x))
+    (if (predicate x) (set-add acc x) acc)))
-	   x))
 
-;; filter-by-type : SetOf<RR> RRType -> SetOf<RR>
+(: filter-by-type : (Setof RR) RRType -> (Setof RR))
 ;; Selects only those members of rrset having rr-type type.
 (define (filter-by-type rrset type)
-  (set-filter (lambda (rr) (eqv? (rr-type rr) type)) rrset))
+  (define p? (rdata-type-pred type))
+  (set-filter (lambda: ([rr : RR]) (p? (rr-rdata rr))) rrset))
 
-;; filter-rrs : SetOf<RR> QueryType QueryClass -> SetOf<RR>
+(: no-rrs : (Setof RR))
+(define no-rrs (set))
+
+(: filter-rrs : (Setof RR) QueryType QueryClass -> (Setof RR))
 ;; Returns a set like its argument with RRs not matching the given
 ;; type and class removed.
 (define (filter-rrs rrs qtype qclass)
   (define filtered-by-type
-    (case qtype
+    (cond
-      ((*) rrs)
+     ((eq? qtype '*) rrs)
-      (else (filter-by-type rrs qtype))))
+     ((eq? qtype 'axfr) no-rrs) ;; TODO: warn? error? AXFR is not currently supported.
+     ((eq? qtype 'mailb) no-rrs) ;; TODO: warn? error? MAILB is not currently supported.
+     ((eq? qtype 'maila) no-rrs) ;; TODO: warn? error? MAILA is not currently supported.
+     (else (filter-by-type rrs qtype))))
   (define filtered-by-type-and-class
     (case qclass
       ((*) filtered-by-type)
-      (else (set-filter (lambda (rr) (eqv? (rr-class rr) qclass)) filtered-by-type))))
+      (else (set-filter (lambda: ([rr : RR]) (eqv? (rr-class rr) qclass)) filtered-by-type))))
   filtered-by-type-and-class)
 
-;; rr-set->list : SetOf<RR> -> ListOf<RR>
+(: rr-set->list : (Setof RR) -> (Listof RR))
 ;; Like set->list, but places all CNAME records first.
 ;; This is apparently to work around bugs in old versions of BIND?
 ;;
@@ -217,47 +241,55 @@
 ;; even supposed to be relevant. So we *recover* the order here, which
 ;; is a bit expensive.
 (define (rr-set->list rrs)
-  (append (cname-sort (set->list (filter-by-type rrs 'cname)))
+  (define cnames (filter-by-type rrs 'cname))
-	  (set->list (set-filter (lambda (rr) (not (eqv? (rr-type rr) 'cname))) rrs))))
+  (append (cname-sort (set->list cnames))
+	  (set->list (set-subtract rrs cnames))))
 
-;; cname-sort : ListOf<RR<CNAME>> -> ListOf<RR<CNAME>>
+(: cname-target : RR -> DomainName)
+(define (cname-target rr)
+  (rdata-domain-name (cast (rr-rdata rr) rdata-domain)))
+
+(: cname-sort : (Listof RR) -> (Listof RR))
 ;; Produce an ordering of the CNAMEs given that respects their
 ;; "causality". For example, if a CNAME b and b CNAME c, then the RRs
 ;; will be presented in that order (and not the other order, with b
 ;; CNAME c first).
 (define (cname-sort cnames)
   (define lhss (list->set (map rr-name cnames)))
-  (define rhss (list->set (map rr-rdata cnames)))
+  (define rhss (list->set (map cname-target cnames)))
   (define roots (set->list (set-subtract lhss rhss))) ;; Nodes not the targets of some edge.
-  (define (targets-of name) (for/list [(rr cnames) #:when (equal? (rr-name rr) name)] rr))
+  (: targets-of : DomainName -> (Listof RR))
-  (let iterate ((remaining roots)
+  (define (targets-of name) (filter (lambda: ([rr : RR]) (equal? (rr-name rr) name)) cnames))
-		(seen (set))
+  (let: iterate ((remaining : (Listof DomainName) roots)
-		(acc '()))
+		 (seen : (Setof DomainName) (set))
+		 (acc : (Listof RR) '()))
     (if (null? remaining)
 	(reverse acc)
 	(let ((source (car remaining)))
 	  (if (set-member? seen source)
 	      (iterate (cdr remaining) seen acc)
 	      (let* ((rrs (targets-of source))
-		     (targets (map rr-rdata rrs)))
+		     (targets (map cname-target rrs)))
 		(iterate (append targets (cdr remaining))
 			 (set-add seen source)
 			 (append rrs acc))))))))
 
-;; CompiledZone -> Bitstring
+(: zone->bit-string : CompiledZone -> BitString)
 ;; Produces a serialized form of the zone suitable for saving to disk.
 (define (zone->bit-string zone)
-  (for*/fold ([acc (bit-string)])
+  (for/fold: ([acc : BitString (bit-string)]) ([name : DomainName (in-hash-keys zone)])
-      ([(name rrmap) zone] [(rr expiry) rrmap])
+    (define rrmap (hash-ref zone name))
-    (bit-string-append
+    (for/fold: ([acc : BitString acc]) ([rr : RR (in-hash-keys rrmap)])
-     acc
+      (define expiry (hash-ref rrmap rr))
-     (match expiry
+      (bit-string-append
-       [(infinite-lifetime ttl)
+       acc
-	(bit-string (rr :: (t:rr)) 1 (ttl :: bits 32))]
+       (cond
-       [expirytime
+	[(infinite-lifetime? expiry)
-	(bit-string (rr :: (t:rr)) 0 ((truncate (inexact->exact expirytime)) :: bits 32))]))))
+	 (bit-string (rr :: (t:rr)) 1 ((exact-truncate (infinite-lifetime-ttl expiry)) :: bits 32))]
+	[else
+	 (bit-string (rr :: (t:rr)) 0 ((exact-truncate expiry) :: bits 32))])))))
 
-;; Bitstring -> CompiledZone
+(: bit-string->zone : BitString -> CompiledZone)
 ;; Produces a deserialized form of the zone. Suitable for use in loading from disk.
 (define (bit-string->zone bs)
   (define now (current-inexact-seconds))
@@ -270,4 +302,5 @@
       ([ (rr0 :: (t:rr empty-packet)) (= 1) (ttl :: bits 32) (rest :: binary) ]
        (loop ((incorporate-rr #f) (struct-copy rr rr0 [ttl ttl]) db) rest))
       ([ (rr0 :: (t:rr empty-packet)) (= 0) (expirytime :: bits 32) (rest :: binary) ]
-       (loop ((incorporate-rr now) (struct-copy rr rr0 [ttl (- expirytime now)]) db) rest)))))
+       (define new-ttl (cast (exact-floor (- expirytime now)) Nonnegative-Integer))
+       (loop ((incorporate-rr now) (struct-copy rr rr0 [ttl new-ttl]) db) rest)))))