Compare commits

..

No commits in common. "syndicate" and "typed" have entirely different histories.

14 changed files with 999 additions and 709 deletions

View File

@ -2,7 +2,7 @@
This is a [Racket](http://racket-lang.org/) implementation of a DNS
server and iterative resolver. It's written to work with
[Syndicate](https://github.com/tonyg/syndicate), but could readily
[Marketplace](https://github.com/tonyg/marketplace), but could readily
be adapted to work with other I/O substrates. (It originally used
Racket's `sync` and events directly.)
@ -18,9 +18,9 @@ equal to Racket 6.0 should work. Racket releases can be downloaded
Once you have Racket installed,
raco pkg install syndicate bitsyntax
raco pkg install marketplace bitsyntax
to install Syndicate and
to install Marketplace (note: will take a long time) and
[bitsyntax](https://github.com/tonyg/racket-bitsyntax/), and then
raco make driver.rkt proxy.rkt

View File

@ -20,9 +20,9 @@
;;; along with marketplace-dns. If not, see
;;; <http://www.gnu.org/licenses/>.
(provide (struct-out domain)
downcase-labels
make-domain)
(require marketplace/struct-map)
(provide (struct-out domain))
;; (These utilities need to be defined ahead of the domain struct
;; definition.)
@ -35,7 +35,10 @@
(struct domain (labels downcased-labels)
#:transparent
#:property prop:equal+hash (list domain=? domain-hash-1/2 domain-hash-1/2))
#:property prop:equal+hash (list domain=? domain-hash-1/2 domain-hash-1/2)
#:property prop:struct-map (lambda (f seed x)
(let-values (((labels seed) (f (domain-labels x) seed)))
(values (make-domain labels) seed))))
;; ListOf<Bytes> -> ListOf<Bytes>
;; Converts the 7-bit ASCII bytes in the argument to lower-case

188
api.rkt
View File

@ -1,4 +1,4 @@
#lang racket/base
#lang typed/racket/base
;; Definitions for use in the API to the functionality of the library.
;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@ -19,12 +19,18 @@
;;; along with marketplace-dns. If not, see
;;; <http://www.gnu.org/licenses/>.
(provide (except-out (struct-out domain) domain)
(provide DomainName
(except-out (struct-out domain) domain)
(rename-out [make-domain domain])
domain-root?
domain-parent
(struct-out question)
IPv4
IPv6
(struct-out question-repr)
Question question question?
QuestionPattern question-pattern question-pattern?
question-cyclic?
question-too-glueless?
@ -33,14 +39,19 @@
cname-question
ns-question
(struct-out answered-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)
@ -55,6 +66,10 @@
(struct-out rdata-raw)
rdata-type-pred
RRType
QueryType
RRClass
QueryClass
type->value value->type
qtype->value value->qtype
class->value value->class
@ -63,30 +78,50 @@
(require "mapping.rkt")
(require racket/set)
(require racket/match)
(require syndicate)
(require marketplace)
(require marketplace/struct-map)
(require marketplace/support/pseudo-substruct)
;; A DomainName is a (domain ListOf<Bytes>), representing a domain
;; name. The head of the list is the leftmost label; for example,
;; www.google.com is represented as '(#"www" #"google" #"com").
(require "api-untyped.rkt")
(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 question (name type class context) #:transparent)
(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
@ -99,20 +134,33 @@
;; 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) #:transparent)
(struct cname-subq subquestion () #:transparent)
(struct ns-subq subquestion () #:transparent)
(struct: subquestion ([parent : Question]) #:transparent)
(struct: cname-subq subquestion () #:transparent)
(struct: ns-subq subquestion () #:transparent)
(define-type QuestionContext (U subquestion cname-subq ns-subq False 'restart))
;; An AnsweredQuestion is an (answered-question Question
;; Maybe<CompleteAnswer>).
(struct answered-question (q a) #:transparent)
(struct: (TQ TA) answered-question-repr ([q : TQ] [a : TA]) #:transparent)
(pseudo-substruct: (answered-question-repr Question (Option CompleteAnswer))
AnsweredQuestion answered-question answered-question?)
(pseudo-substruct: (answered-question-repr (U Wild Question) (U Wild (Option CompleteAnswer)))
AnsweredQuestionPattern answered-question-pattern answered-question-pattern?)
;; A CompleteAnswer is a (complete-answer Set<RR> Set<RR> Set<RR>)
(struct complete-answer (rrs authorities additional) #:transparent)
(struct: complete-answer
([rrs : (Setof RR)] [authorities : (Setof RR)] [additional : (Setof RR)])
#:transparent)
(define-type CompleteAnswer complete-answer)
;; An RR is a (rr DomainName RRClass Uint32 RData),
;; An RR is a (rr DomainName RRType RRClass Uint32 RData),
;; representing a resource record.
(struct rr (name class ttl rdata) #:transparent)
(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
@ -133,20 +181,30 @@
;;
;; Many of these variants are obsolete in today's DNS database (marked
;; [O] above).
(struct rdata (type) #:transparent)
(struct rdata-domain rdata (name) #:transparent)
(struct rdata-ipv4 rdata (address) #:transparent)
(struct rdata-ipv6 rdata (address) #:transparent)
(struct rdata-hinfo rdata (cpu os) #:transparent)
(struct rdata-minfo rdata (rmailbx emailbx) #:transparent)
(struct rdata-mx rdata (preference exchange) #:transparent)
(struct rdata-soa rdata (mname rname serial refresh retry expire minimum) #:transparent)
(struct rdata-wks rdata (address protocol bitmap) #:transparent)
(struct rdata-srv rdata (priority weight port target) #:transparent)
(struct rdata-txt rdata (strings) #:transparent)
(struct rdata-raw rdata (body) #:transparent)
(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))
(: rdata-type-pred : RRType -> (RData -> Boolean))
(define ((rdata-type-pred t) d)
(eq? (rdata-type d) t))
@ -154,8 +212,12 @@
;; 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.
;; (: type->value : RRType -> Nonnegative-Integer)
;; (: value->type : Nonnegative-Integer -> RRType)
(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
@ -181,8 +243,9 @@
;; 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.
;; (: qtype->value : QueryType -> Nonnegative-Integer)
;; (: value->qtype : Nonnegative-Integer -> QueryType)
(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
@ -195,8 +258,9 @@
;; 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.
;; (: class->value : RRClass -> Nonnegative-Integer)
;; (: value->class : Nonnegative-Integer -> RRClass)
(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
@ -208,28 +272,48 @@
;; 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.
;; (: qclass->value : QueryClass -> Nonnegative-Integer)
;; (: value->qclass : Nonnegative-Integer -> QueryClass)
(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))
;; (: domain-root? : DomainName -> Boolean)
;; ListOf<Bytes> -> ListOf<Bytes>
;; Converts the 7-bit ASCII bytes in the argument to lower-case
;; equivalents. Used to normalize case for domain-name comparisons.
(: downcase-labels : (Listof Bytes) -> (Listof Bytes))
(define (downcase-labels labels)
(for/list ([label labels])
(define b (make-bytes (bytes-length label)))
(for ([i (bytes-length label)])
(define v (bytes-ref label i))
(bytes-set! b i (if (<= 65 v 90) (+ 32 v) v)))
b))
;; ListOf<Bytes> -> DomainName
;; Replacement constructor for domain structs. Automatically downcases
;; labels appropriately.
(: make-domain : (Listof Bytes) -> DomainName)
(define (make-domain labels)
(domain labels (downcase-labels labels)))
(: domain-root? : DomainName -> Boolean)
(define (domain-root? d)
(null? (domain-labels d)))
;; (: domain-parent : DomainName -> (Option DomainName))
(: 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)
(: empty-complete-answer : -> CompleteAnswer)
(define (empty-complete-answer)
(complete-answer (set) (set) (set)))
;; (: merge-answers : CompleteAnswer CompleteAnswer -> CompleteAnswer)
(: 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)
@ -237,7 +321,7 @@
(set-union u1 u2)
(set-union d1 d2)))
;; (: extract-addresses : DomainName (Option CompleteAnswer) -> (Setof IPv4))
(: extract-addresses : DomainName (Option CompleteAnswer) -> (Setof IPv4))
(define (extract-addresses name ans)
(match ans
[#f ;; name-error/NXDOMAIN, so definitely no addresses.
@ -245,12 +329,12 @@
[(complete-answer ns us ds)
(define rrs (set->list (set-union ns us ds)))
(let loop ((names (list name))
(ips (set))
(seen (set)))
(ips ((inst set IPv4)))
(seen ((inst set DomainName))))
(if (null? names)
ips
(let* ((name (car names))
(records (filter (lambda (rr) (equal? name (rr-name rr))) rrs))
(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)
@ -264,10 +348,10 @@
;; #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)
(: question-cyclic? : Question -> Boolean)
(define (question-cyclic? q)
(match-define (question name type class parent) q)
(let search ((ancestor parent))
(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
@ -279,10 +363,10 @@
;; 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)
(: question-too-glueless? : Question -> Boolean)
(define (question-too-glueless? q)
(define count
(let search ((q q) (acc 0))
(let: search : Integer ((q : Question q) (acc : Integer 0))
(match-define (question _ _ _ parent) q)
(cond
[(ns-subq? parent) (search (subquestion-parent parent) (+ acc 1))]
@ -298,7 +382,7 @@
;; Question -> Boolean
;; #t iff this question is being asked in the context of some
;; excessively glueless subquestion.
;; (: question-restarted? : Question -> Boolean)
(: question-restarted? : Question -> Boolean)
(define (question-restarted? q)
(match-define (question name type class parent) q)
(let search ((ancestor parent))
@ -310,19 +394,19 @@
;; 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)
(: restart-question : Question -> Question)
(define (restart-question q)
(struct-copy question q [context 'restart]))
(struct-copy question-repr q [context 'restart]))
;; DomainName Question -> Question
;; Produces a new question with CNAME context.
;; (: cname-question : DomainName Question -> Question)
(: 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)
(: ns-question : DomainName Question -> Question)
(define (ns-question name q)
(question name 'a 'in (ns-subq q))) ;; TODO: 'aaaa ?

View File

@ -1,4 +1,4 @@
#lang racket/base
#lang typed/racket/base
;; DNS wire-protocol codec.
;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@ -19,9 +19,17 @@
;;; along with marketplace-dns. If not, see
;;; <http://www.gnu.org/licenses/>.
(provide value->query-opcode query-opcode->value
(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
@ -42,8 +50,9 @@
;; 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.
;; (: value->query-opcode : Nonnegative-Integer -> Opcode)
;; (: query-opcode->value : Opcode -> Nonnegative-Integer)
(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
@ -54,8 +63,11 @@
;; 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.
;; (: value->query-response-code : Nonnegative-Integer -> ResponseCode)
;; (: query-response-code->value : ResponseCode -> Nonnegative-Integer)
(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)
@ -71,24 +83,25 @@
;;
;; Interpreted as either a DNS request or reply, depending on the
;; Direction.
(struct dns-message (id
direction
opcode
authoritative
truncated
recursion-desired
recursion-available
response-code
questions
answers
authorities
additional)
#:transparent)
;; (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))
(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:
@ -102,7 +115,7 @@
;; 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))
(: loop : Integer (Listof Type) BitString -> (Values (Option (Listof Type)) BitString))
(define (loop count acc input)
(cond
((positive? count) (bit-string-case input
@ -145,7 +158,7 @@
(else
(kf))))
((_ #f vs Type option ...)
(let loop ((vs vs))
(let: loop : BitString ((vs : (Listof Type) vs))
(cond
((pair? vs) (bit-string ((car vs) :: option ...)
((loop (cdr vs)) :: binary)))
@ -189,7 +202,7 @@
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; </rfc1035>
;; (: packet->dns-message : BitString -> DNSMessage)
(: 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)
@ -219,7 +232,7 @@
(value->query-response-code rcode)
q-section a-section auth-section additional-section))))
;; (: dns-message->packet : DNSMessage -> Bytes)
(: dns-message->packet : DNSMessage -> Bytes)
;; Render a Racket structured DNS message using the DNS binary encoding.
(define (dns-message->packet m)
(bit-string->bytes
@ -275,14 +288,14 @@
((_ #f val)
(encode-domain-name val))))
;; (: encode-domain-name : DomainName -> BitString)
(: 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))
(: 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
@ -324,7 +337,7 @@
((_ #f val)
(t:pascal-string #f val "Character-string" 256))
((_ #f val string-kind length-limit)
(let ([s val])
(let: ([s : Bytes val])
(let ((len (bytes-length s)))
(when (>= len length-limit)
(error 't:pascal-string "~s too long: ~v" string-kind s))
@ -364,10 +377,10 @@
#f)
tail))))
((_ #f val)
(let ([q val])
(bit-string ((question-name q) :: (t:domain-name))
((qtype->value (question-type q)) :: bits 16)
((qclass->value (question-class q)) :: bits 16))))))
(let: ([q : Question val])
(bit-string ((question-repr-name q) :: (t:domain-name))
((qtype->value (question-repr-type q)) :: bits 16)
((qclass->value (question-repr-class q)) :: bits 16))))))
;; <rfc1035>
;; All RRs have the same top level format shown below:
@ -416,7 +429,7 @@
tail)))
(else (kf)))))
((_ #f val)
(let ([rr 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)
@ -425,7 +438,7 @@
((quotient (bit-string-length encoded-rdata) 8) :: bits 16)
(encoded-rdata :: binary)))))))
;; (: decode-rdata : BitString RRType BitString -> RData)
(: 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)
@ -474,7 +487,7 @@
(rdata-srv type priority weight port target))))
(else (rdata-raw type (bit-string->bytes rdata)))))
;; (: encode-rdata : RData -> BitString)
(: encode-rdata : RData -> BitString)
;; Encode RData according to its RRType.
(define (encode-rdata rdata)
(match rdata
@ -506,5 +519,5 @@
[(rdata-raw _ bs) bs]))
;; UInt32
;; (: max-ttl : Nonnegative-Integer)
(: max-ttl : Nonnegative-Integer)
(define max-ttl #xffffffff)

View File

@ -1,4 +1,4 @@
#lang racket/base
#lang typed/racket/base
;; DNS server using os-big-bang.rkt and os-udp.rkt.
;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@ -28,9 +28,9 @@
(require "codec.rkt")
(require "zonedb.rkt")
(require "resolver.rkt")
(require syndicate/ground)
(require syndicate/actor)
(require syndicate/drivers/udp)
(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
@ -46,7 +46,7 @@
;; determines subzones based on the RRs it is configured with at
;; startup.
;; (: start-server : Nonnegative-Integer RR (Listof RR) -> Void)
(: 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.
@ -58,24 +58,26 @@
(display ";; Ready.\n")
(run-ground (spawn-udp-driver)
(dataspace (dns-spy)
(dns-read-driver local-addr)
(dns-write-driver local-addr)
(forever
(on (message ($ p (bad-dns-packet _ _ _ _)))
(log-error (pretty-format p)))
(on (message ($ r (dns-request _ _ _)))
(let ((reply (handle-request soa-rr zone r)))
(when reply (send! reply))))))))
(ground-vm: ((inst udp-driver Void))
((inst generic-spy Void) 'UDP)
(spawn-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))
(subscriber: Void (bad-dns-packet-pattern (wild) (wild) (wild) (wild))
(on-message [p (begin (log-error (pretty-format p)) '())]))
(subscriber: Void (dns-request-pattern (wild) (wild) (wild))
(on-message [(? dns-request? r)
(let ((reply (handle-request soa-rr zone r)))
(when reply (send-message reply)))])))))
;; (define-type ReplyMaker (DomainName Boolean (Setof RR) (Setof RR) (Setof RR) -> DNSMessage))
(define-type ReplyMaker (DomainName Boolean (Setof RR) (Setof RR) (Setof RR) -> DNSMessage))
;; (: handle-request : RR CompiledZone DNSRequest -> (Option DNSReply))
(: 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)
(: make-reply : ReplyMaker)
(define (make-reply name send-name-error? answers authorities additional)
(dns-message (dns-message-id request-message)
'response
@ -90,7 +92,7 @@
(rr-set->list authorities)
(rr-set->list additional)))
;; (: answer-question : Question ReplyMaker -> DNSMessage)
(: 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
@ -108,7 +110,7 @@
;; here. Reexamine the rules for doing so.
(match-define (question qname qtype qclass #f) q)
;; (: expand-cnames : (Listof DomainName) CompleteAnswer -> DNSMessage)
(: expand-cnames : (Listof DomainName) CompleteAnswer -> DNSMessage)
(define (expand-cnames worklist ans)
(match worklist
['()
@ -118,7 +120,7 @@
(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)
(: incorporate-answer : Answer (Listof DomainName) CompleteAnswer -> DNSMessage)
(define (incorporate-answer this-answer worklist ans)
(match this-answer
[(partial-answer new-info more-cnames)

View File

@ -1,41 +0,0 @@
#lang racket
(require net/url)
(define records
(map (lambda (r) (string-split r "\t"))
(string-split (port->string
(get-pure-port
(string->url "http://www.internic.net/domain/root.zone")))
"\n")))
(define (split-host-str s)
(map string->bytes/utf-8 (string-split s ".")))
(define (split-ip-str s)
(list->vector (map string->number (string-split s "."))))
(pretty-write
`(list
,@(filter values
(for/list [(r records)]
(match r
[(list "."
""
""
ttl-str
"IN"
"NS"
(regexp #px"^(.+)\\.$" (list _ host-str)))
`(NS/ttl '()
',(split-host-str host-str)
,(string->number ttl-str))]
[(list (regexp #px"^([^.]+\\.root-servers\\.net)\\.$" (list _ host-str))
ttl-str
"IN"
"A"
ip-str)
`(A/ttl ',(split-host-str host-str)
',(split-ip-str ip-str)
,(string->number ttl-str))]
[_ #f])))))

View File

@ -1,4 +1,4 @@
#lang racket/base
#lang typed/racket/base
;; Macros for defining weak and extensible mappings between sets of values
;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>

View File

@ -1,4 +1,4 @@
#lang racket/base
#lang typed/racket/base
;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
;;;
@ -23,13 +23,17 @@
(require "api.rkt")
(require "codec.rkt")
(require "zonedb.rkt")
(require syndicate/actor)
(require syndicate/drivers/udp)
(require syndicate/drivers/timer)
(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))
(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
@ -123,18 +127,48 @@
(define first-timeout 3) ;; seconds
;; A NetworkRequest is a (network-request UdpAddress Question
;; DomainName NEListOf<DomainName> UniqueID) representing the
;; parameters used to start and process a network query.
(struct: network-request ([client-socket : UdpAddress]
[question : Question]
[zone-origin : DomainName]
[server-names : (Listof DomainName)]
[unique-id : Any])
#:transparent)
(define-type NetworkRequest network-request)
;; A NetworkReply is a (network-reply UniqueID Maybe<CompleteAnswer>)
;; representing the final result of a network query.
(struct network-reply (unique-id answer) #:transparent)
(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?)
;; (: next-timeout : Natural -> (Option Natural))
;; A NetworkQueryState is a (network-query-state NetworkRequest
;; Integer Map<DomainName,ListOf<UdpAddress>> ListOf<UdpAddress>
;; Maybe<DomainName> ListOf<DomainName>), representing an in-progress
;; DNS network query.
(struct: network-query-state ([request : NetworkRequest]
[timeout : (Option Natural)]
[known-addresses : (HashTable DomainName (Listof UdpAddress))]
[remaining-addresses : (Listof UdpAddress)]
[current-name : (Option DomainName)]
[remaining-names : (Listof DomainName)])
#:transparent)
(define-type NetworkQueryState network-query-state)
(: next-timeout : Natural -> (Option Natural))
(define (next-timeout timeout)
(cond
[(equal? timeout 3) 11]
[(equal? timeout 11) 45]
[else #f]))
;; (: make-dns-query-message : Question Nonnegative-Integer -> DNSMessage)
(: make-dns-query-message : Question Nonnegative-Integer -> DNSMessage)
(define (make-dns-query-message q query-id)
(dns-message query-id
'request
@ -149,9 +183,9 @@
'()
'()))
;; (define-type CheckedAnswer (U (Option CompleteAnswer) 'bad-answer 'lame-delegation))
(define-type CheckedAnswer (U (Option CompleteAnswer) 'bad-answer 'lame-delegation))
;; (: filter-dns-reply : Question DNSMessage DomainName -> CheckedAnswer)
(: 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
@ -166,24 +200,25 @@
(define (filter-dns-reply q message zone-origin)
(case (dns-message-response-code message)
[(no-error)
;; (: f : (Listof RR) -> (Setof RR))
(: f : (Listof RR) -> (Setof RR))
(define (f l)
(list->set (filter (lambda (claim-rr) (in-bailiwick? (rr-name claim-rr) zone-origin)) 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) (and (eqv? (rdata-type (rr-rdata rr)) 'ns)
(or (equal? (rr-name rr) zone-origin)
(not (in-bailiwick? (rr-name rr) 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) (equal? (rr-name rr) (question-name q))) answers))
(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-type q) (question-class q)))
(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?
@ -193,129 +228,171 @@
(f (dns-message-additional message))))]
[(name-error) #f]
[else
(log-info "Abnormal response-code ~v in response to questions ~v"
(dns-message-response-code message)
(dns-message-questions message))
(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)
(: 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)
(: 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 ->
;; Void))
(: network-query : (All (ParentState)
UdpAddress Question DomainName (Listof DomainName) Any ->
(Action ParentState)))
(define (network-query s q zone-origin server-names unique-id)
(spawn*
#:name (list 'network-query q)
(field [timeout first-timeout]
[known-addresses #hash()] ;; Hash DomainName (Listof UdpAddress)
[remaining-addresses '()] ;; Listof UdpAddress
[current-name #f] ;; Option DomainName
[remaining-names server-names]) ;; Listof DomainName
(name-process (list 'network-query q)
(spawn: #: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)))))
(define (on-answer ans server-ip)
(match ans
['bad-answer ;; can come from filter-dns-reply
(try-next-server)]
['lame-delegation ;; can come from filter-dns-reply
(log-info "Lame delegation received from ~v (at ~v) in bailiwick ~v in response to ~v"
(current-name)
server-ip
zone-origin
q)
(when (and (current-name) server-ip)
;; Actually remove the offending IP address so it's never tried again.
(known-addresses (hash-update (known-addresses)
(current-name)
(lambda (addrs) (remove server-ip addrs)))))
(try-next-server)]
[(and (or (? complete-answer?) #f) ans)
(send! (network-reply unique-id ans))]))
(: 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)
(let-fresh (subq-id)
(name-endpoint subq-id
(subscriber: NetworkQueryState (answered-question-pattern subq (wild))
(match-state w
(on-message
[(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))
(name-endpoint rpc-id
(subscriber: NetworkQueryState `(reply ,rpc-id ,(wild))
(match-state w
(on-message
[`(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))])))))])))
(define (try-next-server)
(if (not (timeout))
;; No more timeouts to try, so give up.
(on-answer (empty-complete-answer) #f)
(match (remaining-addresses)
['()
(match (remaining-names)
['()
;; 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.)
(timeout (next-timeout (timeout)))
(current-name #f)
(remaining-names server-names)
(try-next-server)]
[(cons next-name new-remaining-names)
(current-name next-name)
(remaining-names new-remaining-names)
(if (hash-has-key? (known-addresses) next-name)
(begin (remaining-addresses (hash-ref (known-addresses) (current-name)))
(try-next-server))
(let ((subq (ns-question next-name q)))
(react (on-start (send! subq))
(stop-when (message (answered-question subq $ans))
(define ips
(for/list [(a (extract-addresses next-name ans))]
(make-dns-address a)))
(known-addresses (hash-set (known-addresses) next-name ips))
(remaining-addresses ips)
(try-next-server)))))])]
[(cons current-ip new-remaining-ips)
(remaining-addresses new-remaining-ips)
(define rpc-id (gensym 'network-query/allocate-query-id))
(react (on-start (send! `(request ,rpc-id allocate-query-id)))
(stop-when (message `(reply ,rpc-id ,(? exact-nonnegative-integer? $id)))
(remaining-addresses new-remaining-ips)
(send-request id current-ip)))])))
(: 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)))]))
(define (send-request query-id server-ip)
(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 "Sending ~v ~v to ~v ~v with ~v seconds of timeout"
q query-id
zone-origin server-ip
(timeout))
;; NB: ANALYSIS: Previous implementation of this used a
;; quasi-join, where one endpoint deleted the other. Here the two
;; stop-when clauses do a similar job. Also, we can pull the
;; `release-query-id` send up to an on-stop clause.
(react (on-start
(send! (dns-request query s server-ip))
(send! (set-timer timeout-id (* (timeout) 1000) 'relative)))
(on-stop
(send! (list 'release-query-id query-id)))
(stop-when (message (timer-expired timeout-id _))
(log-debug "Timed out ~v ~v to ~v ~v after ~v seconds"
q query-id
zone-origin server-ip
(timeout))
(try-next-server))
(stop-when (message (dns-reply
(? (lambda (m) (= (dns-message-id m)
(dns-message-id query)))
$reply-message)
$source
s))
;; TODO: maybe receive only specifically from the queried IP address?
(log-debug "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))
(on-answer (filter-dns-reply q reply-message zone-origin) server-ip))))
(try-next-server)))
(define ((dns-message-id-matches? expected) m)
(= (dns-message-id m) expected))
(: 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
(name-endpoint timeout-id
(subscriber: NetworkQueryState (timer-expired-pattern timeout-id (wild))
(match-state w
(on-message
[(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))))]))))
(name-endpoint reply-wait-id
(subscriber: NetworkQueryState (dns-reply-pattern (wild) (wild) s)
(match-state w
(on-message
[(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)))))]))))))

531
proxy.rkt
View File

@ -1,4 +1,4 @@
#lang racket/base
#lang typed/racket/base
;; DNS proxy using os-big-bang.rkt and os-udp.rkt.
;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@ -28,10 +28,10 @@
(require "zonedb.rkt")
(require "network-query.rkt")
(require "resolver.rkt")
(require (except-in syndicate dataspace assert))
(require syndicate/actor)
(require syndicate/drivers/timer)
(require syndicate/drivers/udp)
(require marketplace/sugar-typed)
(require marketplace/support/spy)
(require marketplace/drivers/timer)
(require marketplace/drivers/udp)
(require "tk-dns.rkt")
(require racket/pretty)
@ -40,262 +40,343 @@
;; searches from. Performs recursive queries.
;; For discarding retransmitted requests that we're still working on.
(struct active-request (source id) #:transparent)
(struct: active-request ([source : UdpAddress] [id : Natural]) #:transparent)
(define-type ActiveRequest active-request)
;; (: start-proxy : Natural CompiledZone CompiledZone -> Void)
(: 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.")
(run-ground
(spawn-timer-driver)
(spawn-udp-driver)
(dataspace #:name 'dns-vm
(dns-spy)
(spawn #:name 'timer-relay:dns
(on (message (inbound ($ m (timer-expired _ _)))) (send! m))
(on (message ($ m (set-timer _ _ _))) (send! (outbound m))))
(query-id-allocator)
(dns-read-driver server-addr)
(dns-write-driver server-addr)
(dns-read-driver client-addr)
(dns-write-driver client-addr)
(packet-dispatcher server-addr)
(question-dispatcher zone roots-only client-addr)
(forever))))
(ground-vm:
((inst generic-spy Void) 'UDP)
((inst udp-driver Void))
((inst timer-driver Void))
(spawn-vm: : Void
#:debug-name 'dns-vm
(name-process 'dns-spy (spawn: #:parent : Void #:child : Void (dns-spy)))
((inst timer-relay Void) 'timer-relay:dns)
(name-process 'query-id-allocator (spawn: #:parent : Void #:child : (Setof Natural)
(query-id-allocator)))
(name-process 'server-dns-reader (spawn: #:parent : Void #:child : Void
(dns-read-driver server-addr)))
(name-process 'server-dns-writer (spawn: #:parent : Void #:child : Void
(dns-write-driver server-addr)))
(name-process 'client-dns-reader (spawn: #:parent : Void #:child : Void
(dns-read-driver client-addr)))
(name-process 'client-dns-writer (spawn: #:parent : Void #:child : Void
(dns-write-driver client-addr)))
(name-process 'packet-dispatcher (spawn: #:parent : Void
#:child : (Setof ActiveRequest)
(packet-dispatcher server-addr)))
(name-process 'question-dispatcher (spawn: #:parent : Void
#:child : CompiledZone
(question-dispatcher zone
roots-only
client-addr))))))
;; (: query-id-allocator : -> Void)
(: 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
(spawn #:name 'query-id-allocator
(field [allocated (set)])
(on (message `(request ,$reply-addr allocate-query-id))
(let recheck ()
(define n (random 65536))
(if (set-member? (allocated) n)
(recheck)
(begin (allocated (set-add (allocated) n))
(send! `(reply ,reply-addr ,n))))))
(on (message `(release-query-id ,(? exact-nonnegative-integer? $n)))
(allocated (set-remove (allocated) n)))))
(transition: ((inst set Natural)) : (Setof Natural) ;; all active query IDs
(subscriber: (Setof Natural) `(request ,(wild) allocate-query-id)
(match-state allocated
(on-message
[`(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)))))])))
(subscriber: (Setof Natural) `(release-query-id ,(wild))
(match-state allocated
(on-message
[`(release-query-id ,(? exact-nonnegative-integer? n))
(transition: (set-remove allocated n) : (Setof Natural))])))))
;; (: packet-dispatcher : UdpAddress -> Void)
(: packet-dispatcher : UdpAddress -> (Transition (Setof ActiveRequest)))
(define (packet-dispatcher s)
(spawn #:name 'packet-dispatcher
(field [old-active-requests (set)])
(on (message ($ p (bad-dns-packet _ _ _ _)))
(log-error "~a" (pretty-format p)))
(on (message ($ r (dns-request $m $source s)))
;; ^ We only listen for requests on our server socket
(define 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.
(when (not (set-member? (old-active-requests) req-id))
;; ^ ignore retransmitted duplicates
(old-active-requests (set-add (old-active-requests) req-id))
(packet-relay req-id r)))
(on (message ($ r (dns-reply $m s $sink)))
(define req-id (active-request sink (dns-message-id m)))
(old-active-requests (set-remove (old-active-requests) req-id)))))
(transition: ((inst set ActiveRequest)) : (Setof ActiveRequest)
(subscriber: (Setof ActiveRequest) (bad-dns-packet-pattern (wild) (wild) (wild) (wild))
(on-message [p (begin (log-error (pretty-format p)) '())]))
(subscriber: (Setof ActiveRequest) (dns-request-pattern (wild) (wild) s)
(match-state old-active-requests
(on-message
[(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)
(name-process (list 'packet-relay req-id)
(spawn: #:parent : (Setof ActiveRequest)
#:child : Void (packet-relay req-id r))))))])))
(subscriber: (Setof ActiveRequest) (dns-reply-pattern (wild) s (wild))
(match-state old-active-requests
(on-message
[(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 -> Void)
(: 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)
(: 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))]))
[#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)
'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)
(let-fresh (wait-id)
(name-endpoint wait-id
(subscriber: Void (answered-question-pattern original-question (wild))
(on-message
[(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))))])))))]))
(spawn*
#:name (list 'packet-relay req-id)
;; TODO: pay attention to recursion-desired flag
(match (dns-message-questions request-message)
['()
;; No questions!
(send! (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)))
(send! original-question)
(react (stop-when (message (answered-question original-question $answer))
(log-debug "Final answer to ~v with query id ~v is ~v"
original-question
(dns-message-id request-message)
answer)
(send! (answer->reply original-question answer))))])))
;; (: glueless-question-handler : CompiledZone Question UdpAddress -> Void)
(: 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))
(spawn #:name (list 'glueless-question-handler q)
(stop-when (message (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.
(send! (answered-question q ans)))
(on-start (question-handler roots-only-zone restarted-question client-sock))))
(transition/no-state
(let-fresh (relay)
(name-endpoint relay
(subscriber: Void (answered-question-pattern restarted-question (wild))
(on-message
[(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)))]))))
(name-process (list 'glueless-question-handler-inner restarted-question)
(spawn: #:parent : Void
#:child : QHState
(question-handler roots-only-zone restarted-question client-sock)))))
;; (: question-dispatcher : CompiledZone CompiledZone UdpAddress -> Void)
(: 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))
(spawn #:name 'question-dispatcher
(field [zone cleaned-seed-zone])
(on-start (set-timers! initial-timers))
(sequence-actions (transition-and-set-timers cleaned-seed-zone initial-timers)
;; TODO: consider deduping questions here too?
(subscriber: CompiledZone `(debug-dump)
(match-state zone
(on-message
[`(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))])))
(subscriber: CompiledZone (question-pattern (wild) (wild) (wild) (wild))
(match-state zone
(on-message
[(? 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))
(name-process (list 'glueless-question-handler-outer q)
(spawn: #:parent : CompiledZone
#:child : Void
(glueless-question-handler roots-only q client-sock)))]
[else
(name-process (list 'question-handler q)
(spawn: #:parent : CompiledZone
#:child : QHState
(question-handler zone q client-sock)))]))])))
(subscriber: CompiledZone (network-reply-pattern (wild) (wild))
(match-state zone
(on-message
[(network-reply _ answer)
(let-values (((new-zone timers) (incorporate-complete-answer answer zone #t)))
(transition-and-set-timers new-zone timers))])))
(subscriber: CompiledZone (timer-expired-pattern (list 'check-dns-expiry (wild)) (wild))
(match-state zone
(on-message
[(timer-expired (list 'check-dns-expiry (? domain? name)) (? number? now-msec))
(transition: (zone-expire-name zone name (/ now-msec 1000.0)) : CompiledZone)])))))
(define (set-timers! timers)
(for/list ([timerspec timers])
(match-define (cons name ttl) timerspec)
(send! (set-timer (list 'check-dns-expiry name) (* ttl 1000) 'relative))))
(struct: question-state ([zone : CompiledZone]
[q : Question]
[client-sock : UdpAddress]
[nameservers-tried : (Setof DomainName)]
[retry-count : Natural]) #:transparent)
(define-type QuestionState question-state)
;; TODO: consider deduping questions here too?
(struct: expanding-cnames ([q : Question]
[accumulator : CompleteAnswer]
[remaining-count : Integer]) #:transparent)
(define-type ExpandingCNAMEs expanding-cnames)
(on (message `(debug-dump))
(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)
)
(define-type QHState (U QuestionState ExpandingCNAMEs))
(on (message ($ q (question _ _ _ _)))
(cond
[(question-cyclic? q)
(log-warning (format "Cyclic question ~v" q))
(send! (answered-question q (empty-complete-answer)))]
[(question-too-glueless? q)
(log-warning (format "Overly-glueless question ~v" q))
(glueless-question-handler roots-only q client-sock)]
[else
(question-handler (zone) q client-sock)]))
(: 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)))
(on (message (network-reply _ $answer))
(define-values (new-zone timers) (incorporate-complete-answer answer (zone) #t))
(zone new-zone)
(set-timers! timers))
(: send-empty-reply : QHState Question -> (Transition QHState))
(define (send-empty-reply w q)
(transition w (send-message (answered-question q (empty-complete-answer)))))
(on (message (timer-expired (list 'check-dns-expiry (? domain? $name))
(? number? $now-msec)))
(zone (zone-expire-name (zone) name (/ now-msec 1000.0))))))
;; (: send-empty-reply! : Question -> Void)
(define (send-empty-reply! q)
(send! (answered-question q (empty-complete-answer))))
;; (: question-handler : CompiledZone Question UdpAddress -> Void)
(define (question-handler zone0 q client-sock)
(spawn*
#:name (list 'question-handler q)
(let retry-question ((zone zone0)
(nameservers-tried (set))
(retry-count 0))
(if (= retry-count 20) ;; TODO: is this a sensible limit?
;; Too many retries, i.e. too many referrals.
(begin (log-error (format "Too many retries: ~v" q))
(send-empty-reply! q))
;; Credit remaining. Try once more (perhaps for the first time, in fact).
(let ((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! 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))))
(network-query client-sock
q
zone-origin
(map rr-rdata-domain-name (set->list nameserver-rrs))
referral-id)
(react (stop-when
(message (network-reply referral-id $ans))
(cond [(not ans) ;; name-error/NXDOMAIN
(send! (answered-question q #f))]
[else
(define-values (new-zone _ignored-timers)
(incorporate-complete-answer ans zone #f))
(when (log-level? (current-logger) 'debug)
(log-debug "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 "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
(for/set ([rr nameserver-rrs]) (rr-rdata-domain-name rr)))
(retry-question new-zone
(set-union nameservers-tried nameserver-names)
(+ retry-count 1))])))]
[(? complete-answer? ans)
(send! (answered-question q ans))]
[(partial-answer base cnames)
;; TODO: record chains of CNAMEs to avoid pathologically-long chains
(react (field [acc base]
[remaining (length cnames)])
(on-start (for [(cname cnames)]
(define cname-q (cname-question cname q))
(react (on-start (send! cname-q))
(stop-when (message (answered-question cname-q $ans))
(acc (if ans (merge-answers (acc) ans) (acc)))
(remaining (- (remaining) 1))))))
(stop-when (rising-edge (zero? (remaining)))
(send! (answered-question q (acc)))))]))))))
(: 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)
(name-endpoint referral-id
(subscriber: QHState (network-reply-pattern referral-id (wild))
(match-state w
(on-message
[(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)
(let-fresh (subscription-id)
(name-endpoint subscription-id
(subscriber: QHState (answered-question-pattern cname-q (wild))
(match-state (expanding-cnames q acc remaining)
(on-message
[(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)

View File

@ -1,4 +1,4 @@
#lang racket/base
#lang typed/racket/base
;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
;;;
@ -27,8 +27,12 @@
(require "codec.rkt")
(require "zonedb.rkt")
(provide (struct-out partial-answer)
(provide PartialAnswer
Referral
Answer
(struct-out partial-answer)
(struct-out referral)
resolve-from-zone)
;; Rules:
@ -63,22 +67,27 @@
;; -- a CompleteAnswer (a complete answer ready to send),
;; -- #f (the domain name does not exist in the CompiledZone given),
;; -- a Referral (a referral to some other nameserver).
(define-type Answer (U CompleteAnswer PartialAnswer Referral #f))
;; A PartialAnswer is a (partial-answer CompleteAnswer ListOf<DomainName>)
;; A collection of relevant RRs together with some CNAMEs that need expanding.
(struct partial-answer (base cnames) #:transparent)
(struct: partial-answer ([base : CompleteAnswer] [cnames : (Listof DomainName)]) #:transparent)
(define-type PartialAnswer partial-answer)
;; A Referral is a (referral DomainName Set<RR> Set<RR>)
(struct referral (zone-origin nameserver-rrs additional) #:transparent)
(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)
(: 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 (or (zone-ref zone name) (set)))
(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))
@ -96,9 +105,9 @@
[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))
(: closest-nameservers : DomainName CompiledZone -> (Setof RR))
(define (closest-nameservers name zone)
(let search ((name name))
(let: search ((name : (Option DomainName) name))
(cond
((not name)
;; We've walked up the tree past the root. Give up.
@ -115,44 +124,45 @@
;; Remove a label and keep looking.
(search (domain-parent name))))))
;; (: closest-untried-nameservers : Question CompiledZone (Setof DomainName) -> (Setof RR))
(: 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-name q))
(define name (question-repr-name q))
(define ns-rrset (closest-nameservers name zone))
(list->set
(for/list ([rr ns-rrset] #:when (not (set-member? nameservers-tried (rr-rdata-domain-name rr))))
rr)))
(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))
(: 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-name q) (rr-name start-of-authority))
(in-bailiwick? (question-repr-name q) (rr-name start-of-authority))
;; ^ for this in particular
(not (zone-includes-name? zone (question-name q))))
(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))
(: 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 section)
(foldl (lambda: ([name : DomainName] [section : (Setof RR)])
(set-union section
(set-filter (lambda (rr)
(set-filter (lambda: ([rr : RR])
(and (memv (rdata-type (rr-rdata rr)) '(a aaaa))
(eqv? (rr-class rr) 'in)))
(or (zone-ref zone name) (set)))))
(set)
(or (zone-ref zone name) ((inst set RR))))))
((inst set RR))
names))
;; (: resolve-from-zone : Question CompiledZone (Option RR) (Setof DomainName) -> Answer)
(: 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)))

View File

@ -156,30 +156,30 @@
'no-error
(list (question (domain '(#"google" #"com")) '* 'in #f))
(list
(rr (domain '(#"google" #"com")) 'in 3119 (rdata-txt 'txt '(#"v=spf1 include:_netblocks.google.com ip4:216.73.93.70/31 ip4:216.73.93.72/31 ~all")))
(rr (domain '(#"google" #"com")) 'in 285 (rdata-ipv4 'a '#(74 125 226 146)))
(rr (domain '(#"google" #"com")) 'in 285 (rdata-ipv4 'a '#(74 125 226 148)))
(rr (domain '(#"google" #"com")) 'in 285 (rdata-ipv4 'a '#(74 125 226 145)))
(rr (domain '(#"google" #"com")) 'in 285 (rdata-ipv4 'a '#(74 125 226 147)))
(rr (domain '(#"google" #"com")) 'in 285 (rdata-ipv4 'a '#(74 125 226 144)))
(rr (domain '(#"google" #"com")) 'in 238877 (rdata-domain 'ns (domain '(#"ns2" #"google" #"com"))))
(rr (domain '(#"google" #"com")) 'in 238877 (rdata-domain 'ns (domain '(#"ns3" #"google" #"com"))))
(rr (domain '(#"google" #"com")) 'in 238877 (rdata-domain 'ns (domain '(#"ns1" #"google" #"com"))))
(rr (domain '(#"google" #"com")) 'in 238877 (rdata-domain 'ns (domain '(#"ns4" #"google" #"com"))))
(rr (domain '(#"google" #"com")) 'in 42 (rdata-mx 'mx 20 (domain '(#"alt1" #"aspmx" #"l" #"google" #"com"))))
(rr (domain '(#"google" #"com")) 'in 42 (rdata-mx 'mx 30 (domain '(#"alt2" #"aspmx" #"l" #"google" #"com"))))
(rr (domain '(#"google" #"com")) 'in 42 (rdata-mx 'mx 10 (domain '(#"aspmx" #"l" #"google" #"com"))))
(rr (domain '(#"google" #"com")) 'in 42 (rdata-mx 'mx 40 (domain '(#"alt3" #"aspmx" #"l" #"google" #"com"))))
(rr (domain '(#"google" #"com")) 'in 42 (rdata-mx 'mx 50 (domain '(#"alt4" #"aspmx" #"l" #"google" #"com")))))
(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")) 'in 238287 (rdata-ipv4 'a '#(216 239 36 10)))
(rr (domain '(#"ns1" #"google" #"com")) 'in 238287 (rdata-ipv4 'a '#(216 239 32 10)))
(rr (domain '(#"ns4" #"google" #"com")) 'in 238287 (rdata-ipv4 'a '#(216 239 38 10)))
(rr (domain '(#"ns2" #"google" #"com")) 'in 238287 (rdata-ipv4 'a '#(216 239 34 10)))
(rr (domain '(#"alt2" #"aspmx" #"l" #"google" #"com")) 'in 240 (rdata-ipv4 'a '#(74 125 39 27)))
(rr (domain '(#"aspmx" #"l" #"google" #"com")) 'in 246 (rdata-ipv4 'a '#(74 125 115 27)))
(rr (domain '(#"alt1" #"aspmx" #"l" #"google" #"com")) 'in 33 (rdata-ipv4 'a '#(74 125 77 27))))))
(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
@ -271,7 +271,7 @@
'no-error
(list (question (domain '(#"google" #"com")) 'aaaa 'in #f))
'()
(list (rr (domain '(#"google" #"com")) 'in 594 (rdata-soa 'soa (domain '(#"ns1" #"google" #"com")) (domain '(#"dns-admin" #"google" #"com")) 1454883 7200 1800 1209600 300)))
(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:
@ -318,7 +318,7 @@
'no-recursion-available
'no-error
(list (question (domain '(#"www" #"google" #"com")) 'aaaa 'in #f))
(list (rr (domain '(#"www" #"google" #"com")) 'in 604800 (rdata-domain 'cname (domain '(#"www" #"l" #"google" #"com")))))
(list (rr (domain '(#"www" #"google" #"com")) 'cname 'in 604800 (domain '(#"www" #"l" #"google" #"com"))))
'()
'()))
@ -348,8 +348,8 @@
'no-recursion-available
'no-error
(list (question (domain '(#"ipv6" #"google" #"com")) 'aaaa 'in #f))
(list (rr (domain '(#"ipv6" #"google" #"com")) 'in 604800 (rdata-domain 'cname (domain '(#"ipv6" #"l" #"google" #"com"))))
(rr (domain '(#"ipv6" #"l" #"google" #"com")) 'in 300 (rdata-ipv6 'aaaa '#(32 1 72 96 128 15 0 0 0 0 0 0 0 0 0 104))))
(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)))
'()
'()))
@ -440,24 +440,24 @@
'recursion-available
'no-error
(list (question X 'srv 'in #f))
(list (rr X 'in 882 (rdata-srv 'srv 20 0 5269 (domain '(#"xmpp-server4" #"l" #"google" #"com"))))
(rr X 'in 882 (rdata-srv 'srv 5 0 5269 (domain '(#"xmpp-server" #"l" #"google" #"com"))))
(rr X 'in 882 (rdata-srv 'srv 20 0 5269 (domain '(#"xmpp-server1" #"l" #"google" #"com"))))
(rr X 'in 882 (rdata-srv 'srv 20 0 5269 (domain '(#"xmpp-server2" #"l" #"google" #"com"))))
(rr X 'in 882 (rdata-srv 'srv 20 0 5269 (domain '(#"xmpp-server3" #"l" #"google" #"com")))))
(list (rr (domain '(#"google" #"com")) 'in 87076 (rdata-domain 'ns (domain '(#"ns3" #"google" #"com"))))
(rr (domain '(#"google" #"com")) 'in 87076 (rdata-domain 'ns (domain '(#"ns4" #"google" #"com"))))
(rr (domain '(#"google" #"com")) 'in 87076 (rdata-domain 'ns (domain '(#"ns2" #"google" #"com"))))
(rr (domain '(#"google" #"com")) 'in 87076 (rdata-domain 'ns (domain '(#"ns1" #"google" #"com")))))
(list (rr (domain '(#"xmpp-server" #"l" #"google" #"com")) 'in 282 (rdata-ipv4 'a '#(74 125 153 125)))
(rr (domain '(#"xmpp-server1" #"l" #"google" #"com")) 'in 1782 (rdata-ipv4 'a '#(74 125 53 125)))
(rr (domain '(#"xmpp-server2" #"l" #"google" #"com")) 'in 1782 (rdata-ipv4 'a '#(74 125 47 125)))
(rr (domain '(#"xmpp-server3" #"l" #"google" #"com")) 'in 1782 (rdata-ipv4 'a '#(74 125 45 125)))
(rr (domain '(#"xmpp-server4" #"l" #"google" #"com")) 'in 1782 (rdata-ipv4 'a '#(74 125 45 125)))
(rr (domain '(#"ns1" #"google" #"com")) 'in 2737 (rdata-ipv4 'a '#(216 239 32 10)))
(rr (domain '(#"ns2" #"google" #"com")) 'in 2737 (rdata-ipv4 'a '#(216 239 34 10)))
(rr (domain '(#"ns3" #"google" #"com")) 'in 2737 (rdata-ipv4 'a '#(216 239 36 10)))
(rr (domain '(#"ns4" #"google" #"com")) 'in 2737 (rdata-ipv4 'a '#(216 239 38 10)))))))
(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.
@ -473,9 +473,9 @@
(let ()
(define rrs
(list (rr (domain '(#"a")) 'in 30 (rdata-domain 'cname (domain '(#"b"))))
(rr (domain '(#"b")) 'in 30 (rdata-domain 'cname (domain '(#"c"))))
(rr (domain '(#"c")) 'in 30 (rdata-domain 'cname (domain '(#"d"))))))
(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))

View File

@ -1,4 +1,4 @@
#lang racket/base
#lang typed/racket/base
;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
;;;
@ -33,16 +33,16 @@
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)
(: 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 ip)))
(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))
@ -62,38 +62,38 @@
(A '(#"subns" #"example") '#(127 0 0 2))))
(define test-roots
(list (NS/ttl '() '(#"a" #"root-servers" #"net") 518400)
(NS/ttl '() '(#"b" #"root-servers" #"net") 518400)
(NS/ttl '() '(#"c" #"root-servers" #"net") 518400)
(NS/ttl '() '(#"d" #"root-servers" #"net") 518400)
(NS/ttl '() '(#"e" #"root-servers" #"net") 518400)
(NS/ttl '() '(#"f" #"root-servers" #"net") 518400)
(NS/ttl '() '(#"g" #"root-servers" #"net") 518400)
(NS/ttl '() '(#"h" #"root-servers" #"net") 518400)
(NS/ttl '() '(#"i" #"root-servers" #"net") 518400)
(NS/ttl '() '(#"j" #"root-servers" #"net") 518400)
(NS/ttl '() '(#"k" #"root-servers" #"net") 518400)
(NS/ttl '() '(#"l" #"root-servers" #"net") 518400)
(NS/ttl '() '(#"m" #"root-servers" #"net") 518400)
(A/ttl '(#"a" #"root-servers" #"net") '#(198 41 0 4) 518400)
(A/ttl '(#"b" #"root-servers" #"net") '#(192 228 79 201) 518400)
(A/ttl '(#"c" #"root-servers" #"net") '#(192 33 4 12) 518400)
(A/ttl '(#"d" #"root-servers" #"net") '#(199 7 91 13) 518400)
(A/ttl '(#"e" #"root-servers" #"net") '#(192 203 230 10) 518400)
(A/ttl '(#"f" #"root-servers" #"net") '#(192 5 5 241) 518400)
(A/ttl '(#"g" #"root-servers" #"net") '#(192 112 36 4) 518400)
(A/ttl '(#"h" #"root-servers" #"net") '#(198 97 190 53) 518400)
(A/ttl '(#"i" #"root-servers" #"net") '#(192 36 148 17) 518400)
(A/ttl '(#"j" #"root-servers" #"net") '#(192 58 128 30) 518400)
(A/ttl '(#"k" #"root-servers" #"net") '#(193 0 14 129) 518400)
(A/ttl '(#"l" #"root-servers" #"net") '#(199 7 83 42) 518400)
(A/ttl '(#"m" #"root-servers" #"net") '#(202 12 27 33) 518400)))
(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)
(: test-port-number : -> Nonnegative-Integer)
(define (test-port-number)
(define p
(string->number

View File

@ -1,4 +1,4 @@
#lang racket/base
#lang typed/racket/base
;; DNS drivers using marketplace.
;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@ -22,55 +22,106 @@
(require racket/set)
(require racket/match)
(require "codec.rkt")
(require syndicate/actor)
(require syndicate/protocol/standard-relay)
(require syndicate/drivers/udp)
(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?
(provide (struct-out bad-dns-packet)
(struct-out dns-request)
(struct-out dns-reply)
dns-read-driver
dns-write-driver
dns-spy)
(struct bad-dns-packet (detail source sink reason) #:transparent)
(struct dns-request (message source sink) #:transparent)
(struct dns-reply (message source sink) #:transparent)
(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)
(spawn
#:name (list 'dns-read-driver s)
(on (message (inbound (udp-packet $source s #"")))
(log-info "Debug dump packet received")
(send! `(debug-dump)))
(on (message (inbound (udp-packet $source s $body)))
(when (positive? (bytes-length body))
(send!
(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)))))))))
(define (translate message s sink)
(with-handlers ((exn:fail? (lambda (e) (bad-dns-packet message s sink 'unencodable))))
(outbound (udp-packet s sink (dns-message->packet message)))))
(transition: (void) : Void
(at-meta-level: Void
(subscriber: Void (udp-packet-pattern (wild) s (wild))
(on-message
[(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)
(spawn #:name (list 'dns-write-driver s)
(on (message (dns-request $message s $sink))
(send! (translate message s sink)))
(on (message (dns-reply $message s $sink))
(send! (translate message s sink)))))
(: 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: Void
(send-message (udp-packet s sink (dns-message->packet message))))))
(transition: (void) : Void
(subscriber: Void (dns-request-pattern (wild) s (wild))
(on-message
[(dns-request message (== s) sink) (translate message sink)]))
(subscriber: Void (dns-reply-pattern (wild) s (wild))
(on-message
[(dns-reply message (== s) sink) (translate message sink)]))))
(: dns-spy : -> (Transition Void))
(define (dns-spy)
(spawn #:name 'dns-spy
(on (message (dns-request $message $source $sink))
(log-info (format "DNS: ~v asks ~v ~v~n : ~v"
source sink (dns-message-id message)
(dns-message-questions message))))
(on (message (dns-reply $message $source $sink))
(log-info (format "DNS: ~v answers ~v~n : ~v"
source sink
message)))))
(transition: (void) : Void
(observe-publishers: Void (wild)
(on-message
[(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))]))))

View File

@ -1,4 +1,4 @@
#lang racket/base
#lang typed/racket/base
;; Noddy representation of a zone, and various zone and RRSet utilities.
;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@ -25,8 +25,10 @@
(require "api.rkt")
(require "codec.rkt")
(require bitsyntax)
(require (rename-in marketplace/tr-struct-copy [tr-struct-copy struct-copy])) ;; PR13149
(provide zone-ref
(provide CompiledZone
zone-ref
zone-includes-name?
incorporate-complete-answer
zone-expire-name
@ -43,47 +45,52 @@
zone->bit-string
bit-string->zone)
;; (define-type RelativeSeconds Real)
;; (define-type AbsoluteSeconds Real)
;; (define-predicate absolute-seconds? AbsoluteSeconds)
(define absolute-seconds? real?)
(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) #:transparent)
(struct: infinite-lifetime ([ttl : RelativeSeconds]) #:transparent)
(define-type InfiniteLifetime infinite-lifetime)
;; An Expiry is either an AbsoluteSeconds or an InfiniteLifetime.
(define-type Expiry (U AbsoluteSeconds InfiniteLifetime))
;; A CompiledZone is a Hash<DomainName,Hash<RR,(or AbsoluteSeconds
;; InfiniteLifetime)>>, representing a collection of DNS RRSets
;; indexed by DomainName. Each RR in an RRSet either has an expiry
;; time associated with it or has an InfiniteLifetime associated with
;; it, in which case it should not expire.
(define-type CompiledZone (HashTable DomainName (HashTable RR Expiry)))
;; A Timers is a SetOf<(cons DomainName RelativeSeconds)>,
;; representing a collection of timeouts that should be set against
;; names to to see if their associated RRs have expired.
(define-type Timer (Pairof DomainName RelativeSeconds))
(define-type Timers (Setof Timer))
;; TODO: maybe store domain names big-end first? It'd make bailiwick
;; and subzone checks into prefix rather than suffix checks. It makes
;; domain names into paths through the DNS DB tree.
;; (: current-inexact-seconds : -> AbsoluteSeconds)
(: current-inexact-seconds : -> AbsoluteSeconds)
(define (current-inexact-seconds)
(/ (current-inexact-milliseconds) 1000.0))
;; (: still-valid? : Expiry AbsoluteSeconds -> Boolean)
(: still-valid? : Expiry AbsoluteSeconds -> Boolean)
(define (still-valid? expiry now)
(or (infinite-lifetime? expiry)
(>= expiry now)))
;; (: zone-ref : CompiledZone DomainName -> (Option (Setof RR)))
(: 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 (set)]) ([resource (in-hash-keys expirymap)])
(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)
@ -91,14 +98,14 @@
(- expiry now))))
(set-add acc
(struct-copy rr resource
[ttl (exact-floor new-ttl)])))
[ttl (cast (exact-floor new-ttl) Nonnegative-Integer)])))
acc)))))
;; (: zone-includes-name? : CompiledZone DomainName -> Boolean)
(: zone-includes-name? : CompiledZone DomainName -> Boolean)
(define (zone-includes-name? db name)
(hash-has-key? db name))
;; (: incorporate-rr : (Option AbsoluteSeconds) -> (RR CompiledZone -> CompiledZone))
(: 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
@ -122,7 +129,7 @@
(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 () #hash())))
(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
@ -132,15 +139,15 @@
[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))
(: 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 (set)])
(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
@ -149,14 +156,15 @@
(values ((incorporate-rr now) rr db)
(set-add timers (cons (rr-name rr) (rr-ttl rr))))))]))
;; (: zone-expire-name : CompiledZone DomainName AbsoluteSeconds -> CompiledZone)
(: 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 #hash())
(define empty-expirymap (ann #hash() (HashTable RR Expiry)))
(define old-expirymap (hash-ref db name (lambda () empty-expirymap)))
(define new-expirymap
(for/fold ([acc empty-expirymap]) ([resource (in-hash-keys old-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)
@ -165,33 +173,33 @@
(hash-remove db name)
(hash-set db name new-expirymap)))
;; (: zone-expire : CompiledZone -> (Values CompiledZone Timers))
(: 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 zone] [timers (set)])
([name (in-hash-keys zone)])
(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) (cons name (- e now-seconds)))
(map (lambda: ([e : AbsoluteSeconds]) (cons name (- e now-seconds)))
(filter absolute-seconds? (hash-values expirymap))))
timers)
timers))))
;; (: empty-zone-db : -> CompiledZone)
(: empty-zone-db : -> CompiledZone)
(define (empty-zone-db)
(make-immutable-hash))
;; (: compile-zone-db : (Listof RR) -> CompiledZone)
(: 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)
(: in-bailiwick? : DomainName DomainName -> Boolean)
;; Answers #t iff dn falls within the bailiwick of the zone with
;; origin o.
(define (in-bailiwick? dn o)
@ -199,23 +207,23 @@
(let ((p (domain-parent dn)))
(and p (in-bailiwick? p o)))))
;; (: set-filter : (All (X) (X -> Boolean) (Setof X) -> (Setof X)))
(: 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 (set)]) ([x (in-list (set->list 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))
(: 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) (p? (rr-rdata rr))) rrset))
(set-filter (lambda: ([rr : RR]) (p? (rr-rdata rr))) rrset))
;; (: no-rrs : (Setof RR))
(: no-rrs : (Setof RR))
(define no-rrs (set))
;; (: filter-rrs : (Setof RR) QueryType QueryClass -> (Setof RR))
(: 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)
@ -229,10 +237,10 @@
(define filtered-by-type-and-class
(case qclass
((*) filtered-by-type)
(else (set-filter (lambda (rr) (eqv? (rr-class rr) 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))
(: 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?
;;
@ -256,11 +264,11 @@
(append (cname-sort (set->list cnames))
(set->list (set-subtract rrs cnames))))
;; (: rr-rdata-domain-name : RR -> DomainName)
(: rr-rdata-domain-name : RR -> DomainName)
(define (rr-rdata-domain-name rr)
(rdata-domain-name (rr-rdata rr)))
(rdata-domain-name (cast (rr-rdata rr) rdata-domain)))
;; (: cname-sort : (Listof RR) -> (Listof RR))
(: 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
@ -269,9 +277,11 @@
(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) (equal? (rr-name rr) name)) cnames))
(let iterate ((remaining roots) (seen (set)) (acc '()))
(: 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)))
@ -283,12 +293,12 @@
(set-add seen source)
(append rrs acc))))))))
;; (: zone->bit-string : CompiledZone -> BitString)
(: 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 (bit-string)]) ([name (in-hash-keys zone)])
(for/fold: ([acc : BitString (bit-string)]) ([name : DomainName (in-hash-keys zone)])
(define rrmap (hash-ref zone name))
(for/fold ([acc acc]) ([rr (in-hash-keys rrmap)])
(for/fold: ([acc : BitString acc]) ([rr : RR (in-hash-keys rrmap)])
(define expiry (hash-ref rrmap rr))
(bit-string-append
acc
@ -298,7 +308,7 @@
[else
(bit-string (rr :: (t:rr)) 0 ((exact-truncate expiry) :: bits 32))])))))
;; (: bit-string->zone : BitString -> CompiledZone)
(: 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))