syndicate-lang
/
marketplace-dns-2014
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Initial commit extracted from racket-dns repo

This commit is contained in:
Tony Garnock-Jones 2013-05-10 16:38:25 -04:00
commit e2f38da0e7
16 changed files with 3051 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored Normal file
View File

@ -0,0 +1 @@
compiled/

33
TODO Normal file
View File

@ -0,0 +1,33 @@
## DNS
Tests needed:
- encode and decode of each kind of RR
- so far, have: txt, a, ns, mx, soa, cname, aaaa, srv.
- that leaves: md, mf, mb, mg, mr, null, wks, ptr, hinfo, minfo
- most of those are obsolete, so finding wild examples will be
very difficult
- encode and decode of several variants of packet, both sensible and not
- misleading section length count - short, long
- misleading label length - short, long
- misleading rdata length - short, long
- misleading txt record string length - short, long
- looping domain-name (using compressed format)
- compressed domain-name pointing into hyperspace
- txt record with rdata filled with a list of empty byte-strings
### Proxy
#### Make CNAME NXDOMAIN refer to the target record, not the CNAME itself
See also RFC 2308 section 2.1 and
http://homepage.ntlworld.com./jonathan.deboynepollard/FGA/dns-response-taxonomy.html
Basically, if the CNAME record is in the response, that's sufficient
indication that the name of the CNAME exists! So NXDOMAIN clearly
doesn't make sense to apply there.
#### Should the cache replace SOAs by serial number?
It probably shouldn't cache SOA records at all. Djbdns doesn't.
("dnscache does not cache SOA records", from http://cr.yp.to/djbdns/dnscache.html)

40
api-untyped.rkt Normal file
View File

@ -0,0 +1,40 @@
#lang racket/base
;; Untyped struct definitions required to interoperate with marketplace's struct-map
;; See also Racket PR 13593.
(require marketplace/struct-map)
(provide (struct-out domain))
;; (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)))
(struct domain (labels downcased-labels)
#:transparent
#:property prop:equal+hash (list domain=? domain-hash-1/2 domain-hash-1/2)
#:property prop:struct-map (lambda (f seed x)
(let-values (((labels seed) (f (domain-labels x) seed)))
(values (make-domain labels) seed))))
;; 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)))

394
api.rkt Normal file
View File

@ -0,0 +1,394 @@
#lang typed/racket/base
;; Definitions for use in the API to the functionality of the library.
(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 ?

505
codec.rkt Normal file
View File

@ -0,0 +1,505 @@
#lang typed/racket/base
;; DNS wire-protocol codec.
(provide Opcode
ResponseCode
value->query-opcode query-opcode->value
value->query-response-code query-response-code->value
DNSMessage
Direction
Authoritativeness
Truncatedness
RecursionDesired
RecursionAvailable
(struct-out dns-message)
packet->dns-message
dns-message->packet
max-ttl
;; For the use of zonedb's save/load routines, etc.
t:rr)
(require "api.rkt")
(require "mapping.rkt")
(require racket/match)
(require (planet tonyg/bitsyntax))
;; An Opcode is a Symbol or a Number, one of the possibilities given
;; in the following define-mapping. It represents a DNS message
;; operation; see the RFC for details.
(define-type Opcode (U 'query 'iquery 'status Nonnegative-Integer))
(: value->query-opcode : Nonnegative-Integer -> Opcode)
(: query-opcode->value : Opcode -> Nonnegative-Integer)
(define-mapping value->query-opcode query-opcode->value
#:forward-default values
#:backward-default values
(0 query)
(1 iquery)
(2 status))
;; A ResponseCode is a Symbol or a Number, one of the possibilities
;; given in the following define-mapping. It represents the outcome of
;; a DNS query.
(define-type ResponseCode (U 'no-error 'format-error 'server-failure
'name-error 'not-implemented 'refused
Nonnegative-Integer))
(: value->query-response-code : Nonnegative-Integer -> ResponseCode)
(: query-response-code->value : ResponseCode -> Nonnegative-Integer)
(define-mapping value->query-response-code query-response-code->value
(0 no-error)
(1 format-error)
(2 server-failure)
(3 name-error) ;; most frequently known on the internet as NXDOMAIN.
(4 not-implemented)
(5 refused))
;; A DNSMessage is a
;; (dns-message Uint16 Direction Opcode Authoritativeness
;; Truncatedness RecursionDesired RecursionAvailable ResponseCode
;; ListOf<Question> ListOf<RR> ListOf<RR> ListOf<RR>).
;;
;; Interpreted as either a DNS request or reply, depending on the
;; Direction.
(struct: dns-message ([id : Nonnegative-Integer]
[direction : Direction]
[opcode : Opcode]
[authoritative : Authoritativeness]
[truncated : Truncatedness]
[recursion-desired : RecursionDesired]
[recursion-available : RecursionAvailable]
[response-code : ResponseCode]
[questions : (Listof Question)]
[answers : (Listof RR)]
[authorities : (Listof RR)]
[additional : (Listof RR)])
#:transparent)
(define-type DNSMessage dns-message)
(define-type Direction (U 'request 'response))
(define-type Authoritativeness (U 'non-authoritative 'authoritative))
(define-type Truncatedness (U 'not-truncated 'truncated))
(define-type RecursionDesired (U 'no-recursion-desired 'recursion-desired))
(define-type RecursionAvailable (U 'no-recursion-available 'recursion-available))
;; Bit-syntax type for counted repeats of a value.
;; Example: Length-prefixed list of 32-bit unsigned words:
;; (bit-string-case input ([ len (vals :: (t:ntimes Integer len bits 32)) ] vals))
;; (bit-string (vals :: (t:ntimes Integer bits 32)))
(define-syntax t:ntimes
(syntax-rules ()
((_ #t input0 ks kf Type times-to-repeat option ...)
(let ()
;; A simple loop without multiple-values or #f is much cleaner
;; here, but I can't find a way of expressing the types
;; required while making that work. This way, we avoid needing
;; to mention the type of the result of calls to ks.
(: loop : Integer (Listof Type) BitString -> (Values (Option (Listof Type)) BitString))
(define (loop count acc input)
(cond
((positive? count) (bit-string-case input
([ (v :: option ...) (rest :: binary) ]
(loop (- count 1) (cons v acc) rest))
(else
(values #f input))))
(else (values (reverse acc) input))))
(let-values (((vs rest) (loop times-to-repeat '() input0)))
(if vs
(ks vs rest)
(kf)))))
((_ #f val Type option ...)
(t:listof #f val Type option ...))))
;; Bit-syntax type for repeats of a value until no more input available.
;; Example: List of 32-bit unsigned words:
;; (bit-string-case input ([ (vals :: (t:listof Integer bits 32)) ] vals))
;; (bit-string (vals :: (t:listof Integer bits 32)))
(define-syntax t:listof
(syntax-rules ()
((_ #t input0 ks kf Type option ...)
;; The loop is unrolled once here to let Typed Racket propagate
;; the type of v0 into the type of acc in the loop. When not
;; unrolled, it gives acc type (Listof Any).
;; TODO: come up with some other way of doing this that avoids the duplication.
(bit-string-case input0
([ (v0 :: option ...) (input1 :: binary) ]
(let loop ((acc (list v0))
(input input1))
(bit-string-case input
([ (v :: option ...) (rest :: binary) ]
(loop (cons v acc) rest))
([]
(ks (reverse acc) #""))
(else
(kf)))))
([]
(ks '() #""))
(else
(kf))))
((_ #f vs Type option ...)
(let: loop : BitString ((vs : (Listof Type) vs))
(cond
((pair? vs) (bit-string ((car vs) :: option ...)
((loop (cdr vs)) :: binary)))
(else (bit-string)))))))
;; <rfc1035>
;; All communications inside of the domain protocol are carried in a single
;; format called a message. The top level format of message is divided
;; into 5 sections (some of which are empty in certain cases) shown below:
;;
;; +---------------------+
;; | Header |
;; +---------------------+
;; | Question | the question for the name server
;; +---------------------+
;; | Answer | RRs answering the question
;; +---------------------+
;; | Authority | RRs pointing toward an authority
;; +---------------------+
;; | Additional | RRs holding additional information
;; +---------------------+
;; </rfc1035>
;; <rfc1035>
;; The header contains the following fields:
;;
;; 1 1 1 1 1 1
;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; | ID |
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; |QR| Opcode |AA|TC|RD|RA| Z | RCODE |
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; | QDCOUNT |
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; | ANCOUNT |
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; | NSCOUNT |
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; | ARCOUNT |
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; </rfc1035>
(: packet->dns-message : BitString -> DNSMessage)
;; Parse an encoded DNS message packet into the corresponding Racket
;; structure. Raises an exception on failure.
(define (packet->dns-message packet)
(bit-string-case packet
([ (id :: bits 16)
;; 16 bits of flags, opcode, and response-code:
(qr :: (t:named-bit 'request 'response))
(opcode :: bits 4)
(aa :: (t:named-bit 'non-authoritative 'authoritative))
(tc :: (t:named-bit 'not-truncated 'truncated))
(rd :: (t:named-bit 'no-recursion-desired 'recursion-desired))
(ra :: (t:named-bit 'no-recursion-available 'recursion-available))
(= 0 :: bits 3)
(rcode :: bits 4)
(qdcount :: bits 16)
(ancount :: bits 16)
(nscount :: bits 16)
(arcount :: bits 16)
(q-section :: (t:ntimes Question qdcount (t:question packet)))
(a-section :: (t:ntimes RR ancount (t:rr packet)))
(auth-section :: (t:ntimes RR nscount (t:rr packet)))
(additional-section :: (t:ntimes RR arcount (t:rr packet))) ]
(dns-message id qr (value->query-opcode opcode)
aa tc rd ra
(value->query-response-code rcode)
q-section a-section auth-section additional-section))))
(: dns-message->packet : DNSMessage -> Bytes)
;; Render a Racket structured DNS message using the DNS binary encoding.
(define (dns-message->packet m)
(bit-string->bytes
(bit-string ((dns-message-id m) :: bits 16)
((dns-message-direction m) :: (t:named-bit 'request 'response))
((query-opcode->value (dns-message-opcode m)) :: bits 4)
((dns-message-authoritative m) :: (t:named-bit 'non-authoritative 'authoritative))
((dns-message-truncated m) :: (t:named-bit 'not-truncated 'truncated))
((dns-message-recursion-desired m)
:: (t:named-bit 'no-recursion-desired 'recursion-desired))
((dns-message-recursion-available m)
:: (t:named-bit 'no-recursion-available 'recursion-available))
(0 :: bits 3)
((query-response-code->value (dns-message-response-code m)) :: bits 4)
((length (dns-message-questions m)) :: bits 16)
((length (dns-message-answers m)) :: bits 16)
((length (dns-message-authorities m)) :: bits 16)
((length (dns-message-additional m)) :: bits 16)
((dns-message-questions m) :: (t:ntimes Question (t:question)))
((dns-message-answers m) :: (t:ntimes RR (t:rr)))
((dns-message-authorities m) :: (t:ntimes RR (t:rr)))
((dns-message-additional m) :: (t:ntimes RR (t:rr))))))
;; Bit-syntax type for a single bit, represented in Racket as one of
;; two possible symbolic values.
;; Example: a bit represented by 'zero when it is zero, and 'one when it is one.
;; (bit-string-case input ([ (v :: (t:named-bit 'zero 'one)) ] v))
;; (bit-string (v :: (t:named-bit 'zero 'one)))
(define-syntax t:named-bit
(syntax-rules ()
((_ #t input ks kf name0 name1)
(bit-string-case input
([ (v :: bits 1) (rest :: binary) ]
(ks (if (zero? v) name0 name1) rest))
(else (kf))))
((_ #f v name0 name1)
(cond
((eq? v name1) (bit-string (1 :: bits 1)))
((eq? v name0) (bit-string (0 :: bits 1)))
(else (error 't:named-bit
"Value supplied is neither ~v nor ~v: ~v"
name0 name1 v))))))
;; Bit-syntax type for a DomainName. When decoding (but not when
;; encoding!), we support DNS's weird compressed domain-name syntax;
;; this requires us to pass in the *whole packet* to the decoder to
;; let it refer to random substrings within the packet.
(define-syntax t:domain-name
(syntax-rules ()
((_ #t input ks kf whole-packet)
(let-values (((name rest) (parse-domain-name whole-packet input '())))
(ks (domain name) rest)))
((_ #f val)
(encode-domain-name val))))
(: encode-domain-name : DomainName -> BitString)
(define (encode-domain-name name)
(define labels (domain-labels name))
(bit-string (labels :: (t:listof Bytes (t:pascal-string "Label" 64)))
(0 :: integer bytes 1))) ;; end of list of labels!
(: parse-domain-name :
BitString BitString (Listof Natural) -> (Values (Listof Bytes) BitString))
;; PRECONDITION: input never empty
;; INVARIANT: pointers-followed contains every "jump target" we have
;; jumped to so far during decoding of this domain-name, in order to
;; prevent us from getting stuck in a pointer loop. It should start as
;; the empty list.
(define (parse-domain-name whole-packet input pointers-followed)
(bit-string-case input
([(= 3 :: bits 2) (offset :: bits 14) (rest :: binary)]
(if (member offset pointers-followed)
(error 'parse-domain-name "DNS compressed-pointer loop detected")
(let-values (((lhs rhs) (bit-string-split-at whole-packet (* 8 offset))))
(let-values (((labels ignored-tail)
(parse-domain-name whole-packet rhs (cons offset pointers-followed))))
(values labels rest)))))
([(= 0 :: bits 8) (rest :: binary)]
(values '() rest))
([(= 0 :: bits 2) (len :: bits 6) (label :: binary bytes len) (rest :: binary)]
;; TODO: validate labels: make sure they conform to the prescribed syntax
(let-values (((labels leftover)
(parse-domain-name whole-packet rest pointers-followed)))
(values (cons (bit-string->bytes label) labels) leftover)))))
;; Bit-syntax type for single-byte-length-prefixed strings of
;; bytes. No character codec is applied to the bytes. During encoding,
;; expects two extra arguments: the name of the kind of value, for use
;; in error reports, and the maximum permissible length (plus one). If
;; the encoder is given a string of length greater than or equal to
;; the given maximum, an error is signalled.
(define-syntax t:pascal-string
(syntax-rules ()
((_ #t input ks kf)
(bit-string-case input
([ len (body :: binary bytes len) (rest :: binary) ]
(ks (bit-string->bytes body) rest))
(else (kf))))
((_ #f val)
(t:pascal-string #f val "Character-string" 256))
((_ #f val string-kind length-limit)
(let: ([s : Bytes val])
(let ((len (bytes-length s)))
(when (>= len length-limit)
(error 't:pascal-string "~s too long: ~v" string-kind s))
(bit-string len (s :: binary)))))))
;; <rfc1035>
;; The question section is used to carry the "question" in most queries,
;; i.e., the parameters that define what is being asked. The section
;; contains QDCOUNT (usually 1) entries, each of the following format:
;;
;; 1 1 1 1 1 1
;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; | |
;; / QNAME /
;; / /
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; | QTYPE |
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; | QCLASS |
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; </rfc1035>
;; Bit-syntax type for Questions. The decoder needs to be given the
;; whole packet because the question may contain nested domain-names.
(define-syntax t:question
(syntax-rules ()
((_ #t input ks kf whole-packet)
(bit-string-case input
([ (qname :: (t:domain-name whole-packet))
(qtype :: bits 16)
(qclass :: bits 16)
(tail :: binary) ]
(ks (question qname
(value->qtype qtype)
(value->qclass qclass)
#f)
tail))))
((_ #f val)
(let: ([q : Question val])
(bit-string ((question-repr-name q) :: (t:domain-name))
((qtype->value (question-repr-type q)) :: bits 16)
((qclass->value (question-repr-class q)) :: bits 16))))))
;; <rfc1035>
;; All RRs have the same top level format shown below:
;;
;; 1 1 1 1 1 1
;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; | |
;; / /
;; / NAME /
;; | |
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; | TYPE |
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; | CLASS |
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; | TTL |
;; | |
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; | RDLENGTH |
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--|
;; / RDATA /
;; / /
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; </rfc1035>
;; Bit-syntax type for RRs. The decoder needs to be given the whole
;; packet because the RR may contain nested domain-names.
(define-syntax t:rr
(syntax-rules ()
((_ #t input ks kf whole-packet0)
(let ((whole-packet whole-packet0))
(bit-string-case input
([ (name :: (t:domain-name whole-packet))
(type-number :: bits 16)
(class :: bits 16)
(ttl :: bits 32)
(rdlength :: bits 16)
(rdata :: binary bytes rdlength)
(tail :: binary) ]
(let ((type (value->type type-number)))
(ks (rr name
(value->class class)
ttl
(decode-rdata whole-packet type rdata))
tail)))
(else (kf)))))
((_ #f val)
(let: ([rr : RR val])
(let ((encoded-rdata (encode-rdata (rr-rdata rr))))
(bit-string ((rr-name rr) :: (t:domain-name))
((type->value (rdata-type (rr-rdata rr))) :: bits 16)
((class->value (rr-class rr)) :: bits 16)
((rr-ttl rr) :: bits 32)
((quotient (bit-string-length encoded-rdata) 8) :: bits 16)
(encoded-rdata :: binary)))))))
(: decode-rdata : BitString RRType BitString -> RData)
;; Decode RData according to the RRType. Takes the whole packet for
;; the same reason as t:rr does.
(define (decode-rdata whole-packet type rdata)
(case type
((cname mb md mf mg mr ns ptr) (bit-string-case rdata
([ (name :: (t:domain-name whole-packet)) ]
(rdata-domain type name))))
((hinfo) (bit-string-case rdata
([ (cpu :: (t:pascal-string)) (os :: (t:pascal-string)) ]
(rdata-hinfo type cpu os))))
((minfo) (bit-string-case rdata
([ (rmailbx :: (t:domain-name whole-packet))
(emailbx :: (t:domain-name whole-packet)) ]
(rdata-minfo type rmailbx emailbx))))
((mx) (bit-string-case rdata
([ (preference :: bits 16)
(exchange :: (t:domain-name whole-packet)) ]
(rdata-mx type preference exchange))))
((null) (rdata-raw type (bit-string->bytes rdata)))
((soa) (bit-string-case rdata
([ (mname :: (t:domain-name whole-packet))
(rname :: (t:domain-name whole-packet))
(serial :: bits 32)
(refresh :: bits 32)
(retry :: bits 32)
(expire :: bits 32)
(minimum :: bits 32) ]
(rdata-soa type mname rname serial refresh retry expire minimum))))
((txt) (bit-string-case rdata
([ (strs :: (t:listof Bytes (t:pascal-string))) ]
(rdata-txt type strs))))
((a) (bit-string-case rdata
([ a b c d ]
(rdata-ipv4 type (vector a b c d)))))
((aaaa) (bit-string-case rdata
([ a b c d e f g h i j k l m n o p ]
(rdata-ipv6 type (vector a b c d e f g h i j k l m n o p)))))
((wks) (bit-string-case rdata
([ a b c d protocol (bitmap :: binary) ]
(rdata-wks type (vector a b c d) protocol (bit-string->bytes bitmap)))))
((srv) (bit-string-case rdata
([ (priority :: bits 16)
(weight :: bits 16)
(port :: bits 16)
(target :: (t:domain-name whole-packet)) ]
(rdata-srv type priority weight port target))))
(else (rdata-raw type (bit-string->bytes rdata)))))
(: encode-rdata : RData -> BitString)
;; Encode RData according to its RRType.
(define (encode-rdata rdata)
(match rdata
[(rdata-domain _ name) (encode-domain-name name)]
[(rdata-hinfo _ cpu os) (bit-string (cpu :: (t:pascal-string))
(os :: (t:pascal-string)))]
[(rdata-minfo _ rmailbx emailbx) (bit-string (rmailbx :: (t:domain-name))
(emailbx :: (t:domain-name)))]
[(rdata-mx _ preference exchange) (bit-string (preference :: bits 16)
(exchange :: (t:domain-name)))]
[(rdata-soa _ mname rname serial refresh retry expire minimum)
(bit-string (mname :: (t:domain-name))
(rname :: (t:domain-name))
(serial :: bits 32)
(refresh :: bits 32)
(retry :: bits 32)
(expire :: bits 32)
(minimum :: bits 32))]
[(rdata-txt _ strings) (bit-string (strings :: (t:listof Bytes (t:pascal-string))))]
[(rdata-ipv4 _ (vector a b c d)) (bit-string a b c d)]
[(rdata-ipv6 _ aaaa) (bit-string ((list->bytes (vector->list aaaa)) :: binary bits 128))]
[(rdata-wks _ (vector a b c d) protocol bitmap)
(bit-string a b c d protocol (bitmap :: binary))]
[(rdata-srv _ priority weight port target)
(bit-string (priority :: bits 16)
(weight :: bits 16)
(port :: bits 16)
(target :: (t:domain-name)))]
[(rdata-raw _ bs) bs]))
;; UInt32
(: max-ttl : Nonnegative-Integer)
(define max-ttl #xffffffff)

133
driver.rkt Normal file
View File

@ -0,0 +1,133 @@
#lang typed/racket/base
;; DNS server using os-big-bang.rkt and os-udp.rkt.
(require racket/match)
(require racket/set)
(require racket/bool)
(require (planet tonyg/bitsyntax))
(require "api.rkt")
(require "codec.rkt")
(require "zonedb.rkt")
(require "resolver.rkt")
(require marketplace/sugar-typed)
(require marketplace/support/spy)
(require marketplace/drivers/udp)
(require "tk-dns.rkt")
;; Instantiated with a SOA record for the zone it is serving as well
;; as a zone's worth of DNS data which is used to answer queries
;; authoritatively. Never caches information, never performs recursive
;; queries.
;; Rules:
;; - Answers authoritative NXDOMAIN answers for queries falling within
;; its zone. (This is the only responder entitled to answer NXDOMAIN!)
;; - Answers with referrals for queries falling in subzones. It
;; determines subzones based on the RRs it is configured with at
;; startup.
(: start-server : Nonnegative-Integer 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
;; in the soa-rr given.
(require racket/pretty)
(define (start-server port-number soa-rr rrs)
;; Compile the zone hash table
(define zone (compile-zone-db (cons soa-rr rrs)))
(define local-addr (udp-listener port-number))
(display ";; Ready.\n")
(ground-vm: ((inst udp-driver Void))
((inst generic-spy Void) 'UDP)
(nested-vm: : Void
(spawn: #:parent : Void #:child : Void (dns-spy))
(spawn: #:parent : Void #:child : Void (dns-read-driver local-addr))
(spawn: #:parent : Void #:child : Void (dns-write-driver local-addr))
(endpoint: : Void #:subscriber (bad-dns-packet (wild) (wild) (wild) (wild))
[p (begin (log-error (pretty-format p))
'())])
(endpoint: : Void #:subscriber (dns-request (wild) (wild) (wild))
[(? dns-request? r)
(begin (define reply (handle-request soa-rr zone r))
(when reply (send-message reply)))]))))
(define-type ReplyMaker (DomainName Boolean (Setof RR) (Setof RR) (Setof RR) -> DNSMessage))
(: handle-request : RR CompiledZone DNSRequest -> (Option DNSReply))
(define (handle-request soa-rr zone request)
(match-define (dns-request request-message request-source request-sink) request)
(: make-reply : ReplyMaker)
(define (make-reply name send-name-error? answers authorities additional)
(dns-message (dns-message-id request-message)
'response
'query
(if (in-bailiwick? name (rr-name soa-rr)) 'authoritative 'non-authoritative)
'not-truncated
(dns-message-recursion-desired request-message)
'no-recursion-available
(if send-name-error? 'name-error 'no-error)
(dns-message-questions request-message)
(rr-set->list answers)
(rr-set->list authorities)
(rr-set->list additional)))
(: answer-question : Question ReplyMaker -> DNSMessage)
(define (answer-question q make-reply)
;; Notice that we claim to be authoritative for our configured
;; zone. If we ever answer name-error, that means there are no RRs
;; *at all* for the queried name. If there are RRs for the queried
;; name, but they happen not to be the ones asked for, name-error
;; must *not* be returned: instead, a normal no-error reply is
;; sent with an empty answer section.
;;
;; If we wanted to support caching of negative replies, we'd
;; follow the guidelines in section 4.3.4 "Negative response
;; caching" of RFC1034, adding our zone SOA with an appropriate
;; TTL to the additional section of the reply.
;;
;; TODO: We support returning out-of-bailiwick records (glue)
;; here. Reexamine the rules for doing so.
(match-define (question qname qtype qclass #f) q)
(: expand-cnames : (Listof DomainName) CompleteAnswer -> DNSMessage)
(define (expand-cnames worklist ans)
(match worklist
['()
(match-define (complete-answer ns us ds) ans)
(make-reply qname #f ns us ds)]
[(cons next-cname rest)
(define a (resolve-from-zone (cname-question next-cname q) zone soa-rr (set)))
(incorporate-answer a rest ans)]))
(: incorporate-answer : Answer (Listof DomainName) CompleteAnswer -> DNSMessage)
(define (incorporate-answer this-answer worklist ans)
(match this-answer
[(partial-answer new-info more-cnames)
(expand-cnames (append worklist more-cnames)
(merge-answers new-info ans))]
[(? complete-answer? c)
(expand-cnames worklist (merge-answers c ans))]
[_ ;; #f or a referral
(expand-cnames worklist ans)]))
(match (resolve-from-zone q zone soa-rr (set))
[#f ;; Signal name-error/NXDOMAIN
(make-reply qname #t (set) (set) (set))]
[(referral _ ns-rrs additional)
(make-reply qname #f ns-rrs (set soa-rr) additional)]
[this-answer
(incorporate-answer this-answer '() (empty-complete-answer))]))
;; TODO: check opcode and direction in request
;; TODO: think again about multiple questions in one packet
(match (dns-message-questions request-message)
['() #f]
[(cons q _)
(dns-reply (answer-question q make-reply) request-sink request-source)]))
(require "test-rrs.rkt")
(start-server (test-port-number) test-soa-rr test-rrs)

52
mapping.rkt Normal file
View File

@ -0,0 +1,52 @@
#lang typed/racket/base
;; Macros for defining weak and extensible mappings between sets of values
(provide define-mapping)
;; Internal. Extracts macro keywords from a list of arguments.
(define-syntax check-defaults
(syntax-rules ()
((_ fn bn fd bd #:forward-default new-fd rest ...)
(check-defaults fn bn new-fd bd rest ...))
((_ fn bn fd bd #:backward-default new-bd rest ...)
(check-defaults fn bn fd new-bd rest ...))
((_ fn bn fd bd (lhs rhs) ...)
(begin
(define (fn l)
(cond
((eqv? l 'lhs) 'rhs) ...
(else (fd l))))
(define (bn r)
(cond
((eqv? r 'rhs) 'lhs) ...
(else (bd r))))))))
;; Symbol -> raised exn:fail:contract
;; Used by default to complain when no specific mapping is found.
;; The argument indicates to the user the direction of the mapping.
(define (die-with-mapping-name n)
(lambda (v)
(raise (exn:fail:contract
(format "~v: Mapping not found for ~v" n v)
(current-continuation-marks)))))
;; (define-mapping <identifier> <identifier>
;; { #:forward-default <expr> }?
;; { #:backward-default <expr> }?
;; (<expr> <expr>) ...)
;; Defines two functions, forward-name and backward-name, which take
;; values from the left-hand-sides of the mappings given as "(<expr>
;; <expr>)" to the right-hand-sides and vice versa, respectively.
;;
;; If specified, the #:forward-default and #:backward-default exprs
;; should evaluate to a procedure of one argument which can be used
;; for fallback computation of the mapping or for error
;; reporting. They default to raising exn:fail:contract.
(define-syntax define-mapping
(syntax-rules ()
((_ forward-name backward-name rest ...)
(check-defaults forward-name
backward-name
(die-with-mapping-name 'forward-name)
(die-with-mapping-name 'backward-name)
rest ...))))

375
network-query.rkt Normal file
View File

@ -0,0 +1,375 @@
#lang typed/racket/base
(require racket/set)
(require racket/match)
(require "api.rkt")
(require "codec.rkt")
(require "zonedb.rkt")
(require marketplace/sugar-typed)
(require marketplace/drivers/udp)
(require marketplace/drivers/timer)
(require marketplace/support/pseudo-substruct)
(require "tk-dns.rkt")
(require (rename-in marketplace/tr-struct-copy [tr-struct-copy struct-copy])) ;; PR13149
(provide network-query
(struct-out network-reply-repr)
NetworkReply network-reply network-reply?
NetworkReplyPattern network-reply-pattern network-reply-pattern?)
;; DJB's rules for handling DNS responses. Some of these are handled
;; here (specifically, rules 2 through 5, in the action of
;; filter-dns-reply), some are handled in resolver.rkt (rule 1, in the
;; action of answer-from-zone), and some are handled in the
;; interaction between the resolver and the network-query modules
;; (rule 1 as well, the interplay between CNAME expansion and
;; recursion):
;; <blockquote>
;; When a cache receives a normal DNS response, it learns exactly one
;; of the following five pieces of information:
;;
;; 1. ``The query was not answered because the query name is an
;; alias. I need to change the query name and try again.'' This
;; applies if the answer section of the response contains a CNAME
;; record for the query name and CNAME does not match the query type.
;;
;; 2. ``The query name has no records answering the query, and is also
;; guaranteed to have no records of any other type.'' This applies if
;; the response code is NXDOMAIN and #1 doesn't apply. The amount of
;; time that this information can be cached depends on the contents of
;; the SOA record in the authority section of the response, if there
;; is one.
;;
;; 3. ``The query name has one or more records answering the query.''
;; This applies if the answer section of the response contains one or
;; more records under the query name matching the query type, and #1
;; doesn't apply, and #2 doesn't apply.
;;
;; 4. ``The query was not answered because the server does not have
;; the answer. I need to contact other servers.'' This applies if the
;; authority section of the response contains NS records, and the
;; authority section of the response does not contain SOA records, and
;; #1 doesn't apply, and #2 doesn't apply, and #3 doesn't apply. The
;; ``other servers'' are named in the NS records in the authority
;; section.
;;
;; 5. ``The query name has no records answering the query, but it may
;; have records of another type.'' This applies if #1 doesn't apply,
;; and #2 doesn't apply, and #3 doesn't apply, and #4 doesn't
;; apply. The amount of time that this information can be cached
;; depends on the contents of the SOA record in the authority section,
;; if there is one.
;;
;; This procedure requires an incredible amount of bug-prone parsing
;; for a very small amount of information. The underlying problem is
;; that DNS was designed to declare information in a human-oriented
;; format, rather than to support crucial operations in the simplest
;; possible way.
;; </blockquote>
;;---------------------------------------------------------------------------
;; DJB's djbdns logic for determining whether a response is a lame
;; referral or not is as follows (see his query.c in areas dealing
;; with the variable "flagreferral" and calls to the function
;; "log_lame"):
;;
;; If a response -
;;
;; 1. has response-code no-error (0), and
;; 2. has no CNAME records in the answer section for the domain we're
;; interested in, and
;; 3. has no records in the answer section for the domain and type
;; we're interested in, and
;; 4. has no SOA records in the authority section, and
;; 5. has at least one NS record in the authority section, and
;; 6. that NS record's name is equal to our bailiwick or is not in our
;; bailiwick,
;;
;; then it is a lame referral.
;;
;; Anything with non-zero response-code is clearly not a referral, so
;; that explains (1). If either of checks (2) and (3) fail then the
;; answer is a real, sensible answer to the question we posed. I'm not
;; 100% on why (4) is there; presumably it's to be conservative, and
;; not treat something possibly-valid as definitely-lame? Rules (5)
;; and (6) are the real heart of lameness, where a referral is given
;; to somewhere that can't be more authoritative than the responder
;; was supposed to be.
;;
;; We modify check (4) to ignore SOA records not in bailiwick, just
;; for consistency. It's correct to leave (5) and (6) alone because
;; it's incorrect for a server to refer us to anywhere at the same
;; level of the tree or further up the tree, but we do apply them to
;; every NS record rather than just the first, which is slightly
;; stricter than DJB's rule.
;;---------------------------------------------------------------------------
(define first-timeout 3) ;; seconds
;; A NetworkRequest is a (network-request UdpAddress Question
;; DomainName NEListOf<DomainName> UniqueID) representing the
;; parameters used to start and process a network query.
(struct: network-request ([client-socket : UdpAddress]
[question : Question]
[zone-origin : DomainName]
[server-names : (Listof DomainName)]
[unique-id : Any])
#:transparent)
(define-type NetworkRequest network-request)
;; A NetworkReply is a (network-reply UniqueID Maybe<CompleteAnswer>)
;; representing the final result of a network query.
(struct: (TId TAnswer)
network-reply-repr
([unique-id : TId] [answer : TAnswer]) #:transparent)
(pseudo-substruct: (network-reply-repr Any (Option CompleteAnswer))
NetworkReply network-reply network-reply?)
(pseudo-substruct: (network-reply-repr (U Wild Any) (U Wild (Option CompleteAnswer)))
NetworkReplyPattern network-reply-pattern network-reply-pattern?)
;; A NetworkQueryState is a (network-query-state NetworkRequest
;; Integer Map<DomainName,ListOf<UdpAddress>> ListOf<UdpAddress>
;; Maybe<DomainName> ListOf<DomainName>), representing an in-progress
;; DNS network query.
(struct: network-query-state ([request : NetworkRequest]
[timeout : (Option Natural)]
[known-addresses : (HashTable DomainName (Listof UdpAddress))]
[remaining-addresses : (Listof UdpAddress)]
[current-name : (Option DomainName)]
[remaining-names : (Listof DomainName)])
#:transparent)
(define-type NetworkQueryState network-query-state)
(: next-timeout : Natural -> (Option Natural))
(define (next-timeout timeout)
(cond
[(equal? timeout 3) 11]
[(equal? timeout 11) 45]
[else #f]))
(: make-dns-query-message : Question Nonnegative-Integer -> DNSMessage)
(define (make-dns-query-message q query-id)
(dns-message query-id
'request
'query
'non-authoritative
'not-truncated
'no-recursion-desired
'no-recursion-available
'no-error
(list q)
'()
'()
'()))
(define-type CheckedAnswer (U (Option CompleteAnswer) 'bad-answer 'lame-delegation))
(: filter-dns-reply : Question DNSMessage DomainName -> CheckedAnswer)
;; Filters RRs from the answer, authorities, and additional sections
;; of the passed-in `message`, returning the set of RRs surviving the
;; filter. RRs are only accepted if their `rr-name` falls in the
;; bailiwick of the given `zone-origin`. All of this only happens if
;; the passed-in message's `dns-message-response-code` is `'no-error`:
;; if it's `'name-error`, then `#f` is returned, and if it's any other
;; code, `'bad-answer` is returned.
;;
;; In cases where a CompleteAnswer would otherwise be returned, if the
;; answer is in fact a lame delegation (see notes above), then
;; 'lame-delegation is returned instead.
(define (filter-dns-reply q message zone-origin)
(case (dns-message-response-code message)
[(no-error)
(: f : (Listof RR) -> (Setof RR))
(define (f l)
(list->set (filter (lambda: ([claim-rr : RR])
(in-bailiwick? (rr-name claim-rr) zone-origin)) l)))
;; Here's where we do the "lame referral" check. This code is
;; nice and simple (though wrong) without it. Ho hum.
(define answers (f (dns-message-answers message)))
(define unfiltered-authorities (dns-message-authorities message))
(define non-subzone-ns-rrs ;; all NS authorities not for a STRICT subzone of our zone-origin
(filter (lambda: ([rr : RR]) (and (eqv? (rdata-type (rr-rdata rr)) 'ns)
(or (equal? (rr-name rr) zone-origin)
(not (in-bailiwick? (rr-name rr) zone-origin)))))
unfiltered-authorities))
(define authorities (f unfiltered-authorities))
(define answers-to-q ;; answers specifically to the question we asked
(set-filter (lambda: ([rr : RR]) (equal? (rr-name rr) (question-repr-name q))) answers))
(define lame?
(and (set-empty? (filter-by-type answers-to-q 'cname))
(set-empty? (filter-rrs answers-to-q (question-repr-type q) (question-repr-class q)))
(set-empty? (filter-by-type authorities 'soa))
(not (null? non-subzone-ns-rrs))))
(if lame?
'lame-delegation
(complete-answer answers
authorities
(f (dns-message-additional message))))]
[(name-error) #f]
[else
(log-info (format "Abnormal response-code ~v in response to questions ~v"
(dns-message-response-code message)
(dns-message-questions message)))
'bad-answer]))
(: ip->host-name : IPv4 -> String)
(define (ip->host-name ip-address)
(match-define (vector a b c d) ip-address)
(format "~a.~a.~a.~a" a b c d))
(: make-dns-address : IPv4 -> UdpAddress)
(define (make-dns-address ip-address)
(udp-remote-address (ip->host-name ip-address) 53))
(: network-query : (All (ParentState)
UdpAddress Question DomainName (Listof DomainName) Any ->
(Action ParentState)))
(define (network-query s q zone-origin server-names unique-id)
(spawn: #:debug-name (list 'network-query q)
#:parent : ParentState
#:child : NetworkQueryState
(try-next-server
(network-query-state (network-request s q zone-origin server-names unique-id)
first-timeout
(ann #hash() (HashTable DomainName (Listof UdpAddress)))
'()
#f
server-names))))
(: try-next-server : NetworkQueryState -> (Transition NetworkQueryState))
(define (try-next-server w)
(define timeout (network-query-state-timeout w))
(if (not timeout)
;; No more timeouts to try, so give up.
(on-answer w (empty-complete-answer) #f)
(match w
[(network-query-state req _ _ '() _ '())
;; No more addresses to try with this timeout. Refill the list
;; and bump the timeout and retry.
;; TODO: randomize ordering of servers in list. (Don't forget the initial fill.)
(try-next-server (struct-copy network-query-state w
[timeout (next-timeout timeout)]
[remaining-addresses '()]
[current-name #f]
[remaining-names (network-request-server-names req)]))]
[(network-query-state req _ known-addresses '() _ (cons current-name remaining-names))
(if (hash-has-key? known-addresses current-name)
(try-next-server (struct-copy network-query-state w
[remaining-addresses (hash-ref known-addresses current-name)]
[current-name current-name]
[remaining-names remaining-names]))
(let ((subq (ns-question current-name (network-request-question req))))
(transition: (struct-copy network-query-state w
[current-name current-name]
[remaining-names remaining-names]) : NetworkQueryState
(send-message subq)
(endpoint: w : NetworkQueryState
#:subscriber (answered-question subq (wild))
#:let-name subq-id
[(answered-question (== subq) ans)
(let ((ips (map make-dns-address
(set->list (extract-addresses current-name ans)))))
(sequence-actions
(try-next-server (struct-copy network-query-state w
[known-addresses (hash-set known-addresses
current-name
ips)]
[remaining-addresses ips]))
(delete-endpoint subq-id)))]))))]
[(network-query-state req _ _ (cons current-ip remaining-ips) _ _)
(define rpc-id (gensym 'network-query/allocate-query-id))
(transition: w : NetworkQueryState
(send-message `(request ,rpc-id allocate-query-id))
(endpoint: w : NetworkQueryState
#:subscriber `(reply ,rpc-id ,(wild))
#:name rpc-id
[`(reply ,(== rpc-id) ,(? exact-nonnegative-integer? id))
(sequence-actions (send-request (struct-copy network-query-state w
[remaining-addresses remaining-ips])
id
timeout
current-ip)
(delete-endpoint rpc-id))]))])))
(: on-answer : NetworkQueryState CheckedAnswer (Option UdpAddress)
-> (Transition NetworkQueryState))
(define (on-answer w ans server-ip)
(match ans
['bad-answer ;; can come from filter-dns-reply
(try-next-server w)]
['lame-delegation ;; can come from filter-dns-reply
(match-define (network-query-state req _ known-addresses _ current-name _) w)
(match-define (network-request _ q zone-origin _ _) req)
(log-info (format "Lame delegation received from ~v (at ~v) in bailiwick ~v in response to ~v"
current-name
server-ip
zone-origin
q))
(try-next-server (if (and current-name server-ip)
;; Actually remove the offending IP address so it's never tried again.
(struct-copy network-query-state w
[known-addresses (hash-update known-addresses
current-name
(lambda: ([addrs : (Listof
UdpAddress)])
(remove server-ip addrs)))])
w))]
[(and (or (? complete-answer?) #f) ans)
(transition: w : NetworkQueryState
(send-message (network-reply (network-request-unique-id (network-query-state-request w))
ans)))]))
(: send-request : NetworkQueryState Nonnegative-Integer Natural UdpAddress
-> (Transition NetworkQueryState))
(define (send-request w query-id timeout server-ip)
(match-define (network-request s q zone-origin _ _) (network-query-state-request w))
(define query (make-dns-query-message q query-id))
(define reply-wait-id (list s query-id 'reply-wait))
(define timeout-id (list s query-id 'timeout))
(define start-time (current-inexact-milliseconds))
(log-debug (format "Sending ~v ~v to ~v ~v with ~v seconds of timeout"
q query-id
zone-origin server-ip
timeout))
(transition: w : NetworkQueryState
(send-message (dns-request query s server-ip))
(send-message (set-timer timeout-id (* timeout 1000) 'relative))
;; TODO: Restore this to a "join" when proper pattern-unions are implemented
(endpoint: w : NetworkQueryState
#:subscriber (timer-expired timeout-id (wild))
#:name timeout-id
[(timer-expired (== timeout-id) _)
(begin
(log-debug (format "Timed out ~v ~v to ~v ~v after ~v seconds"
q query-id
zone-origin server-ip
timeout))
(sequence-actions (try-next-server w)
(delete-endpoint timeout-id)
(delete-endpoint reply-wait-id)
(send-message (list 'release-query-id query-id))))])
(endpoint: w : NetworkQueryState
#:subscriber (dns-reply (wild) (wild) s)
#:name reply-wait-id
[(dns-reply reply-message source (== s))
;; TODO: maybe receive only specifically from the queried IP address?
(begin
(log-debug
(format
"Answer to ~v from ~v ~v in ~v ms~n-- Answers: ~v~n-- Authorities: ~v~n-- Additional: ~v"
q zone-origin server-ip
(inexact->exact (round (- (current-inexact-milliseconds) start-time)))
(dns-message-answers reply-message)
(dns-message-authorities reply-message)
(dns-message-additional reply-message)))
(if (not (= (dns-message-id reply-message) (dns-message-id query)))
(transition: w : NetworkQueryState)
(sequence-actions (on-answer w
(filter-dns-reply q reply-message zone-origin)
server-ip)
(delete-endpoint timeout-id)
(delete-endpoint reply-wait-id)
(send-message (list 'release-query-id query-id)))))])))

353
proxy.rkt Normal file
View File

@ -0,0 +1,353 @@
#lang typed/racket/base
;; DNS proxy using os-big-bang.rkt and os-udp.rkt.
(require racket/match)
(require racket/set)
(require racket/bool)
(require (planet tonyg/bitsyntax))
(require "api.rkt")
(require "codec.rkt")
(require "zonedb.rkt")
(require "network-query.rkt")
(require "resolver.rkt")
(require marketplace/sugar-typed)
(require marketplace/support/spy)
(require marketplace/drivers/timer)
(require marketplace/drivers/udp)
(require "tk-dns.rkt")
(require racket/pretty)
;; Instantiated with a collection of trusted roots to begin its
;; searches from. Performs recursive queries.
;; For discarding retransmitted requests that we're still working on.
(struct: active-request ([source : UdpAddress] [id : Natural]) #:transparent)
(define-type ActiveRequest active-request)
(: start-proxy : Natural CompiledZone CompiledZone -> Void)
(define (start-proxy port-number zone roots-only)
(define server-addr (udp-listener port-number))
(define client-addr (udp-handle 'dns-client))
(log-info "Ready.")
(ground-vm:
((inst generic-spy Void) 'UDP)
((inst udp-driver Void))
((inst timer-driver Void))
(nested-vm: : Void
#:debug-name 'dns-vm
(spawn: #:debug-name 'dns-spy #:parent : Void #:child : Void (dns-spy))
((inst timer-relay Void) 'timer-relay:dns)
(spawn: #:debug-name 'query-id-allocator #:parent : Void
#:child : (Setof Natural)
(query-id-allocator))
(spawn: #:debug-name 'server-dns-reader #:parent : Void
#:child : Void (dns-read-driver server-addr))
(spawn: #:debug-name 'server-dns-writer #:parent : Void
#:child : Void (dns-write-driver server-addr))
(spawn: #:debug-name 'client-dns-reader #:parent : Void
#:child : Void (dns-read-driver client-addr))
(spawn: #:debug-name 'client-dns-writer #:parent : Void
#:child : Void (dns-write-driver client-addr))
(spawn: #:debug-name 'packet-dispatcher #:parent : Void
#:child : (Setof ActiveRequest) (packet-dispatcher server-addr))
(spawn: #:debug-name 'question-dispatcher #:parent : Void
#:child : CompiledZone (question-dispatcher zone roots-only client-addr)))))
(: query-id-allocator : -> (Transition (Setof Natural)))
(define (query-id-allocator)
;; TODO: track how many are allocated and throttle requests if too
;; many are in flight
(transition: ((inst set Natural)) : (Setof Natural) ;; all active query IDs
(endpoint: allocated : (Setof Natural)
#:subscriber `(request ,(wild) allocate-query-id)
[`(request ,reply-addr allocate-query-id)
(let: recheck : (Transition (Setof Natural)) ()
(define n (random 65536))
(if (set-member? allocated n)
(recheck)
(transition: (set-add allocated n) : (Setof Natural)
(send-message `(reply ,reply-addr ,n)))))])
(endpoint: allocated : (Setof Natural)
#:subscriber `(release-query-id ,(wild))
[`(release-query-id ,(? exact-nonnegative-integer? n))
(transition: (set-remove allocated n) : (Setof Natural))])))
(: packet-dispatcher : UdpAddress -> (Transition (Setof ActiveRequest)))
(define (packet-dispatcher s)
(transition: ((inst set ActiveRequest)) : (Setof ActiveRequest)
(endpoint: : (Setof ActiveRequest)
#:subscriber (bad-dns-packet-pattern (wild) (wild) (wild) (wild))
[p (begin (log-error (pretty-format p)) '())])
(endpoint: old-active-requests : (Setof ActiveRequest)
#:subscriber (dns-request-pattern (wild) (wild) s)
[(and r (dns-request m source (== s)))
;; ^ We only listen for requests on our server socket
(let ((req-id (active-request source (dns-message-id m))))
;; TODO: when we have presence/error-handling, remove req-id
;; from active requests once request-handler pseudothread exits.
(if (set-member? old-active-requests req-id)
(transition: old-active-requests : (Setof ActiveRequest))
;; ^ ignore retransmitted duplicates
(transition: (set-add old-active-requests req-id) : (Setof ActiveRequest)
(spawn: #:debug-name (list 'packet-relay req-id)
#:parent : (Setof ActiveRequest)
#:child : Void (packet-relay req-id r)))))])
(endpoint: old-active-requests : (Setof ActiveRequest)
#:subscriber (dns-reply-pattern (wild) s (wild))
[(and r (dns-reply m (== s) sink))
(let ((req-id (active-request sink (dns-message-id m))))
(transition: (set-remove old-active-requests req-id) : (Setof ActiveRequest)))])))
(: packet-relay : ActiveRequest DNSRequest -> (Transition Void))
(define (packet-relay req-id request)
(match-define (dns-request request-message request-source request-sink) request)
(: answer->reply : (Option Question) (Option CompleteAnswer) -> DNSReply)
(define (answer->reply q a)
(define-values (response-code ns us ds)
(match a
[#f
(values 'name-error '() '() '())]
[(complete-answer ns us ds)
(values 'no-error (rr-set->list ns) (rr-set->list us) (rr-set->list ds))]))
(dns-reply
(dns-message (dns-message-id request-message)
'response
'query
'non-authoritative
'not-truncated
(dns-message-recursion-desired request-message)
'recursion-available
response-code
(if q (list q) '())
ns
us
ds)
request-sink
request-source))
;; TODO: pay attention to recursion-desired flag
(match (dns-message-questions request-message)
['()
;; No questions!
(transition/no-state
(send-message (answer->reply #f (empty-complete-answer))))]
[(cons original-question _)
;; At least one question
(log-debug (format "Looking up ~v with query id ~v"
original-question (dns-message-id request-message)))
(transition/no-state
(send-message original-question)
(endpoint: : Void
#:subscriber (answered-question-pattern original-question (wild))
#:let-name wait-id
[(answered-question (== original-question) answer)
(begin (log-debug (format "Final answer to ~v with query id ~v is ~v"
original-question
(dns-message-id request-message)
answer))
(list (delete-endpoint wait-id)
(send-message (answer->reply original-question answer))))]))]))
(: glueless-question-handler : CompiledZone Question UdpAddress -> (Transition Void))
(define (glueless-question-handler roots-only-zone q client-sock)
;; Restart q, an overly-glueless question, from the roots.
(define restarted-question (restart-question q))
(transition/no-state
(endpoint: : Void
#:subscriber (answered-question-pattern restarted-question (wild))
#:let-name relay
[(answered-question (== restarted-question) ans)
;; We got the answer to our restarted question; now transform
;; it into an answer to the original question, to unblock the
;; original questioner.
(list (delete-endpoint relay)
(send-message (answered-question q ans)))])
(spawn: #:debug-name (list 'glueless-question-handler-inner restarted-question)
#:parent : Void
#:child : QHState
(question-handler roots-only-zone restarted-question client-sock))))
(: question-dispatcher : CompiledZone CompiledZone UdpAddress -> (Transition CompiledZone))
(define (question-dispatcher seed-zone roots-only client-sock)
(: transition-and-set-timers : CompiledZone (Setof (Pairof DomainName Real))
-> (Transition CompiledZone))
(define (transition-and-set-timers new-zone timers)
(transition: new-zone : CompiledZone
(for/list: : (Listof (Action CompiledZone)) ([timerspec timers])
(match-define (cons name ttl) timerspec)
(send-message (set-timer (list 'check-dns-expiry name) (* ttl 1000) 'relative)))))
(define-values (cleaned-seed-zone initial-timers) (zone-expire seed-zone))
(sequence-actions (transition-and-set-timers cleaned-seed-zone initial-timers)
;; TODO: consider deduping questions here too?
(endpoint: zone : CompiledZone
#:subscriber `(debug-dump)
[`(debug-dump)
(begin
(with-output-to-file "zone-proxy.zone"
(lambda ()
(write-bytes (bit-string->bytes (zone->bit-string zone))))
#:mode 'binary
#:exists 'replace)
(with-output-to-file "zone-proxy.dump"
(lambda ()
(display "----------------------------------------------------------------------\n")
(display (seconds->date (current-seconds)))
(newline)
(for: ([name (in-hash-keys zone)])
(define rrmap (hash-ref zone name))
(for: ([rr (in-hash-keys rrmap)])
(define expiry (hash-ref rrmap rr))
(write (list rr expiry))
(newline)))
(newline))
#:mode 'text
#:exists 'append)
;; (with-output-to-file "zone-proxy.debug"
;; (lambda ()
;; (display "----------------------------------------------------------------------\n")
;; (display (seconds->date (current-seconds)))
;; (newline)
;; (pretty-write current-ground-transition))
;; #:mode 'text
;; #:exists 'append)
(transition: zone : CompiledZone))])
(endpoint: zone : CompiledZone
#:subscriber (question-pattern (wild) (wild) (wild) (wild))
[(? question? q)
(transition: zone : CompiledZone
(cond
[(question-cyclic? q)
(log-warning (format "Cyclic question ~v" q))
(send-message (answered-question q (empty-complete-answer)))]
[(question-too-glueless? q)
(log-warning (format "Overly-glueless question ~v" q))
(spawn: #:debug-name (list 'glueless-question-handler-outer q)
#:parent : CompiledZone
#:child : Void
(glueless-question-handler roots-only q client-sock))]
[else
(spawn: #:debug-name (list 'question-handler q)
#:parent : CompiledZone
#:child : QHState
(question-handler zone q client-sock))]))])
(endpoint: zone : CompiledZone
#:subscriber (network-reply-pattern (wild) (wild))
[(network-reply _ answer)
(let-values (((new-zone timers) (incorporate-complete-answer answer zone #t)))
(transition-and-set-timers new-zone timers))])
(endpoint: zone : CompiledZone
#:subscriber (timer-expired (list 'check-dns-expiry (wild)) (wild))
[(timer-expired (list 'check-dns-expiry (? domain? name)) (? number? now-msec))
(transition: (zone-expire-name zone name (/ now-msec 1000.0)) : CompiledZone)])))
(struct: question-state ([zone : CompiledZone]
[q : Question]
[client-sock : UdpAddress]
[nameservers-tried : (Setof DomainName)]
[retry-count : Natural]) #:transparent)
(define-type QuestionState question-state)
(struct: expanding-cnames ([q : Question]
[accumulator : CompleteAnswer]
[remaining-count : Integer]) #:transparent)
(define-type ExpandingCNAMEs expanding-cnames)
(define-type QHState (U QuestionState ExpandingCNAMEs))
(: question-handler : CompiledZone Question UdpAddress -> (Transition QHState))
(define (question-handler zone q client-sock)
(retry-question (question-state zone q client-sock ((inst set DomainName)) 0)))
(: send-empty-reply : QHState Question -> (Transition QHState))
(define (send-empty-reply w q)
(transition w (send-message (answered-question q (empty-complete-answer)))))
(: retry-question : QHState -> (Transition QHState))
(define (retry-question w)
(match w
[(question-state _ q _ _ 20) ;; TODO: is this a sensible limit?
;; Too many retries, i.e. too many referrals.
(log-error (format "Too many retries: ~v" w))
(send-empty-reply w q)]
[(question-state zone q client-sock nameservers-tried old-retry-count)
;; Credit remaining. Try once more (perhaps for the first time, in fact).
(define resolution-result (resolve-from-zone q zone #f nameservers-tried))
(log-debug (format "Resolution result: ~v" resolution-result))
(match resolution-result
[#f ;; We're not authoritative so this is just a signal that we can't answer usefully
(send-empty-reply w q)]
[(referral zone-origin nameserver-rrs _)
(define referral-id (gensym 'referral))
(log-debug (format "Referral for ~v id ~v to ~v servers ~v"
q referral-id (domain-labels zone-origin)
(map domain-labels (set-map nameserver-rrs rr-rdata-domain-name))))
(transition: w : QHState
((inst network-query QHState) client-sock
q
zone-origin
(map rr-rdata-domain-name (set->list nameserver-rrs))
referral-id)
(endpoint: w : QHState
#:subscriber (network-reply-pattern referral-id (wild))
#:name referral-id
[(network-reply (== referral-id) #f) ;; name-error/NXDOMAIN
(transition: w : QHState
(delete-endpoint referral-id)
(send-message (answered-question q #f)))]
[(network-reply (== referral-id) ans)
(let-values (((new-zone ignored-timers) (incorporate-complete-answer ans zone #f)))
(when (log-level? (current-logger) 'debug)
(log-debug (format "Referral ~v results in origin ~v:~n"
referral-id zone-origin))
(for ([k (set-union (list->set (hash-keys zone))
(list->set (hash-keys new-zone)))]
#:when (in-bailiwick? k zone-origin))
(log-debug (format "Old ~v ~v~nNew ~v ~v"
k (hash-ref zone k (lambda () 'missing))
k (hash-ref new-zone k (lambda () 'missing)))))
(log-debug "=-=-=-=-=-="))
(define nameserver-names
(list->set
(for/list: : (Listof DomainName) ([rr nameserver-rrs]) (rr-rdata-domain-name rr))))
(sequence-actions
(retry-question (struct-copy question-state w
[nameservers-tried (set-union nameservers-tried
nameserver-names)]
[zone new-zone]
[retry-count (+ old-retry-count 1)]))
(delete-endpoint referral-id)))]))]
[(? complete-answer? ans)
(transition: w : QHState (send-message (answered-question q ans)))]
[(partial-answer base cnames)
(transition: (expanding-cnames q base (length cnames)) : QHState
((inst map (ActionTree QHState) DomainName)
(lambda: ([cname : DomainName])
;; TODO: record chains of CNAMEs to avoid pathologically-long chains
(define cname-q (cname-question cname q))
(list (send-message cname-q)
(endpoint: (expanding-cnames q acc remaining) : QHState
#:subscriber (answered-question-pattern cname-q (wild))
#:let-name subscription-id
[(answered-question (== cname-q) ans)
(let ()
(define new-acc (if ans (merge-answers acc ans) acc))
(define new-remaining (- remaining 1))
(define new-w (expanding-cnames q new-acc new-remaining))
(transition: new-w : QHState
(delete-endpoint subscription-id)
(if (zero? new-remaining)
(send-message (answered-question q new-acc))
'())))])))
cnames))])]))
(require "test-rrs.rkt")
(require racket/file)
(file-stream-buffer-mode (current-output-port) 'none)
(start-proxy (test-port-number)
(if (file-exists? "zone-proxy.zone")
(bit-string->zone (file->bytes "zone-proxy.zone"))
(compile-zone-db test-roots))
(compile-zone-db test-roots))

157
resolver.rkt Normal file
View File

@ -0,0 +1,157 @@
#lang typed/racket/base
(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))))))))

8
send-signal.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang racket/base
(require racket/udp)
(require "test-rrs.rkt")
(define s (udp-open-socket #f #f))
(define buffer (make-bytes 0))
(udp-send-to s "127.0.0.1" (test-port-number) #"")

469
test-dns.rkt Normal file
View File

@ -0,0 +1,469 @@
#lang racket/base
(require "api.rkt")
(require "codec.rkt")
(require "zonedb.rkt")
(require "test-rrs.rkt")
(require rackunit)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Simple request/response from the wild.
;; DNS Packets collected using tcpdump.
;; q-google-in-any-bytes : -> Bytes
;; A query for IN ANY against google.com
;; Wed Jun 29 16:33:58 2011 (4e0b8c36): UDP: localhost sent 28 bytes:
;; 00000000: 66 3A 01 00 00 01 00 00 : 00 00 00 00 06 67 6F 6F f:...........goo
;; 00000010: 67 6C 65 03 63 6F 6D 00 : 00 FF 00 01 gle.com.....
;; 0000001C:
(define (q-google-in-any-bytes)
(bytes #x66 #x3A ;; query ID
#x01 #x00 ;; flags and bits
#x00 #x01 ;; one question
#x00 #x00 ;; no answers
#x00 #x00 ;; no name server records
#x00 #x00 ;; no additional records
;; The question:
#x06 #x67 #x6F #x6F #x67 #x6C #x65 ;; "google"
#x03 #x63 #x6F #x6D ;; "com"
#x00 ;; end of domain name
#x00 #xFF ;; query type ANY
#x00 #x01 ;; query class IN
))
;; q-google-in-any : DNSMessage
;; Decoded (q-google-in-any-bytes).
(define q-google-in-any (packet->dns-message (q-google-in-any-bytes)))
;; a-google-in-any-bytes : -> Bytes
;; The answer Google gave to (q-google-in-any), once upon a time.
;; Wed Jun 29 16:33:58 2011 (4e0b8c36): UDP: dslrouter.westell.com sent 494 bytes:
;; 00000000: 66 3A 81 80 00 01 00 0F : 00 00 00 07 06 67 6F 6F f:...........goo
;; 00000010: 67 6C 65 03 63 6F 6D 00 : 00 FF 00 01 C0 0C 00 10 gle.com.........
;; 00000020: 00 01 00 00 0C 2F 00 52 : 51 76 3D 73 70 66 31 20 ...../.RQv=spf1
;; 00000030: 69 6E 63 6C 75 64 65 3A : 5F 6E 65 74 62 6C 6F 63 include:_netbloc
;; 00000040: 6B 73 2E 67 6F 6F 67 6C : 65 2E 63 6F 6D 20 69 70 ks.google.com ip
;; 00000050: 34 3A 32 31 36 2E 37 33 : 2E 39 33 2E 37 30 2F 33 4:216.73.93.70/3
;; 00000060: 31 20 69 70 34 3A 32 31 : 36 2E 37 33 2E 39 33 2E 1 ip4:216.73.93.
;; 00000070: 37 32 2F 33 31 20 7E 61 : 6C 6C C0 0C 00 01 00 01 72/31 ~all......
;; 00000080: 00 00 01 1D 00 04 4A 7D : E2 92 C0 0C 00 01 00 01 ......J}........
;; 00000090: 00 00 01 1D 00 04 4A 7D : E2 94 C0 0C 00 01 00 01 ......J}........
;; 000000A0: 00 00 01 1D 00 04 4A 7D : E2 91 C0 0C 00 01 00 01 ......J}........
;; 000000B0: 00 00 01 1D 00 04 4A 7D : E2 93 C0 0C 00 01 00 01 ......J}........
;; 000000C0: 00 00 01 1D 00 04 4A 7D : E2 90 C0 0C 00 02 00 01 ......J}........
;; 000000D0: 00 03 A5 1D 00 06 03 6E : 73 32 C0 0C C0 0C 00 02 .......ns2......
;; 000000E0: 00 01 00 03 A5 1D 00 06 : 03 6E 73 33 C0 0C C0 0C .........ns3....
;; 000000F0: 00 02 00 01 00 03 A5 1D : 00 06 03 6E 73 31 C0 0C ...........ns1..
;; 00000100: C0 0C 00 02 00 01 00 03 : A5 1D 00 06 03 6E 73 34 .............ns4
;; 00000110: C0 0C C0 0C 00 0F 00 01 : 00 00 00 2A 00 11 00 14 ...........*....
;; 00000120: 04 61 6C 74 31 05 61 73 : 70 6D 78 01 6C C0 0C C0 .alt1.aspmx.l...
;; 00000130: 0C 00 0F 00 01 00 00 00 : 2A 00 09 00 1E 04 61 6C ........*.....al
;; 00000140: 74 32 C1 25 C0 0C 00 0F : 00 01 00 00 00 2A 00 04 t2.%.........*..
;; 00000150: 00 0A C1 25 C0 0C 00 0F : 00 01 00 00 00 2A 00 09 ...%.........*..
;; 00000160: 00 28 04 61 6C 74 33 C1 : 25 C0 0C 00 0F 00 01 00 .(.alt3.%.......
;; 00000170: 00 00 2A 00 09 00 32 04 : 61 6C 74 34 C1 25 C0 E8 ..*...2.alt4.%..
;; 00000180: 00 01 00 01 00 03 A2 CF : 00 04 D8 EF 24 0A C0 FA ............$...
;; 00000190: 00 01 00 01 00 03 A2 CF : 00 04 D8 EF 20 0A C1 0C ............ ...
;; 000001A0: 00 01 00 01 00 03 A2 CF : 00 04 D8 EF 26 0A C0 D6 ............&...
;; 000001B0: 00 01 00 01 00 03 A2 CF : 00 04 D8 EF 22 0A C1 3D ............"..=
;; 000001C0: 00 01 00 01 00 00 00 F0 : 00 04 4A 7D 27 1B C1 25 ..........J}'..%
;; 000001D0: 00 01 00 01 00 00 00 F6 : 00 04 4A 7D 73 1B C1 20 ..........J}s..
;; 000001E0: 00 01 00 01 00 00 00 21 : 00 04 4A 7D 4D 1B .......!..J}M.
;; 000001EE:
(define (a-google-in-any-bytes)
(bytes
#x66 #x3A #x81 #x80 #x00 #x01 #x00 #x0F #x00 #x00 #x00 #x07 #x06 #x67 #x6F #x6F
#x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #xFF #x00 #x01 #xC0 #x0C #x00 #x10
#x00 #x01 #x00 #x00 #x0C #x2F #x00 #x52 #x51 #x76 #x3D #x73 #x70 #x66 #x31 #x20
#x69 #x6E #x63 #x6C #x75 #x64 #x65 #x3A #x5F #x6E #x65 #x74 #x62 #x6C #x6F #x63
#x6B #x73 #x2E #x67 #x6F #x6F #x67 #x6C #x65 #x2E #x63 #x6F #x6D #x20 #x69 #x70
#x34 #x3A #x32 #x31 #x36 #x2E #x37 #x33 #x2E #x39 #x33 #x2E #x37 #x30 #x2F #x33
#x31 #x20 #x69 #x70 #x34 #x3A #x32 #x31 #x36 #x2E #x37 #x33 #x2E #x39 #x33 #x2E
#x37 #x32 #x2F #x33 #x31 #x20 #x7E #x61 #x6C #x6C #xC0 #x0C #x00 #x01 #x00 #x01
#x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x92 #xC0 #x0C #x00 #x01 #x00 #x01
#x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x94 #xC0 #x0C #x00 #x01 #x00 #x01
#x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x91 #xC0 #x0C #x00 #x01 #x00 #x01
#x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x93 #xC0 #x0C #x00 #x01 #x00 #x01
#x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x90 #xC0 #x0C #x00 #x02 #x00 #x01
#x00 #x03 #xA5 #x1D #x00 #x06 #x03 #x6E #x73 #x32 #xC0 #x0C #xC0 #x0C #x00 #x02
#x00 #x01 #x00 #x03 #xA5 #x1D #x00 #x06 #x03 #x6E #x73 #x33 #xC0 #x0C #xC0 #x0C
#x00 #x02 #x00 #x01 #x00 #x03 #xA5 #x1D #x00 #x06 #x03 #x6E #x73 #x31 #xC0 #x0C
#xC0 #x0C #x00 #x02 #x00 #x01 #x00 #x03 #xA5 #x1D #x00 #x06 #x03 #x6E #x73 #x34
#xC0 #x0C #xC0 #x0C #x00 #x0F #x00 #x01 #x00 #x00 #x00 #x2A #x00 #x11 #x00 #x14
#x04 #x61 #x6C #x74 #x31 #x05 #x61 #x73 #x70 #x6D #x78 #x01 #x6C #xC0 #x0C #xC0
#x0C #x00 #x0F #x00 #x01 #x00 #x00 #x00 #x2A #x00 #x09 #x00 #x1E #x04 #x61 #x6C
#x74 #x32 #xC1 #x25 #xC0 #x0C #x00 #x0F #x00 #x01 #x00 #x00 #x00 #x2A #x00 #x04
#x00 #x0A #xC1 #x25 #xC0 #x0C #x00 #x0F #x00 #x01 #x00 #x00 #x00 #x2A #x00 #x09
#x00 #x28 #x04 #x61 #x6C #x74 #x33 #xC1 #x25 #xC0 #x0C #x00 #x0F #x00 #x01 #x00
#x00 #x00 #x2A #x00 #x09 #x00 #x32 #x04 #x61 #x6C #x74 #x34 #xC1 #x25 #xC0 #xE8
#x00 #x01 #x00 #x01 #x00 #x03 #xA2 #xCF #x00 #x04 #xD8 #xEF #x24 #x0A #xC0 #xFA
#x00 #x01 #x00 #x01 #x00 #x03 #xA2 #xCF #x00 #x04 #xD8 #xEF #x20 #x0A #xC1 #x0C
#x00 #x01 #x00 #x01 #x00 #x03 #xA2 #xCF #x00 #x04 #xD8 #xEF #x26 #x0A #xC0 #xD6
#x00 #x01 #x00 #x01 #x00 #x03 #xA2 #xCF #x00 #x04 #xD8 #xEF #x22 #x0A #xC1 #x3D
#x00 #x01 #x00 #x01 #x00 #x00 #x00 #xF0 #x00 #x04 #x4A #x7D #x27 #x1B #xC1 #x25
#x00 #x01 #x00 #x01 #x00 #x00 #x00 #xF6 #x00 #x04 #x4A #x7D #x73 #x1B #xC1 #x20
#x00 #x01 #x00 #x01 #x00 #x00 #x00 #x21 #x00 #x04 #x4A #x7D #x4D #x1B))
;; a-google-in-any : DNSMessage
;; Decoded (a-google-in-any-bytes).
(define a-google-in-any (packet->dns-message (a-google-in-any-bytes)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Simple codec tests
(check-equal? q-google-in-any
(dns-message 26170
'request
'query
'non-authoritative
'not-truncated
'recursion-desired
'no-recursion-available
'no-error
(list (question (domain '(#"google" #"com")) '* 'in #f))
'()
'()
'()))
(check-equal? a-google-in-any
(dns-message
26170
'response
'query
'non-authoritative
'not-truncated
'recursion-desired
'recursion-available
'no-error
(list (question (domain '(#"google" #"com")) '* 'in #f))
(list
(rr (domain '(#"google" #"com")) 'txt 'in 3119 '(#"v=spf1 include:_netblocks.google.com ip4:216.73.93.70/31 ip4:216.73.93.72/31 ~all"))
(rr (domain '(#"google" #"com")) 'a 'in 285 '#(74 125 226 146))
(rr (domain '(#"google" #"com")) 'a 'in 285 '#(74 125 226 148))
(rr (domain '(#"google" #"com")) 'a 'in 285 '#(74 125 226 145))
(rr (domain '(#"google" #"com")) 'a 'in 285 '#(74 125 226 147))
(rr (domain '(#"google" #"com")) 'a 'in 285 '#(74 125 226 144))
(rr (domain '(#"google" #"com")) 'ns 'in 238877 (domain '(#"ns2" #"google" #"com")))
(rr (domain '(#"google" #"com")) 'ns 'in 238877 (domain '(#"ns3" #"google" #"com")))
(rr (domain '(#"google" #"com")) 'ns 'in 238877 (domain '(#"ns1" #"google" #"com")))
(rr (domain '(#"google" #"com")) 'ns 'in 238877 (domain '(#"ns4" #"google" #"com")))
(rr (domain '(#"google" #"com")) 'mx 'in 42 (mx 20 (domain '(#"alt1" #"aspmx" #"l" #"google" #"com"))))
(rr (domain '(#"google" #"com")) 'mx 'in 42 (mx 30 (domain '(#"alt2" #"aspmx" #"l" #"google" #"com"))))
(rr (domain '(#"google" #"com")) 'mx 'in 42 (mx 10 (domain '(#"aspmx" #"l" #"google" #"com"))))
(rr (domain '(#"google" #"com")) 'mx 'in 42 (mx 40 (domain '(#"alt3" #"aspmx" #"l" #"google" #"com"))))
(rr (domain '(#"google" #"com")) 'mx 'in 42 (mx 50 (domain '(#"alt4" #"aspmx" #"l" #"google" #"com")))))
'()
(list
(rr (domain '(#"ns3" #"google" #"com")) 'a 'in 238287 '#(216 239 36 10))
(rr (domain '(#"ns1" #"google" #"com")) 'a 'in 238287 '#(216 239 32 10))
(rr (domain '(#"ns4" #"google" #"com")) 'a 'in 238287 '#(216 239 38 10))
(rr (domain '(#"ns2" #"google" #"com")) 'a 'in 238287 '#(216 239 34 10))
(rr (domain '(#"alt2" #"aspmx" #"l" #"google" #"com")) 'a 'in 240 '#(74 125 39 27))
(rr (domain '(#"aspmx" #"l" #"google" #"com")) 'a 'in 246 '#(74 125 115 27))
(rr (domain '(#"alt1" #"aspmx" #"l" #"google" #"com")) 'a 'in 33 '#(74 125 77 27)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Roundtrip tests
;;
;; It's not possible IN GENERAL to test the roundtrip [encoded ->
;; decoded -> encoded], because the encoding process here doesn't use
;; the domain-name compression syntax that DNS supports (whereas most
;; DNS libraries do support it). It is, however, possible to test
;; [decoded -> encoded -> decoded], which should be a structural
;; identity.
;; check-roundtrip-ok? : DNSMessage -> Void
;; Passes iff the decoded encoded argument is equal? to the argument.
(define (check-roundtrip-ok? decoded-message)
(check-equal? (packet->dns-message (dns-message->packet decoded-message))
decoded-message))
;; check-roundtrip-ok?* : Bytes -> Void
;; Used for some packets simple enough to work with roundtripping the
;; other way. Passes iff the bytes are exactly the same after a
;; roundtrip.
(define (check-roundtrip-ok?* encoded-message)
(check-equal? (dns-message->packet (packet->dns-message encoded-message))
encoded-message))
(check-roundtrip-ok?* (q-google-in-any-bytes))
;; The following is one of the compression-using packets, which won't
;; pass a check-roundtrip-ok?* tyest:
;; (check-roundtrip-ok?* (a-google-in-any-bytes))
(check-roundtrip-ok? q-google-in-any)
(check-roundtrip-ok? a-google-in-any)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Both decoding and roundtripping.
;; check-body : Bytes DNSMessage -> Void
;; Passes iff both check-roundtrip-ok? and check-equal?.
(define (check-both encoded-message decoded-message)
(check-equal? (packet->dns-message encoded-message) decoded-message)
(check-roundtrip-ok? decoded-message))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; IPv6 records from the wild.
;; Wed Jun 29 20:59:17 2011 (4e0bca65): UDP: localhost sent 28 bytes:
;; 00000000: 47 16 01 00 00 01 00 00 : 00 00 00 00 06 67 6F 6F G............goo
;; 00000010: 67 6C 65 03 63 6F 6D 00 : 00 1C 00 01 gle.com.....
;; 0000001C:
;; Wed Jun 29 20:59:17 2011 (4e0bca65): UDP: pass through succeeded
;; Wed Jun 29 20:59:17 2011 (4e0bca65): UDP: google-public-dns-a.google.com sent 78 bytes:
;; 00000000: 47 16 81 80 00 01 00 00 : 00 01 00 00 06 67 6F 6F G............goo
;; 00000010: 67 6C 65 03 63 6F 6D 00 : 00 1C 00 01 C0 0C 00 06 gle.com.........
;; 00000020: 00 01 00 00 02 52 00 26 : 03 6E 73 31 C0 0C 09 64 .....R.&.ns1...d
;; 00000030: 6E 73 2D 61 64 6D 69 6E : C0 0C 00 16 33 23 00 00 ns-admin....3#..
;; 00000040: 1C 20 00 00 07 08 00 12 : 75 00 00 00 01 2C . ......u....,
;; 0000004E:
(check-both
(bytes
#x47 #x16 #x01 #x00 #x00 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x06 #x67 #x6F #x6F
#x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00 #x01)
(dns-message 18198
'request
'query
'non-authoritative
'not-truncated
'recursion-desired
'no-recursion-available
'no-error
(list (question (domain '(#"google" #"com")) 'aaaa 'in #f))
'()
'()
'()))
(check-both
(bytes
#x47 #x16 #x81 #x80 #x00 #x01 #x00 #x00 #x00 #x01 #x00 #x00 #x06 #x67 #x6F #x6F
#x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00 #x01 #xC0 #x0C #x00 #x06
#x00 #x01 #x00 #x00 #x02 #x52 #x00 #x26 #x03 #x6E #x73 #x31 #xC0 #x0C #x09 #x64
#x6E #x73 #x2D #x61 #x64 #x6D #x69 #x6E #xC0 #x0C #x00 #x16 #x33 #x23 #x00 #x00
#x1C #x20 #x00 #x00 #x07 #x08 #x00 #x12 #x75 #x00 #x00 #x00 #x01 #x2C)
(dns-message 18198
'response
'query
'non-authoritative
'not-truncated
'recursion-desired
'recursion-available
'no-error
(list (question (domain '(#"google" #"com")) 'aaaa 'in #f))
'()
(list (rr (domain '(#"google" #"com")) 'soa 'in 594 (soa (domain '(#"ns1" #"google" #"com")) (domain '(#"dns-admin" #"google" #"com")) 1454883 7200 1800 1209600 300)))
'()))
;; Wed Jun 29 21:05:03 2011 (4e0bcbbf): UDP: localhost sent 32 bytes:
;; 00000000: 12 70 01 00 00 01 00 00 : 00 00 00 00 03 77 77 77 .p...........www
;; 00000010: 06 67 6F 6F 67 6C 65 03 : 63 6F 6D 00 00 1C 00 01 .google.com.....
;; 00000020:
;; Wed Jun 29 21:05:03 2011 (4e0bcbbf): UDP: pass through succeeded
;; Wed Jun 29 21:05:03 2011 (4e0bcbbf): UDP: ns1.google.com sent 52 bytes:
;; 00000000: 12 70 85 00 00 01 00 01 : 00 00 00 00 03 77 77 77 .p...........www
;; 00000010: 06 67 6F 6F 67 6C 65 03 : 63 6F 6D 00 00 1C 00 01 .google.com.....
;; 00000020: C0 0C 00 05 00 01 00 09 : 3A 80 00 08 03 77 77 77 ........:....www
;; 00000030: 01 6C C0 10 : .l..
;; 00000034:
(check-both
(bytes
#x12 #x70 #x01 #x00 #x00 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x03 #x77 #x77 #x77
#x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00 #x01)
(dns-message 4720
'request
'query
'non-authoritative
'not-truncated
'recursion-desired
'no-recursion-available
'no-error
(list (question (domain '(#"www" #"google" #"com")) 'aaaa 'in #f))
'()
'()
'()))
(check-both
(bytes
#x12 #x70 #x85 #x00 #x00 #x01 #x00 #x01 #x00 #x00 #x00 #x00 #x03 #x77 #x77 #x77
#x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00 #x01
#xC0 #x0C #x00 #x05 #x00 #x01 #x00 #x09 #x3A #x80 #x00 #x08 #x03 #x77 #x77 #x77
#x01 #x6C #xC0 #x10)
(dns-message 4720
'response
'query
'authoritative
'not-truncated
'recursion-desired
'no-recursion-available
'no-error
(list (question (domain '(#"www" #"google" #"com")) 'aaaa 'in #f))
(list (rr (domain '(#"www" #"google" #"com")) 'cname 'in 604800 (domain '(#"www" #"l" #"google" #"com"))))
'()
'()))
;; Wed Jun 29 21:07:46 2011 (4e0bcc62): UDP: ns1.google.com sent 82 bytes:
;; 00000000: 23 79 85 00 00 01 00 02 : 00 00 00 00 04 69 70 76 #y...........ipv
;; 00000010: 36 06 67 6F 6F 67 6C 65 : 03 63 6F 6D 00 00 1C 00 6.google.com....
;; 00000020: 01 C0 0C 00 05 00 01 00 : 09 3A 80 00 09 04 69 70 .........:....ip
;; 00000030: 76 36 01 6C C0 11 C0 2D : 00 1C 00 01 00 00 01 2C v6.l...-.......,
;; 00000040: 00 10 20 01 48 60 80 0F : 00 00 00 00 00 00 00 00 .. .H`..........
;; 00000050: 00 68 : .h
;; 00000052:
(check-both
(bytes
#x23 #x79 #x85 #x00 #x00 #x01 #x00 #x02 #x00 #x00 #x00 #x00 #x04 #x69 #x70 #x76
#x36 #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00
#x01 #xC0 #x0C #x00 #x05 #x00 #x01 #x00 #x09 #x3A #x80 #x00 #x09 #x04 #x69 #x70
#x76 #x36 #x01 #x6C #xC0 #x11 #xC0 #x2D #x00 #x1C #x00 #x01 #x00 #x00 #x01 #x2C
#x00 #x10 #x20 #x01 #x48 #x60 #x80 #x0F #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
#x00 #x68)
(dns-message 9081
'response
'query
'authoritative
'not-truncated
'recursion-desired
'no-recursion-available
'no-error
(list (question (domain '(#"ipv6" #"google" #"com")) 'aaaa 'in #f))
(list (rr (domain '(#"ipv6" #"google" #"com")) 'cname 'in 604800 (domain '(#"ipv6" #"l" #"google" #"com")))
(rr (domain '(#"ipv6" #"l" #"google" #"com")) 'aaaa 'in 300 '#(32 1 72 96 128 15 0 0 0 0 0 0 0 0 0 104)))
'()
'()))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SRV records from the wild.
;; Thu Jun 30 15:12:45 2011 (4e0ccaad): UDP: asgard.ccs.neu.edu sent 486 bytes:
;; 00000000: 13 CA 81 80 00 01 00 05 : 00 04 00 09 0C 5F 78 6D ............._xm
;; 00000010: 70 70 2D 73 65 72 76 65 : 72 04 5F 74 63 70 06 67 pp-server._tcp.g
;; 00000020: 6F 6F 67 6C 65 03 63 6F : 6D 00 00 21 00 01 C0 0C oogle.com..!....
;; 00000030: 00 21 00 01 00 00 03 72 : 00 21 00 14 00 00 14 95 .!.....r.!......
;; 00000040: 0C 78 6D 70 70 2D 73 65 : 72 76 65 72 34 01 6C 06 .xmpp-server4.l.
;; 00000050: 67 6F 6F 67 6C 65 03 63 : 6F 6D 00 C0 0C 00 21 00 google.com....!.
;; 00000060: 01 00 00 03 72 00 20 00 : 05 00 00 14 95 0B 78 6D ....r. .......xm
;; 00000070: 70 70 2D 73 65 72 76 65 : 72 01 6C 06 67 6F 6F 67 pp-server.l.goog
;; 00000080: 6C 65 03 63 6F 6D 00 C0 : 0C 00 21 00 01 00 00 03 le.com....!.....
;; 00000090: 72 00 21 00 14 00 00 14 : 95 0C 78 6D 70 70 2D 73 r.!.......xmpp-s
;; 000000A0: 65 72 76 65 72 31 01 6C : 06 67 6F 6F 67 6C 65 03 erver1.l.google.
;; 000000B0: 63 6F 6D 00 C0 0C 00 21 : 00 01 00 00 03 72 00 21 com....!.....r.!
;; 000000C0: 00 14 00 00 14 95 0C 78 : 6D 70 70 2D 73 65 72 76 .......xmpp-serv
;; 000000D0: 65 72 32 01 6C 06 67 6F : 6F 67 6C 65 03 63 6F 6D er2.l.google.com
;; 000000E0: 00 C0 0C 00 21 00 01 00 : 00 03 72 00 21 00 14 00 ....!.....r.!...
;; 000000F0: 00 14 95 0C 78 6D 70 70 : 2D 73 65 72 76 65 72 33 ....xmpp-server3
;; 00000100: 01 6C 06 67 6F 6F 67 6C : 65 03 63 6F 6D 00 C1 02 .l.google.com...
;; 00000110: 00 02 00 01 00 01 54 24 : 00 06 03 6E 73 33 C1 02 ......T$...ns3..
;; 00000120: C1 02 00 02 00 01 00 01 : 54 24 00 06 03 6E 73 34 ........T$...ns4
;; 00000130: C1 02 C1 02 00 02 00 01 : 00 01 54 24 00 06 03 6E ..........T$...n
;; 00000140: 73 32 C1 02 C1 02 00 02 : 00 01 00 01 54 24 00 06 s2..........T$..
;; 00000150: 03 6E 73 31 C1 02 C0 6D : 00 01 00 01 00 00 01 1A .ns1...m........
;; 00000160: 00 04 4A 7D 99 7D C0 99 : 00 01 00 01 00 00 06 F6 ..J}.}..........
;; 00000170: 00 04 4A 7D 35 7D C0 C6 : 00 01 00 01 00 00 06 F6 ..J}5}..........
;; 00000180: 00 04 4A 7D 2F 7D C0 F3 : 00 01 00 01 00 00 06 F6 ..J}/}..........
;; 00000190: 00 04 4A 7D 2D 7D C0 40 : 00 01 00 01 00 00 06 F6 ..J}-}.@........
;; 000001A0: 00 04 4A 7D 2D 7D C1 50 : 00 01 00 01 00 00 0A B1 ..J}-}.P........
;; 000001B0: 00 04 D8 EF 20 0A C1 3E : 00 01 00 01 00 00 0A B1 .... ..>........
;; 000001C0: 00 04 D8 EF 22 0A C1 1A : 00 01 00 01 00 00 0A B1 ...."...........
;; 000001D0: 00 04 D8 EF 24 0A C1 2C : 00 01 00 01 00 00 0A B1 ....$..,........
;; 000001E0: 00 04 D8 EF 26 0A : ....&.
;; 000001E6:
;; ANSWER SECTION:
;;_xmpp-server._tcp.google.com. 900 IN SRV 5 0 5269 xmpp-server.l.google.com.
;;_xmpp-server._tcp.google.com. 900 IN SRV 20 0 5269 xmpp-server1.l.google.com.
;;_xmpp-server._tcp.google.com. 900 IN SRV 20 0 5269 xmpp-server2.l.google.com.
;;_xmpp-server._tcp.google.com. 900 IN SRV 20 0 5269 xmpp-server3.l.google.com.
;;_xmpp-server._tcp.google.com. 900 IN SRV 20 0 5269 xmpp-server4.l.google.com.
(check-both
(bytes
#x13 #xCA #x81 #x80 #x00 #x01 #x00 #x05 #x00 #x04 #x00 #x09 #x0C #x5F #x78 #x6D
#x70 #x70 #x2D #x73 #x65 #x72 #x76 #x65 #x72 #x04 #x5F #x74 #x63 #x70 #x06 #x67
#x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x21 #x00 #x01 #xC0 #x0C
#x00 #x21 #x00 #x01 #x00 #x00 #x03 #x72 #x00 #x21 #x00 #x14 #x00 #x00 #x14 #x95
#x0C #x78 #x6D #x70 #x70 #x2D #x73 #x65 #x72 #x76 #x65 #x72 #x34 #x01 #x6C #x06
#x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #xC0 #x0C #x00 #x21 #x00
#x01 #x00 #x00 #x03 #x72 #x00 #x20 #x00 #x05 #x00 #x00 #x14 #x95 #x0B #x78 #x6D
#x70 #x70 #x2D #x73 #x65 #x72 #x76 #x65 #x72 #x01 #x6C #x06 #x67 #x6F #x6F #x67
#x6C #x65 #x03 #x63 #x6F #x6D #x00 #xC0 #x0C #x00 #x21 #x00 #x01 #x00 #x00 #x03
#x72 #x00 #x21 #x00 #x14 #x00 #x00 #x14 #x95 #x0C #x78 #x6D #x70 #x70 #x2D #x73
#x65 #x72 #x76 #x65 #x72 #x31 #x01 #x6C #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03
#x63 #x6F #x6D #x00 #xC0 #x0C #x00 #x21 #x00 #x01 #x00 #x00 #x03 #x72 #x00 #x21
#x00 #x14 #x00 #x00 #x14 #x95 #x0C #x78 #x6D #x70 #x70 #x2D #x73 #x65 #x72 #x76
#x65 #x72 #x32 #x01 #x6C #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D
#x00 #xC0 #x0C #x00 #x21 #x00 #x01 #x00 #x00 #x03 #x72 #x00 #x21 #x00 #x14 #x00
#x00 #x14 #x95 #x0C #x78 #x6D #x70 #x70 #x2D #x73 #x65 #x72 #x76 #x65 #x72 #x33
#x01 #x6C #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #xC1 #x02
#x00 #x02 #x00 #x01 #x00 #x01 #x54 #x24 #x00 #x06 #x03 #x6E #x73 #x33 #xC1 #x02
#xC1 #x02 #x00 #x02 #x00 #x01 #x00 #x01 #x54 #x24 #x00 #x06 #x03 #x6E #x73 #x34
#xC1 #x02 #xC1 #x02 #x00 #x02 #x00 #x01 #x00 #x01 #x54 #x24 #x00 #x06 #x03 #x6E
#x73 #x32 #xC1 #x02 #xC1 #x02 #x00 #x02 #x00 #x01 #x00 #x01 #x54 #x24 #x00 #x06
#x03 #x6E #x73 #x31 #xC1 #x02 #xC0 #x6D #x00 #x01 #x00 #x01 #x00 #x00 #x01 #x1A
#x00 #x04 #x4A #x7D #x99 #x7D #xC0 #x99 #x00 #x01 #x00 #x01 #x00 #x00 #x06 #xF6
#x00 #x04 #x4A #x7D #x35 #x7D #xC0 #xC6 #x00 #x01 #x00 #x01 #x00 #x00 #x06 #xF6
#x00 #x04 #x4A #x7D #x2F #x7D #xC0 #xF3 #x00 #x01 #x00 #x01 #x00 #x00 #x06 #xF6
#x00 #x04 #x4A #x7D #x2D #x7D #xC0 #x40 #x00 #x01 #x00 #x01 #x00 #x00 #x06 #xF6
#x00 #x04 #x4A #x7D #x2D #x7D #xC1 #x50 #x00 #x01 #x00 #x01 #x00 #x00 #x0A #xB1
#x00 #x04 #xD8 #xEF #x20 #x0A #xC1 #x3E #x00 #x01 #x00 #x01 #x00 #x00 #x0A #xB1
#x00 #x04 #xD8 #xEF #x22 #x0A #xC1 #x1A #x00 #x01 #x00 #x01 #x00 #x00 #x0A #xB1
#x00 #x04 #xD8 #xEF #x24 #x0A #xC1 #x2C #x00 #x01 #x00 #x01 #x00 #x00 #x0A #xB1
#x00 #x04 #xD8 #xEF #x26 #x0A)
(let ((X (domain '(#"_xmpp-server" #"_tcp" #"google" #"com"))))
(dns-message 5066
'response
'query
'non-authoritative
'not-truncated
'recursion-desired
'recursion-available
'no-error
(list (question X 'srv 'in #f))
(list (rr X 'srv 'in 882 (srv 20 0 5269 (domain '(#"xmpp-server4" #"l" #"google" #"com"))))
(rr X 'srv 'in 882 (srv 5 0 5269 (domain '(#"xmpp-server" #"l" #"google" #"com"))))
(rr X 'srv 'in 882 (srv 20 0 5269 (domain '(#"xmpp-server1" #"l" #"google" #"com"))))
(rr X 'srv 'in 882 (srv 20 0 5269 (domain '(#"xmpp-server2" #"l" #"google" #"com"))))
(rr X 'srv 'in 882 (srv 20 0 5269 (domain '(#"xmpp-server3" #"l" #"google" #"com")))))
(list (rr (domain '(#"google" #"com")) 'ns 'in 87076 (domain '(#"ns3" #"google" #"com")))
(rr (domain '(#"google" #"com")) 'ns 'in 87076 (domain '(#"ns4" #"google" #"com")))
(rr (domain '(#"google" #"com")) 'ns 'in 87076 (domain '(#"ns2" #"google" #"com")))
(rr (domain '(#"google" #"com")) 'ns 'in 87076 (domain '(#"ns1" #"google" #"com"))))
(list (rr (domain '(#"xmpp-server" #"l" #"google" #"com")) 'a 'in 282 '#(74 125 153 125))
(rr (domain '(#"xmpp-server1" #"l" #"google" #"com")) 'a 'in 1782 '#(74 125 53 125))
(rr (domain '(#"xmpp-server2" #"l" #"google" #"com")) 'a 'in 1782 '#(74 125 47 125))
(rr (domain '(#"xmpp-server3" #"l" #"google" #"com")) 'a 'in 1782 '#(74 125 45 125))
(rr (domain '(#"xmpp-server4" #"l" #"google" #"com")) 'a 'in 1782 '#(74 125 45 125))
(rr (domain '(#"ns1" #"google" #"com")) 'a 'in 2737 '#(216 239 32 10))
(rr (domain '(#"ns2" #"google" #"com")) 'a 'in 2737 '#(216 239 34 10))
(rr (domain '(#"ns3" #"google" #"com")) 'a 'in 2737 '#(216 239 36 10))
(rr (domain '(#"ns4" #"google" #"com")) 'a 'in 2737 '#(216 239 38 10))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Zone saving/loading.
(check-equal? (compile-zone-db test-rrs)
(bit-string->zone (zone->bit-string (compile-zone-db test-rrs))))
(check-equal? (compile-zone-db test-roots)
(bit-string->zone (zone->bit-string (compile-zone-db test-roots))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CNAME sorting
(let ()
(define rrs
(list (rr (domain '(#"a")) 'cname 'in 30 (domain '(#"b")))
(rr (domain '(#"b")) 'cname 'in 30 (domain '(#"c")))
(rr (domain '(#"c")) 'cname 'in 30 (domain '(#"d")))))
(define (check-transpose ns)
(define permuted (map (lambda (i) (list-ref rrs i)) ns))
(check-equal? (cname-sort permuted) rrs))
(check-transpose '(0 1 2))
(check-transpose '(0 2 1))
(check-transpose '(2 0 1))
(check-transpose '(2 1 0))
(check-transpose '(1 2 0))
(check-transpose '(1 0 2)))

26
test-mapping.rkt Normal file
View File

@ -0,0 +1,26 @@
#lang racket/base
;; Tests for mapping.rkt.
(require "mapping.rkt")
(require rackunit)
(define-mapping a->b b->a
(a b))
(check-equal? (a->b 'a) 'b)
(check-equal? (b->a 'b) 'a)
(check-exn exn:fail:contract? (lambda () (a->b 123)))
(check-exn exn:fail:contract? (lambda () (a->b 'b)))
(check-exn exn:fail:contract? (lambda () (b->a 123)))
(check-exn exn:fail:contract? (lambda () (b->a 'a)))
(define-mapping c->d d->c
#:forward-default (lambda (x) 'default-d)
#:backward-default (lambda (x) 'default-c)
(c 123)
(e 234))
(check-equal? (c->d 'c) 123)
(check-equal? (d->c 234) 'e)
(check-equal? (c->d 'other) 'default-d)
(check-equal? (d->c '235) 'default-c)

86
test-rrs.rkt Normal file
View File

@ -0,0 +1,86 @@
#lang typed/racket/base
(require "api.rkt")
(provide (all-defined-out))
(define test-soa-rr
(rr (domain '(#"example")) 'in 30
(rdata-soa 'soa
(domain '(#"ns" #"example"))
(domain '(#"tonyg" #"example"))
1
24
24
30
10)))
(: A : (Listof Bytes) (Vector Integer Integer Integer Integer) -> RR)
(: A/ttl : (Listof Bytes) (Vector Integer Integer Integer Integer) Nonnegative-Integer -> RR)
(: MX : (Listof Bytes) Nonnegative-Integer (Listof Bytes) -> RR)
(: CNAME : (Listof Bytes) (Listof Bytes) -> RR)
(: NS : (Listof Bytes) (Listof Bytes) -> RR)
(: NS/ttl : (Listof Bytes) (Listof Bytes) Nonnegative-Integer -> RR)
(: TXT : (Listof Bytes) (Listof Bytes) -> RR)
(define (A n ip) (A/ttl n ip 30))
(define (A/ttl n ip ttl) (rr (domain n) 'in ttl (rdata-ipv4 'a (cast ip IPv4))))
(define (MX n p t) (rr (domain n) 'in 30 (rdata-mx 'mx p (domain t))))
(define (CNAME n1 n2) (rr (domain n1) 'in 30 (rdata-domain 'cname (domain n2))))
(define (NS n1 n2) (NS/ttl n1 n2 30))
(define (NS/ttl n1 n2 ttl) (rr (domain n1) 'in ttl (rdata-domain 'ns (domain n2))))
(define (TXT n strs) (rr (domain n) 'in 30 (rdata-txt 'txt strs)))
(define test-rrs
(list (A '(#"localhost" #"example") '#(127 0 0 1))
(MX '(#"example") 5 '(#"localhost" #"example"))
(MX '(#"example") 10 '(#"subns" #"example"))
(CNAME '(#"google" #"example")'(#"www" #"google" #"com"))
(A '(#"roar" #"example") '#(192 168 1 1))
(CNAME '(#"alias" #"example") '(#"roar" #"example"))
(A '(#"ns" #"example") '#(127 0 0 1))
(TXT '(#"hello" #"example") '(#"Hello CRASH"))
(NS '(#"subzone" #"example") '(#"subns" #"example"))
(A '(#"subns" #"example") '#(127 0 0 2))))
(define test-roots
(list (A/ttl '(#"a" #"root-servers" #"net") '#(198 41 0 4) 3600000)
(A/ttl '(#"b" #"root-servers" #"net") '#(192 228 79 201) 3600000)
(A/ttl '(#"c" #"root-servers" #"net") '#(192 33 4 12) 3600000)
(A/ttl '(#"d" #"root-servers" #"net") '#(199 7 91 13) 3600000)
(A/ttl '(#"e" #"root-servers" #"net") '#(192 203 230 10) 3600000)
(A/ttl '(#"f" #"root-servers" #"net") '#(192 5 5 241) 3600000)
(A/ttl '(#"g" #"root-servers" #"net") '#(192 112 36 4) 3600000)
(A/ttl '(#"h" #"root-servers" #"net") '#(128 63 2 53) 3600000)
(A/ttl '(#"i" #"root-servers" #"net") '#(192 36 148 17) 3600000)
(A/ttl '(#"j" #"root-servers" #"net") '#(192 58 128 30) 3600000)
(A/ttl '(#"k" #"root-servers" #"net") '#(193 0 14 129) 3600000)
(A/ttl '(#"l" #"root-servers" #"net") '#(199 7 83 42) 3600000)
(A/ttl '(#"m" #"root-servers" #"net") '#(202 12 27 33) 3600000)
(NS/ttl '() '(#"a" #"root-servers" #"net") 3600000)
(NS/ttl '() '(#"b" #"root-servers" #"net") 3600000)
(NS/ttl '() '(#"c" #"root-servers" #"net") 3600000)
(NS/ttl '() '(#"d" #"root-servers" #"net") 3600000)
(NS/ttl '() '(#"e" #"root-servers" #"net") 3600000)
(NS/ttl '() '(#"f" #"root-servers" #"net") 3600000)
(NS/ttl '() '(#"g" #"root-servers" #"net") 3600000)
(NS/ttl '() '(#"h" #"root-servers" #"net") 3600000)
(NS/ttl '() '(#"i" #"root-servers" #"net") 3600000)
(NS/ttl '() '(#"j" #"root-servers" #"net") 3600000)
(NS/ttl '() '(#"k" #"root-servers" #"net") 3600000)
(NS/ttl '() '(#"l" #"root-servers" #"net") 3600000)
(NS/ttl '() '(#"m" #"root-servers" #"net") 3600000)))
(define pathological-roots
(list (NS '(#"a") '(#"ns" #"b"))
(NS '(#"b") '(#"ns" #"a"))))
(: test-port-number : -> Nonnegative-Integer)
(define (test-port-number)
(define p
(string->number
(or (getenv "DNSPORT")
(error 'test-port-number "Please set your DNSPORT environment variable."))))
(if (or (not p) (not (exact? p)) (not (integer? p)) (negative? p))
(error 'test-port-number "Invalid DNSPORT setting.")
p))

109
tk-dns.rkt Normal file
View File

@ -0,0 +1,109 @@
#lang typed/racket/base
;; DNS drivers using marketplace.
(require racket/set)
(require racket/match)
(require "codec.rkt")
(require marketplace/sugar-typed)
(require marketplace/drivers/udp)
(require marketplace/support/pseudo-substruct)
(provide (struct-out bad-dns-packet-repr)
BadDnsPacket bad-dns-packet bad-dns-packet?
BadDnsPacketPattern bad-dns-packet-pattern bad-dns-packet-pattern?
(struct-out dns-request-repr)
DNSRequest dns-request dns-request?
DNSRequestPattern dns-request-pattern dns-request-pattern?
(struct-out dns-reply-repr)
DNSReply dns-reply dns-reply?
DNSReplyPattern dns-reply-pattern dns-reply-pattern?
dns-read-driver
dns-write-driver
dns-spy)
(struct: (TDetail TSource TSink TReason)
bad-dns-packet-repr
([detail : TDetail] [source : TSource] [sink : TSink] [reason : TReason]) #:transparent)
(pseudo-substruct: (bad-dns-packet-repr Any UdpAddress UdpAddress Symbol)
BadDnsPacket bad-dns-packet bad-dns-packet?)
(pseudo-substruct: (bad-dns-packet-repr Any
(U Wild UdpAddressPattern)
(U Wild UdpAddressPattern)
(U Wild Symbol))
BadDnsPacketPattern bad-dns-packet-pattern bad-dns-packet-pattern?)
(struct: (TMessage TSource TSink)
dns-request-repr
([message : TMessage] [source : TSource] [sink : TSink]) #:transparent)
(pseudo-substruct: (dns-request-repr DNSMessage UdpAddress UdpAddress)
DNSRequest dns-request dns-request?)
(pseudo-substruct: (dns-request-repr (U Wild DNSMessage)
(U Wild UdpAddressPattern)
(U Wild UdpAddressPattern))
DNSRequestPattern dns-request-pattern dns-request-pattern?)
(struct: (TMessage TSource TSink)
dns-reply-repr
([message : TMessage] [source : TSource] [sink : TSink]) #:transparent)
(pseudo-substruct: (dns-reply-repr DNSMessage UdpAddress UdpAddress)
DNSReply dns-reply dns-reply?)
(pseudo-substruct: (dns-reply-repr (U Wild DNSMessage)
(U Wild UdpAddressPattern)
(U Wild UdpAddressPattern))
DNSReplyPattern dns-reply-pattern dns-reply-pattern?)
(: dns-read-driver : UdpAddress -> (Transition Void))
(define (dns-read-driver s)
(transition: (void) : Void
(at-meta-level
(endpoint: : Void
#:subscriber (udp-packet-pattern (wild) s (wild))
[(udp-packet source (== s) #"")
(begin (log-info "Debug dump packet received")
(send-message `(debug-dump)))]
[(udp-packet source (== s) body)
(send-message
(with-handlers ((exn:fail? (lambda (e)
(bad-dns-packet body source s 'unparseable))))
(define message (packet->dns-message body))
(case (dns-message-direction message)
((request) (dns-request message source s))
((response) (dns-reply message source s)))))]))))
(: dns-write-driver : UdpAddress -> (Transition Void))
(define (dns-write-driver s)
(: translate : DNSMessage UdpAddress -> (ActionTree Void))
(define (translate message sink)
(with-handlers ((exn:fail? (lambda (e)
(send-message (bad-dns-packet message s sink 'unencodable)))))
(at-meta-level
(send-message (udp-packet s sink (dns-message->packet message))))))
(transition: (void) : Void
(endpoint: : Void
#:subscriber (dns-request (wild) s (wild))
[(dns-request message (== s) sink) (translate message sink)])
(endpoint: : Void
#:subscriber (dns-reply (wild) s (wild))
[(dns-reply message (== s) sink) (translate message sink)])))
(: dns-spy : -> (Transition Void))
(define (dns-spy)
(transition: (void) : Void
(endpoint: : Void
#:subscriber (wild) #:observer
[(dns-request message source sink)
(begin (log-info (format "DNS: ~v asks ~v ~v~n : ~v"
source sink (dns-message-id message)
(dns-message-questions message)))
(void))]
[(dns-reply message source sink)
(begin (log-info (format "DNS: ~v answers ~v~n : ~v"
source sink
message))
(void))]
[x
(begin (log-info (format "DNS: ~v" x))
(void))])))

310
zonedb.rkt Normal file
View File

@ -0,0 +1,310 @@
#lang typed/racket/base
;; Noddy representation of a zone, and various zone and RRSet utilities.
(require racket/set)
(require racket/match)
(require (only-in racket/math exact-floor exact-truncate))
(require "api.rkt")
(require "codec.rkt")
(require (planet tonyg/bitsyntax))
(require (rename-in marketplace/tr-struct-copy [tr-struct-copy struct-copy])) ;; PR13149
(provide CompiledZone
zone-ref
zone-includes-name?
incorporate-complete-answer
zone-expire-name
zone-expire
empty-zone-db
compile-zone-db
in-bailiwick?
set-filter
filter-by-type
filter-rrs
rr-set->list
rr-rdata-domain-name
cname-sort ;; provided for unit tests
zone->bit-string
bit-string->zone)
(define-type RelativeSeconds Real)
(define-type AbsoluteSeconds Real)
(define-predicate absolute-seconds? AbsoluteSeconds)
;; An InfiniteLifetime is an (infinite-lifetime RelativeSeconds), a
;; specification of the TTL to use when sending a non-expiring RR to a
;; peer.
(struct: infinite-lifetime ([ttl : RelativeSeconds]) #:transparent)
(define-type InfiniteLifetime infinite-lifetime)
;; An Expiry is either an AbsoluteSeconds or an InfiniteLifetime.
(define-type Expiry (U AbsoluteSeconds InfiniteLifetime))
;; A CompiledZone is a Hash<DomainName,Hash<RR,(or AbsoluteSeconds
;; InfiniteLifetime)>>, representing a collection of DNS RRSets
;; indexed by DomainName. Each RR in an RRSet either has an expiry
;; time associated with it or has an InfiniteLifetime associated with
;; it, in which case it should not expire.
(define-type CompiledZone (HashTable DomainName (HashTable RR Expiry)))
;; A Timers is a SetOf<(cons DomainName RelativeSeconds)>,
;; representing a collection of timeouts that should be set against
;; names to to see if their associated RRs have expired.
(define-type Timer (Pairof DomainName RelativeSeconds))
(define-type Timers (Setof Timer))
;; 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.
(: current-inexact-seconds : -> AbsoluteSeconds)
(define (current-inexact-seconds)
(/ (current-inexact-milliseconds) 1000.0))
(: still-valid? : Expiry AbsoluteSeconds -> Boolean)
(define (still-valid? expiry now)
(or (infinite-lifetime? expiry)
(>= expiry now)))
(: zone-ref : CompiledZone DomainName -> (Option (Setof RR)))
(define (zone-ref db name)
(define expirymap (hash-ref db name (lambda () #f)))
(and expirymap
(let ((now (current-inexact-seconds)))
(for/fold: ([acc : (Setof RR) (set)])
([resource : RR (in-hash-keys expirymap)])
(define expiry (hash-ref expirymap resource))
(if (still-valid? expiry now)
(let ((new-ttl (if (infinite-lifetime? expiry)
(infinite-lifetime-ttl expiry)
(- expiry now))))
(set-add acc
(struct-copy rr resource
[ttl (cast (exact-floor new-ttl) Nonnegative-Integer)])))
acc)))))
(: zone-includes-name? : CompiledZone DomainName -> Boolean)
(define (zone-includes-name? db name)
(hash-has-key? db name))
(: incorporate-rr : (Option AbsoluteSeconds) -> (RR CompiledZone -> CompiledZone))
;; Incorporates the given RR into our database. If base-time is a
;; number of seconds, we treat the RR as having a TTL that decreases
;; as time goes by; otherwise base-time is #f, and we treat the RR as
;; being non-expiring with an InfiniteLifetime.
(define ((incorporate-rr base-time) resource0 db)
(define expiry (if base-time
(if (zero? (rr-ttl resource0))
;; We are definitely not caching this
;; resource then, because we are not even
;; called by incorporate-complete-answer in
;; case of 0-TTL and the cache. This record
;; is transient and used just for the current
;; resolution. Storing it with a real 0-TTL
;; would mean it immediately is ignored,
;; which is silly, so store it with an
;; infinite-lifetime instead.
(infinite-lifetime 0)
;; Otherwise it has a normal TTL, which we
;; honour.
(+ base-time (rr-ttl resource0)))
(infinite-lifetime (rr-ttl resource0))))
(define resource (struct-copy rr resource0 [ttl 0]))
(define name (rr-name resource))
(define old-expirymap (hash-ref db name (lambda () (ann #hash() (HashTable rr Expiry)))))
(define old-expiry (hash-ref old-expirymap resource (lambda () 0)))
(cond
[(infinite-lifetime? old-expiry) ;; don't update TTL: the existing record should live forever
db]
[(or (infinite-lifetime? expiry) (> expiry old-expiry)) ;; update TTL
(hash-set db name (hash-set old-expirymap resource expiry))]
[else ;; old record finite-lifetime but expiring after the new expiry: leave it alone
db]))
(: incorporate-complete-answer :
(Option CompleteAnswer) CompiledZone Boolean -> (Values CompiledZone Timers))
(define (incorporate-complete-answer ans db is-cache?)
(match ans
[#f
(values db (set))]
[(complete-answer ns us ds)
(define now (current-inexact-seconds))
(for/fold ([db db] [timers ((inst set Timer))])
([rr (in-list (append (set->list ns)
(set->list us)
(set->list ds)))]) ;; no in-sequences in typed racket
(if (and is-cache? (zero? (rr-ttl rr))) ;; Do not *cache* 0-TTL RRs (RFC 1034 3.6)
(values db timers)
(values ((incorporate-rr now) rr db)
(set-add timers (cons (rr-name rr) (rr-ttl rr))))))]))
(: zone-expire-name : CompiledZone DomainName AbsoluteSeconds -> CompiledZone)
;; Checks the given name to see if there are any expiring records, and
;; if so, removes them.
(define (zone-expire-name db name now-seconds)
(define empty-expirymap (ann #hash() (HashTable RR Expiry)))
(define old-expirymap (hash-ref db name (lambda () empty-expirymap)))
(define new-expirymap
(for/fold: ([acc : (HashTable RR Expiry) empty-expirymap])
([resource : RR (in-hash-keys old-expirymap)])
(define expiry (hash-ref old-expirymap resource))
(if (still-valid? expiry now-seconds)
(hash-set acc resource expiry)
acc)))
(if (zero? (hash-count new-expirymap))
(hash-remove db name)
(hash-set db name new-expirymap)))
(: zone-expire : CompiledZone -> (Values CompiledZone Timers))
;; Used to freshen a saved zone when it is loaded from disk.
(define (zone-expire zone)
(define now-seconds (current-inexact-seconds))
(for/fold: ([zone : CompiledZone zone] [timers : Timers (set)])
([name : DomainName (in-hash-keys zone)])
(define new-zone (zone-expire-name zone name now-seconds))
(define expirymap (hash-ref new-zone name (lambda () #f)))
(values new-zone
(if expirymap
(set-union (list->set
(map (lambda: ([e : AbsoluteSeconds]) (cons name (- e now-seconds)))
(filter absolute-seconds? (hash-values expirymap))))
timers)
timers))))
(: empty-zone-db : -> CompiledZone)
(define (empty-zone-db)
(make-immutable-hash))
(: 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)
(foldl (incorporate-rr #f) (empty-zone-db) rrs))
(: in-bailiwick? : DomainName DomainName -> Boolean)
;; Answers #t iff dn falls within the bailiwick of the zone with
;; origin o.
(define (in-bailiwick? dn o)
(or (equal? dn o)
(let ((p (domain-parent dn)))
(and p (in-bailiwick? p o)))))
(: set-filter : (All (X) (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/fold: ([acc : (Setof X) (set)]) ([x : X (in-list (set->list in))])
(if (predicate x) (set-add acc x) acc)))
(: filter-by-type : (Setof RR) RRType -> (Setof RR))
;; Selects only those members of rrset having rr-type type.
(define (filter-by-type rrset type)
(define p? (rdata-type-pred type))
(set-filter (lambda: ([rr : RR]) (p? (rr-rdata rr))) rrset))
(: no-rrs : (Setof RR))
(define no-rrs (set))
(: filter-rrs : (Setof RR) QueryType QueryClass -> (Setof RR))
;; 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
(cond
((eq? qtype '*) rrs)
((eq? qtype 'axfr) no-rrs) ;; TODO: warn? error? AXFR is not currently supported.
((eq? qtype 'mailb) no-rrs) ;; TODO: warn? error? MAILB is not currently supported.
((eq? qtype 'maila) no-rrs) ;; TODO: warn? error? MAILA is not currently supported.
(else (filter-by-type rrs qtype))))
(define filtered-by-type-and-class
(case qclass
((*) filtered-by-type)
(else (set-filter (lambda: ([rr : RR]) (eqv? (rr-class rr) qclass)) filtered-by-type))))
filtered-by-type-and-class)
(: rr-set->list : (Setof RR) -> (Listof RR))
;; Like set->list, but places all CNAME records first.
;; This is apparently to work around bugs in old versions of BIND?
;;
;; The CNAMEs even need to be in topologically-sorted order.
;; http://homepage.ntlworld.com./jonathan.deboynepollard/FGA/dns-response-taxonomy.html
;; has this to say on this topic:
;; "A content DNS server following the algorithm in § 4.3.2 of RFC
;; 1034 will insert this chain in first-to-last order in the
;; response. The response parsing code in most resolving proxy DNS
;; servers and DNS client libraries expects this order. However,
;; the actual text of RFC 1034 itself does not guarantee it."
;; Sure enough, the resolver in Firefox seems not to be able to handle
;; CNAMEs in any order other than strictly causal. While we could be
;; more careful about retaining the ordering of RRs all the way
;; through the resolution and CNAME expansion processes, that would
;; pollute the logic with a bunch of noise about RR order which isn't
;; even supposed to be relevant. So we *recover* the order here, which
;; is a bit expensive.
(define (rr-set->list rrs)
(define cnames (filter-by-type rrs 'cname))
(append (cname-sort (set->list cnames))
(set->list (set-subtract rrs cnames))))
(: rr-rdata-domain-name : RR -> DomainName)
(define (rr-rdata-domain-name rr)
(rdata-domain-name (cast (rr-rdata rr) rdata-domain)))
(: cname-sort : (Listof RR) -> (Listof RR))
;; Produce an ordering of the CNAMEs given that respects their
;; "causality". For example, if a CNAME b and b CNAME c, then the RRs
;; will be presented in that order (and not the other order, with b
;; CNAME c first).
(define (cname-sort cnames)
(define lhss (list->set (map rr-name cnames)))
(define rhss (list->set (map rr-rdata-domain-name cnames)))
(define roots (set->list (set-subtract lhss rhss))) ;; Nodes not the targets of some edge.
(: targets-of : DomainName -> (Listof RR))
(define (targets-of name) (filter (lambda: ([rr : RR]) (equal? (rr-name rr) name)) cnames))
(let: iterate ((remaining : (Listof DomainName) roots)
(seen : (Setof DomainName) (set))
(acc : (Listof RR) '()))
(if (null? remaining)
(reverse acc)
(let ((source (car remaining)))
(if (set-member? seen source)
(iterate (cdr remaining) seen acc)
(let* ((rrs (targets-of source))
(targets (map rr-rdata-domain-name rrs)))
(iterate (append targets (cdr remaining))
(set-add seen source)
(append rrs acc))))))))
(: zone->bit-string : CompiledZone -> BitString)
;; Produces a serialized form of the zone suitable for saving to disk.
(define (zone->bit-string zone)
(for/fold: ([acc : BitString (bit-string)]) ([name : DomainName (in-hash-keys zone)])
(define rrmap (hash-ref zone name))
(for/fold: ([acc : BitString acc]) ([rr : RR (in-hash-keys rrmap)])
(define expiry (hash-ref rrmap rr))
(bit-string-append
acc
(cond
[(infinite-lifetime? expiry)
(bit-string (rr :: (t:rr)) 1 ((exact-truncate (infinite-lifetime-ttl expiry)) :: bits 32))]
[else
(bit-string (rr :: (t:rr)) 0 ((exact-truncate expiry) :: bits 32))])))))
(: bit-string->zone : BitString -> CompiledZone)
;; Produces a deserialized form of the zone. Suitable for use in loading from disk.
(define (bit-string->zone bs)
(define now (current-inexact-seconds))
(define empty-packet (bytes))
(let loop ((db (empty-zone-db))
(bs bs))
(bit-string-case bs
([ ]
db)
([ (rr0 :: (t:rr empty-packet)) (= 1) (ttl :: bits 32) (rest :: binary) ]
(loop ((incorporate-rr #f) (struct-copy rr rr0 [ttl ttl]) db) rest))
([ (rr0 :: (t:rr empty-packet)) (= 0) (expirytime :: bits 32) (rest :: binary) ]
(define new-ttl (exact-floor (- expirytime now)))
(if (negative? new-ttl)
(loop db rest)
(loop ((incorporate-rr now) (struct-copy rr rr0 [ttl new-ttl]) db) rest))))))