Split out zone utilities
This commit is contained in:
Tony Garnock-Jones
parent
07f5abfbff
commit
e63391d8fc
78
driver.rkt
78
driver.rkt
|
|
@ -9,6 +9,7 @@
|
|||
(require "../racket-bitsyntax/main.rkt")
|
||||
(require "api.rkt")
|
||||
(require "codec.rkt")
|
||||
(require "zonedb.rkt")
|
||||
(require "dump-bytes.rkt")
|
||||
|
||||
;; Instantiated with a SOA record for the zone it is serving as well
|
||||
|
|
@ -24,64 +25,11 @@
|
|||
;; determines subzones based on the RRs it is configured with at
|
||||
;; startup.
|
||||
|
||||
;; 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.
|
||||
|
||||
;; compile-db : ListOf<RR> -> Hash<DomainName,ListSetOf<RR>>
|
||||
;; Builds an immutable hash table from the given RRs, suitable for
|
||||
;; quickly looking up answers to queries.
|
||||
(define (compile-db rrs)
|
||||
;; RR Hash -> Hash
|
||||
(define (incorporate-rr rr db)
|
||||
(hash-set db (rr-name rr) (set-add (hash-ref db (rr-name rr) (set)) rr)))
|
||||
(foldl incorporate-rr (make-immutable-hash) rrs))
|
||||
|
||||
(define (in-bailiwick? dn root)
|
||||
(cond
|
||||
((equal? dn root) #t)
|
||||
((null? dn) #f)
|
||||
(else (in-bailiwick? (cdr dn) root))))
|
||||
|
||||
(define (authoritativeness-for dn soa-rr)
|
||||
(if (in-bailiwick? dn (rr-name soa-rr))
|
||||
'authoritative
|
||||
'non-authoritative))
|
||||
|
||||
(define (filter-by-type rrset type)
|
||||
(set-filter (lambda (rr) (eqv? (rr-type rr) type)) rrset))
|
||||
|
||||
(define (referral-for name soa-rr zone)
|
||||
(define limit (rr-name soa-rr))
|
||||
(let search ((name name))
|
||||
(cond
|
||||
((or (null? name) (equal? name limit))
|
||||
;; We've walked up the tree to the top of the zone. No referrals
|
||||
;; are possible.
|
||||
#f)
|
||||
((hash-ref zone name #f) =>
|
||||
;; There's an entry for this suffix of the original name. Check
|
||||
;; to see if it has an NS record indicating a subzone.
|
||||
(lambda (rrset)
|
||||
(define ns-rrset (filter-by-type rrset 'ns))
|
||||
(if (set-empty? ns-rrset)
|
||||
(search (cdr name)) ;; no NS records for this suffix. Keep looking.
|
||||
ns-rrset)))
|
||||
(else
|
||||
;; Nothing for this suffix. Keep lookup.
|
||||
(search (cdr name))))))
|
||||
|
||||
(define (additional-section/a zone names)
|
||||
;; RFC 3596 (section 3) requires that we process AAAA here as well
|
||||
;; as A.
|
||||
(foldl (lambda (name section)
|
||||
(set-union section
|
||||
(set-filter (lambda (rr) (and (memv (rr-type rr) '(a aaaa))
|
||||
(eqv? (rr-class rr) 'in)))
|
||||
(hash-ref zone name))))
|
||||
(set)
|
||||
names))
|
||||
|
||||
;; ASSUMPTION: r1 and r2 are both DNS replies to the same query.
|
||||
;; ASSUMPTION: no response-codes other than no-error or name-error are in use.
|
||||
(define (merge-replies r1 r2)
|
||||
|
|
@ -107,28 +55,6 @@
|
|||
(define (listset-union xs1 xs2)
|
||||
(set->list (set-union (list->set xs1) (list->set xs2))))
|
||||
|
||||
;; 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-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)
|
||||
|
||||
;; start-server : UInt16 RR ListOf<RR> -> Void
|
||||
;; Starts a server that will answer questions received on the given
|
||||
;; UDP port based on the RRs it is given and the zone origin specified
|
||||
|
|
@ -136,7 +62,7 @@
|
|||
(require racket/pretty)
|
||||
(define (start-server port-number soa-rr rrs)
|
||||
;; Compile the zone hash table
|
||||
(define zone (compile-db (cons soa-rr rrs)))
|
||||
(define zone (compile-zone-db (cons soa-rr rrs)))
|
||||
|
||||
(pretty-print zone)
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,102 @@
|
|||
#lang racket/base
|
||||
|
||||
;; Noddy representation of a zone, and various zone and RRSet utilities.
|
||||
|
||||
(require racket/set)
|
||||
(require "api.rkt")
|
||||
(require "codec.rkt")
|
||||
|
||||
(provide compile-zone-db
|
||||
in-bailiwick?
|
||||
set-filter
|
||||
filter-by-type
|
||||
referral-for
|
||||
additional-section/a
|
||||
filter-rrs)
|
||||
|
||||
;; A CompiledZone is a Hash<DomainName,ListSetOf<RR>>, representing a
|
||||
;; collection of DNS RRSets indexed by DomainName.
|
||||
|
||||
;; 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.
|
||||
|
||||
;; 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)
|
||||
;; RR Hash -> Hash
|
||||
(define (incorporate-rr rr db)
|
||||
(hash-set db (rr-name rr) (set-add (hash-ref db (rr-name rr) (set)) rr)))
|
||||
(foldl incorporate-rr (make-immutable-hash) rrs))
|
||||
|
||||
;; in-bailiwick? : DomainName DomainName -> Boolean
|
||||
;; Answers #t iff dn falls within the bailiwick of the zone with
|
||||
;; origin root.
|
||||
(define (in-bailiwick? dn root)
|
||||
(cond
|
||||
((equal? dn root) #t)
|
||||
((null? dn) #f)
|
||||
(else (in-bailiwick? (cdr dn) root))))
|
||||
|
||||
;; 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))
|
||||
|
||||
(define (referral-for name soa-rr zone)
|
||||
(define limit (rr-name soa-rr))
|
||||
(let search ((name name))
|
||||
(cond
|
||||
((or (null? name) (equal? name limit))
|
||||
;; We've walked up the tree to the top of the zone. No referrals
|
||||
;; are possible.
|
||||
#f)
|
||||
((hash-ref zone name #f) =>
|
||||
;; There's an entry for this suffix of the original name. Check
|
||||
;; to see if it has an NS record indicating a subzone.
|
||||
(lambda (rrset)
|
||||
(define ns-rrset (filter-by-type rrset 'ns))
|
||||
(if (set-empty? ns-rrset)
|
||||
(search (cdr name)) ;; no NS records for this suffix. Keep looking.
|
||||
ns-rrset)))
|
||||
(else
|
||||
;; Nothing for this suffix. Keep lookup.
|
||||
(search (cdr name))))))
|
||||
|
||||
;; additional-section/a : CompiledZone ListOf<DomainName>
|
||||
;; Implements the "additional section" rules from RFC 1035 (and the
|
||||
;; rules for IPv6 from RFC 3596). Provides A and AAAA records for
|
||||
;; names mentioned in the "names" list that have entries in "zone".
|
||||
(define (additional-section/a zone names)
|
||||
;; RFC 3596 (section 3) requires that we process AAAA here as well
|
||||
;; as A.
|
||||
(foldl (lambda (name section)
|
||||
(set-union section
|
||||
(set-filter (lambda (rr) (and (memv (rr-type rr) '(a aaaa))
|
||||
(eqv? (rr-class rr) 'in)))
|
||||
(hash-ref zone name))))
|
||||
(set)
|
||||
names))
|
||||
|
||||
;; 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)
|
||||
Loading…
Reference in New Issue