racket-dns-2012/api.rkt

310 lines
10 KiB
Racket

#lang racket/base
;; Definitions for use in the API to the functionality of the library.
(provide (except-out (struct-out domain) domain)
(rename-out [make-domain domain])
domain-root?
domain-parent
(struct-out question)
question-cyclic?
question-too-glueless?
question-restarted?
restart-question
cname-question
ns-question
(struct-out answered-question)
(struct-out rr)
(struct-out complete-answer)
empty-complete-answer
merge-answers
extract-addresses
(struct-out hinfo)
(struct-out minfo)
(struct-out mx)
(struct-out soa)
(struct-out wks)
(struct-out srv)
type->value value->type
qtype->value value->qtype
class->value value->class
qclass->value value->qclass)
(require "mapping.rkt")
(require racket/set)
(require racket/match)
;; (These utilities need to be defined ahead of the domain struct
;; definition.)
(define (domain=? a b recursive-equal?)
(recursive-equal? (domain-downcased-labels a)
(domain-downcased-labels b)))
(define (domain-hash-1/2 d recursive-hash)
(recursive-hash (domain-downcased-labels d)))
;; A DomainName is a (domain ListOf<Bytes>), representing a domain
;; name. The head of the list is the leftmost label; for example,
;; www.google.com is represented as '(#"www" #"google" #"com").
(struct domain (labels downcased-labels)
#:transparent
#:property prop:equal+hash (list domain=? domain-hash-1/2 domain-hash-1/2))
(require "../racket-matrix/struct-map.rkt")
(install-struct-mapper! struct:domain
(lambda (f seed x)
(let-values (((labels seed) (f (domain-labels x) seed)))
(values (make-domain labels) seed))))
;; A ShortString is a String with length 255 or shorter.
;; An IPv4 is a (vector Byte Byte Byte Byte), representing an IPv4
;; address. For example, 127.0.0.1 is represented as (vector 127 0 0
;; 1).
;; An IPv6 is a Vector of length 16 containing Bytes, representing an
;; IPv6 address. For example, 2001:0db8:85a3:0000:0000:8a2e:0370:7334
;; is represented as (vector #x20 #x01 #x0d #xb8 #x85 #xa3 #x00 #x00
;; #x00 #x00 #x8a #x2e #x03 #x70 #x73 #x34).
;; A Question is a (question DomainName QueryType QueryClass
;; QuestionContext), representing a DNS question: "What are the RRs
;; for the given name, type and class?" as well as a possible parent
;; question that the answer to this question is to contribute to the
;; answer to.
(struct question (name type class context) #:prefab)
;; A QuestionContext is one of
;; -- (cname-subq Question), resulting from the expansion of a CNAME
;; -- (ns-subq Question), resulting from a network referral
;; -- #f, an original question from a remote peer
;; -- 'restart, a restarted question.
;;
;; The context is needed to break cycles in the DNS database. If the
;; context chain ends in 'restart, then the question results from an
;; excessively-glueless subquestion not represented here, and should
;; *not* in turn be considered for gluelessness-restarting: this is
;; needed to avoid a different kind of infinite loop.
(struct subquestion (parent) #:prefab)
(struct cname-subq subquestion () #:prefab)
(struct ns-subq subquestion () #:prefab)
;; An AnsweredQuestion is an (answered-question Question
;; Maybe<CompleteAnswer>).
(struct answered-question (q a) #:prefab)
;; A CompleteAnswer is a (complete-answer Set<RR> Set<RR> Set<RR>)
(struct complete-answer (rrs authorities additional) #:prefab)
;; An RR is a (rr DomainName RRType RRClass Uint32 RData),
;; representing a resource record.
(struct rr (name type class ttl rdata) #:prefab)
;; An RData is one of
;; - a DomainName, for CNAME, MB, MD, MF, MG, MR, NS and PTR records
;; - an IPv4, an "A" record
;; - an IPv6, an "AAAA" record
;; - (hinfo ShortString ShortString), a host information record [O]
;; - (minfo DomainName DomainName), a mailbox information record [O]
;; - (mx Uint16 DomainName), a mail exchanger record
;; - (soa DomainName DomainName Uint32 Uint32 Uint32 Uint32 Uint32), a
;; start-of-authority record
;; - (wks IPv4 Byte Bytes), a Well-Known Service [O]
;; - (srv Uint16 Uint16 Uint16 DomainName), an "SRV" record
;; - a Bytes, either a 'null type RR or any unrecognised RR type.
;;
;; In each case, the RData's variant MUST line up correctly with the
;; type field of any RR containing it.
;;
;; Many of these variants are obsolete in today's DNS database (marked
;; [O] above).
(struct hinfo (cpu os) #:prefab)
(struct minfo (rmailbx emailbx) #:prefab)
(struct mx (preference exchange) #:prefab)
(struct soa (mname rname serial refresh retry expire minimum) #:prefab)
(struct wks (address protocol bitmap) #:prefab)
(struct srv (priority weight port target) #:prefab)
;; An RRType is a Symbol or a Number, one of the possibilities given
;; in the following define-mapping. It represents the type of an
;; RR. When used in an RR with an RData, the RRType and the RData
;; variant must correspond.
(define-mapping type->value value->type
#:forward-default values
#:backward-default values
(a 1)
(ns 2)
(md 3)
(mf 4)
(cname 5)
(soa 6)
(mb 7)
(mg 8)
(mr 9)
(null 10)
(wks 11)
(ptr 12)
(hinfo 13)
(minfo 14)
(mx 15)
(txt 16)
(aaaa 28)
(srv 33))
;; A QueryType is a Symbol or Number (as given in the following
;; define-mapping) or an RRType. It specifies the kinds of records
;; being sought after in a DNS query.
(define-mapping qtype->value value->qtype
#:forward-default type->value
#:backward-default value->type
(axfr 252)
(mailb 253)
(maila 254)
(* 255))
;; An RRClass is a Symbol or a Number, one of the possibilities given
;; in the following define-mapping. It represents the "class" of DNS
;; records being discussed. All classes except 'in are obsolete in
;; today's DNS databases.
(define-mapping class->value value->class
#:forward-default values
#:backward-default values
(in 1)
(cs 2)
(ch 3)
(hs 4))
;; A QueryClass is a Symbol or Number (as given in the following
;; define-mapping) or an RRClass. It specifies the "class" of records
;; being sought after in a DNS query.
(define-mapping qclass->value value->qclass
#:forward-default class->value
#:backward-default value->class
(* 255))
;; ListOf<Bytes> -> ListOf<Bytes>
;; Converts the 7-bit ASCII bytes in the argument to lower-case
;; equivalents. Used to normalize case for domain-name comparisons.
(define (downcase-labels labels)
(for/list ([label labels])
(define b (make-bytes (bytes-length label)))
(for ([i (bytes-length label)])
(define v (bytes-ref label i))
(bytes-set! b i (if (<= 65 v 90) (+ 32 v) v)))
b))
;; ListOf<Bytes> -> DomainName
;; Replacement constructor for domain structs. Automatically downcases
;; labels appropriately.
(define (make-domain labels)
(domain labels (downcase-labels labels)))
;; DomainName -> Boolean
(define (domain-root? d)
(null? (domain-labels d)))
;; DomainName -> Maybe<DomainName>
(define (domain-parent d)
(and (pair? (domain-labels d))
(domain (cdr (domain-labels d))
(cdr (domain-downcased-labels d)))))
;; -> CompleteAnswer
(define (empty-complete-answer)
(complete-answer (set) (set) (set)))
;; CompleteAnswer CompleteAnswer -> CompleteAnswer
(define (merge-answers a1 a2)
(match-define (complete-answer n1 u1 d1) a1)
(match-define (complete-answer n2 u2 d2) a2)
(complete-answer (set-union n1 n2)
(set-union u1 u2)
(set-union d1 d2)))
;; DomainName Maybe<CompleteAnswer> -> SetOf<IPv4>
(define (extract-addresses name ans)
(match ans
[#f ;; name-error/NXDOMAIN, so definitely no addresses.
(set)]
[(complete-answer ns us ds)
(define rrs (set->list (set-union ns us ds)))
(let loop ((names (list name))
(ips (set))
(seen (set)))
(if (null? names)
ips
(let* ((name (car names))
(records (filter (lambda (rr) (equal? name (rr-name rr))) rrs)))
(if (set-member? seen name)
(loop (cdr names) ips seen)
(let ((a-records (filter (lambda (rr) (equal? 'a (rr-type rr))) records))
(cname-records (filter (lambda (rr) (equal? 'cname (rr-type rr))) records)))
(loop (append (map rr-rdata cname-records) (cdr names))
(set-union ips (list->set (map rr-rdata a-records)))
(set-add seen name)))))))]))
;; Question -> Boolean
;; #t iff this question is being asked in order to supply answers
;; contributing to a parent context that's trying to answer exactly
;; this question.
(define (question-cyclic? q)
(match-define (question name type class parent) q)
(let search ((ancestor parent))
(match ancestor
[(subquestion (question (== name) (== type) (== class) _)) #t] ;; uh-oh! A cycle!
[(subquestion (question _ _ _ ancestor-parent)) (search ancestor-parent)] ;; recursive case
[_ #f]))) ;; no further parents -> definitely not cyclic
;; Question -> Boolean
;; If we're looking up a nameserver's address, in order to look up a
;; nameserver's address, in order to answer some question, that came
;; from the outside world, then that's too glueless. See
;; http://cr.yp.to/djbdns/notes.html in the sections "Gluelessness"
;; and "Expiring glue".
(define (question-too-glueless? q)
(define count
(let search ((q q) (acc 0))
(match-define (question _ _ _ parent) q)
(cond
[(ns-subq? parent) (search (subquestion-parent parent) (+ acc 1))]
[(subquestion? parent) (search (subquestion-parent parent) acc)]
[else acc])))
(if (>= count 2)
;; We're (at least) at the right nesting level: now see if this
;; question was already the result of a restart. If so, we
;; grimly press on with it unchanged.
(not (question-restarted? q))
#f))
;; Question -> Boolean
;; #t iff this question is being asked in the context of some
;; excessively glueless subquestion.
(define (question-restarted? q)
(match-define (question name type class parent) q)
(let search ((ancestor parent))
(match ancestor
[(subquestion (question _ _ _ ancestor-parent)) (search ancestor-parent)]
['restart #t]
[_ #f])))
;; Question -> Question
;; Returns a question equivalent to q, but in a 'restart context, for
;; retracing from the roots in cases of excessive gluelessness.
(define (restart-question q)
(struct-copy question q [context 'restart]))
;; DomainName Question -> Question
;; Produces a new question with CNAME context.
(define (cname-question name q)
(match-define (question _ type class _) q)
(question name type class (cname-subq q)))
;; DomainName Question -> Question
;; Produces a new question with NS context.
(define (ns-question name q)
(question name 'a 'in (ns-subq q))) ;; TODO: 'aaaa ?