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

First pass at stripping types

This commit is contained in:
Tony Garnock-Jones 2014-08-06 21:58:50 -07:00
parent fd73114fc3
commit dc3df20d9b
11 changed files with 380 additions and 580 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
api-untyped.rkt
View File

@ -22,7 +22,9 @@
(require marketplace/struct-map) (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 ;; (These utilities need to be defined ahead of the domain struct
;; definition.) ;; definition.)

185
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. ;; Definitions for use in the API to the functionality of the library.
;; ;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu> ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@ -19,18 +19,12 @@
;;; along with marketplace-dns. If not, see ;;; along with marketplace-dns. If not, see
;;; <http://www.gnu.org/licenses/>. ;;; <http://www.gnu.org/licenses/>.
(provide DomainName (provide (except-out (struct-out domain) domain)
(except-out (struct-out domain) domain)
(rename-out [make-domain domain]) (rename-out [make-domain domain])
domain-root? domain-root?
domain-parent domain-parent
IPv4 (struct-out question)
IPv6
(struct-out question-repr)
Question question question?
QuestionPattern question-pattern question-pattern?
question-cyclic? question-cyclic?
question-too-glueless? question-too-glueless?
@ -39,19 +33,14 @@
cname-question cname-question
ns-question ns-question
(struct-out answered-question-repr) (struct-out answered-question)
AnsweredQuestion answered-question answered-question?
AnsweredQuestionPattern answered-question-pattern answered-question-pattern?
(struct-out rr) (struct-out rr)
RR
CompleteAnswer
(struct-out complete-answer) (struct-out complete-answer)
empty-complete-answer empty-complete-answer
merge-answers merge-answers
extract-addresses extract-addresses
RData
(struct-out rdata) (struct-out rdata)
(struct-out rdata-domain) (struct-out rdata-domain)
(struct-out rdata-ipv4) (struct-out rdata-ipv4)
@ -66,10 +55,6 @@
(struct-out rdata-raw) (struct-out rdata-raw)
rdata-type-pred rdata-type-pred
RRType
QueryType
RRClass
QueryClass
type->value value->type type->value value->type
qtype->value value->qtype qtype->value value->qtype
class->value value->class class->value value->class
@ -80,48 +65,29 @@
(require racket/match) (require racket/match)
(require marketplace) (require marketplace)
(require marketplace/struct-map) (require marketplace/struct-map)
(require marketplace/support/pseudo-substruct)
;; A DomainName is a (domain ListOf<Bytes>), representing a domain ;; A DomainName is a (domain ListOf<Bytes>), representing a domain
;; name. The head of the list is the leftmost label; for example, ;; name. The head of the list is the leftmost label; for example,
;; www.google.com is represented as '(#"www" #"google" #"com"). ;; www.google.com is represented as '(#"www" #"google" #"com").
(require/typed "api-untyped.rkt" (require "api-untyped.rkt")
[#:struct domain ([labels : (Listof Bytes)]
[downcased-labels : (Listof Bytes)])])
(define-type DomainName domain)
;; A ShortString is a String with length 255 or shorter. ;; A ShortString is a String with length 255 or shorter.
;; An IPv4 is a (vector Byte Byte Byte Byte), representing an IPv4 ;; 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 ;; address. For example, 127.0.0.1 is represented as (vector 127 0 0
;; 1). ;; 1).
(define-type IPv4 (Vector Byte Byte Byte Byte))
;; An IPv6 is a Vector of length 16 containing Bytes, representing an ;; An IPv6 is a Vector of length 16 containing Bytes, representing an
;; IPv6 address. For example, 2001:0db8:85a3:0000:0000:8a2e:0370:7334 ;; IPv6 address. For example, 2001:0db8:85a3:0000:0000:8a2e:0370:7334
;; is represented as (vector #x20 #x01 #x0d #xb8 #x85 #xa3 #x00 #x00 ;; is represented as (vector #x20 #x01 #x0d #xb8 #x85 #xa3 #x00 #x00
;; #x00 #x00 #x8a #x2e #x03 #x70 #x73 #x34). ;; #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 ;; A Question is a (question DomainName QueryType QueryClass
;; QuestionContext), representing a DNS question: "What are the RRs ;; QuestionContext), representing a DNS question: "What are the RRs
;; for the given name, type and class?" as well as a possible parent ;; 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 ;; question that the answer to this question is to contribute to the
;; answer to. ;; answer to.
(struct: (TName TType TClass TContext) (struct question (name type class context) #:transparent)
question-repr
([name : TName] [type : TType] [class : TClass] [context : TContext])
#:transparent)
(pseudo-substruct: (question-repr DomainName QueryType QueryClass QuestionContext)
Question question question?)
(pseudo-substruct: (question-repr (U Wild DomainName)
(U Wild QueryType)
(U Wild QueryClass)
(U Wild QuestionContext))
QuestionPattern question-pattern question-pattern?)
;; A QuestionContext is one of ;; A QuestionContext is one of
;; -- (cname-subq Question), resulting from the expansion of a CNAME ;; -- (cname-subq Question), resulting from the expansion of a CNAME
@ -134,33 +100,20 @@
;; excessively-glueless subquestion not represented here, and should ;; excessively-glueless subquestion not represented here, and should
;; *not* in turn be considered for gluelessness-restarting: this is ;; *not* in turn be considered for gluelessness-restarting: this is
;; needed to avoid a different kind of infinite loop. ;; needed to avoid a different kind of infinite loop.
(struct: subquestion ([parent : Question]) #:transparent) (struct subquestion (parent) #:transparent)
(struct: cname-subq subquestion () #:transparent) (struct cname-subq subquestion () #:transparent)
(struct: ns-subq subquestion () #:transparent) (struct ns-subq subquestion () #:transparent)
(define-type QuestionContext (U subquestion cname-subq ns-subq False 'restart))
;; An AnsweredQuestion is an (answered-question Question ;; An AnsweredQuestion is an (answered-question Question
;; Maybe<CompleteAnswer>). ;; Maybe<CompleteAnswer>).
(struct: (TQ TA) answered-question-repr ([q : TQ] [a : TA]) #:transparent) (struct answered-question (q a) #:transparent)
(pseudo-substruct: (answered-question-repr Question (Option CompleteAnswer))
AnsweredQuestion answered-question answered-question?)
(pseudo-substruct: (answered-question-repr (U Wild Question) (U Wild (Option CompleteAnswer)))
AnsweredQuestionPattern answered-question-pattern answered-question-pattern?)
;; A CompleteAnswer is a (complete-answer Set<RR> Set<RR> Set<RR>) ;; A CompleteAnswer is a (complete-answer Set<RR> Set<RR> Set<RR>)
(struct: complete-answer (struct complete-answer (rrs authorities additional) #:transparent)
([rrs : (Setof RR)] [authorities : (Setof RR)] [additional : (Setof RR)])
#:transparent)
(define-type CompleteAnswer complete-answer)
;; An RR is a (rr DomainName RRType RRClass Uint32 RData), ;; An RR is a (rr DomainName RRClass Uint32 RData),
;; representing a resource record. ;; representing a resource record.
(struct: rr ([name : DomainName] (struct rr (name class ttl rdata) #:transparent)
[class : RRClass]
[ttl : Nonnegative-Integer]
[rdata : RData])
#:transparent)
(define-type RR rr)
;; An RData is one of ;; An RData is one of
;; - a DomainName, for CNAME, MB, MD, MF, MG, MR, NS and PTR records ;; - a DomainName, for CNAME, MB, MD, MF, MG, MR, NS and PTR records
@ -181,30 +134,20 @@
;; ;;
;; Many of these variants are obsolete in today's DNS database (marked ;; Many of these variants are obsolete in today's DNS database (marked
;; [O] above). ;; [O] above).
(struct: rdata ([type : RRType]) #:transparent) (struct rdata (type) #:transparent)
(struct: rdata-domain rdata ([name : DomainName]) #:transparent) (struct rdata-domain rdata (name) #:transparent)
(struct: rdata-ipv4 rdata ([address : IPv4]) #:transparent) (struct rdata-ipv4 rdata (address) #:transparent)
(struct: rdata-ipv6 rdata ([address : IPv6]) #:transparent) (struct rdata-ipv6 rdata (address) #:transparent)
(struct: rdata-hinfo rdata ([cpu : Bytes] [os : Bytes]) #:transparent) (struct rdata-hinfo rdata (cpu os) #:transparent)
(struct: rdata-minfo rdata ([rmailbx : DomainName] [emailbx : DomainName]) #:transparent) (struct rdata-minfo rdata (rmailbx emailbx) #:transparent)
(struct: rdata-mx rdata ([preference : Nonnegative-Integer] [exchange : DomainName]) #:transparent) (struct rdata-mx rdata (preference exchange) #:transparent)
(struct: rdata-soa rdata ([mname : DomainName] (struct rdata-soa rdata (mname rname serial refresh retry expire minimum) #:transparent)
[rname : DomainName] (struct rdata-wks rdata (address protocol bitmap) #:transparent)
[serial : Nonnegative-Integer] (struct rdata-srv rdata (priority weight port target) #:transparent)
[refresh : Nonnegative-Integer] (struct rdata-txt rdata (strings) #:transparent)
[retry : Nonnegative-Integer] (struct rdata-raw rdata (body) #:transparent)
[expire : Nonnegative-Integer]
[minimum : Nonnegative-Integer]) #:transparent)
(struct: rdata-wks rdata ([address : IPv4] [protocol : Byte] [bitmap : Bytes]) #:transparent)
(struct: rdata-srv rdata ([priority : Nonnegative-Integer]
[weight : Nonnegative-Integer]
[port : Nonnegative-Integer]
[target : DomainName]) #:transparent)
(struct: rdata-txt rdata ([strings : (Listof Bytes)]) #:transparent)
(struct: rdata-raw rdata ([body : Bytes]) #:transparent)
(define-type RData rdata)
(: rdata-type-pred : RRType -> (RData -> Boolean)) ;; (: rdata-type-pred : RRType -> (RData -> Boolean))
(define ((rdata-type-pred t) d) (define ((rdata-type-pred t) d)
(eq? (rdata-type d) t)) (eq? (rdata-type d) t))
@ -212,12 +155,8 @@
;; in the following define-mapping. It represents the type of an ;; 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 ;; RR. When used in an RR with an RData, the RRType and the RData
;; variant must correspond. ;; variant must correspond.
(define-type RRType (U 'a 'ns 'md 'mf 'cname 'soa 'mb 'mg ;; (: type->value : RRType -> Nonnegative-Integer)
'mr 'null 'wks 'ptr 'hinfo 'minfo 'mx 'txt ;; (: value->type : Nonnegative-Integer -> RRType)
'aaaa 'srv
Nonnegative-Integer))
(: type->value : RRType -> Nonnegative-Integer)
(: value->type : Nonnegative-Integer -> RRType)
(define-mapping type->value value->type (define-mapping type->value value->type
#:forward-default values #:forward-default values
#:backward-default values #:backward-default values
@ -243,9 +182,8 @@
;; A QueryType is a Symbol or Number (as given in the following ;; A QueryType is a Symbol or Number (as given in the following
;; define-mapping) or an RRType. It specifies the kinds of records ;; define-mapping) or an RRType. It specifies the kinds of records
;; being sought after in a DNS query. ;; being sought after in a DNS query.
(define-type QueryType (U RRType 'axfr 'mailb 'maila '*)) ;; (: qtype->value : QueryType -> Nonnegative-Integer)
(: qtype->value : QueryType -> Nonnegative-Integer) ;; (: value->qtype : Nonnegative-Integer -> QueryType)
(: value->qtype : Nonnegative-Integer -> QueryType)
(define-mapping qtype->value value->qtype (define-mapping qtype->value value->qtype
#:forward-default type->value #:forward-default type->value
#:backward-default value->type #:backward-default value->type
@ -258,9 +196,8 @@
;; in the following define-mapping. It represents the "class" of DNS ;; in the following define-mapping. It represents the "class" of DNS
;; records being discussed. All classes except 'in are obsolete in ;; records being discussed. All classes except 'in are obsolete in
;; today's DNS databases. ;; today's DNS databases.
(define-type RRClass (U 'in 'cs 'ch 'hs Nonnegative-Integer)) ;; (: class->value : RRClass -> Nonnegative-Integer)
(: class->value : RRClass -> Nonnegative-Integer) ;; (: value->class : Nonnegative-Integer -> RRClass)
(: value->class : Nonnegative-Integer -> RRClass)
(define-mapping class->value value->class (define-mapping class->value value->class
#:forward-default values #:forward-default values
#:backward-default values #:backward-default values
@ -272,48 +209,28 @@
;; A QueryClass is a Symbol or Number (as given in the following ;; A QueryClass is a Symbol or Number (as given in the following
;; define-mapping) or an RRClass. It specifies the "class" of records ;; define-mapping) or an RRClass. It specifies the "class" of records
;; being sought after in a DNS query. ;; being sought after in a DNS query.
(define-type QueryClass (U RRClass '*)) ;; (: qclass->value : QueryClass -> Nonnegative-Integer)
(: qclass->value : QueryClass -> Nonnegative-Integer) ;; (: value->qclass : Nonnegative-Integer -> QueryClass)
(: value->qclass : Nonnegative-Integer -> QueryClass)
(define-mapping qclass->value value->qclass (define-mapping qclass->value value->qclass
#:forward-default class->value #:forward-default class->value
#:backward-default value->class #:backward-default value->class
(* 255)) (* 255))
;; ListOf<Bytes> -> ListOf<Bytes> ;; (: domain-root? : DomainName -> Boolean)
;; Converts the 7-bit ASCII bytes in the argument to lower-case
;; equivalents. Used to normalize case for domain-name comparisons.
(: downcase-labels : (Listof Bytes) -> (Listof Bytes))
(define (downcase-labels labels)
(for/list ([label labels])
(define b (make-bytes (bytes-length label)))
(for ([i (bytes-length label)])
(define v (bytes-ref label i))
(bytes-set! b i (if (<= 65 v 90) (+ 32 v) v)))
b))
;; ListOf<Bytes> -> DomainName
;; Replacement constructor for domain structs. Automatically downcases
;; labels appropriately.
(: make-domain : (Listof Bytes) -> DomainName)
(define (make-domain labels)
(domain labels (downcase-labels labels)))
(: domain-root? : DomainName -> Boolean)
(define (domain-root? d) (define (domain-root? d)
(null? (domain-labels d))) (null? (domain-labels d)))
(: domain-parent : DomainName -> (Option DomainName)) ;; (: domain-parent : DomainName -> (Option DomainName))
(define (domain-parent d) (define (domain-parent d)
(and (pair? (domain-labels d)) (and (pair? (domain-labels d))
(domain (cdr (domain-labels d)) (domain (cdr (domain-labels d))
(cdr (domain-downcased-labels d))))) (cdr (domain-downcased-labels d)))))
(: empty-complete-answer : -> CompleteAnswer) ;; (: empty-complete-answer : -> CompleteAnswer)
(define (empty-complete-answer) (define (empty-complete-answer)
(complete-answer (set) (set) (set))) (complete-answer (set) (set) (set)))
(: merge-answers : CompleteAnswer CompleteAnswer -> CompleteAnswer) ;; (: merge-answers : CompleteAnswer CompleteAnswer -> CompleteAnswer)
(define (merge-answers a1 a2) (define (merge-answers a1 a2)
(match-define (complete-answer n1 u1 d1) a1) (match-define (complete-answer n1 u1 d1) a1)
(match-define (complete-answer n2 u2 d2) a2) (match-define (complete-answer n2 u2 d2) a2)
@ -321,7 +238,7 @@
(set-union u1 u2) (set-union u1 u2)
(set-union d1 d2))) (set-union d1 d2)))
(: extract-addresses : DomainName (Option CompleteAnswer) -> (Setof IPv4)) ;; (: extract-addresses : DomainName (Option CompleteAnswer) -> (Setof IPv4))
(define (extract-addresses name ans) (define (extract-addresses name ans)
(match ans (match ans
[#f ;; name-error/NXDOMAIN, so definitely no addresses. [#f ;; name-error/NXDOMAIN, so definitely no addresses.
@ -329,12 +246,12 @@
[(complete-answer ns us ds) [(complete-answer ns us ds)
(define rrs (set->list (set-union ns us ds))) (define rrs (set->list (set-union ns us ds)))
(let loop ((names (list name)) (let loop ((names (list name))
(ips ((inst set IPv4))) (ips (set))
(seen ((inst set DomainName)))) (seen (set)))
(if (null? names) (if (null? names)
ips ips
(let* ((name (car names)) (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))) (data (map rr-rdata records)))
(if (set-member? seen name) (if (set-member? seen name)
(loop (cdr names) ips seen) (loop (cdr names) ips seen)
@ -348,10 +265,10 @@
;; #t iff this question is being asked in order to supply answers ;; #t iff this question is being asked in order to supply answers
;; contributing to a parent context that's trying to answer exactly ;; contributing to a parent context that's trying to answer exactly
;; this question. ;; this question.
(: question-cyclic? : Question -> Boolean) ;; (: question-cyclic? : Question -> Boolean)
(define (question-cyclic? q) (define (question-cyclic? q)
(match-define (question name type class parent) q) (match-define (question name type class parent) q)
(let: search : Boolean ((ancestor : QuestionContext parent)) (let search ((ancestor parent))
(match ancestor (match ancestor
[(subquestion (question (== name) (== type) (== class) _)) #t] ;; uh-oh! A cycle! [(subquestion (question (== name) (== type) (== class) _)) #t] ;; uh-oh! A cycle!
[(subquestion (question _ _ _ ancestor-parent)) (search ancestor-parent)] ;; recursive case [(subquestion (question _ _ _ ancestor-parent)) (search ancestor-parent)] ;; recursive case
@ -363,10 +280,10 @@
;; from the outside world, then that's too glueless. See ;; from the outside world, then that's too glueless. See
;; http://cr.yp.to/djbdns/notes.html in the sections "Gluelessness" ;; http://cr.yp.to/djbdns/notes.html in the sections "Gluelessness"
;; and "Expiring glue". ;; and "Expiring glue".
(: question-too-glueless? : Question -> Boolean) ;; (: question-too-glueless? : Question -> Boolean)
(define (question-too-glueless? q) (define (question-too-glueless? q)
(define count (define count
(let: search : Integer ((q : Question q) (acc : Integer 0)) (let search ((q q) (acc 0))
(match-define (question _ _ _ parent) q) (match-define (question _ _ _ parent) q)
(cond (cond
[(ns-subq? parent) (search (subquestion-parent parent) (+ acc 1))] [(ns-subq? parent) (search (subquestion-parent parent) (+ acc 1))]
@ -382,7 +299,7 @@
;; Question -> Boolean ;; Question -> Boolean
;; #t iff this question is being asked in the context of some ;; #t iff this question is being asked in the context of some
;; excessively glueless subquestion. ;; excessively glueless subquestion.
(: question-restarted? : Question -> Boolean) ;; (: question-restarted? : Question -> Boolean)
(define (question-restarted? q) (define (question-restarted? q)
(match-define (question name type class parent) q) (match-define (question name type class parent) q)
(let search ((ancestor parent)) (let search ((ancestor parent))
@ -394,19 +311,19 @@
;; Question -> Question ;; Question -> Question
;; Returns a question equivalent to q, but in a 'restart context, for ;; Returns a question equivalent to q, but in a 'restart context, for
;; retracing from the roots in cases of excessive gluelessness. ;; retracing from the roots in cases of excessive gluelessness.
(: restart-question : Question -> Question) ;; (: restart-question : Question -> Question)
(define (restart-question q) (define (restart-question q)
(struct-copy question-repr q [context 'restart])) (struct-copy question q [context 'restart]))
;; DomainName Question -> Question ;; DomainName Question -> Question
;; Produces a new question with CNAME context. ;; Produces a new question with CNAME context.
(: cname-question : DomainName Question -> Question) ;; (: cname-question : DomainName Question -> Question)
(define (cname-question name q) (define (cname-question name q)
(match-define (question _ type class _) q) (match-define (question _ type class _) q)
(question name type class (cname-subq q))) (question name type class (cname-subq q)))
;; DomainName Question -> Question ;; DomainName Question -> Question
;; Produces a new question with NS context. ;; Produces a new question with NS context.
(: ns-question : DomainName Question -> Question) ;; (: ns-question : DomainName Question -> Question)
(define (ns-question name q) (define (ns-question name q)
(question name 'a 'in (ns-subq q))) ;; TODO: 'aaaa ? (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. ;; DNS wire-protocol codec.
;; ;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu> ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@ -19,17 +19,9 @@
;;; along with marketplace-dns. If not, see ;;; along with marketplace-dns. If not, see
;;; <http://www.gnu.org/licenses/>. ;;; <http://www.gnu.org/licenses/>.
(provide Opcode (provide value->query-opcode query-opcode->value
ResponseCode
value->query-opcode query-opcode->value
value->query-response-code query-response-code->value value->query-response-code query-response-code->value
DNSMessage
Direction
Authoritativeness
Truncatedness
RecursionDesired
RecursionAvailable
(struct-out dns-message) (struct-out dns-message)
packet->dns-message packet->dns-message
@ -50,9 +42,8 @@
;; An Opcode is a Symbol or a Number, one of the possibilities given ;; An Opcode is a Symbol or a Number, one of the possibilities given
;; in the following define-mapping. It represents a DNS message ;; in the following define-mapping. It represents a DNS message
;; operation; see the RFC for details. ;; operation; see the RFC for details.
(define-type Opcode (U 'query 'iquery 'status Nonnegative-Integer)) ;; (: value->query-opcode : Nonnegative-Integer -> Opcode)
(: value->query-opcode : Nonnegative-Integer -> Opcode) ;; (: query-opcode->value : Opcode -> Nonnegative-Integer)
(: query-opcode->value : Opcode -> Nonnegative-Integer)
(define-mapping value->query-opcode query-opcode->value (define-mapping value->query-opcode query-opcode->value
#:forward-default values #:forward-default values
#:backward-default values #:backward-default values
@ -63,11 +54,8 @@
;; A ResponseCode is a Symbol or a Number, one of the possibilities ;; A ResponseCode is a Symbol or a Number, one of the possibilities
;; given in the following define-mapping. It represents the outcome of ;; given in the following define-mapping. It represents the outcome of
;; a DNS query. ;; a DNS query.
(define-type ResponseCode (U 'no-error 'format-error 'server-failure ;; (: value->query-response-code : Nonnegative-Integer -> ResponseCode)
'name-error 'not-implemented 'refused ;; (: query-response-code->value : ResponseCode -> Nonnegative-Integer)
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 (define-mapping value->query-response-code query-response-code->value
(0 no-error) (0 no-error)
(1 format-error) (1 format-error)
@ -83,25 +71,24 @@
;; ;;
;; Interpreted as either a DNS request or reply, depending on the ;; Interpreted as either a DNS request or reply, depending on the
;; Direction. ;; Direction.
(struct: dns-message ([id : Nonnegative-Integer] (struct dns-message (id
[direction : Direction] direction
[opcode : Opcode] opcode
[authoritative : Authoritativeness] authoritative
[truncated : Truncatedness] truncated
[recursion-desired : RecursionDesired] recursion-desired
[recursion-available : RecursionAvailable] recursion-available
[response-code : ResponseCode] response-code
[questions : (Listof Question)] questions
[answers : (Listof RR)] answers
[authorities : (Listof RR)] authorities
[additional : (Listof RR)]) additional)
#:transparent) #:transparent)
(define-type DNSMessage dns-message) ;; (define-type Direction (U 'request 'response))
(define-type Direction (U 'request 'response)) ;; (define-type Authoritativeness (U 'non-authoritative 'authoritative))
(define-type Authoritativeness (U 'non-authoritative 'authoritative)) ;; (define-type Truncatedness (U 'not-truncated 'truncated))
(define-type Truncatedness (U 'not-truncated 'truncated)) ;; (define-type RecursionDesired (U 'no-recursion-desired 'recursion-desired))
(define-type RecursionDesired (U 'no-recursion-desired 'recursion-desired)) ;; (define-type RecursionAvailable (U 'no-recursion-available 'recursion-available))
(define-type RecursionAvailable (U 'no-recursion-available 'recursion-available))
;; Bit-syntax type for counted repeats of a value. ;; Bit-syntax type for counted repeats of a value.
;; Example: Length-prefixed list of 32-bit unsigned words: ;; 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 ;; here, but I can't find a way of expressing the types
;; required while making that work. This way, we avoid needing ;; required while making that work. This way, we avoid needing
;; to mention the type of the result of calls to ks. ;; 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) (define (loop count acc input)
(cond (cond
((positive? count) (bit-string-case input ((positive? count) (bit-string-case input
@ -158,7 +145,7 @@
(else (else
(kf)))) (kf))))
((_ #f vs Type option ...) ((_ #f vs Type option ...)
(let: loop : BitString ((vs : (Listof Type) vs)) (let loop ((vs vs))
(cond (cond
((pair? vs) (bit-string ((car vs) :: option ...) ((pair? vs) (bit-string ((car vs) :: option ...)
((loop (cdr vs)) :: binary))) ((loop (cdr vs)) :: binary)))
@ -202,7 +189,7 @@
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ ;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; </rfc1035> ;; </rfc1035>
(: packet->dns-message : BitString -> DNSMessage) ;; (: packet->dns-message : BitString -> DNSMessage)
;; Parse an encoded DNS message packet into the corresponding Racket ;; Parse an encoded DNS message packet into the corresponding Racket
;; structure. Raises an exception on failure. ;; structure. Raises an exception on failure.
(define (packet->dns-message packet) (define (packet->dns-message packet)
@ -232,7 +219,7 @@
(value->query-response-code rcode) (value->query-response-code rcode)
q-section a-section auth-section additional-section)))) 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. ;; Render a Racket structured DNS message using the DNS binary encoding.
(define (dns-message->packet m) (define (dns-message->packet m)
(bit-string->bytes (bit-string->bytes
@ -288,14 +275,14 @@
((_ #f val) ((_ #f val)
(encode-domain-name val)))) (encode-domain-name val))))
(: encode-domain-name : DomainName -> BitString) ;; (: encode-domain-name : DomainName -> BitString)
(define (encode-domain-name name) (define (encode-domain-name name)
(define labels (domain-labels name)) (define labels (domain-labels name))
(bit-string (labels :: (t:listof Bytes (t:pascal-string "Label" 64))) (bit-string (labels :: (t:listof Bytes (t:pascal-string "Label" 64)))
(0 :: integer bytes 1))) ;; end of list of labels! (0 :: integer bytes 1))) ;; end of list of labels!
(: parse-domain-name : ;; (: parse-domain-name :
BitString BitString (Listof Natural) -> (Values (Listof Bytes) BitString)) ;; BitString BitString (Listof Natural) -> (Values (Listof Bytes) BitString))
;; PRECONDITION: input never empty ;; PRECONDITION: input never empty
;; INVARIANT: pointers-followed contains every "jump target" we have ;; INVARIANT: pointers-followed contains every "jump target" we have
;; jumped to so far during decoding of this domain-name, in order to ;; jumped to so far during decoding of this domain-name, in order to
@ -337,7 +324,7 @@
((_ #f val) ((_ #f val)
(t:pascal-string #f val "Character-string" 256)) (t:pascal-string #f val "Character-string" 256))
((_ #f val string-kind length-limit) ((_ #f val string-kind length-limit)
(let: ([s : Bytes val]) (let ([s val])
(let ((len (bytes-length s))) (let ((len (bytes-length s)))
(when (>= len length-limit) (when (>= len length-limit)
(error 't:pascal-string "~s too long: ~v" string-kind s)) (error 't:pascal-string "~s too long: ~v" string-kind s))
@ -377,10 +364,10 @@
#f) #f)
tail)))) tail))))
((_ #f val) ((_ #f val)
(let: ([q : Question val]) (let ([q val])
(bit-string ((question-repr-name q) :: (t:domain-name)) (bit-string ((question-name q) :: (t:domain-name))
((qtype->value (question-repr-type q)) :: bits 16) ((qtype->value (question-type q)) :: bits 16)
((qclass->value (question-repr-class q)) :: bits 16)))))) ((qclass->value (question-class q)) :: bits 16))))))
;; <rfc1035> ;; <rfc1035>
;; All RRs have the same top level format shown below: ;; All RRs have the same top level format shown below:
@ -429,7 +416,7 @@
tail))) tail)))
(else (kf))))) (else (kf)))))
((_ #f val) ((_ #f val)
(let: ([rr : RR val]) (let ([rr val])
(let ((encoded-rdata (encode-rdata (rr-rdata rr)))) (let ((encoded-rdata (encode-rdata (rr-rdata rr))))
(bit-string ((rr-name rr) :: (t:domain-name)) (bit-string ((rr-name rr) :: (t:domain-name))
((type->value (rdata-type (rr-rdata rr))) :: bits 16) ((type->value (rdata-type (rr-rdata rr))) :: bits 16)
@ -438,7 +425,7 @@
((quotient (bit-string-length encoded-rdata) 8) :: bits 16) ((quotient (bit-string-length encoded-rdata) 8) :: bits 16)
(encoded-rdata :: binary))))))) (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 ;; Decode RData according to the RRType. Takes the whole packet for
;; the same reason as t:rr does. ;; the same reason as t:rr does.
(define (decode-rdata whole-packet type rdata) (define (decode-rdata whole-packet type rdata)
@ -487,7 +474,7 @@
(rdata-srv type priority weight port target)))) (rdata-srv type priority weight port target))))
(else (rdata-raw type (bit-string->bytes rdata))))) (else (rdata-raw type (bit-string->bytes rdata)))))
(: encode-rdata : RData -> BitString) ;; (: encode-rdata : RData -> BitString)
;; Encode RData according to its RRType. ;; Encode RData according to its RRType.
(define (encode-rdata rdata) (define (encode-rdata rdata)
(match rdata (match rdata
@ -519,5 +506,5 @@
[(rdata-raw _ bs) bs])) [(rdata-raw _ bs) bs]))
;; UInt32 ;; UInt32
(: max-ttl : Nonnegative-Integer) ;; (: max-ttl : Nonnegative-Integer)
(define max-ttl #xffffffff) (define max-ttl #xffffffff)

42
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. ;; DNS server using os-big-bang.rkt and os-udp.rkt.
;; ;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu> ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@ -28,7 +28,7 @@
(require "codec.rkt") (require "codec.rkt")
(require "zonedb.rkt") (require "zonedb.rkt")
(require "resolver.rkt") (require "resolver.rkt")
(require marketplace/sugar-typed) (require marketplace/sugar)
(require marketplace/support/spy) (require marketplace/support/spy)
(require marketplace/drivers/udp) (require marketplace/drivers/udp)
(require "tk-dns.rkt") (require "tk-dns.rkt")
@ -46,7 +46,7 @@
;; determines subzones based on the RRs it is configured with at ;; determines subzones based on the RRs it is configured with at
;; startup. ;; 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 ;; 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 ;; UDP port based on the RRs it is given and the zone origin specified
;; in the soa-rr given. ;; in the soa-rr given.
@ -58,26 +58,26 @@
(display ";; Ready.\n") (display ";; Ready.\n")
(ground-vm: ((inst udp-driver Void)) (ground-vm (udp-driver)
((inst generic-spy Void) 'UDP) (generic-spy 'UDP)
(spawn-vm: : Void (spawn-vm
(spawn: #:parent : Void #:child : Void (dns-spy)) (spawn (dns-spy))
(spawn: #:parent : Void #:child : Void (dns-read-driver local-addr)) (spawn (dns-read-driver local-addr))
(spawn: #:parent : Void #:child : Void (dns-write-driver local-addr)) (spawn (dns-write-driver local-addr))
(subscriber: Void (bad-dns-packet-pattern (wild) (wild) (wild) (wild)) (subscriber (bad-dns-packet (wild) (wild) (wild) (wild))
(on-message [p (begin (log-error (pretty-format p)) '())])) (on-message [p (begin (log-error (pretty-format p)) '())]))
(subscriber: Void (dns-request-pattern (wild) (wild) (wild)) (subscriber (dns-request (wild) (wild) (wild))
(on-message [(? dns-request? r) (on-message [(? dns-request? r)
(let ((reply (handle-request soa-rr zone r))) (let ((reply (handle-request soa-rr zone r)))
(when reply (send-message reply)))]))))) (when reply (send-message reply)))])))))
(define-type ReplyMaker (DomainName Boolean (Setof RR) (Setof RR) (Setof RR) -> DNSMessage)) ;; (define-type ReplyMaker (DomainName Boolean (Setof RR) (Setof RR) (Setof RR) -> DNSMessage))
(: handle-request : RR CompiledZone DNSRequest -> (Option DNSReply)) ;; (: handle-request : RR CompiledZone DNSRequest -> (Option DNSReply))
(define (handle-request soa-rr zone request) (define (handle-request soa-rr zone request)
(match-define (dns-request request-message request-source request-sink) 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) (define (make-reply name send-name-error? answers authorities additional)
(dns-message (dns-message-id request-message) (dns-message (dns-message-id request-message)
'response 'response
@ -92,7 +92,7 @@
(rr-set->list authorities) (rr-set->list authorities)
(rr-set->list additional))) (rr-set->list additional)))
(: answer-question : Question ReplyMaker -> DNSMessage) ;; (: answer-question : Question ReplyMaker -> DNSMessage)
(define (answer-question q make-reply) (define (answer-question q make-reply)
;; Notice that we claim to be authoritative for our configured ;; Notice that we claim to be authoritative for our configured
;; zone. If we ever answer name-error, that means there are no RRs ;; zone. If we ever answer name-error, that means there are no RRs
@ -110,7 +110,7 @@
;; here. Reexamine the rules for doing so. ;; here. Reexamine the rules for doing so.
(match-define (question qname qtype qclass #f) q) (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) (define (expand-cnames worklist ans)
(match worklist (match worklist
['() ['()
@ -120,7 +120,7 @@
(define a (resolve-from-zone (cname-question next-cname q) zone soa-rr (set))) (define a (resolve-from-zone (cname-question next-cname q) zone soa-rr (set)))
(incorporate-answer a rest ans)])) (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) (define (incorporate-answer this-answer worklist ans)
(match this-answer (match this-answer
[(partial-answer new-info more-cnames) [(partial-answer new-info more-cnames)

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 ;; Macros for defining weak and extensible mappings between sets of values
;; ;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu> ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>

151
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> ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
;;; ;;;
@ -23,17 +23,13 @@
(require "api.rkt") (require "api.rkt")
(require "codec.rkt") (require "codec.rkt")
(require "zonedb.rkt") (require "zonedb.rkt")
(require marketplace/sugar-typed) (require marketplace/sugar)
(require marketplace/drivers/udp) (require marketplace/drivers/udp)
(require marketplace/drivers/timer) (require marketplace/drivers/timer)
(require marketplace/support/pseudo-substruct)
(require "tk-dns.rkt") (require "tk-dns.rkt")
(require (rename-in marketplace/tr-struct-copy [tr-struct-copy struct-copy])) ;; PR13149
(provide network-query (provide network-query
(struct-out network-reply-repr) (struct-out network-reply))
NetworkReply network-reply network-reply?
NetworkReplyPattern network-reply-pattern network-reply-pattern?)
;; DJB's rules for handling DNS responses. Some of these are handled ;; DJB's rules for handling DNS responses. Some of these are handled
;; here (specifically, rules 2 through 5, in the action of ;; here (specifically, rules 2 through 5, in the action of
@ -130,45 +126,32 @@
;; A NetworkRequest is a (network-request UdpAddress Question ;; A NetworkRequest is a (network-request UdpAddress Question
;; DomainName NEListOf<DomainName> UniqueID) representing the ;; DomainName NEListOf<DomainName> UniqueID) representing the
;; parameters used to start and process a network query. ;; parameters used to start and process a network query.
(struct: network-request ([client-socket : UdpAddress] (struct network-request (client-socket question zone-origin server-names unique-id) #:transparent)
[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>) ;; A NetworkReply is a (network-reply UniqueID Maybe<CompleteAnswer>)
;; representing the final result of a network query. ;; representing the final result of a network query.
(struct: (TId TAnswer) (struct network-reply (unique-id answer) #:transparent)
network-reply-repr
([unique-id : TId] [answer : TAnswer]) #:transparent)
(pseudo-substruct: (network-reply-repr Any (Option CompleteAnswer))
NetworkReply network-reply network-reply?)
(pseudo-substruct: (network-reply-repr (U Wild Any) (U Wild (Option CompleteAnswer)))
NetworkReplyPattern network-reply-pattern network-reply-pattern?)
;; A NetworkQueryState is a (network-query-state NetworkRequest ;; A NetworkQueryState is a (network-query-state NetworkRequest
;; Integer Map<DomainName,ListOf<UdpAddress>> ListOf<UdpAddress> ;; Integer Map<DomainName,ListOf<UdpAddress>> ListOf<UdpAddress>
;; Maybe<DomainName> ListOf<DomainName>), representing an in-progress ;; Maybe<DomainName> ListOf<DomainName>), representing an in-progress
;; DNS network query. ;; DNS network query.
(struct: network-query-state ([request : NetworkRequest] (struct network-query-state (request
[timeout : (Option Natural)] timeout
[known-addresses : (HashTable DomainName (Listof UdpAddress))] known-addresses
[remaining-addresses : (Listof UdpAddress)] remaining-addresses
[current-name : (Option DomainName)] current-name
[remaining-names : (Listof DomainName)]) remaining-names)
#:transparent) #:transparent)
(define-type NetworkQueryState network-query-state)
(: next-timeout : Natural -> (Option Natural)) ;; (: next-timeout : Natural -> (Option Natural))
(define (next-timeout timeout) (define (next-timeout timeout)
(cond (cond
[(equal? timeout 3) 11] [(equal? timeout 3) 11]
[(equal? timeout 11) 45] [(equal? timeout 11) 45]
[else #f])) [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) (define (make-dns-query-message q query-id)
(dns-message query-id (dns-message query-id
'request 'request
@ -183,9 +166,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 ;; Filters RRs from the answer, authorities, and additional sections
;; of the passed-in `message`, returning the set of RRs surviving the ;; of the passed-in `message`, returning the set of RRs surviving the
;; filter. RRs are only accepted if their `rr-name` falls in the ;; filter. RRs are only accepted if their `rr-name` falls in the
@ -200,25 +183,24 @@
(define (filter-dns-reply q message zone-origin) (define (filter-dns-reply q message zone-origin)
(case (dns-message-response-code message) (case (dns-message-response-code message)
[(no-error) [(no-error)
(: f : (Listof RR) -> (Setof RR)) ;; (: f : (Listof RR) -> (Setof RR))
(define (f l) (define (f l)
(list->set (filter (lambda: ([claim-rr : RR]) (list->set (filter (lambda (claim-rr) (in-bailiwick? (rr-name claim-rr) zone-origin)) l)))
(in-bailiwick? (rr-name claim-rr) zone-origin)) l)))
;; Here's where we do the "lame referral" check. This code is ;; Here's where we do the "lame referral" check. This code is
;; nice and simple (though wrong) without it. Ho hum. ;; nice and simple (though wrong) without it. Ho hum.
(define answers (f (dns-message-answers message))) (define answers (f (dns-message-answers message)))
(define unfiltered-authorities (dns-message-authorities 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 (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) (filter (lambda (rr) (and (eqv? (rdata-type (rr-rdata rr)) 'ns)
(or (equal? (rr-name rr) zone-origin) (or (equal? (rr-name rr) zone-origin)
(not (in-bailiwick? (rr-name rr) zone-origin))))) (not (in-bailiwick? (rr-name rr) zone-origin)))))
unfiltered-authorities)) unfiltered-authorities))
(define authorities (f unfiltered-authorities)) (define authorities (f unfiltered-authorities))
(define answers-to-q ;; answers specifically to the question we asked (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? (define lame?
(and (set-empty? (filter-by-type answers-to-q 'cname)) (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)) (set-empty? (filter-by-type authorities 'soa))
(not (null? non-subzone-ns-rrs)))) (not (null? non-subzone-ns-rrs))))
(if lame? (if lame?
@ -233,31 +215,29 @@
(dns-message-questions message))) (dns-message-questions message)))
'bad-answer])) 'bad-answer]))
(: ip->host-name : IPv4 -> String) ;; (: ip->host-name : IPv4 -> String)
(define (ip->host-name ip-address) (define (ip->host-name ip-address)
(match-define (vector a b c d) ip-address) (match-define (vector a b c d) ip-address)
(format "~a.~a.~a.~a" a b c d)) (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) (define (make-dns-address ip-address)
(udp-remote-address (ip->host-name ip-address) 53)) (udp-remote-address (ip->host-name ip-address) 53))
(: network-query : (All (ParentState) ;; (: network-query : (All (ParentState)
UdpAddress Question DomainName (Listof DomainName) Any -> ;; UdpAddress Question DomainName (Listof DomainName) Any ->
(Action ParentState))) ;; (Action ParentState)))
(define (network-query s q zone-origin server-names unique-id) (define (network-query s q zone-origin server-names unique-id)
(name-process (list 'network-query q) (name-process (list 'network-query q)
(spawn: #:parent : ParentState (spawn (try-next-server
#:child : NetworkQueryState (network-query-state (network-request s q zone-origin server-names unique-id)
(try-next-server first-timeout
(network-query-state (network-request s q zone-origin server-names unique-id) #hash()
first-timeout '()
(ann #hash() (HashTable DomainName (Listof UdpAddress))) #f
'() server-names)))))
#f
server-names)))))
(: try-next-server : NetworkQueryState -> (Transition NetworkQueryState)) ;; (: try-next-server : NetworkQueryState -> (Transition NetworkQueryState))
(define (try-next-server w) (define (try-next-server w)
(define timeout (network-query-state-timeout w)) (define timeout (network-query-state-timeout w))
(if (not timeout) (if (not timeout)
@ -280,31 +260,31 @@
[current-name current-name] [current-name current-name]
[remaining-names remaining-names])) [remaining-names remaining-names]))
(let ((subq (ns-question current-name (network-request-question req)))) (let ((subq (ns-question current-name (network-request-question req))))
(transition: (struct-copy network-query-state w (transition (struct-copy network-query-state w
[current-name current-name] [current-name current-name]
[remaining-names remaining-names]) : NetworkQueryState [remaining-names remaining-names])
(send-message subq) (send-message subq)
(let-fresh (subq-id) (let-fresh (subq-id)
(name-endpoint subq-id (name-endpoint subq-id
(subscriber: NetworkQueryState (answered-question-pattern subq (wild)) (subscriber (answered-question subq (wild))
(match-state w (match-state w
(on-message (on-message
[(answered-question (== subq) ans) [(answered-question (== subq) ans)
(let ((ips (map make-dns-address (let ((ips (map make-dns-address
(set->list (extract-addresses current-name ans))))) (set->list (extract-addresses current-name ans)))))
(sequence-actions (sequence-actions
(try-next-server (struct-copy network-query-state w (try-next-server (struct-copy network-query-state w
[known-addresses (hash-set known-addresses [known-addresses (hash-set known-addresses
current-name current-name
ips)] ips)]
[remaining-addresses ips])) [remaining-addresses ips]))
(delete-endpoint subq-id)))]))))))))] (delete-endpoint subq-id)))]))))))))]
[(network-query-state req _ _ (cons current-ip remaining-ips) _ _) [(network-query-state req _ _ (cons current-ip remaining-ips) _ _)
(define rpc-id (gensym 'network-query/allocate-query-id)) (define rpc-id (gensym 'network-query/allocate-query-id))
(transition: w : NetworkQueryState (transition w
(send-message `(request ,rpc-id allocate-query-id)) (send-message `(request ,rpc-id allocate-query-id))
(name-endpoint rpc-id (name-endpoint rpc-id
(subscriber: NetworkQueryState `(reply ,rpc-id ,(wild)) (subscriber `(reply ,rpc-id ,(wild))
(match-state w (match-state w
(on-message (on-message
[`(reply ,(== rpc-id) ,(? exact-nonnegative-integer? id)) [`(reply ,(== rpc-id) ,(? exact-nonnegative-integer? id))
@ -313,10 +293,10 @@
id id
timeout timeout
current-ip) current-ip)
(delete-endpoint rpc-id))])))))]))) (delete-endpoint rpc-id))])))))])))
(: on-answer : NetworkQueryState CheckedAnswer (Option UdpAddress) ;; (: on-answer : NetworkQueryState CheckedAnswer (Option UdpAddress)
-> (Transition NetworkQueryState)) ;; -> (Transition NetworkQueryState))
(define (on-answer w ans server-ip) (define (on-answer w ans server-ip)
(match ans (match ans
['bad-answer ;; can come from filter-dns-reply ['bad-answer ;; can come from filter-dns-reply
@ -334,17 +314,16 @@
(struct-copy network-query-state w (struct-copy network-query-state w
[known-addresses (hash-update known-addresses [known-addresses (hash-update known-addresses
current-name current-name
(lambda: ([addrs : (Listof (lambda (addrs)
UdpAddress)])
(remove server-ip addrs)))]) (remove server-ip addrs)))])
w))] w))]
[(and (or (? complete-answer?) #f) ans) [(and (or (? complete-answer?) #f) ans)
(transition: w : NetworkQueryState (transition w
(send-message (network-reply (network-request-unique-id (network-query-state-request w)) (send-message (network-reply (network-request-unique-id (network-query-state-request w))
ans)))])) ans)))]))
(: send-request : NetworkQueryState Nonnegative-Integer Natural UdpAddress ;; (: send-request : NetworkQueryState Nonnegative-Integer Natural UdpAddress
-> (Transition NetworkQueryState)) ;; -> (Transition NetworkQueryState))
(define (send-request w query-id timeout server-ip) (define (send-request w query-id timeout server-ip)
(match-define (network-request s q zone-origin _ _) (network-query-state-request w)) (match-define (network-request s q zone-origin _ _) (network-query-state-request w))
(define query (make-dns-query-message q query-id)) (define query (make-dns-query-message q query-id))
@ -355,12 +334,12 @@
q query-id q query-id
zone-origin server-ip zone-origin server-ip
timeout)) timeout))
(transition: w : NetworkQueryState (transition w
(send-message (dns-request query s server-ip)) (send-message (dns-request query s server-ip))
(send-message (set-timer timeout-id (* timeout 1000) 'relative)) (send-message (set-timer timeout-id (* timeout 1000) 'relative))
;; TODO: Restore this to a "join" when proper pattern-unions are implemented ;; TODO: Restore this to a "join" when proper pattern-unions are implemented
(name-endpoint timeout-id (name-endpoint timeout-id
(subscriber: NetworkQueryState (timer-expired-pattern timeout-id (wild)) (subscriber (timer-expired timeout-id (wild))
(match-state w (match-state w
(on-message (on-message
[(timer-expired (== timeout-id) _) [(timer-expired (== timeout-id) _)
@ -370,11 +349,11 @@
zone-origin server-ip zone-origin server-ip
timeout)) timeout))
(sequence-actions (try-next-server w) (sequence-actions (try-next-server w)
(delete-endpoint timeout-id) (delete-endpoint timeout-id)
(delete-endpoint reply-wait-id) (delete-endpoint reply-wait-id)
(send-message (list 'release-query-id query-id))))])))) (send-message (list 'release-query-id query-id))))]))))
(name-endpoint reply-wait-id (name-endpoint reply-wait-id
(subscriber: NetworkQueryState (dns-reply-pattern (wild) (wild) s) (subscriber (dns-reply (wild) (wild) s)
(match-state w (match-state w
(on-message (on-message
[(dns-reply reply-message source (== s)) [(dns-reply reply-message source (== s))
@ -389,10 +368,10 @@
(dns-message-authorities reply-message) (dns-message-authorities reply-message)
(dns-message-additional reply-message))) (dns-message-additional reply-message)))
(if (not (= (dns-message-id reply-message) (dns-message-id query))) (if (not (= (dns-message-id reply-message) (dns-message-id query)))
(transition: w : NetworkQueryState) (transition w)
(sequence-actions (on-answer w (sequence-actions (on-answer w
(filter-dns-reply q reply-message zone-origin) (filter-dns-reply q reply-message zone-origin)
server-ip) server-ip)
(delete-endpoint timeout-id) (delete-endpoint timeout-id)
(delete-endpoint reply-wait-id) (delete-endpoint reply-wait-id)
(send-message (list 'release-query-id query-id)))))])))))) (send-message (list 'release-query-id query-id)))))]))))))

230
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. ;; DNS proxy using os-big-bang.rkt and os-udp.rkt.
;; ;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu> ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@ -28,7 +28,7 @@
(require "zonedb.rkt") (require "zonedb.rkt")
(require "network-query.rkt") (require "network-query.rkt")
(require "resolver.rkt") (require "resolver.rkt")
(require marketplace/sugar-typed) (require marketplace/sugar)
(require marketplace/support/spy) (require marketplace/support/spy)
(require marketplace/drivers/timer) (require marketplace/drivers/timer)
(require marketplace/drivers/udp) (require marketplace/drivers/udp)
@ -40,70 +40,59 @@
;; searches from. Performs recursive queries. ;; searches from. Performs recursive queries.
;; For discarding retransmitted requests that we're still working on. ;; For discarding retransmitted requests that we're still working on.
(struct: active-request ([source : UdpAddress] [id : Natural]) #:transparent) (struct active-request (source id) #:transparent)
(define-type ActiveRequest active-request)
(: start-proxy : Natural CompiledZone CompiledZone -> Void) ;; (: start-proxy : Natural CompiledZone CompiledZone -> Void)
(define (start-proxy port-number zone roots-only) (define (start-proxy port-number zone roots-only)
(define server-addr (udp-listener port-number)) (define server-addr (udp-listener port-number))
(define client-addr (udp-handle 'dns-client)) (define client-addr (udp-handle 'dns-client))
(log-info "Ready.") (log-info "Ready.")
(ground-vm: (ground-vm
((inst generic-spy Void) 'UDP) (generic-spy 'UDP)
((inst udp-driver Void)) (udp-driver)
((inst timer-driver Void)) (timer-driver)
(spawn-vm: : Void (spawn-vm #:debug-name 'dns-vm
#:debug-name 'dns-vm (name-process 'dns-spy (spawn (dns-spy)))
(name-process 'dns-spy (spawn: #:parent : Void #:child : Void (dns-spy))) (timer-relay 'timer-relay:dns)
((inst timer-relay Void) 'timer-relay:dns) (name-process 'query-id-allocator (spawn (query-id-allocator)))
(name-process 'query-id-allocator (spawn: #:parent : Void #:child : (Setof Natural) (name-process 'server-dns-reader (spawn (dns-read-driver server-addr)))
(query-id-allocator))) (name-process 'server-dns-writer (spawn (dns-write-driver server-addr)))
(name-process 'server-dns-reader (spawn: #:parent : Void #:child : Void (name-process 'client-dns-reader (spawn (dns-read-driver client-addr)))
(dns-read-driver server-addr))) (name-process 'client-dns-writer (spawn (dns-write-driver client-addr)))
(name-process 'server-dns-writer (spawn: #:parent : Void #:child : Void (name-process 'packet-dispatcher (spawn (packet-dispatcher server-addr)))
(dns-write-driver server-addr))) (name-process 'question-dispatcher (spawn (question-dispatcher zone
(name-process 'client-dns-reader (spawn: #:parent : Void #:child : Void roots-only
(dns-read-driver client-addr))) client-addr))))))
(name-process 'client-dns-writer (spawn: #:parent : Void #:child : Void
(dns-write-driver client-addr)))
(name-process 'packet-dispatcher (spawn: #:parent : Void
#:child : (Setof ActiveRequest)
(packet-dispatcher server-addr)))
(name-process 'question-dispatcher (spawn: #:parent : Void
#:child : CompiledZone
(question-dispatcher zone
roots-only
client-addr))))))
(: query-id-allocator : -> (Transition (Setof Natural))) ;; (: query-id-allocator : -> (Transition (Setof Natural)))
(define (query-id-allocator) (define (query-id-allocator)
;; TODO: track how many are allocated and throttle requests if too ;; TODO: track how many are allocated and throttle requests if too
;; many are in flight ;; many are in flight
(transition: ((inst set Natural)) : (Setof Natural) ;; all active query IDs (transition (set) ;; all active query IDs
(subscriber: (Setof Natural) `(request ,(wild) allocate-query-id) (subscriber `(request ,(wild) allocate-query-id)
(match-state allocated (match-state allocated
(on-message (on-message
[`(request ,reply-addr allocate-query-id) [`(request ,reply-addr allocate-query-id)
(let: recheck : (Transition (Setof Natural)) () (let recheck ()
(define n (random 65536)) (define n (random 65536))
(if (set-member? allocated n) (if (set-member? allocated n)
(recheck) (recheck)
(transition: (set-add allocated n) : (Setof Natural) (transition (set-add allocated n)
(send-message `(reply ,reply-addr ,n)))))]))) (send-message `(reply ,reply-addr ,n)))))])))
(subscriber: (Setof Natural) `(release-query-id ,(wild)) (subscriber `(release-query-id ,(wild))
(match-state allocated (match-state allocated
(on-message (on-message
[`(release-query-id ,(? exact-nonnegative-integer? n)) [`(release-query-id ,(? exact-nonnegative-integer? n))
(transition: (set-remove allocated n) : (Setof Natural))]))))) (transition (set-remove allocated n))])))))
(: packet-dispatcher : UdpAddress -> (Transition (Setof ActiveRequest))) ;; (: packet-dispatcher : UdpAddress -> (Transition (Setof ActiveRequest)))
(define (packet-dispatcher s) (define (packet-dispatcher s)
(transition: ((inst set ActiveRequest)) : (Setof ActiveRequest) (transition (set)
(subscriber: (Setof ActiveRequest) (bad-dns-packet-pattern (wild) (wild) (wild) (wild)) (subscriber (bad-dns-packet (wild) (wild) (wild) (wild))
(on-message [p (begin (log-error (pretty-format p)) '())])) (on-message [p (begin (log-error (pretty-format p)) '())]))
(subscriber: (Setof ActiveRequest) (dns-request-pattern (wild) (wild) s) (subscriber (dns-request (wild) (wild) s)
(match-state old-active-requests (match-state old-active-requests
(on-message (on-message
[(and r (dns-request m source (== s))) [(and r (dns-request m source (== s)))
@ -112,23 +101,22 @@
;; TODO: when we have presence/error-handling, remove req-id ;; TODO: when we have presence/error-handling, remove req-id
;; from active requests once request-handler pseudothread exits. ;; from active requests once request-handler pseudothread exits.
(if (set-member? old-active-requests req-id) (if (set-member? old-active-requests req-id)
(transition: old-active-requests : (Setof ActiveRequest)) (transition old-active-requests)
;; ^ ignore retransmitted duplicates ;; ^ ignore retransmitted duplicates
(transition: (set-add old-active-requests req-id) : (Setof ActiveRequest) (transition (set-add old-active-requests req-id)
(name-process (list 'packet-relay req-id) (name-process (list 'packet-relay req-id)
(spawn: #:parent : (Setof ActiveRequest) (spawn (packet-relay req-id r))))))])))
#:child : Void (packet-relay req-id r))))))]))) (subscriber (dns-reply (wild) s (wild))
(subscriber: (Setof ActiveRequest) (dns-reply-pattern (wild) s (wild))
(match-state old-active-requests (match-state old-active-requests
(on-message (on-message
[(and r (dns-reply m (== s) sink)) [(and r (dns-reply m (== s) sink))
(let ((req-id (active-request sink (dns-message-id m)))) (let ((req-id (active-request sink (dns-message-id m))))
(transition: (set-remove old-active-requests req-id) : (Setof ActiveRequest)))]))))) (transition (set-remove old-active-requests req-id)))])))))
(: packet-relay : ActiveRequest DNSRequest -> (Transition Void)) ;; (: packet-relay : ActiveRequest DNSRequest -> (Transition Void))
(define (packet-relay req-id request) (define (packet-relay req-id request)
(match-define (dns-request request-message request-source request-sink) 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 (answer->reply q a)
(define-values (response-code ns us ds) (define-values (response-code ns us ds)
(match a (match a
@ -165,7 +153,7 @@
(send-message original-question) (send-message original-question)
(let-fresh (wait-id) (let-fresh (wait-id)
(name-endpoint wait-id (name-endpoint wait-id
(subscriber: Void (answered-question-pattern original-question (wild)) (subscriber (answered-question original-question (wild))
(on-message (on-message
[(answered-question (== original-question) answer) [(answered-question (== original-question) answer)
(begin (log-debug (format "Final answer to ~v with query id ~v is ~v" (begin (log-debug (format "Final answer to ~v with query id ~v is ~v"
@ -175,14 +163,14 @@
(list (delete-endpoint wait-id) (list (delete-endpoint wait-id)
(send-message (answer->reply original-question answer))))])))))])) (send-message (answer->reply original-question answer))))])))))]))
(: glueless-question-handler : CompiledZone Question UdpAddress -> (Transition Void)) ;; (: glueless-question-handler : CompiledZone Question UdpAddress -> (Transition Void))
(define (glueless-question-handler roots-only-zone q client-sock) (define (glueless-question-handler roots-only-zone q client-sock)
;; Restart q, an overly-glueless question, from the roots. ;; Restart q, an overly-glueless question, from the roots.
(define restarted-question (restart-question q)) (define restarted-question (restart-question q))
(transition/no-state (transition/no-state
(let-fresh (relay) (let-fresh (relay)
(name-endpoint relay (name-endpoint relay
(subscriber: Void (answered-question-pattern restarted-question (wild)) (subscriber (answered-question restarted-question (wild))
(on-message (on-message
[(answered-question (== restarted-question) ans) [(answered-question (== restarted-question) ans)
;; We got the answer to our restarted question; now transform ;; We got the answer to our restarted question; now transform
@ -191,23 +179,21 @@
(list (delete-endpoint relay) (list (delete-endpoint relay)
(send-message (answered-question q ans)))])))) (send-message (answered-question q ans)))]))))
(name-process (list 'glueless-question-handler-inner restarted-question) (name-process (list 'glueless-question-handler-inner restarted-question)
(spawn: #:parent : Void (spawn (question-handler roots-only-zone restarted-question client-sock)))))
#:child : QHState
(question-handler roots-only-zone restarted-question client-sock)))))
(: question-dispatcher : CompiledZone CompiledZone UdpAddress -> (Transition CompiledZone)) ;; (: question-dispatcher : CompiledZone CompiledZone UdpAddress -> (Transition CompiledZone))
(define (question-dispatcher seed-zone roots-only client-sock) (define (question-dispatcher seed-zone roots-only client-sock)
(: transition-and-set-timers : CompiledZone (Setof (Pairof DomainName Real)) ;; (: transition-and-set-timers : CompiledZone (Setof (Pairof DomainName Real))
-> (Transition CompiledZone)) ;; -> (Transition CompiledZone))
(define (transition-and-set-timers new-zone timers) (define (transition-and-set-timers new-zone timers)
(transition: new-zone : CompiledZone (transition new-zone
(for/list: : (Listof (Action CompiledZone)) ([timerspec timers]) (for/list ([timerspec timers])
(match-define (cons name ttl) timerspec) (match-define (cons name ttl) timerspec)
(send-message (set-timer (list 'check-dns-expiry name) (* ttl 1000) 'relative))))) (send-message (set-timer (list 'check-dns-expiry name) (* ttl 1000) 'relative)))))
(define-values (cleaned-seed-zone initial-timers) (zone-expire seed-zone)) (define-values (cleaned-seed-zone initial-timers) (zone-expire seed-zone))
(sequence-actions (transition-and-set-timers cleaned-seed-zone initial-timers) (sequence-actions (transition-and-set-timers cleaned-seed-zone initial-timers)
;; TODO: consider deduping questions here too? ;; TODO: consider deduping questions here too?
(subscriber: CompiledZone `(debug-dump) (subscriber `(debug-dump)
(match-state zone (match-state zone
(on-message (on-message
[`(debug-dump) [`(debug-dump)
@ -222,9 +208,9 @@
(display "----------------------------------------------------------------------\n") (display "----------------------------------------------------------------------\n")
(display (seconds->date (current-seconds))) (display (seconds->date (current-seconds)))
(newline) (newline)
(for: ([name (in-hash-keys zone)]) (for ([name (in-hash-keys zone)])
(define rrmap (hash-ref zone name)) (define rrmap (hash-ref zone name))
(for: ([rr (in-hash-keys rrmap)]) (for ([rr (in-hash-keys rrmap)])
(define expiry (hash-ref rrmap rr)) (define expiry (hash-ref rrmap rr))
(write (list rr expiry)) (write (list rr expiry))
(newline))) (newline)))
@ -239,12 +225,12 @@
;; (pretty-write current-ground-transition)) ;; (pretty-write current-ground-transition))
;; #:mode 'text ;; #:mode 'text
;; #:exists 'append) ;; #:exists 'append)
(transition: zone : CompiledZone))]))) (transition zone))])))
(subscriber: CompiledZone (question-pattern (wild) (wild) (wild) (wild)) (subscriber (question (wild) (wild) (wild) (wild))
(match-state zone (match-state zone
(on-message (on-message
[(? question? q) [(? question? q)
(transition: zone : CompiledZone (transition zone
(cond (cond
[(question-cyclic? q) [(question-cyclic? q)
(log-warning (format "Cyclic question ~v" q)) (log-warning (format "Cyclic question ~v" q))
@ -252,49 +238,37 @@
[(question-too-glueless? q) [(question-too-glueless? q)
(log-warning (format "Overly-glueless question ~v" q)) (log-warning (format "Overly-glueless question ~v" q))
(name-process (list 'glueless-question-handler-outer q) (name-process (list 'glueless-question-handler-outer q)
(spawn: #:parent : CompiledZone (spawn (glueless-question-handler roots-only q client-sock)))]
#:child : Void
(glueless-question-handler roots-only q client-sock)))]
[else [else
(name-process (list 'question-handler q) (name-process (list 'question-handler q)
(spawn: #:parent : CompiledZone (spawn (question-handler zone q client-sock)))]))])))
#:child : QHState (subscriber (network-reply (wild) (wild))
(question-handler zone q client-sock)))]))])))
(subscriber: CompiledZone (network-reply-pattern (wild) (wild))
(match-state zone (match-state zone
(on-message (on-message
[(network-reply _ answer) [(network-reply _ answer)
(let-values (((new-zone timers) (incorporate-complete-answer answer zone #t))) (let-values (((new-zone timers) (incorporate-complete-answer answer zone #t)))
(transition-and-set-timers new-zone timers))]))) (transition-and-set-timers new-zone timers))])))
(subscriber: CompiledZone (timer-expired-pattern (list 'check-dns-expiry (wild)) (wild)) (subscriber (timer-expired (list 'check-dns-expiry (wild)) (wild))
(match-state zone (match-state zone
(on-message (on-message
[(timer-expired (list 'check-dns-expiry (? domain? name)) (? number? now-msec)) [(timer-expired (list 'check-dns-expiry (? domain? name)) (? number? now-msec))
(transition: (zone-expire-name zone name (/ now-msec 1000.0)) : CompiledZone)]))))) (transition (zone-expire-name zone name (/ now-msec 1000.0)))])))))
(struct: question-state ([zone : CompiledZone] (struct question-state (zone q client-sock nameservers-tried retry-count) #:transparent)
[q : Question]
[client-sock : UdpAddress]
[nameservers-tried : (Setof DomainName)]
[retry-count : Natural]) #:transparent)
(define-type QuestionState question-state)
(struct: expanding-cnames ([q : Question] (struct expanding-cnames (q accumulator remaining-count) #:transparent)
[accumulator : CompleteAnswer]
[remaining-count : Integer]) #:transparent)
(define-type ExpandingCNAMEs expanding-cnames)
(define-type QHState (U QuestionState ExpandingCNAMEs)) ;; (define-type QHState (U QuestionState ExpandingCNAMEs))
(: question-handler : CompiledZone Question UdpAddress -> (Transition QHState)) ;; (: question-handler : CompiledZone Question UdpAddress -> (Transition QHState))
(define (question-handler zone q client-sock) (define (question-handler zone q client-sock)
(retry-question (question-state zone q client-sock ((inst set DomainName)) 0))) (retry-question (question-state zone q client-sock (set) 0)))
(: send-empty-reply : QHState Question -> (Transition QHState)) ;; (: send-empty-reply : QHState Question -> (Transition QHState))
(define (send-empty-reply w q) (define (send-empty-reply w q)
(transition w (send-message (answered-question q (empty-complete-answer))))) (transition w (send-message (answered-question q (empty-complete-answer)))))
(: retry-question : QHState -> (Transition QHState)) ;; (: retry-question : QHState -> (Transition QHState))
(define (retry-question w) (define (retry-question w)
(match w (match w
[(question-state _ q _ _ 20) ;; TODO: is this a sensible limit? [(question-state _ q _ _ 20) ;; TODO: is this a sensible limit?
@ -313,18 +287,18 @@
(log-debug (format "Referral for ~v id ~v to ~v servers ~v" (log-debug (format "Referral for ~v id ~v to ~v servers ~v"
q referral-id (domain-labels zone-origin) q referral-id (domain-labels zone-origin)
(map domain-labels (set-map nameserver-rrs rr-rdata-domain-name)))) (map domain-labels (set-map nameserver-rrs rr-rdata-domain-name))))
(transition: w : QHState (transition w
((inst network-query QHState) client-sock (network-query client-sock
q q
zone-origin zone-origin
(map rr-rdata-domain-name (set->list nameserver-rrs)) (map rr-rdata-domain-name (set->list nameserver-rrs))
referral-id) referral-id)
(name-endpoint referral-id (name-endpoint referral-id
(subscriber: QHState (network-reply-pattern referral-id (wild)) (subscriber (network-reply referral-id (wild))
(match-state w (match-state w
(on-message (on-message
[(network-reply (== referral-id) #f) ;; name-error/NXDOMAIN [(network-reply (== referral-id) #f) ;; name-error/NXDOMAIN
(transition: w : QHState (transition w
(delete-endpoint referral-id) (delete-endpoint referral-id)
(send-message (answered-question q #f)))] (send-message (answered-question q #f)))]
[(network-reply (== referral-id) ans) [(network-reply (== referral-id) ans)
@ -342,9 +316,8 @@
(log-debug "=-=-=-=-=-=")) (log-debug "=-=-=-=-=-="))
(define nameserver-names (define nameserver-names
(list->set (list->set
(for/list: : (Listof DomainName) (for/list ([rr nameserver-rrs])
([rr nameserver-rrs]) (rr-rdata-domain-name rr))))
(rr-rdata-domain-name rr))))
(sequence-actions (sequence-actions
(retry-question (struct-copy question-state w (retry-question (struct-copy question-state w
[nameservers-tried (set-union nameservers-tried [nameservers-tried (set-union nameservers-tried
@ -353,30 +326,29 @@
[retry-count (+ old-retry-count 1)])) [retry-count (+ old-retry-count 1)]))
(delete-endpoint referral-id)))])))))] (delete-endpoint referral-id)))])))))]
[(? complete-answer? ans) [(? complete-answer? ans)
(transition: w : QHState (send-message (answered-question q ans)))] (transition w (send-message (answered-question q ans)))]
[(partial-answer base cnames) [(partial-answer base cnames)
(transition: (expanding-cnames q base (length cnames)) : QHState (transition (expanding-cnames q base (length cnames))
((inst map (ActionTree QHState) DomainName) (map (lambda (cname)
(lambda: ([cname : DomainName]) ;; TODO: record chains of CNAMEs to avoid pathologically-long chains
;; TODO: record chains of CNAMEs to avoid pathologically-long chains (define cname-q (cname-question cname q))
(define cname-q (cname-question cname q)) (list (send-message cname-q)
(list (send-message cname-q) (let-fresh (subscription-id)
(let-fresh (subscription-id) (name-endpoint subscription-id
(name-endpoint subscription-id (subscriber (answered-question cname-q (wild))
(subscriber: QHState (answered-question-pattern cname-q (wild)) (match-state (expanding-cnames q acc remaining)
(match-state (expanding-cnames q acc remaining) (on-message
(on-message [(answered-question (== cname-q) ans)
[(answered-question (== cname-q) ans) (let ()
(let () (define new-acc (if ans (merge-answers acc ans) acc))
(define new-acc (if ans (merge-answers acc ans) acc)) (define new-remaining (- remaining 1))
(define new-remaining (- remaining 1)) (define new-w (expanding-cnames q new-acc new-remaining))
(define new-w (expanding-cnames q new-acc new-remaining)) (transition new-w
(transition: new-w : QHState (delete-endpoint subscription-id)
(delete-endpoint subscription-id) (if (zero? new-remaining)
(if (zero? new-remaining) (send-message (answered-question q new-acc))
(send-message (answered-question q new-acc)) '())))])))))))
'())))]))))))) cnames))])]))
cnames))])]))
(require "test-rrs.rkt") (require "test-rrs.rkt")
(require racket/file) (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> ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
;;; ;;;
@ -27,12 +27,8 @@
(require "codec.rkt") (require "codec.rkt")
(require "zonedb.rkt") (require "zonedb.rkt")
(provide PartialAnswer (provide (struct-out partial-answer)
Referral
Answer
(struct-out partial-answer)
(struct-out referral) (struct-out referral)
resolve-from-zone) resolve-from-zone)
;; Rules: ;; Rules:
@ -67,27 +63,22 @@
;; -- a CompleteAnswer (a complete answer ready to send), ;; -- a CompleteAnswer (a complete answer ready to send),
;; -- #f (the domain name does not exist in the CompiledZone given), ;; -- #f (the domain name does not exist in the CompiledZone given),
;; -- a Referral (a referral to some other nameserver). ;; -- 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 PartialAnswer is a (partial-answer CompleteAnswer ListOf<DomainName>)
;; A collection of relevant RRs together with some CNAMEs that need expanding. ;; A collection of relevant RRs together with some CNAMEs that need expanding.
(struct: partial-answer ([base : CompleteAnswer] [cnames : (Listof DomainName)]) #:transparent) (struct partial-answer (base cnames) #:transparent)
(define-type PartialAnswer partial-answer)
;; A Referral is a (referral DomainName Set<RR> Set<RR>) ;; A Referral is a (referral DomainName Set<RR> Set<RR>)
(struct: referral ([zone-origin : DomainName] (struct referral (zone-origin nameserver-rrs additional) #:transparent)
[nameserver-rrs : (Setof RR)]
[additional : (Setof RR)]) #:transparent)
(define-type Referral referral)
(: answer-from-zone : Question CompiledZone (Option RR) -> Answer) ;; (: answer-from-zone : Question CompiledZone (Option RR) -> Answer)
;; An answer of #f here does NOT indicate a missing domain-name ;; An answer of #f here does NOT indicate a missing domain-name
;; (name-error/NXDOMAIN), but instead indicates that there are no ;; (name-error/NXDOMAIN), but instead indicates that there are no
;; records matching the query in the database given. It's up to the ;; records matching the query in the database given. It's up to the
;; caller to decide what to do about that. ;; caller to decide what to do about that.
(define (answer-from-zone q zone start-of-authority) (define (answer-from-zone q zone start-of-authority)
(match-define (question name qtype qclass _) q) (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 filtered-rrs (filter-rrs rrset qtype qclass))
(define cnames (filter-by-type rrset 'cname)) ;; TODO: filter by class too?? (define cnames (filter-by-type rrset 'cname)) ;; TODO: filter by class too??
(define answer-set (set-union cnames filtered-rrs)) (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 [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))])) (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) (define (closest-nameservers name zone)
(let: search ((name : (Option DomainName) name)) (let search ((name name))
(cond (cond
((not name) ((not name)
;; We've walked up the tree past the root. Give up. ;; We've walked up the tree past the root. Give up.
@ -124,45 +115,44 @@
;; Remove a label and keep looking. ;; Remove a label and keep looking.
(search (domain-parent name)))))) (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. ;; Returns a set of NS RRs in an arbitrary order.
(define (closest-untried-nameservers q zone nameservers-tried) (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)) (define ns-rrset (closest-nameservers name zone))
(list->set (list->set
(for/list: : (Listof RR) ([rr : RR ns-rrset] (for/list ([rr ns-rrset] #:when (not (set-member? nameservers-tried (rr-rdata-domain-name rr))))
#:when (not (set-member? nameservers-tried (rr-rdata-domain-name rr)))) 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) (define (empty-answer q zone start-of-authority)
(if (and start-of-authority ;; we are authoritative for something (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 ;; ^ 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 ;; ^ there are no RRs at all for this q
;; NXDOMAIN/name-error: we definitely know 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 #f
;; A normal no-answers packet otherwise. ;; A normal no-answers packet otherwise.
(empty-complete-answer))) (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 ;; Implements the "additional section" rules from RFC 1035 (and the
;; rules for IPv6 from RFC 3596). Provides A and AAAA records for ;; rules for IPv6 from RFC 3596). Provides A and AAAA records for
;; names mentioned in the "names" list that have entries in "zone". ;; names mentioned in the "names" list that have entries in "zone".
(define (additional-section/a zone names) (define (additional-section/a zone names)
;; RFC 3596 (section 3) requires that we process AAAA here as well ;; RFC 3596 (section 3) requires that we process AAAA here as well
;; as A. ;; as A.
(foldl (lambda: ([name : DomainName] [section : (Setof RR)]) (foldl (lambda (name section)
(set-union section (set-union section
(set-filter (lambda: ([rr : RR]) (set-filter (lambda (rr)
(and (memv (rdata-type (rr-rdata rr)) '(a aaaa)) (and (memv (rdata-type (rr-rdata rr)) '(a aaaa))
(eqv? (rr-class rr) 'in))) (eqv? (rr-class rr) 'in)))
(or (zone-ref zone name) ((inst set RR)))))) (or (zone-ref zone name) (set)))))
((inst set RR)) (set)
names)) 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) (define (resolve-from-zone q zone start-of-authority nameservers-tried)
(or (answer-from-zone q zone start-of-authority) (or (answer-from-zone q zone start-of-authority)
(let ((best-nameservers (closest-untried-nameservers q zone nameservers-tried))) (let ((best-nameservers (closest-untried-nameservers q zone nameservers-tried)))

20
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> ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
;;; ;;;
@ -33,16 +33,16 @@
30 30
10))) 10)))
(: A : (Listof Bytes) (Vector Integer Integer Integer Integer) -> RR) ;; (: A : (Listof Bytes) (Vector Integer Integer Integer Integer) -> RR)
(: A/ttl : (Listof Bytes) (Vector Integer Integer Integer Integer) Nonnegative-Integer -> RR) ;; (: A/ttl : (Listof Bytes) (Vector Integer Integer Integer Integer) Nonnegative-Integer -> RR)
(: MX : (Listof Bytes) Nonnegative-Integer (Listof Bytes) -> RR) ;; (: MX : (Listof Bytes) Nonnegative-Integer (Listof Bytes) -> RR)
(: CNAME : (Listof Bytes) (Listof Bytes) -> RR) ;; (: CNAME : (Listof Bytes) (Listof Bytes) -> RR)
(: NS : (Listof Bytes) (Listof Bytes) -> RR) ;; (: NS : (Listof Bytes) (Listof Bytes) -> RR)
(: NS/ttl : (Listof Bytes) (Listof Bytes) Nonnegative-Integer -> RR) ;; (: NS/ttl : (Listof Bytes) (Listof Bytes) Nonnegative-Integer -> RR)
(: TXT : (Listof Bytes) (Listof Bytes) -> RR) ;; (: TXT : (Listof Bytes) (Listof Bytes) -> RR)
(define (A n ip) (A/ttl n ip 30)) (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 (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 (CNAME n1 n2) (rr (domain n1) 'in 30 (rdata-domain 'cname (domain n2))))
(define (NS n1 n2) (NS/ttl n1 n2 30)) (define (NS n1 n2) (NS/ttl n1 n2 30))
@ -93,7 +93,7 @@
(list (NS '(#"a") '(#"ns" #"b")) (list (NS '(#"a") '(#"ns" #"b"))
(NS '(#"b") '(#"ns" #"a")))) (NS '(#"b") '(#"ns" #"a"))))
(: test-port-number : -> Nonnegative-Integer) ;; (: test-port-number : -> Nonnegative-Integer)
(define (test-port-number) (define (test-port-number)
(define p (define p
(string->number (string->number

79
tk-dns.rkt
View File

@ -1,4 +1,4 @@
#lang typed/racket/base #lang racket/base
;; DNS drivers using marketplace. ;; DNS drivers using marketplace.
;; ;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu> ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@ -22,62 +22,25 @@
(require racket/set) (require racket/set)
(require racket/match) (require racket/match)
(require "codec.rkt") (require "codec.rkt")
(require marketplace/sugar-typed) (require marketplace/sugar)
(require marketplace/drivers/udp) (require marketplace/drivers/udp)
(require marketplace/support/pseudo-substruct)
(provide (struct-out bad-dns-packet-repr)
BadDnsPacket bad-dns-packet bad-dns-packet?
BadDnsPacketPattern bad-dns-packet-pattern bad-dns-packet-pattern?
(struct-out dns-request-repr)
DNSRequest dns-request dns-request?
DNSRequestPattern dns-request-pattern dns-request-pattern?
(struct-out dns-reply-repr)
DNSReply dns-reply dns-reply?
DNSReplyPattern dns-reply-pattern dns-reply-pattern?
(provide (struct-out bad-dns-packet)
(struct-out dns-request)
(struct-out dns-reply)
dns-read-driver dns-read-driver
dns-write-driver dns-write-driver
dns-spy) dns-spy)
(struct: (TDetail TSource TSink TReason) (struct bad-dns-packet (detail source sink reason) #:transparent)
bad-dns-packet-repr (struct dns-request (message source sink) #:transparent)
([detail : TDetail] [source : TSource] [sink : TSink] [reason : TReason]) #:transparent) (struct dns-reply (message source sink) #:transparent)
(pseudo-substruct: (bad-dns-packet-repr Any UdpAddress UdpAddress Symbol)
BadDnsPacket bad-dns-packet bad-dns-packet?)
(pseudo-substruct: (bad-dns-packet-repr Any
(U Wild UdpAddressPattern)
(U Wild UdpAddressPattern)
(U Wild Symbol))
BadDnsPacketPattern bad-dns-packet-pattern bad-dns-packet-pattern?)
(struct: (TMessage TSource TSink) ;; (: dns-read-driver : UdpAddress -> (Transition Void))
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) (define (dns-read-driver s)
(transition: (void) : Void (transition (void)
(at-meta-level: Void (at-meta-level
(subscriber: Void (udp-packet-pattern (wild) s (wild)) (subscriber (udp-packet (wild) s (wild))
(on-message (on-message
[(udp-packet source (== s) #"") [(udp-packet source (== s) #"")
(begin (log-info "Debug dump packet received") (begin (log-info "Debug dump packet received")
@ -91,26 +54,26 @@
((request) (dns-request message source s)) ((request) (dns-request message source s))
((response) (dns-reply message source s)))))]))))) ((response) (dns-reply message source s)))))])))))
(: dns-write-driver : UdpAddress -> (Transition Void)) ;; (: dns-write-driver : UdpAddress -> (Transition Void))
(define (dns-write-driver s) (define (dns-write-driver s)
(: translate : DNSMessage UdpAddress -> (ActionTree Void)) ;; (: translate : DNSMessage UdpAddress -> (ActionTree Void))
(define (translate message sink) (define (translate message sink)
(with-handlers ((exn:fail? (lambda (e) (with-handlers ((exn:fail? (lambda (e)
(send-message (bad-dns-packet message s sink 'unencodable))))) (send-message (bad-dns-packet message s sink 'unencodable)))))
(at-meta-level: Void (at-meta-level
(send-message (udp-packet s sink (dns-message->packet message)))))) (send-message (udp-packet s sink (dns-message->packet message))))))
(transition: (void) : Void (transition (void)
(subscriber: Void (dns-request-pattern (wild) s (wild)) (subscriber (dns-request (wild) s (wild))
(on-message (on-message
[(dns-request message (== s) sink) (translate message sink)])) [(dns-request message (== s) sink) (translate message sink)]))
(subscriber: Void (dns-reply-pattern (wild) s (wild)) (subscriber (dns-reply (wild) s (wild))
(on-message (on-message
[(dns-reply message (== s) sink) (translate message sink)])))) [(dns-reply message (== s) sink) (translate message sink)]))))
(: dns-spy : -> (Transition Void)) ;; (: dns-spy : -> (Transition Void))
(define (dns-spy) (define (dns-spy)
(transition: (void) : Void (transition (void)
(observe-publishers: Void (wild) (observe-publishers (wild)
(on-message (on-message
[(dns-request message source sink) [(dns-request message source sink)
(begin (log-info (format "DNS: ~v asks ~v ~v~n : ~v" (begin (log-info (format "DNS: ~v asks ~v ~v~n : ~v"

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. ;; Noddy representation of a zone, and various zone and RRSet utilities.
;; ;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu> ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
@ -25,10 +25,8 @@
(require "api.rkt") (require "api.rkt")
(require "codec.rkt") (require "codec.rkt")
(require bitsyntax) (require bitsyntax)
(require (rename-in marketplace/tr-struct-copy [tr-struct-copy struct-copy])) ;; PR13149
(provide CompiledZone (provide zone-ref
zone-ref
zone-includes-name? zone-includes-name?
incorporate-complete-answer incorporate-complete-answer
zone-expire-name zone-expire-name
@ -45,52 +43,47 @@
zone->bit-string zone->bit-string
bit-string->zone) bit-string->zone)
(define-type RelativeSeconds Real) ;; (define-type RelativeSeconds Real)
(define-type AbsoluteSeconds Real) ;; (define-type AbsoluteSeconds Real)
(define-predicate absolute-seconds? AbsoluteSeconds) ;; (define-predicate absolute-seconds? AbsoluteSeconds)
(define absolute-seconds? real?)
;; An InfiniteLifetime is an (infinite-lifetime RelativeSeconds), a ;; An InfiniteLifetime is an (infinite-lifetime RelativeSeconds), a
;; specification of the TTL to use when sending a non-expiring RR to a ;; specification of the TTL to use when sending a non-expiring RR to a
;; peer. ;; peer.
(struct: infinite-lifetime ([ttl : RelativeSeconds]) #:transparent) (struct infinite-lifetime (ttl) #:transparent)
(define-type InfiniteLifetime infinite-lifetime)
;; An Expiry is either an AbsoluteSeconds or an InfiniteLifetime. ;; 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 ;; A CompiledZone is a Hash<DomainName,Hash<RR,(or AbsoluteSeconds
;; InfiniteLifetime)>>, representing a collection of DNS RRSets ;; InfiniteLifetime)>>, representing a collection of DNS RRSets
;; indexed by DomainName. Each RR in an RRSet either has an expiry ;; indexed by DomainName. Each RR in an RRSet either has an expiry
;; time associated with it or has an InfiniteLifetime associated with ;; time associated with it or has an InfiniteLifetime associated with
;; it, in which case it should not expire. ;; it, in which case it should not expire.
(define-type CompiledZone (HashTable DomainName (HashTable RR Expiry)))
;; A Timers is a SetOf<(cons DomainName RelativeSeconds)>, ;; A Timers is a SetOf<(cons DomainName RelativeSeconds)>,
;; representing a collection of timeouts that should be set against ;; representing a collection of timeouts that should be set against
;; names to to see if their associated RRs have expired. ;; 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 ;; TODO: maybe store domain names big-end first? It'd make bailiwick
;; and subzone checks into prefix rather than suffix checks. It makes ;; and subzone checks into prefix rather than suffix checks. It makes
;; domain names into paths through the DNS DB tree. ;; domain names into paths through the DNS DB tree.
(: current-inexact-seconds : -> AbsoluteSeconds) ;; (: current-inexact-seconds : -> AbsoluteSeconds)
(define (current-inexact-seconds) (define (current-inexact-seconds)
(/ (current-inexact-milliseconds) 1000.0)) (/ (current-inexact-milliseconds) 1000.0))
(: still-valid? : Expiry AbsoluteSeconds -> Boolean) ;; (: still-valid? : Expiry AbsoluteSeconds -> Boolean)
(define (still-valid? expiry now) (define (still-valid? expiry now)
(or (infinite-lifetime? expiry) (or (infinite-lifetime? expiry)
(>= expiry now))) (>= expiry now)))
(: zone-ref : CompiledZone DomainName -> (Option (Setof RR))) ;; (: zone-ref : CompiledZone DomainName -> (Option (Setof RR)))
(define (zone-ref db name) (define (zone-ref db name)
(define expirymap (hash-ref db name (lambda () #f))) (define expirymap (hash-ref db name (lambda () #f)))
(and expirymap (and expirymap
(let ((now (current-inexact-seconds))) (let ((now (current-inexact-seconds)))
(for/fold: ([acc : (Setof RR) (set)]) (for/fold ([acc (set)]) ([resource (in-hash-keys expirymap)])
([resource : RR (in-hash-keys expirymap)])
(define expiry (hash-ref expirymap resource)) (define expiry (hash-ref expirymap resource))
(if (still-valid? expiry now) (if (still-valid? expiry now)
(let ((new-ttl (if (infinite-lifetime? expiry) (let ((new-ttl (if (infinite-lifetime? expiry)
@ -98,14 +91,14 @@
(- expiry now)))) (- expiry now))))
(set-add acc (set-add acc
(struct-copy rr resource (struct-copy rr resource
[ttl (cast (exact-floor new-ttl) Nonnegative-Integer)]))) [ttl (exact-floor new-ttl)])))
acc))))) acc)))))
(: zone-includes-name? : CompiledZone DomainName -> Boolean) ;; (: zone-includes-name? : CompiledZone DomainName -> Boolean)
(define (zone-includes-name? db name) (define (zone-includes-name? db name)
(hash-has-key? 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 ;; 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 ;; 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 ;; as time goes by; otherwise base-time is #f, and we treat the RR as
@ -129,7 +122,7 @@
(infinite-lifetime (rr-ttl resource0)))) (infinite-lifetime (rr-ttl resource0))))
(define resource (struct-copy rr resource0 [ttl 0])) (define resource (struct-copy rr resource0 [ttl 0]))
(define name (rr-name resource)) (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))) (define old-expiry (hash-ref old-expirymap resource (lambda () 0)))
(cond (cond
[(infinite-lifetime? old-expiry) ;; don't update TTL: the existing record should live forever [(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 [else ;; old record finite-lifetime but expiring after the new expiry: leave it alone
db])) db]))
(: incorporate-complete-answer : ;; (: incorporate-complete-answer :
(Option CompleteAnswer) CompiledZone Boolean -> (Values CompiledZone Timers)) ;; (Option CompleteAnswer) CompiledZone Boolean -> (Values CompiledZone Timers))
(define (incorporate-complete-answer ans db is-cache?) (define (incorporate-complete-answer ans db is-cache?)
(match ans (match ans
[#f [#f
(values db (set))] (values db (set))]
[(complete-answer ns us ds) [(complete-answer ns us ds)
(define now (current-inexact-seconds)) (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) ([rr (in-list (append (set->list ns)
(set->list us) (set->list us)
(set->list ds)))]) ;; no in-sequences in typed racket (set->list ds)))]) ;; no in-sequences in typed racket
@ -156,15 +149,14 @@
(values ((incorporate-rr now) rr db) (values ((incorporate-rr now) rr db)
(set-add timers (cons (rr-name rr) (rr-ttl rr))))))])) (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 ;; Checks the given name to see if there are any expiring records, and
;; if so, removes them. ;; if so, removes them.
(define (zone-expire-name db name now-seconds) (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 old-expirymap (hash-ref db name (lambda () empty-expirymap)))
(define new-expirymap (define new-expirymap
(for/fold: ([acc : (HashTable RR Expiry) empty-expirymap]) (for/fold ([acc empty-expirymap]) ([resource (in-hash-keys old-expirymap)])
([resource : RR (in-hash-keys old-expirymap)])
(define expiry (hash-ref old-expirymap resource)) (define expiry (hash-ref old-expirymap resource))
(if (still-valid? expiry now-seconds) (if (still-valid? expiry now-seconds)
(hash-set acc resource expiry) (hash-set acc resource expiry)
@ -173,33 +165,33 @@
(hash-remove db name) (hash-remove db name)
(hash-set db name new-expirymap))) (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. ;; Used to freshen a saved zone when it is loaded from disk.
(define (zone-expire zone) (define (zone-expire zone)
(define now-seconds (current-inexact-seconds)) (define now-seconds (current-inexact-seconds))
(for/fold: ([zone : CompiledZone zone] [timers : Timers (set)]) (for/fold ([zone zone] [timers (set)])
([name : DomainName (in-hash-keys zone)]) ([name (in-hash-keys zone)])
(define new-zone (zone-expire-name zone name now-seconds)) (define new-zone (zone-expire-name zone name now-seconds))
(define expirymap (hash-ref new-zone name (lambda () #f))) (define expirymap (hash-ref new-zone name (lambda () #f)))
(values new-zone (values new-zone
(if expirymap (if expirymap
(set-union (list->set (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)))) (filter absolute-seconds? (hash-values expirymap))))
timers) timers)
timers)))) timers))))
(: empty-zone-db : -> CompiledZone) ;; (: empty-zone-db : -> CompiledZone)
(define (empty-zone-db) (define (empty-zone-db)
(make-immutable-hash)) (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 ;; Builds an immutable hash table from the given RRs, suitable for
;; quickly looking up answers to queries. ;; quickly looking up answers to queries.
(define (compile-zone-db rrs) (define (compile-zone-db rrs)
(foldl (incorporate-rr #f) (empty-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 ;; Answers #t iff dn falls within the bailiwick of the zone with
;; origin o. ;; origin o.
(define (in-bailiwick? dn o) (define (in-bailiwick? dn o)
@ -207,23 +199,23 @@
(let ((p (domain-parent dn))) (let ((p (domain-parent dn)))
(and p (in-bailiwick? p o))))) (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 ;; Retains only those elements of its argument for which the predicate
;; answers #t. ;; answers #t.
(define (set-filter predicate in) (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))) (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. ;; Selects only those members of rrset having rr-type type.
(define (filter-by-type rrset type) (define (filter-by-type rrset type)
(define p? (rdata-type-pred 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)) (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 ;; Returns a set like its argument with RRs not matching the given
;; type and class removed. ;; type and class removed.
(define (filter-rrs rrs qtype qclass) (define (filter-rrs rrs qtype qclass)
@ -237,10 +229,10 @@
(define filtered-by-type-and-class (define filtered-by-type-and-class
(case qclass (case qclass
((*) filtered-by-type) ((*) 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) 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. ;; Like set->list, but places all CNAME records first.
;; This is apparently to work around bugs in old versions of BIND? ;; This is apparently to work around bugs in old versions of BIND?
;; ;;
@ -264,11 +256,11 @@
(append (cname-sort (set->list cnames)) (append (cname-sort (set->list cnames))
(set->list (set-subtract rrs 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) (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 ;; Produce an ordering of the CNAMEs given that respects their
;; "causality". For example, if a CNAME b and b CNAME c, then the RRs ;; "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 ;; 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 lhss (list->set (map rr-name cnames)))
(define rhss (list->set (map rr-rdata-domain-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. (define roots (set->list (set-subtract lhss rhss))) ;; Nodes not the targets of some edge.
(: targets-of : DomainName -> (Listof RR)) ;; (: targets-of : DomainName -> (Listof RR))
(define (targets-of name) (filter (lambda: ([rr : RR]) (equal? (rr-name rr) name)) cnames)) (define (targets-of name) (filter (lambda (rr) (equal? (rr-name rr) name)) cnames))
(let: iterate ((remaining : (Listof DomainName) roots) (let iterate ((remaining roots) (seen (set)) (acc '()))
(seen : (Setof DomainName) (set))
(acc : (Listof RR) '()))
(if (null? remaining) (if (null? remaining)
(reverse acc) (reverse acc)
(let ((source (car remaining))) (let ((source (car remaining)))
@ -293,12 +283,12 @@
(set-add seen source) (set-add seen source)
(append rrs acc)))))))) (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. ;; Produces a serialized form of the zone suitable for saving to disk.
(define (zone->bit-string zone) (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)) (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)) (define expiry (hash-ref rrmap rr))
(bit-string-append (bit-string-append
acc acc
@ -308,7 +298,7 @@
[else [else
(bit-string (rr :: (t:rr)) 0 ((exact-truncate expiry) :: bits 32))]))))) (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. ;; Produces a deserialized form of the zone. Suitable for use in loading from disk.
(define (bit-string->zone bs) (define (bit-string->zone bs)
(define now (current-inexact-seconds)) (define now (current-inexact-seconds))