From e2f38da0e7dc88d05fb8e42c4d4f0371a5f1b600 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 10 May 2013 16:38:25 -0400 Subject: [PATCH] Initial commit extracted from racket-dns repo --- .gitignore | 1 + TODO | 33 +++ api-untyped.rkt | 40 ++++ api.rkt | 394 ++++++++++++++++++++++++++++++++++++ codec.rkt | 505 ++++++++++++++++++++++++++++++++++++++++++++++ driver.rkt | 133 ++++++++++++ mapping.rkt | 52 +++++ network-query.rkt | 375 ++++++++++++++++++++++++++++++++++ proxy.rkt | 353 ++++++++++++++++++++++++++++++++ resolver.rkt | 157 ++++++++++++++ send-signal.rkt | 8 + test-dns.rkt | 469 ++++++++++++++++++++++++++++++++++++++++++ test-mapping.rkt | 26 +++ test-rrs.rkt | 86 ++++++++ tk-dns.rkt | 109 ++++++++++ zonedb.rkt | 310 ++++++++++++++++++++++++++++ 16 files changed, 3051 insertions(+) create mode 100644 .gitignore create mode 100644 TODO create mode 100644 api-untyped.rkt create mode 100644 api.rkt create mode 100644 codec.rkt create mode 100644 driver.rkt create mode 100644 mapping.rkt create mode 100644 network-query.rkt create mode 100644 proxy.rkt create mode 100644 resolver.rkt create mode 100644 send-signal.rkt create mode 100644 test-dns.rkt create mode 100644 test-mapping.rkt create mode 100644 test-rrs.rkt create mode 100644 tk-dns.rkt create mode 100644 zonedb.rkt diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..724bbe1 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +compiled/ diff --git a/TODO b/TODO new file mode 100644 index 0000000..4fe45c0 --- /dev/null +++ b/TODO @@ -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) diff --git a/api-untyped.rkt b/api-untyped.rkt new file mode 100644 index 0000000..2590122 --- /dev/null +++ b/api-untyped.rkt @@ -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 -> ListOf +;; 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 -> DomainName +;; Replacement constructor for domain structs. Automatically downcases +;; labels appropriately. +(define (make-domain labels) + (domain labels (downcase-labels labels))) diff --git a/api.rkt b/api.rkt new file mode 100644 index 0000000..67cbaa1 --- /dev/null +++ b/api.rkt @@ -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), 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). +(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 Set Set) +(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, 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 -> ListOf +;; 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 -> 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 ? diff --git a/codec.rkt b/codec.rkt new file mode 100644 index 0000000..685e9dc --- /dev/null +++ b/codec.rkt @@ -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 ListOf ListOf ListOf). +;; +;; 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))))))) + +;; +;; 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 +;; +---------------------+ +;; + +;; +;; 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 | +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; + +(: 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))))))) + +;; +;; 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 | +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; + +;; 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)))))) + +;; +;; 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 / +;; / / +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; + +;; 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) diff --git a/driver.rkt b/driver.rkt new file mode 100644 index 0000000..9e5a7c0 --- /dev/null +++ b/driver.rkt @@ -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) diff --git a/mapping.rkt b/mapping.rkt new file mode 100644 index 0000000..9301a6b --- /dev/null +++ b/mapping.rkt @@ -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 +;; { #:forward-default }? +;; { #:backward-default }? +;; ( ) ...) +;; Defines two functions, forward-name and backward-name, which take +;; values from the left-hand-sides of the mappings given as "( +;; )" 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 ...)))) diff --git a/network-query.rkt b/network-query.rkt new file mode 100644 index 0000000..e128466 --- /dev/null +++ b/network-query.rkt @@ -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): + +;;
+;; 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. +;;
+ +;;--------------------------------------------------------------------------- + +;; 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 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) +;; 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> ListOf +;; Maybe ListOf), 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)))))]))) diff --git a/proxy.rkt b/proxy.rkt new file mode 100644 index 0000000..87bcfea --- /dev/null +++ b/proxy.rkt @@ -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)) diff --git a/resolver.rkt b/resolver.rkt new file mode 100644 index 0000000..d79271c --- /dev/null +++ b/resolver.rkt @@ -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) +;; 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 Set) +(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)))))))) diff --git a/send-signal.rkt b/send-signal.rkt new file mode 100644 index 0000000..d4dea19 --- /dev/null +++ b/send-signal.rkt @@ -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) #"") diff --git a/test-dns.rkt b/test-dns.rkt new file mode 100644 index 0000000..78f8c2d --- /dev/null +++ b/test-dns.rkt @@ -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))) diff --git a/test-mapping.rkt b/test-mapping.rkt new file mode 100644 index 0000000..fe4a478 --- /dev/null +++ b/test-mapping.rkt @@ -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) diff --git a/test-rrs.rkt b/test-rrs.rkt new file mode 100644 index 0000000..2a1d806 --- /dev/null +++ b/test-rrs.rkt @@ -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)) diff --git a/tk-dns.rkt b/tk-dns.rkt new file mode 100644 index 0000000..cefe6c5 --- /dev/null +++ b/tk-dns.rkt @@ -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))]))) diff --git a/zonedb.rkt b/zonedb.rkt new file mode 100644 index 0000000..c59967b --- /dev/null +++ b/zonedb.rkt @@ -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>, 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))))))