diff --git a/zonedb.rkt b/zonedb.rkt index e13e65a..607a1a5 100644 --- a/zonedb.rkt +++ b/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>, 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> +(: zone-ref : CompiledZone DomainName -> (Option (Setof RR))) (define (zone-ref db name) - (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 expirymap (hash-ref db name (lambda () #f))) + (and expirymap + (let ((now (current-inexact-seconds))) + (for/fold: ([acc : (Setof RR) (set)]) + ([resource : RR (in-hash-keys expirymap)]) + (define expiry (hash-ref expirymap resource)) + (if (still-valid? expiry now) + (let ((new-ttl (if (infinite-lifetime? expiry) + (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 -> (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-expiry (hash-ref old-expirymap resource 0)) + (define old-expirymap (hash-ref db name (lambda () (ann #hash() (HashTable rr Expiry))))) + (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 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)]) - ([rr (in-sequences ns us ds)]) + (for/fold ([db db] [timers ((inst set Timer))]) + ([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/hash ([(resource expiry) (hash-ref db name)] #:when (still-valid? expiry now-seconds)) - (values resource expiry)) - (hash))) + (for/fold: ([acc : (HashTable RR Expiry) empty-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) + 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)]) - ([name (hash-keys zone)]) + (for/fold: ([zone : CompiledZone zone] [timers : Timers (set)]) + ([name : DomainName (in-hash-keys zone)]) (define new-zone (zone-expire-name zone name now-seconds)) - (cond - [(hash-ref new-zone name #f) => - (lambda (expirymap) - (values new-zone + (define expirymap (hash-ref new-zone name (lambda () #f))) + (values new-zone + (if expirymap (set-union (list->set - (map (lambda (e) (cons name (- e now-seconds))) - (filter (lambda (e) (not (infinite-lifetime? e))) - (hash-values expirymap)))) - timers)))] - [else - (values new-zone timers)]))) + (map (lambda: ([e : AbsoluteSeconds]) (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 -> 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) - (hash? z)) ;; hm - -;; 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) - (cond - ((equal? dn o) #t) - ((domain-root? dn) #f) - (else (in-bailiwick? (domain-parent dn) o)))) + (or (equal? dn o) + (let ((p (domain-parent dn))) + (and p (in-bailiwick? p o))))) -;; set-filter : (X -> Boolean) SetOf -> SetOf +(: 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)] - #:when (predicate x)) - x)) + (for/fold: ([acc : (Setof X) (set)]) ([x : X (in-list (set->list in))]) + (if (predicate x) (set-add acc x) acc))) -;; filter-by-type : SetOf RRType -> SetOf +(: 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 QueryType QueryClass -> SetOf +(: 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 - ((*) rrs) - (else (filter-by-type rrs qtype)))) + (cond + ((eq? qtype '*) rrs) + ((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 -> ListOf +(: 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))) - (set->list (set-filter (lambda (rr) (not (eqv? (rr-type rr) 'cname))) rrs)))) + (define cnames (filter-by-type rrs 'cname)) + (append (cname-sort (set->list cnames)) + (set->list (set-subtract rrs cnames)))) -;; cname-sort : ListOf> -> ListOf> +(: 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)) - (let iterate ((remaining roots) - (seen (set)) - (acc '())) + (: targets-of : DomainName -> (Listof RR)) + (define (targets-of name) (filter (lambda: ([rr : RR]) (equal? (rr-name rr) name)) cnames)) + (let: iterate ((remaining : (Listof DomainName) roots) + (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)]) - ([(name rrmap) zone] [(rr expiry) rrmap]) - (bit-string-append - acc - (match expiry - [(infinite-lifetime ttl) - (bit-string (rr :: (t:rr)) 1 (ttl :: bits 32))] - [expirytime - (bit-string (rr :: (t:rr)) 0 ((truncate (inexact->exact expirytime)) :: bits 32))])))) + (for/fold: ([acc : BitString (bit-string)]) ([name : DomainName (in-hash-keys zone)]) + (define rrmap (hash-ref zone name)) + (for/fold: ([acc : BitString acc]) ([rr : RR (in-hash-keys rrmap)]) + (define expiry (hash-ref rrmap rr)) + (bit-string-append + acc + (cond + [(infinite-lifetime? expiry) + (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)))))