diff --git a/codec.rkt b/codec.rkt index 87ad84b..4cd7d33 100644 --- a/codec.rkt +++ b/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) diff --git a/proxy.rkt b/proxy.rkt index 35129c4..23800df 100644 --- a/proxy.rkt +++ b/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)] - [(timer-expired 'clear-dns-cache _) - (transition zone0 - (send-message (set-timer 'clear-dns-cache cache-clear-interval #t)))])))) + (define-values (new-zone timers) (incorporate-complete-answer answer zone)) + (transition new-zone + (for/list ([(name ttl) timers]) + (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) diff --git a/zonedb.rkt b/zonedb.rkt index 3d60e0d..5be2964 100644 --- a/zonedb.rkt +++ b/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>, representing a -;; collection of DNS RRSets indexed by DomainName. +;; 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) #:transparent) + +;; A CompiledZone is a Hash>, 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> (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 -(define (incorporate-rr rr db) - (hash-set db (rr-name rr) (set-add (hash-ref db (rr-name rr) set) rr))) +;; incorporate-rr : Maybe -> (RR CompiledZone -> CompiledZone) +;; +;; Incorporates the given RR into our database. If base-time is a +;; number of seconds, we treat the RR as having a TTL that decreases +;; as time goes by; otherwise base-time is #f, and we treat the RR as +;; being non-expiring with an InfiniteLifetime. +(define ((incorporate-rr base-time) resource0 db) + (define expiry (if base-time + (+ base-time (rr-ttl resource0)) + (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 CompiledZone -> CompiledZone +;; Maybe CompiledZone -> (values CompiledZone Hash) (define (incorporate-complete-answer ans db) (match ans - [#f db] - [(complete-answer ns us ds) (foldl incorporate-rr db (append (set->list ns) - (set->list us) - (set->list ds)))])) + [#f + (values db (hash))] + [(complete-answer ns us 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