176 lines
6.9 KiB
Racket
176 lines
6.9 KiB
Racket
#lang typed/racket/base
|
|
;;
|
|
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
|
|
;;;
|
|
;;; This file is part of marketplace-dns.
|
|
;;;
|
|
;;; marketplace-dns is free software: you can redistribute it and/or
|
|
;;; modify it under the terms of the GNU General Public License as
|
|
;;; published by the Free Software Foundation, either version 3 of the
|
|
;;; License, or (at your option) any later version.
|
|
;;;
|
|
;;; marketplace-dns is distributed in the hope that it will be useful,
|
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;; General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with marketplace-dns. If not, see
|
|
;;; <http://www.gnu.org/licenses/>.
|
|
|
|
(require racket/pretty)
|
|
|
|
(require racket/set)
|
|
(require racket/match)
|
|
(require racket/list)
|
|
(require "api.rkt")
|
|
(require "codec.rkt")
|
|
(require "zonedb.rkt")
|
|
|
|
(provide PartialAnswer
|
|
Referral
|
|
Answer
|
|
(struct-out partial-answer)
|
|
(struct-out referral)
|
|
|
|
resolve-from-zone)
|
|
|
|
;; 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.
|
|
|
|
;; An Answer is one of
|
|
;; -- a PartialAnswer (some CNAMEs need expanding),
|
|
;; -- a CompleteAnswer (a complete answer ready to send),
|
|
;; -- #f (the domain name does not exist in the CompiledZone given),
|
|
;; -- a Referral (a referral to some other nameserver).
|
|
(define-type Answer (U CompleteAnswer PartialAnswer Referral #f))
|
|
|
|
;; A PartialAnswer is a (partial-answer CompleteAnswer ListOf<DomainName>)
|
|
;; A collection of relevant RRs together with some CNAMEs that need expanding.
|
|
(struct: partial-answer ([base : CompleteAnswer] [cnames : (Listof DomainName)]) #:transparent)
|
|
(define-type PartialAnswer partial-answer)
|
|
|
|
;; A Referral is a (referral DomainName Set<RR> Set<RR>)
|
|
(struct: referral ([zone-origin : DomainName]
|
|
[nameserver-rrs : (Setof RR)]
|
|
[additional : (Setof RR)]) #:transparent)
|
|
(define-type Referral referral)
|
|
|
|
(: answer-from-zone : Question CompiledZone (Option RR) -> Answer)
|
|
;; An answer of #f here does NOT indicate a missing domain-name
|
|
;; (name-error/NXDOMAIN), but instead indicates that there are no
|
|
;; records matching the query in the database given. It's up to the
|
|
;; caller to decide what to do about that.
|
|
(define (answer-from-zone q zone start-of-authority)
|
|
(match-define (question name qtype qclass _) q)
|
|
(define: rrset : (Setof RR) (or (zone-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 answer-set (set-union cnames filtered-rrs))
|
|
(define base (complete-answer answer-set
|
|
(if (and start-of-authority
|
|
(in-bailiwick? name (rr-name start-of-authority)))
|
|
(set start-of-authority)
|
|
(set))
|
|
(set)))
|
|
(cond
|
|
[(set-empty? answer-set) ;; No matching records or domain absent (deliberately ambiguous)
|
|
#f]
|
|
[(or (eq? qtype 'cname) (set-empty? cnames)) ;; Either asking for CNAMEs, or no CNAMEs to expand
|
|
base]
|
|
[else ;; Kick off the algorithm for CNAME expansion from RFC 1034 4.3.2 step 3a
|
|
(partial-answer base (set-map cnames rr-rdata-domain-name))]))
|
|
|
|
(: closest-nameservers : DomainName CompiledZone -> (Setof RR))
|
|
(define (closest-nameservers name zone)
|
|
(let: search ((name : (Option DomainName) name))
|
|
(cond
|
|
((not name)
|
|
;; We've walked up the tree past the root. Give up.
|
|
(set))
|
|
((zone-ref zone name) =>
|
|
;; 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 (domain-parent name)) ;; no NS records for this suffix. Keep looking.
|
|
ns-rrset)))
|
|
(else
|
|
;; Remove a label and keep looking.
|
|
(search (domain-parent name))))))
|
|
|
|
(: closest-untried-nameservers : Question CompiledZone (Setof DomainName) -> (Setof RR))
|
|
;; Returns a set of NS RRs in an arbitrary order.
|
|
(define (closest-untried-nameservers q zone nameservers-tried)
|
|
(define name (question-repr-name q))
|
|
(define ns-rrset (closest-nameservers name zone))
|
|
(list->set
|
|
(for/list: : (Listof RR) ([rr : RR ns-rrset]
|
|
#:when (not (set-member? nameservers-tried (rr-rdata-domain-name rr))))
|
|
rr)))
|
|
|
|
(: empty-answer : Question CompiledZone (Option RR) -> (Option CompleteAnswer))
|
|
(define (empty-answer q zone start-of-authority)
|
|
(if (and start-of-authority ;; we are authoritative for something
|
|
(in-bailiwick? (question-repr-name q) (rr-name start-of-authority))
|
|
;; ^ for this in particular
|
|
(not (zone-includes-name? zone (question-repr-name q))))
|
|
;; ^ there are no RRs at all for this q
|
|
;; NXDOMAIN/name-error: we definitely know there are no RRs at all for this q.
|
|
#f
|
|
;; A normal no-answers packet otherwise.
|
|
(empty-complete-answer)))
|
|
|
|
(: additional-section/a : CompiledZone (Listof DomainName) -> (Setof RR))
|
|
;; 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 : DomainName] [section : (Setof RR)])
|
|
(set-union section
|
|
(set-filter (lambda: ([rr : RR])
|
|
(and (memv (rdata-type (rr-rdata rr)) '(a aaaa))
|
|
(eqv? (rr-class rr) 'in)))
|
|
(or (zone-ref zone name) ((inst set RR))))))
|
|
((inst set RR))
|
|
names))
|
|
|
|
(: resolve-from-zone : Question CompiledZone (Option RR) (Setof DomainName) -> Answer)
|
|
(define (resolve-from-zone q zone start-of-authority nameservers-tried)
|
|
(or (answer-from-zone q zone start-of-authority)
|
|
(let ((best-nameservers (closest-untried-nameservers q zone nameservers-tried)))
|
|
(if (set-empty? best-nameservers)
|
|
(empty-answer q zone start-of-authority)
|
|
(let ((zone-origin (rr-name (car (set->list best-nameservers))))) ;; any entry will do
|
|
(referral zone-origin
|
|
best-nameservers
|
|
(additional-section/a zone (set-map best-nameservers
|
|
rr-rdata-domain-name))))))))
|