205 lines
7.0 KiB
Racket
205 lines
7.0 KiB
Racket
#lang racket/unit
|
|
|
|
(require racket/pretty)
|
|
|
|
(require racket/set)
|
|
(require racket/match)
|
|
(require "api.rkt")
|
|
(require "codec.rkt")
|
|
(require "zonedb.rkt")
|
|
(require "network-query-sig.rkt")
|
|
(require "resolver-sig.rkt")
|
|
|
|
(import network-query^)
|
|
(export resolver^)
|
|
|
|
;; Rules:
|
|
;;
|
|
;; - If the DB already has an answer, return it.
|
|
;;
|
|
;; - Otherwise, find the leafmost NS record in the DB for the
|
|
;; requested name.
|
|
;;
|
|
;; - Query that service. Augment the DB with the answers received, if
|
|
;; any. Loop back to the beginning, remembering that we've tried
|
|
;; the specific service we just interacted with so we don't try it
|
|
;; again.
|
|
;;
|
|
;; - Eventually, the DB will have either been augmented with an
|
|
;; answer, or we will have run out of untried nameservers to ask.
|
|
;;
|
|
;; - Authoritative NXDOMAINs ('name-error) mean we get to stop
|
|
;; looking.
|
|
;;
|
|
;; - Resolve CNAMEs on the way. Remember which names we've been
|
|
;; resolving in response to any given query, to avoid
|
|
;; loops. Perhaps limit the length of the chain to avoid
|
|
;; DoS. (TODO)
|
|
;;
|
|
;; - Only performs recursive service if so requested.
|
|
;;
|
|
;; - See RFC 1035 section 7.1.
|
|
|
|
;; QuestionResult Maybe<QuestionResult> -> QuestionResult
|
|
;; Add the supporting facts from r2 into r1, keeping r1's
|
|
;; question. Replaces the knowledge from r1 with the knowledge from
|
|
;; r2. Suitable for use when r2 is answering some sub-question of
|
|
;; r1's question.
|
|
(define (merge-replies r1 r2)
|
|
(match r2
|
|
[#f r1]
|
|
[(question-result _ k2 n2 u2 d2) ;; a normal result
|
|
(match-define (question-result q1 k1 n1 u1 d1) r1)
|
|
(question-result q1
|
|
k2
|
|
(set-union n1 n2)
|
|
(set-union u1 u2)
|
|
(set-union d1 d2))]))
|
|
|
|
(define (answer-from-zone q zone start-of-authority recursion-desired? kf)
|
|
(match-define (question name qtype qclass) q)
|
|
(define rrset (hash-ref zone name set))
|
|
(define filtered-rrs (filter-rrs rrset qtype qclass))
|
|
(define cnames (filter-by-type rrset 'cname)) ;; TODO: filter by class too??
|
|
(define base-reply (question-result q
|
|
zone
|
|
(set-union cnames filtered-rrs)
|
|
(if (and start-of-authority
|
|
(in-bailiwick? name start-of-authority))
|
|
(set start-of-authority)
|
|
(set))
|
|
(set)))
|
|
;; Algorithm for CNAME expansion from RFC 1034 4.3.2 step 3a.
|
|
(define expanded-reply
|
|
(if (and (not (set-empty? cnames)) (not (eqv? qtype 'cname)))
|
|
(foldl (lambda (cname-rr current-reply)
|
|
(merge-replies current-reply
|
|
(resolve-from-zone
|
|
(question (rr-rdata cname-rr) qtype qclass)
|
|
zone
|
|
start-of-authority
|
|
recursion-desired?
|
|
(set))))
|
|
base-reply
|
|
(set->list cnames))
|
|
base-reply))
|
|
(if (set-empty? (question-result-answers expanded-reply))
|
|
(kf)
|
|
expanded-reply))
|
|
|
|
(define (closest-nameservers name zone)
|
|
(let search ((name name))
|
|
(cond
|
|
((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)))
|
|
((null? name)
|
|
;; The root, and we don't have an RRSet for it. Give up.
|
|
(set))
|
|
(else
|
|
;; Remove a label and keep looking.
|
|
(search (cdr name))))))
|
|
|
|
;; Returns a list of NS RRs in some priority order: records for which
|
|
;; we know the associated A record are listed before records for which
|
|
;; we don't.
|
|
(define (closest-untried-nameservers q zone nameservers-tried)
|
|
(define name (question-name q))
|
|
(define ns-rrset (closest-nameservers name zone))
|
|
(let loop ((untried (set->list (set-subtract ns-rrset nameservers-tried)))
|
|
(with-address '())
|
|
(without-address '()))
|
|
(if (null? untried)
|
|
(append with-address without-address)
|
|
(let ((ns-rr (car untried)))
|
|
(define rrs (hash-ref zone (rr-rdata ns-rr) (set)))
|
|
(define a-rrs (filter-by-type rrs 'a))
|
|
(define has-address? (not (set-empty? a-rrs)))
|
|
(loop (cdr untried)
|
|
(if has-address? (cons ns-rr with-address) with-address)
|
|
(if has-address? without-address (cons ns-rr without-address)))))))
|
|
|
|
(define (empty-answer q zone start-of-authority)
|
|
(if (and start-of-authority
|
|
(in-bailiwick? (question-name q) start-of-authority))
|
|
;; NXDOMAIN/name-error if the question is something we're qualified to answer
|
|
#f
|
|
;; A normal no-answers packet otherwise.
|
|
(question-result q
|
|
zone
|
|
(set)
|
|
(set)
|
|
(set))))
|
|
|
|
(define (random-element a-nonempty-list)
|
|
(car a-nonempty-list))
|
|
|
|
(define (network-query q zone ns-rr)
|
|
(define ns-name (rr-rdata ns-rr))
|
|
;; ^ the rr-name is the subzone origin; the rr-rdata is the
|
|
;; nameserver for the subzone
|
|
(match (resolve-from-zone (question ns-name 'a 'in) ;; TODO: 'aaaa ?
|
|
zone
|
|
#f
|
|
#t
|
|
(set))
|
|
[#f zone] ;; Can't find the address of the nameserver!
|
|
[(question-result _ enhanced-zone answers _ _)
|
|
(define address-rrs (filter-by-type answers 'a))
|
|
(if (set-empty? address-rrs)
|
|
zone ;; Again, no addresses for the nameserver!
|
|
(network-query/addresses q
|
|
enhanced-zone
|
|
ns-rr
|
|
(map rr-rdata (set->list address-rrs))))]))
|
|
|
|
;; 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))
|
|
|
|
;; build-referral : Question CompiledZone RR SetOf<RR> -> QuestionResult
|
|
;; Used when servers choose iterative referral over recursive
|
|
;; resolution. The RRs in ns-rrset must be NS RRs.
|
|
(define (build-referral q zone start-of-authority ns-rrset)
|
|
(question-result q
|
|
zone
|
|
ns-rrset
|
|
(and start-of-authority (set start-of-authority))
|
|
(additional-section/a zone (set-map ns-rrset rr-rdata))))
|
|
|
|
(define (resolve-from-zone q zone start-of-authority recursion-desired? nameservers-tried)
|
|
(answer-from-zone q zone start-of-authority recursion-desired?
|
|
(lambda ()
|
|
(let ((best-nameservers (closest-untried-nameservers q zone nameservers-tried)))
|
|
(if (null? best-nameservers)
|
|
(empty-answer q zone start-of-authority)
|
|
(if recursion-desired?
|
|
(let ((best-nameserver (random-element best-nameservers)))
|
|
(define enhanced-zone (network-query q zone best-nameserver))
|
|
(if (eq? enhanced-zone #f)
|
|
;; name-error received!
|
|
#f
|
|
;; we presumably learned something that might help us
|
|
(resolve-from-zone q
|
|
enhanced-zone
|
|
start-of-authority
|
|
recursion-desired?
|
|
(set-add nameservers-tried best-nameserver))))
|
|
(build-referral q zone start-of-authority (list->set best-nameservers))))))))
|