413 lines
15 KiB
Racket
413 lines
15 KiB
Racket
#lang typed/racket/base
|
|
;; Definitions for use in the API to the functionality of the library.
|
|
;;
|
|
;;; 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/>.
|
|
|
|
(provide DomainName
|
|
(except-out (struct-out domain) domain)
|
|
(rename-out [make-domain domain])
|
|
domain-root?
|
|
domain-parent
|
|
|
|
IPv4
|
|
IPv6
|
|
|
|
(struct-out question-repr)
|
|
Question question question?
|
|
QuestionPattern question-pattern question-pattern?
|
|
|
|
question-cyclic?
|
|
question-too-glueless?
|
|
question-restarted?
|
|
restart-question
|
|
cname-question
|
|
ns-question
|
|
|
|
(struct-out answered-question-repr)
|
|
AnsweredQuestion answered-question answered-question?
|
|
AnsweredQuestionPattern answered-question-pattern answered-question-pattern?
|
|
(struct-out rr)
|
|
RR
|
|
|
|
CompleteAnswer
|
|
(struct-out complete-answer)
|
|
empty-complete-answer
|
|
merge-answers
|
|
extract-addresses
|
|
|
|
RData
|
|
(struct-out rdata)
|
|
(struct-out rdata-domain)
|
|
(struct-out rdata-ipv4)
|
|
(struct-out rdata-ipv6)
|
|
(struct-out rdata-hinfo)
|
|
(struct-out rdata-minfo)
|
|
(struct-out rdata-mx)
|
|
(struct-out rdata-soa)
|
|
(struct-out rdata-wks)
|
|
(struct-out rdata-srv)
|
|
(struct-out rdata-txt)
|
|
(struct-out rdata-raw)
|
|
rdata-type-pred
|
|
|
|
RRType
|
|
QueryType
|
|
RRClass
|
|
QueryClass
|
|
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)
|
|
(require marketplace)
|
|
(require marketplace/struct-map)
|
|
(require marketplace/support/pseudo-substruct)
|
|
|
|
;; 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").
|
|
(require/typed "api-untyped.rkt"
|
|
[#:struct domain ([labels : (Listof Bytes)]
|
|
[downcased-labels : (Listof Bytes)])])
|
|
(define-type DomainName domain)
|
|
|
|
;; 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).
|
|
(define-type IPv4 (Vector Byte Byte Byte Byte))
|
|
|
|
;; 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).
|
|
(define-type IPv6 (Vector Byte Byte Byte Byte
|
|
Byte Byte Byte Byte
|
|
Byte Byte Byte Byte
|
|
Byte Byte Byte Byte))
|
|
|
|
;; 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: (TName TType TClass TContext)
|
|
question-repr
|
|
([name : TName] [type : TType] [class : TClass] [context : TContext])
|
|
#:transparent)
|
|
(pseudo-substruct: (question-repr DomainName QueryType QueryClass QuestionContext)
|
|
Question question question?)
|
|
(pseudo-substruct: (question-repr (U Wild DomainName)
|
|
(U Wild QueryType)
|
|
(U Wild QueryClass)
|
|
(U Wild QuestionContext))
|
|
QuestionPattern question-pattern question-pattern?)
|
|
|
|
;; 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 : Question]) #:transparent)
|
|
(struct: cname-subq subquestion () #:transparent)
|
|
(struct: ns-subq subquestion () #:transparent)
|
|
(define-type QuestionContext (U subquestion cname-subq ns-subq False 'restart))
|
|
|
|
;; An AnsweredQuestion is an (answered-question Question
|
|
;; Maybe<CompleteAnswer>).
|
|
(struct: (TQ TA) answered-question-repr ([q : TQ] [a : TA]) #:transparent)
|
|
(pseudo-substruct: (answered-question-repr Question (Option CompleteAnswer))
|
|
AnsweredQuestion answered-question answered-question?)
|
|
(pseudo-substruct: (answered-question-repr (U Wild Question) (U Wild (Option CompleteAnswer)))
|
|
AnsweredQuestionPattern answered-question-pattern answered-question-pattern?)
|
|
|
|
;; A CompleteAnswer is a (complete-answer Set<RR> Set<RR> Set<RR>)
|
|
(struct: complete-answer
|
|
([rrs : (Setof RR)] [authorities : (Setof RR)] [additional : (Setof RR)])
|
|
#:transparent)
|
|
(define-type CompleteAnswer complete-answer)
|
|
|
|
;; An RR is a (rr DomainName RRType RRClass Uint32 RData),
|
|
;; representing a resource record.
|
|
(struct: rr ([name : DomainName]
|
|
[class : RRClass]
|
|
[ttl : Nonnegative-Integer]
|
|
[rdata : RData])
|
|
#:transparent)
|
|
(define-type RR rr)
|
|
|
|
;; 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 Bytes Bytes), 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 ListOf<Bytes>, a txt 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: rdata ([type : RRType]) #:transparent)
|
|
(struct: rdata-domain rdata ([name : DomainName]) #:transparent)
|
|
(struct: rdata-ipv4 rdata ([address : IPv4]) #:transparent)
|
|
(struct: rdata-ipv6 rdata ([address : IPv6]) #:transparent)
|
|
(struct: rdata-hinfo rdata ([cpu : Bytes] [os : Bytes]) #:transparent)
|
|
(struct: rdata-minfo rdata ([rmailbx : DomainName] [emailbx : DomainName]) #:transparent)
|
|
(struct: rdata-mx rdata ([preference : Nonnegative-Integer] [exchange : DomainName]) #:transparent)
|
|
(struct: rdata-soa rdata ([mname : DomainName]
|
|
[rname : DomainName]
|
|
[serial : Nonnegative-Integer]
|
|
[refresh : Nonnegative-Integer]
|
|
[retry : Nonnegative-Integer]
|
|
[expire : Nonnegative-Integer]
|
|
[minimum : Nonnegative-Integer]) #:transparent)
|
|
(struct: rdata-wks rdata ([address : IPv4] [protocol : Byte] [bitmap : Bytes]) #:transparent)
|
|
(struct: rdata-srv rdata ([priority : Nonnegative-Integer]
|
|
[weight : Nonnegative-Integer]
|
|
[port : Nonnegative-Integer]
|
|
[target : DomainName]) #:transparent)
|
|
(struct: rdata-txt rdata ([strings : (Listof Bytes)]) #:transparent)
|
|
(struct: rdata-raw rdata ([body : Bytes]) #:transparent)
|
|
(define-type RData rdata)
|
|
|
|
(: rdata-type-pred : RRType -> (RData -> Boolean))
|
|
(define ((rdata-type-pred t) d)
|
|
(eq? (rdata-type d) t))
|
|
|
|
;; 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-type RRType (U 'a 'ns 'md 'mf 'cname 'soa 'mb 'mg
|
|
'mr 'null 'wks 'ptr 'hinfo 'minfo 'mx 'txt
|
|
'aaaa 'srv
|
|
Nonnegative-Integer))
|
|
(: type->value : RRType -> Nonnegative-Integer)
|
|
(: value->type : Nonnegative-Integer -> RRType)
|
|
(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-type QueryType (U RRType 'axfr 'mailb 'maila '*))
|
|
(: qtype->value : QueryType -> Nonnegative-Integer)
|
|
(: value->qtype : Nonnegative-Integer -> QueryType)
|
|
(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-type RRClass (U 'in 'cs 'ch 'hs Nonnegative-Integer))
|
|
(: class->value : RRClass -> Nonnegative-Integer)
|
|
(: value->class : Nonnegative-Integer -> RRClass)
|
|
(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-type QueryClass (U RRClass '*))
|
|
(: qclass->value : QueryClass -> Nonnegative-Integer)
|
|
(: value->qclass : Nonnegative-Integer -> QueryClass)
|
|
(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.
|
|
(: downcase-labels : (Listof Bytes) -> (Listof Bytes))
|
|
(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.
|
|
(: make-domain : (Listof Bytes) -> DomainName)
|
|
(define (make-domain labels)
|
|
(domain labels (downcase-labels labels)))
|
|
|
|
(: domain-root? : DomainName -> Boolean)
|
|
(define (domain-root? d)
|
|
(null? (domain-labels d)))
|
|
|
|
(: domain-parent : DomainName -> (Option DomainName))
|
|
(define (domain-parent d)
|
|
(and (pair? (domain-labels d))
|
|
(domain (cdr (domain-labels d))
|
|
(cdr (domain-downcased-labels d)))))
|
|
|
|
(: empty-complete-answer : -> CompleteAnswer)
|
|
(define (empty-complete-answer)
|
|
(complete-answer (set) (set) (set)))
|
|
|
|
(: merge-answers : 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)))
|
|
|
|
(: extract-addresses : DomainName (Option 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 ((inst set IPv4)))
|
|
(seen ((inst set DomainName))))
|
|
(if (null? names)
|
|
ips
|
|
(let* ((name (car names))
|
|
(records (filter (lambda: ([rr : RR]) (equal? name (rr-name rr))) rrs))
|
|
(data (map rr-rdata records)))
|
|
(if (set-member? seen name)
|
|
(loop (cdr names) ips seen)
|
|
(let ((a-data (filter rdata-ipv4? (filter (rdata-type-pred 'a) data)))
|
|
(cname-data (filter rdata-domain? (filter (rdata-type-pred 'cname) data))))
|
|
(loop (append (map rdata-domain-name cname-data) (cdr names))
|
|
(set-union ips (list->set (map rdata-ipv4-address a-data)))
|
|
(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.
|
|
(: question-cyclic? : Question -> Boolean)
|
|
(define (question-cyclic? q)
|
|
(match-define (question name type class parent) q)
|
|
(let: search : Boolean ((ancestor : QuestionContext 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".
|
|
(: question-too-glueless? : Question -> Boolean)
|
|
(define (question-too-glueless? q)
|
|
(define count
|
|
(let: search : Integer ((q : Question q) (acc : Integer 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.
|
|
(: question-restarted? : Question -> Boolean)
|
|
(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.
|
|
(: restart-question : Question -> Question)
|
|
(define (restart-question q)
|
|
(struct-copy question-repr q [context 'restart]))
|
|
|
|
;; DomainName Question -> Question
|
|
;; Produces a new question with CNAME context.
|
|
(: cname-question : DomainName Question -> Question)
|
|
(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.
|
|
(: ns-question : DomainName Question -> Question)
|
|
(define (ns-question name q)
|
|
(question name 'a 'in (ns-subq q))) ;; TODO: 'aaaa ?
|