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

Compare commits

merge into: syndicate-lang:typed
Branches Tags
syndicate-lang:syndicate
syndicate-lang:typeless
syndicate-lang:typed
...
pull from: syndicate-lang:syndicate
Branches Tags
syndicate-lang:syndicate
syndicate-lang:typeless
syndicate-lang:typed

8 Commits
typed ... syndicate

Author SHA1 Message Date
Tony Garnock-Jones d91c729772 Merge branch 'typeless' into syndicate 2018-01-22 16:46:42 +00:00
Tony Garnock-Jones 35430ecb2e The Big Spawn/Actor Swap 2017-02-20 17:23:10 -05:00
Tony Garnock-Jones 3dbe108662 Update root zone info and add script for doing the update 2016-09-09 15:12:55 -04:00
Tony Garnock-Jones 53af1e0dd5 Progress on Syndicate conversion of proxy.rkt; doesn't run yet 2016-09-07 06:33:16 +01:00
Tony Garnock-Jones aea344fd81 Updates for #:meta-level -> inbound/outbound and for (actor(relay...))->(actor...) 2016-09-05 14:33:28 +01:00
Tony Garnock-Jones b7bdb4065e Initial progress. driver.rkt runs; now on proxy.rkt 2016-06-06 17:07:33 -04:00
Tony Garnock-Jones 806bc1c0fe Dust off tests. 2016-06-06 16:08:53 -04:00
Tony Garnock-Jones dc3df20d9b First pass at stripping types 2014-08-06 21:58:50 -07:00
14 changed files with 709 additions and 999 deletions
Show Stats Expand all files Collapse all files

6
README.md
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
[Marketplace](https://github.com/tonyg/marketplace), but could readily
[Syndicate](https://github.com/tonyg/syndicate), 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 marketplace bitsyntax
raco pkg install syndicate bitsyntax
to install Marketplace (note: will take a long time) and
to install Syndicate and
[bitsyntax](https://github.com/tonyg/racket-bitsyntax/), and then
raco make driver.rkt proxy.rkt

11
api-untyped.rkt
View File

@ -20,9 +20,9 @@
;;; along with marketplace-dns. If not, see
;;; <http://www.gnu.org/licenses/>.
(require marketplace/struct-map)
(provide (struct-out domain))
(provide (struct-out domain)
downcase-labels
make-domain)
;; (These utilities need to be defined ahead of the domain struct
;; definition.)
@ -35,10 +35,7 @@
(struct domain (labels downcased-labels)
#:transparent
#:property prop:equal+hash (list domain=? domain-hash-1/2 domain-hash-1/2)
#:property prop:struct-map (lambda (f seed x)
(let-values (((labels seed) (f (domain-labels x) seed)))
(values (make-domain labels) seed))))
#:property prop:equal+hash (list domain=? domain-hash-1/2 domain-hash-1/2))
;; 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 typed/racket/base
#lang 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,18 +19,12 @@
;;; along with marketplace-dns. If not, see
;;; <http://www.gnu.org/licenses/>.
(provide DomainName
(except-out (struct-out domain) domain)
(provide (except-out (struct-out domain) domain)
(rename-out [make-domain domain])
domain-root?
domain-parent
IPv4
IPv6
(struct-out question-repr)
Question question question?
QuestionPattern question-pattern question-pattern?
(struct-out question)
question-cyclic?
question-too-glueless?
@ -39,19 +33,14 @@
cname-question
ns-question
(struct-out answered-question-repr)
AnsweredQuestion answered-question answered-question?
AnsweredQuestionPattern answered-question-pattern answered-question-pattern?
(struct-out answered-question)
(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)
@ -66,10 +55,6 @@
(struct-out rdata-raw)
rdata-type-pred
RRType
QueryType
RRClass
QueryClass
type->value value->type
qtype->value value->qtype
class->value value->class
@ -78,50 +63,30 @@
(require "mapping.rkt")
(require racket/set)
(require racket/match)
(require marketplace)
(require marketplace/struct-map)
(require marketplace/support/pseudo-substruct)
(require syndicate)
;; A DomainName is a (domain ListOf<Bytes>), representing a domain
;; name. The head of the list is the leftmost label; for example,
;; www.google.com is represented as '(#"www" #"google" #"com").
(require/typed "api-untyped.rkt"
[#:struct domain ([labels : (Listof Bytes)]
[downcased-labels : (Listof Bytes)])])
(define-type DomainName domain)
(require "api-untyped.rkt")
;; A ShortString is a String with length 255 or shorter.
;; An IPv4 is a (vector Byte Byte Byte Byte), representing an IPv4
;; address. For example, 127.0.0.1 is represented as (vector 127 0 0
;; 1).
(define-type IPv4 (Vector Byte Byte Byte Byte))
;; An IPv6 is a Vector of length 16 containing Bytes, representing an
;; IPv6 address. For example, 2001:0db8:85a3:0000:0000:8a2e:0370:7334
;; is represented as (vector #x20 #x01 #x0d #xb8 #x85 #xa3 #x00 #x00
;; #x00 #x00 #x8a #x2e #x03 #x70 #x73 #x34).
(define-type IPv6 (Vector Byte Byte Byte Byte
Byte Byte Byte Byte
Byte Byte Byte Byte
Byte Byte Byte Byte))
;; A Question is a (question DomainName QueryType QueryClass
;; QuestionContext), representing a DNS question: "What are the RRs
;; for the given name, type and class?" as well as a possible parent
;; question that the answer to this question is to contribute to the
;; answer to.
(struct: (TName TType TClass TContext)
question-repr
([name : TName] [type : TType] [class : TClass] [context : TContext])
#:transparent)
(pseudo-substruct: (question-repr DomainName QueryType QueryClass QuestionContext)
Question question question?)
(pseudo-substruct: (question-repr (U Wild DomainName)
(U Wild QueryType)
(U Wild QueryClass)
(U Wild QuestionContext))
QuestionPattern question-pattern question-pattern?)
(struct question (name type class context) #:transparent)
;; A QuestionContext is one of
;; -- (cname-subq Question), resulting from the expansion of a CNAME
@ -134,33 +99,20 @@
;; excessively-glueless subquestion not represented here, and should
;; *not* in turn be considered for gluelessness-restarting: this is
;; needed to avoid a different kind of infinite loop.
(struct: subquestion ([parent : Question]) #:transparent)
(struct: cname-subq subquestion () #:transparent)
(struct: ns-subq subquestion () #:transparent)
(define-type QuestionContext (U subquestion cname-subq ns-subq False 'restart))
(struct subquestion (parent) #:transparent)
(struct cname-subq subquestion () #:transparent)
(struct ns-subq subquestion () #:transparent)
;; An AnsweredQuestion is an (answered-question Question
;; Maybe<CompleteAnswer>).
(struct: (TQ TA) answered-question-repr ([q : TQ] [a : TA]) #:transparent)
(pseudo-substruct: (answered-question-repr Question (Option CompleteAnswer))
AnsweredQuestion answered-question answered-question?)
(pseudo-substruct: (answered-question-repr (U Wild Question) (U Wild (Option CompleteAnswer)))
AnsweredQuestionPattern answered-question-pattern answered-question-pattern?)
(struct answered-question (q a) #:transparent)
;; A CompleteAnswer is a (complete-answer Set<RR> Set<RR> Set<RR>)
(struct: complete-answer
([rrs : (Setof RR)] [authorities : (Setof RR)] [additional : (Setof RR)])
#:transparent)
(define-type CompleteAnswer complete-answer)
(struct complete-answer (rrs authorities additional) #:transparent)
;; An RR is a (rr DomainName RRType RRClass Uint32 RData),
;; An RR is a (rr DomainName RRClass Uint32 RData),
;; representing a resource record.
(struct: rr ([name : DomainName]
[class : RRClass]
[ttl : Nonnegative-Integer]
[rdata : RData])
#:transparent)
(define-type RR rr)
(struct rr (name class ttl rdata) #:transparent)
;; An RData is one of
;; - a DomainName, for CNAME, MB, MD, MF, MG, MR, NS and PTR records
@ -181,30 +133,20 @@
;;
;; Many of these variants are obsolete in today's DNS database (marked
;; [O] above).
(struct: rdata ([type : RRType]) #:transparent)
(struct: rdata-domain rdata ([name : DomainName]) #:transparent)
(struct: rdata-ipv4 rdata ([address : IPv4]) #:transparent)
(struct: rdata-ipv6 rdata ([address : IPv6]) #:transparent)
(struct: rdata-hinfo rdata ([cpu : Bytes] [os : Bytes]) #:transparent)
(struct: rdata-minfo rdata ([rmailbx : DomainName] [emailbx : DomainName]) #:transparent)
(struct: rdata-mx rdata ([preference : Nonnegative-Integer] [exchange : DomainName]) #:transparent)
(struct: rdata-soa rdata ([mname : DomainName]
[rname : DomainName]
[serial : Nonnegative-Integer]
[refresh : Nonnegative-Integer]
[retry : Nonnegative-Integer]
[expire : Nonnegative-Integer]
[minimum : Nonnegative-Integer]) #:transparent)
(struct: rdata-wks rdata ([address : IPv4] [protocol : Byte] [bitmap : Bytes]) #:transparent)
(struct: rdata-srv rdata ([priority : Nonnegative-Integer]
[weight : Nonnegative-Integer]
[port : Nonnegative-Integer]
[target : DomainName]) #:transparent)
(struct: rdata-txt rdata ([strings : (Listof Bytes)]) #:transparent)
(struct: rdata-raw rdata ([body : Bytes]) #:transparent)
(define-type RData rdata)
(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)
(: rdata-type-pred : RRType -> (RData -> Boolean))
;; (: rdata-type-pred : RRType -> (RData -> Boolean))
(define ((rdata-type-pred t) d)
(eq? (rdata-type d) t))
@ -212,12 +154,8 @@
;; in the following define-mapping. It represents the type of an
;; RR. When used in an RR with an RData, the RRType and the RData
;; variant must correspond.
(define-type RRType (U 'a 'ns 'md 'mf 'cname 'soa 'mb 'mg
'mr 'null 'wks 'ptr 'hinfo 'minfo 'mx 'txt
'aaaa 'srv
Nonnegative-Integer))
(: type->value : RRType -> Nonnegative-Integer)
(: value->type : Nonnegative-Integer -> RRType)
;; (: type->value : RRType -> Nonnegative-Integer)
;; (: value->type : Nonnegative-Integer -> RRType)
(define-mapping type->value value->type
#:forward-default values
#:backward-default values
@ -243,9 +181,8 @@
;; A QueryType is a Symbol or Number (as given in the following
;; define-mapping) or an RRType. It specifies the kinds of records
;; being sought after in a DNS query.
(define-type QueryType (U RRType 'axfr 'mailb 'maila '*))
(: qtype->value : QueryType -> Nonnegative-Integer)
(: value->qtype : Nonnegative-Integer -> QueryType)
;; (: qtype->value : QueryType -> Nonnegative-Integer)
;; (: value->qtype : Nonnegative-Integer -> QueryType)
(define-mapping qtype->value value->qtype
#:forward-default type->value
#:backward-default value->type
@ -258,9 +195,8 @@
;; in the following define-mapping. It represents the "class" of DNS
;; records being discussed. All classes except 'in are obsolete in
;; today's DNS databases.
(define-type RRClass (U 'in 'cs 'ch 'hs Nonnegative-Integer))
(: class->value : RRClass -> Nonnegative-Integer)
(: value->class : Nonnegative-Integer -> RRClass)
;; (: class->value : RRClass -> Nonnegative-Integer)
;; (: value->class : Nonnegative-Integer -> RRClass)
(define-mapping class->value value->class
#:forward-default values
#:backward-default values
@ -272,48 +208,28 @@
;; A QueryClass is a Symbol or Number (as given in the following
;; define-mapping) or an RRClass. It specifies the "class" of records
;; being sought after in a DNS query.
(define-type QueryClass (U RRClass '*))
(: qclass->value : QueryClass -> Nonnegative-Integer)
(: value->qclass : Nonnegative-Integer -> QueryClass)
;; (: qclass->value : QueryClass -> Nonnegative-Integer)
;; (: value->qclass : Nonnegative-Integer -> QueryClass)
(define-mapping qclass->value value->qclass
#:forward-default class->value
#:backward-default value->class
(* 255))
;; ListOf<Bytes> -> ListOf<Bytes>
;; Converts the 7-bit ASCII bytes in the argument to lower-case
;; equivalents. Used to normalize case for domain-name comparisons.
(: downcase-labels : (Listof Bytes) -> (Listof Bytes))
(define (downcase-labels labels)
(for/list ([label labels])
(define b (make-bytes (bytes-length label)))
(for ([i (bytes-length label)])
(define v (bytes-ref label i))
(bytes-set! b i (if (<= 65 v 90) (+ 32 v) v)))
b))
;; ListOf<Bytes> -> DomainName
;; Replacement constructor for domain structs. Automatically downcases
;; labels appropriately.
(: make-domain : (Listof Bytes) -> DomainName)
(define (make-domain labels)
(domain labels (downcase-labels labels)))
(: domain-root? : DomainName -> Boolean)
;; (: 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)
@ -321,7 +237,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.
@ -329,12 +245,12 @@
[(complete-answer ns us ds)
(define rrs (set->list (set-union ns us ds)))
(let loop ((names (list name))
(ips ((inst set IPv4)))
(seen ((inst set DomainName))))
(ips (set))
(seen (set)))
(if (null? names)
ips
(let* ((name (car names))
(records (filter (lambda: ([rr : RR]) (equal? name (rr-name rr))) rrs))
(records (filter (lambda (rr) (equal? name (rr-name rr))) rrs))
(data (map rr-rdata records)))
(if (set-member? seen name)
(loop (cdr names) ips seen)
@ -348,10 +264,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 : Boolean ((ancestor : QuestionContext parent))
(let search ((ancestor parent))
(match ancestor
[(subquestion (question (== name) (== type) (== class) _)) #t] ;; uh-oh! A cycle!
[(subquestion (question _ _ _ ancestor-parent)) (search ancestor-parent)] ;; recursive case
@ -363,10 +279,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 : Integer ((q : Question q) (acc : Integer 0))
(let search ((q q) (acc 0))
(match-define (question _ _ _ parent) q)
(cond
[(ns-subq? parent) (search (subquestion-parent parent) (+ acc 1))]
@ -382,7 +298,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))
@ -394,19 +310,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-repr q [context 'restart]))
(struct-copy question 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 ?

93
codec.rkt
View File

@ -1,4 +1,4 @@
#lang typed/racket/base
#lang racket/base
;; DNS wire-protocol codec.
;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@ -19,17 +19,9 @@
;;; along with marketplace-dns. If not, see
;;; <http://www.gnu.org/licenses/>.
(provide Opcode
ResponseCode
value->query-opcode query-opcode->value
(provide 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
@ -50,9 +42,8 @@
;; An Opcode is a Symbol or a Number, one of the possibilities given
;; in the following define-mapping. It represents a DNS message
;; operation; see the RFC for details.
(define-type Opcode (U 'query 'iquery 'status Nonnegative-Integer))
(: value->query-opcode : Nonnegative-Integer -> Opcode)
(: query-opcode->value : Opcode -> Nonnegative-Integer)
;; (: 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
@ -63,11 +54,8 @@
;; A ResponseCode is a Symbol or a Number, one of the possibilities
;; given in the following define-mapping. It represents the outcome of
;; a DNS query.
(define-type ResponseCode (U 'no-error 'format-error 'server-failure
'name-error 'not-implemented 'refused
Nonnegative-Integer))
(: value->query-response-code : Nonnegative-Integer -> ResponseCode)
(: query-response-code->value : ResponseCode -> Nonnegative-Integer)
;; (: 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)
@ -83,25 +71,24 @@
;;
;; Interpreted as either a DNS request or reply, depending on the
;; Direction.
(struct: dns-message ([id : Nonnegative-Integer]
[direction : Direction]
[opcode : Opcode]
[authoritative : Authoritativeness]
[truncated : Truncatedness]
[recursion-desired : RecursionDesired]
[recursion-available : RecursionAvailable]
[response-code : ResponseCode]
[questions : (Listof Question)]
[answers : (Listof RR)]
[authorities : (Listof RR)]
[additional : (Listof RR)])
#:transparent)
(define-type DNSMessage dns-message)
(define-type Direction (U 'request 'response))
(define-type Authoritativeness (U 'non-authoritative 'authoritative))
(define-type Truncatedness (U 'not-truncated 'truncated))
(define-type RecursionDesired (U 'no-recursion-desired 'recursion-desired))
(define-type RecursionAvailable (U 'no-recursion-available 'recursion-available))
(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))
;; Bit-syntax type for counted repeats of a value.
;; Example: Length-prefixed list of 32-bit unsigned words:
@ -115,7 +102,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
@ -158,7 +145,7 @@
(else
(kf))))
((_ #f vs Type option ...)
(let: loop : BitString ((vs : (Listof Type) vs))
(let loop ((vs vs))
(cond
((pair? vs) (bit-string ((car vs) :: option ...)
((loop (cdr vs)) :: binary)))
@ -202,7 +189,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)
@ -232,7 +219,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
@ -288,14 +275,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
@ -337,7 +324,7 @@
((_ #f val)
(t:pascal-string #f val "Character-string" 256))
((_ #f val string-kind length-limit)
(let: ([s : Bytes val])
(let ([s val])
(let ((len (bytes-length s)))
(when (>= len length-limit)
(error 't:pascal-string "~s too long: ~v" string-kind s))
@ -377,10 +364,10 @@
#f)
tail))))
((_ #f val)
(let: ([q : Question val])
(bit-string ((question-repr-name q) :: (t:domain-name))
((qtype->value (question-repr-type q)) :: bits 16)
((qclass->value (question-repr-class q)) :: bits 16))))))
(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))))))
;; <rfc1035>
;; All RRs have the same top level format shown below:
@ -429,7 +416,7 @@
tail)))
(else (kf)))))
((_ #f val)
(let: ([rr : RR val])
(let ([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)
@ -438,7 +425,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)
@ -487,7 +474,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
@ -519,5 +506,5 @@
[(rdata-raw _ bs) bs]))
;; UInt32
(: max-ttl : Nonnegative-Integer)
;; (: max-ttl : Nonnegative-Integer)
(define max-ttl #xffffffff)

44
driver.rkt
View File

@ -1,4 +1,4 @@
#lang typed/racket/base
#lang 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 marketplace/sugar-typed)
(require marketplace/support/spy)
(require marketplace/drivers/udp)
(require syndicate/ground)
(require syndicate/actor)
(require syndicate/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,26 +58,24 @@
(display ";; Ready.\n")
(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)))])))))
(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))))))))
(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
@ -92,7 +90,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
@ -110,7 +108,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
['()
@ -120,7 +118,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)

41
fetch-root-zone.rkt Normal file
View File

@ -0,0 +1,41 @@
#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])))))

2
mapping.rkt
View File

@ -1,4 +1,4 @@
#lang typed/racket/base
#lang 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>

337
network-query.rkt
View File

@ -1,4 +1,4 @@
#lang typed/racket/base
#lang racket/base
;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
;;;
@ -23,17 +23,13 @@
(require "api.rkt")
(require "codec.rkt")
(require "zonedb.rkt")
(require marketplace/sugar-typed)
(require marketplace/drivers/udp)
(require marketplace/drivers/timer)
(require marketplace/support/pseudo-substruct)
(require syndicate/actor)
(require syndicate/drivers/udp)
(require syndicate/drivers/timer)
(require "tk-dns.rkt")
(require (rename-in marketplace/tr-struct-copy [tr-struct-copy struct-copy])) ;; PR13149
(provide network-query
(struct-out network-reply-repr)
NetworkReply network-reply network-reply?
NetworkReplyPattern network-reply-pattern network-reply-pattern?)
(struct-out network-reply))
;; DJB's rules for handling DNS responses. Some of these are handled
;; here (specifically, rules 2 through 5, in the action of
@ -127,48 +123,18 @@
(define first-timeout 3) ;; seconds
;; A NetworkRequest is a (network-request UdpAddress Question
;; DomainName NEListOf<DomainName> UniqueID) representing the
;; parameters used to start and process a network query.
(struct: network-request ([client-socket : UdpAddress]
[question : Question]
[zone-origin : DomainName]
[server-names : (Listof DomainName)]
[unique-id : Any])
#:transparent)
(define-type NetworkRequest network-request)
;; A NetworkReply is a (network-reply UniqueID Maybe<CompleteAnswer>)
;; representing the final result of a network query.
(struct: (TId TAnswer)
network-reply-repr
([unique-id : TId] [answer : TAnswer]) #:transparent)
(pseudo-substruct: (network-reply-repr Any (Option CompleteAnswer))
NetworkReply network-reply network-reply?)
(pseudo-substruct: (network-reply-repr (U Wild Any) (U Wild (Option CompleteAnswer)))
NetworkReplyPattern network-reply-pattern network-reply-pattern?)
(struct network-reply (unique-id answer) #:transparent)
;; 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))
;; (: 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
@ -183,9 +149,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
@ -200,25 +166,24 @@
(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 : RR])
(in-bailiwick? (rr-name claim-rr) zone-origin)) l)))
(list->set (filter (lambda (claim-rr) (in-bailiwick? (rr-name claim-rr) zone-origin)) l)))
;; Here's where we do the "lame referral" check. This code is
;; nice and simple (though wrong) without it. Ho hum.
(define answers (f (dns-message-answers message)))
(define unfiltered-authorities (dns-message-authorities message))
(define non-subzone-ns-rrs ;; all NS authorities not for a STRICT subzone of our zone-origin
(filter (lambda: ([rr : RR]) (and (eqv? (rdata-type (rr-rdata rr)) 'ns)
(or (equal? (rr-name rr) zone-origin)
(not (in-bailiwick? (rr-name rr) zone-origin)))))
(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)))))
unfiltered-authorities))
(define authorities (f unfiltered-authorities))
(define answers-to-q ;; answers specifically to the question we asked
(set-filter (lambda: ([rr : RR]) (equal? (rr-name rr) (question-repr-name q))) answers))
(set-filter (lambda (rr) (equal? (rr-name rr) (question-name q))) answers))
(define lame?
(and (set-empty? (filter-by-type answers-to-q 'cname))
(set-empty? (filter-rrs answers-to-q (question-repr-type q) (question-repr-class q)))
(set-empty? (filter-rrs answers-to-q (question-type q) (question-class q)))
(set-empty? (filter-by-type authorities 'soa))
(not (null? non-subzone-ns-rrs))))
(if lame?
@ -228,171 +193,129 @@
(f (dns-message-additional message))))]
[(name-error) #f]
[else
(log-info (format "Abnormal response-code ~v in response to questions ~v"
(dns-message-response-code message)
(dns-message-questions message)))
(log-info "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 ->
(Action ParentState)))
;; (: network-query : (All (ParentState)
;; UdpAddress Question DomainName (Listof DomainName) Any ->
;; Void))
(define (network-query s q zone-origin server-names unique-id)
(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)))))
(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
(: 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 (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))]))
(: 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 (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)))])))
(: 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)))))]))))))
(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))

531
proxy.rkt
View File

@ -1,4 +1,4 @@
#lang typed/racket/base
#lang 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 marketplace/sugar-typed)
(require marketplace/support/spy)
(require marketplace/drivers/timer)
(require marketplace/drivers/udp)
(require (except-in syndicate dataspace assert))
(require syndicate/actor)
(require syndicate/drivers/timer)
(require syndicate/drivers/udp)
(require "tk-dns.rkt")
(require racket/pretty)
@ -40,343 +40,262 @@
;; searches from. Performs recursive queries.
;; For discarding retransmitted requests that we're still working on.
(struct: active-request ([source : UdpAddress] [id : Natural]) #:transparent)
(define-type ActiveRequest active-request)
(struct active-request (source id) #:transparent)
(: 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.")
(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))))))
(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))))
(: query-id-allocator : -> (Transition (Setof Natural)))
;; (: query-id-allocator : -> Void)
(define (query-id-allocator)
;; TODO: track how many are allocated and throttle requests if too
;; many are in flight
(transition: ((inst set Natural)) : (Setof Natural) ;; all active query IDs
(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))])))))
(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)))))
(: packet-dispatcher : UdpAddress -> (Transition (Setof ActiveRequest)))
;; (: packet-dispatcher : UdpAddress -> Void)
(define (packet-dispatcher s)
(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)))])))))
(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)))))
(: packet-relay : ActiveRequest DNSRequest -> (Transition Void))
;; (: packet-relay : ActiveRequest DNSRequest -> 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))))])))))]))
(: glueless-question-handler : CompiledZone Question UdpAddress -> (Transition Void))
(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)
(define (glueless-question-handler roots-only-zone q client-sock)
;; Restart q, an overly-glueless question, from the roots.
(define restarted-question (restart-question q))
(transition/no-state
(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)))))
(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))))
(: question-dispatcher : CompiledZone CompiledZone UdpAddress -> (Transition CompiledZone))
;; (: question-dispatcher : CompiledZone CompiledZone UdpAddress -> Void)
(define (question-dispatcher seed-zone roots-only client-sock)
(: transition-and-set-timers : CompiledZone (Setof (Pairof DomainName Real))
-> (Transition CompiledZone))
(define (transition-and-set-timers new-zone timers)
(transition: new-zone : CompiledZone
(for/list: : (Listof (Action CompiledZone)) ([timerspec timers])
(match-define (cons name ttl) timerspec)
(send-message (set-timer (list 'check-dns-expiry name) (* ttl 1000) 'relative)))))
(define-values (cleaned-seed-zone initial-timers) (zone-expire seed-zone))
(sequence-actions (transition-and-set-timers cleaned-seed-zone initial-timers)
;; TODO: consider deduping questions here too?
(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)])))))
(spawn #:name 'question-dispatcher
(field [zone cleaned-seed-zone])
(on-start (set-timers! initial-timers))
(struct: question-state ([zone : CompiledZone]
[q : Question]
[client-sock : UdpAddress]
[nameservers-tried : (Setof DomainName)]
[retry-count : Natural]) #:transparent)
(define-type QuestionState question-state)
(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: expanding-cnames ([q : Question]
[accumulator : CompleteAnswer]
[remaining-count : Integer]) #:transparent)
(define-type ExpandingCNAMEs expanding-cnames)
;; TODO: consider deduping questions here too?
(define-type QHState (U QuestionState ExpandingCNAMEs))
(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)
)
(: 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 ($ 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)]))
(: 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 (network-reply _ $answer))
(define-values (new-zone timers) (incorporate-complete-answer answer (zone) #t))
(zone new-zone)
(set-timers! timers))
(: 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))])]))
(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)))))]))))))
(require "test-rrs.rkt")
(require racket/file)

52
resolver.rkt
View File

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

94
test-dns.rkt
View File

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

72
test-rrs.rkt
View File

@ -1,4 +1,4 @@
#lang typed/racket/base
#lang 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 (cast ip IPv4))))
(define (A/ttl n ip ttl) (rr (domain n) 'in ttl (rdata-ipv4 'a ip)))
(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 (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)))
(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)))
(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

135
tk-dns.rkt
View File

@ -1,4 +1,4 @@
#lang typed/racket/base
#lang racket/base
;; DNS drivers using marketplace.
;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@ -22,106 +22,55 @@
(require racket/set)
(require racket/match)
(require "codec.rkt")
(require marketplace/sugar-typed)
(require marketplace/drivers/udp)
(require marketplace/support/pseudo-substruct)
(provide (struct-out bad-dns-packet-repr)
BadDnsPacket bad-dns-packet bad-dns-packet?
BadDnsPacketPattern bad-dns-packet-pattern bad-dns-packet-pattern?
(struct-out dns-request-repr)
DNSRequest dns-request dns-request?
DNSRequestPattern dns-request-pattern dns-request-pattern?
(struct-out dns-reply-repr)
DNSReply dns-reply dns-reply?
DNSReplyPattern dns-reply-pattern dns-reply-pattern?
(require syndicate/actor)
(require syndicate/protocol/standard-relay)
(require syndicate/drivers/udp)
(provide (struct-out bad-dns-packet)
(struct-out dns-request)
(struct-out dns-reply)
dns-read-driver
dns-write-driver
dns-spy)
(struct: (TDetail TSource TSink TReason)
bad-dns-packet-repr
([detail : TDetail] [source : TSource] [sink : TSink] [reason : TReason]) #:transparent)
(pseudo-substruct: (bad-dns-packet-repr Any UdpAddress UdpAddress Symbol)
BadDnsPacket bad-dns-packet bad-dns-packet?)
(pseudo-substruct: (bad-dns-packet-repr Any
(U Wild UdpAddressPattern)
(U Wild UdpAddressPattern)
(U Wild Symbol))
BadDnsPacketPattern bad-dns-packet-pattern bad-dns-packet-pattern?)
(struct bad-dns-packet (detail source sink reason) #:transparent)
(struct dns-request (message source sink) #:transparent)
(struct dns-reply (message source sink) #:transparent)
(struct: (TMessage TSource TSink)
dns-request-repr
([message : TMessage] [source : TSource] [sink : TSink]) #:transparent)
(pseudo-substruct: (dns-request-repr DNSMessage UdpAddress UdpAddress)
DNSRequest dns-request dns-request?)
(pseudo-substruct: (dns-request-repr (U Wild DNSMessage)
(U Wild UdpAddressPattern)
(U Wild UdpAddressPattern))
DNSRequestPattern dns-request-pattern dns-request-pattern?)
(struct: (TMessage TSource TSink)
dns-reply-repr
([message : TMessage] [source : TSource] [sink : TSink]) #:transparent)
(pseudo-substruct: (dns-reply-repr DNSMessage UdpAddress UdpAddress)
DNSReply dns-reply dns-reply?)
(pseudo-substruct: (dns-reply-repr (U Wild DNSMessage)
(U Wild UdpAddressPattern)
(U Wild UdpAddressPattern))
DNSReplyPattern dns-reply-pattern dns-reply-pattern?)
(: dns-read-driver : UdpAddress -> (Transition Void))
(define (dns-read-driver s)
(transition: (void) : Void
(at-meta-level: 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)))))])))))
(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)))))
(: dns-write-driver : UdpAddress -> (Transition Void))
(define (dns-write-driver s)
(: translate : DNSMessage UdpAddress -> (ActionTree Void))
(define (translate message sink)
(with-handlers ((exn:fail? (lambda (e)
(send-message (bad-dns-packet message s sink 'unencodable)))))
(at-meta-level: 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)]))))
(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)))))
(: dns-spy : -> (Transition Void))
(define (dns-spy)
(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))]))))
(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)))))

102
zonedb.rkt
View File

@ -1,4 +1,4 @@
#lang typed/racket/base
#lang 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,10 +25,8 @@
(require "api.rkt")
(require "codec.rkt")
(require bitsyntax)
(require (rename-in marketplace/tr-struct-copy [tr-struct-copy struct-copy])) ;; PR13149
(provide CompiledZone
zone-ref
(provide zone-ref
zone-includes-name?
incorporate-complete-answer
zone-expire-name
@ -45,52 +43,47 @@
zone->bit-string
bit-string->zone)
(define-type RelativeSeconds Real)
(define-type AbsoluteSeconds Real)
(define-predicate absolute-seconds? AbsoluteSeconds)
;; (define-type RelativeSeconds Real)
;; (define-type AbsoluteSeconds Real)
;; (define-predicate absolute-seconds? AbsoluteSeconds)
(define absolute-seconds? real?)
;; An InfiniteLifetime is an (infinite-lifetime RelativeSeconds), a
;; specification of the TTL to use when sending a non-expiring RR to a
;; peer.
(struct: infinite-lifetime ([ttl : RelativeSeconds]) #:transparent)
(define-type InfiniteLifetime infinite-lifetime)
(struct infinite-lifetime (ttl) #:transparent)
;; 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 : (Setof RR) (set)])
([resource : RR (in-hash-keys expirymap)])
(for/fold ([acc (set)]) ([resource (in-hash-keys expirymap)])
(define expiry (hash-ref expirymap resource))
(if (still-valid? expiry now)
(let ((new-ttl (if (infinite-lifetime? expiry)
@ -98,14 +91,14 @@
(- expiry now))))
(set-add acc
(struct-copy rr resource
[ttl (cast (exact-floor new-ttl) Nonnegative-Integer)])))
[ttl (exact-floor new-ttl)])))
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
@ -129,7 +122,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 () (ann #hash() (HashTable rr Expiry)))))
(define old-expirymap (hash-ref db name (lambda () #hash())))
(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
@ -139,15 +132,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 ((inst set Timer))])
(for/fold ([db db] [timers (set)])
([rr (in-list (append (set->list ns)
(set->list us)
(set->list ds)))]) ;; no in-sequences in typed racket
@ -156,15 +149,14 @@
(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 (ann #hash() (HashTable RR Expiry)))
(define empty-expirymap #hash())
(define old-expirymap (hash-ref db name (lambda () empty-expirymap)))
(define new-expirymap
(for/fold: ([acc : (HashTable RR Expiry) empty-expirymap])
([resource : RR (in-hash-keys old-expirymap)])
(for/fold ([acc empty-expirymap]) ([resource (in-hash-keys old-expirymap)])
(define expiry (hash-ref old-expirymap resource))
(if (still-valid? expiry now-seconds)
(hash-set acc resource expiry)
@ -173,33 +165,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 : CompiledZone zone] [timers : Timers (set)])
([name : DomainName (in-hash-keys zone)])
(for/fold ([zone zone] [timers (set)])
([name (in-hash-keys zone)])
(define new-zone (zone-expire-name zone name now-seconds))
(define expirymap (hash-ref new-zone name (lambda () #f)))
(values new-zone
(if expirymap
(set-union (list->set
(map (lambda: ([e : AbsoluteSeconds]) (cons name (- e now-seconds)))
(map (lambda (e) (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)
@ -207,23 +199,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 : (Setof X) (set)]) ([x : X (in-list (set->list in))])
(for/fold ([acc (set)]) ([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 : RR]) (p? (rr-rdata rr))) rrset))
(set-filter (lambda (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)
@ -237,10 +229,10 @@
(define filtered-by-type-and-class
(case qclass
((*) filtered-by-type)
(else (set-filter (lambda: ([rr : RR]) (eqv? (rr-class rr) qclass)) filtered-by-type))))
(else (set-filter (lambda (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?
;;
@ -264,11 +256,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 (cast (rr-rdata rr) rdata-domain)))
(rdata-domain-name (rr-rdata rr)))
(: 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
@ -277,11 +269,9 @@
(define lhss (list->set (map rr-name cnames)))
(define rhss (list->set (map rr-rdata-domain-name cnames)))
(define roots (set->list (set-subtract lhss rhss))) ;; Nodes not the targets of some edge.
(: targets-of : DomainName -> (Listof RR))
(define (targets-of name) (filter (lambda: ([rr : RR]) (equal? (rr-name rr) name)) cnames))
(let: iterate ((remaining : (Listof DomainName) roots)
(seen : (Setof DomainName) (set))
(acc : (Listof RR) '()))
;; (: 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 '()))
(if (null? remaining)
(reverse acc)
(let ((source (car remaining)))
@ -293,12 +283,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 : BitString (bit-string)]) ([name : DomainName (in-hash-keys zone)])
(for/fold ([acc (bit-string)]) ([name (in-hash-keys zone)])
(define rrmap (hash-ref zone name))
(for/fold: ([acc : BitString acc]) ([rr : RR (in-hash-keys rrmap)])
(for/fold ([acc acc]) ([rr (in-hash-keys rrmap)])
(define expiry (hash-ref rrmap rr))
(bit-string-append
acc
@ -308,7 +298,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))