Age and expire cached RRs properly

codec.rkt

@@ -7,7 +7,9 @@
 	 (struct-out dns-message)
 
 	 packet->dns-message
-	 dns-message->packet)
+	 dns-message->packet
+
+	 max-ttl)
 
 (require "api.rkt")
 (require "mapping.rkt")
@@ -464,3 +466,6 @@
 		       ((srv-port rdata) :: bits 16)
 		       ((srv-target rdata) :: (t:domain-name))))
     (else rdata)))
+
+;; UInt32
+(define max-ttl #xffffffff)

proxy.rkt

@@ -142,20 +142,20 @@
 	      (send-message (answer->reply original-question answer)))])))]))
 
 (define (question-dispatcher zone0 client-sock)
-  (define cache-clear-interval (* 60 1000))
   (os-big-bang zone0
     ;; TODO: consider deduping questions here too?
-    (send-message (set-timer 'clear-dns-cache cache-clear-interval #t))
     (subscribe 'question-handler-factory
       (message-handlers zone
 	[(? question? q)
 	 (transition zone
 	   (spawn (question-handler zone q client-sock)))]
 	[(network-reply _ answer)
-	 (incorporate-complete-answer answer zone)]
+	 (define-values (new-zone timers) (incorporate-complete-answer answer zone))
-	[(timer-expired 'clear-dns-cache _)
+	 (transition new-zone
-	 (transition zone0
+	   (for/list ([(name ttl) timers])
-	   (send-message (set-timer 'clear-dns-cache cache-clear-interval #t)))]))))
+	     (send-message (set-timer (list 'check-dns-expiry name) (* ttl 1000) #t))))]
+	[(timer-expired (list 'check-dns-expiry name) _)
+	 (zone-expire-name zone name)]))))
 
 (struct question-state (zone q client-sock nameservers-tried retry-count) #:transparent)
 (struct expanding-cnames (q accumulator remaining-count) #:transparent)
@@ -190,11 +190,12 @@
 	      [(network-reply (== referral-id) #f) ;; name-error/NXDOMAIN
 	       (transition w (send-message (answered-question q #f)))]
 	      [(network-reply (== referral-id) ans)
+	       (define-values (new-zone ignored-timers) (incorporate-complete-answer ans zone))
 	       (extend-transition
 		   (retry-question (struct-copy question-state w
 						[nameservers-tried (set-union nameservers-tried
 									      nameserver-rrs)]
-						[zone (incorporate-complete-answer ans zone)]
+						[zone new-zone]
 						[retry-count (+ old-retry-count 1)]))
 		 (unsubscribe referral-id))])))]
        [(? complete-answer? ans)

zonedb.rkt

@@ -9,8 +9,8 @@
 
 (provide zone-ref
 	 zone-includes-name?
-	 incorporate-rr
 	 incorporate-complete-answer
+	 zone-expire-name
 	 empty-zone-db
 	 compile-zone-db
 	 compiled-zone?
@@ -20,31 +20,84 @@
 	 filter-rrs
 	 rr-set->list)
 
-;; A CompiledZone is a Hash<DomainName,SetOf<RR>>, representing a
+;; An InfiniteLifetime is an (infinite-lifetime RelativeSeconds), a
-;; collection of DNS RRSets indexed by DomainName.
+;; specification of the TTL to use when sending a non-expiring RR to a
+;; peer.
+(struct infinite-lifetime (ttl) #:transparent)
+
+;; 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.
 
 ;; 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.
 
+(define (current-inexact-seconds)
+  (/ (current-inexact-milliseconds) 1000.0))
+
+(define (still-valid? expiry now)
+  (or (infinite-lifetime? expiry)
+      (>= expiry now)))
+
 ;; CompiledZone DomainName -> Maybe<Set<RR>>
 (define (zone-ref db name)
-  (hash-ref db name #f))
+  (cond
+   [(hash-ref db name #f) =>
+    (lambda (expirymap)
+      (define now (current-inexact-seconds))
+      (for/set ([(resource expiry) expirymap] #:when (still-valid? expiry now))
+	(struct-copy rr resource [ttl (if (infinite-lifetime? expiry)
+					  (infinite-lifetime-ttl expiry)
+					  (inexact->exact (floor (- expiry now))))])))]
+   [else #f]))
 
 (define (zone-includes-name? db name)
   (hash-has-key? db name))
 
-;; RR CompiledZone -> CompiledZone
+;; incorporate-rr : Maybe<AbsoluteSeconds> -> (RR CompiledZone -> CompiledZone)
-(define (incorporate-rr rr db)
+;;
-  (hash-set db (rr-name rr) (set-add (hash-ref db (rr-name rr) set) rr)))
+;; Incorporates the given RR into our database. If base-time is a
+;; number of seconds, we treat the RR as having a TTL that decreases
+;; as time goes by; otherwise base-time is #f, and we treat the RR as
+;; being non-expiring with an InfiniteLifetime.
+(define ((incorporate-rr base-time) resource0 db)
+  (define expiry (if base-time
+		     (+ base-time (rr-ttl resource0))
+		     (infinite-lifetime (rr-ttl resource0))))
+  (define resource (struct-copy rr resource0 [ttl 0]))
+  (hash-set db (rr-name resource)
+	    (hash-set (hash-ref db (rr-name resource) hash) resource expiry)))
 
-;; Maybe<CompleteAnswer> CompiledZone -> CompiledZone
+;; Maybe<CompleteAnswer> CompiledZone -> (values CompiledZone Hash<Name,AbsoluteSeconds>)
 (define (incorporate-complete-answer ans db)
   (match ans
-    [#f db]
+    [#f
-    [(complete-answer ns us ds) (foldl incorporate-rr db (append (set->list ns)
+     (values db (hash))]
-								 (set->list us)
+    [(complete-answer ns us ds)
-								 (set->list ds)))]))
+     (define now (current-inexact-seconds))
+     (for/fold ([db db] [timers (hash)])
+	 ([rr (in-sequences ns us ds)])
+       (values ((incorporate-rr now) rr db)
+	       (hash-update timers (rr-name rr)
+			    (lambda (old-ttl) (min old-ttl (rr-ttl rr)))
+			    max-ttl)))]))
+
+;; CompiledZone DomainName -> CompiledZone
+;; Checks the given name to see if there are any expiring records, and
+;; if so, removes them.
+(define (zone-expire-name db name)
+  (define now (current-inexact-seconds))
+  (define new-expirymap
+    (if (zone-includes-name? db name)
+	(for/hash ([(resource expiry) (hash-ref db name)] #:when (still-valid? expiry now))
+	  (values resource expiry))
+	(hash)))
+  (if (zero? (hash-count new-expirymap))
+      (hash-remove db name)
+      (hash-set db name new-expirymap)))
 
 ;; empty-zone-db : -> CompiledZone
 (define (empty-zone-db)
@@ -54,7 +107,7 @@
 ;; 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 (make-immutable-hash) rrs))
+  (foldl (incorporate-rr #f) (empty-zone-db) rrs))
 
 (define (compiled-zone? z)
   (hash? z)) ;; hm