racket-dns-2012/zonedb.rkt

#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))))