157 lines
5.2 KiB
Racket
157 lines
5.2 KiB
Racket
#lang racket/base
|
|
|
|
;; Noddy representation of a zone, and various zone and RRSet utilities.
|
|
|
|
(require racket/set)
|
|
(require racket/match)
|
|
(require "api.rkt")
|
|
(require "codec.rkt")
|
|
|
|
(provide zone-ref
|
|
zone-includes-name?
|
|
incorporate-complete-answer
|
|
zone-expire-name
|
|
empty-zone-db
|
|
compile-zone-db
|
|
compiled-zone?
|
|
in-bailiwick?
|
|
set-filter
|
|
filter-by-type
|
|
filter-rrs
|
|
rr-set->list)
|
|
|
|
;; 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<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)
|
|
(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))
|
|
|
|
;; incorporate-rr : Maybe<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
|
|
;; 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 -> (values CompiledZone Hash<Name,AbsoluteSeconds>)
|
|
(define (incorporate-complete-answer ans db)
|
|
(match ans
|
|
[#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)
|
|
(make-immutable-hash))
|
|
|
|
;; 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
|
|
;; Answers #t iff dn falls within the bailiwick of the zone with
|
|
;; origin o.
|
|
(define (in-bailiwick? dn o)
|
|
(cond
|
|
((equal? dn o) #t)
|
|
((null? dn) #f)
|
|
(else (in-bailiwick? (cdr dn) o))))
|
|
|
|
;; set-filter : (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))
|
|
|
|
;; 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))
|
|
|
|
;; filter-rrs : SetOf<RR> QueryType QueryClass
|
|
;; 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))))
|
|
(define filtered-by-type-and-class
|
|
(case 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>
|
|
;; Like set->list, but places all CNAME records first.
|
|
;; This is apparently to work around bugs in old versions of BIND?
|
|
(define (rr-set->list rrs)
|
|
(append (set->list (filter-by-type rrs 'cname))
|
|
(set->list (set-filter (lambda (rr) (not (eqv? (rr-type rr) 'cname))) rrs))))
|