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

Typed implementation WIP

This commit is contained in:
Tony Garnock-Jones 2013-03-13 17:30:57 -04:00
parent f68f9cb56a
commit af9fa2cea8
5 changed files with 346 additions and 199 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
api-untyped.rkt Normal file
View File

@ -0,0 +1,40 @@
#lang racket/base
;; Untyped struct definitions required to interoperate with typed-matrix's struct-map
;; See also Racket PR 13593.
(require racket-typed-matrix/struct-map)
(provide (struct-out domain))
;; (These utilities need to be defined ahead of the domain struct
;; definition.)
(define (domain=? a b recursive-equal?)
(recursive-equal? (domain-downcased-labels a)
(domain-downcased-labels b)))
(define (domain-hash-1/2 d recursive-hash)
(recursive-hash (domain-downcased-labels d)))
(struct domain (labels downcased-labels)
#:transparent
#:property prop:equal+hash (list domain=? domain-hash-1/2 domain-hash-1/2)
#:property prop:struct-map (lambda (f seed x)
(let-values (((labels seed) (f (domain-labels x) seed)))
(values (make-domain labels) seed))))
;; ListOf<Bytes> -> ListOf<Bytes>
;; Converts the 7-bit ASCII bytes in the argument to lower-case
;; equivalents. Used to normalize case for domain-name comparisons.
(define (downcase-labels labels)
(for/list ([label labels])
(define b (make-bytes (bytes-length label)))
(for ([i (bytes-length label)])
(define v (bytes-ref label i))
(bytes-set! b i (if (<= 65 v 90) (+ 32 v) v)))
b))
;; ListOf<Bytes> -> DomainName
;; Replacement constructor for domain structs. Automatically downcases
;; labels appropriately.
(define (make-domain labels)
(domain labels (downcase-labels labels)))

150
api.rkt
View File

@ -1,11 +1,16 @@
#lang racket/base #lang typed/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.
(provide (except-out (struct-out domain) domain) (provide DomainName
(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
IPv6
Question
(struct-out question) (struct-out question)
question-cyclic? question-cyclic?
question-too-glueless? question-too-glueless?
@ -14,21 +19,30 @@
cname-question cname-question
ns-question ns-question
AnsweredQuestion
RR
(struct-out answered-question) (struct-out answered-question)
(struct-out rr) (struct-out 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 hinfo) (struct-out hinfo)
(struct-out minfo) (struct-out minfo)
(struct-out mx) (struct-out mx)
(struct-out soa) (struct-out soa)
(struct-out wks) (struct-out wks)
(struct-out srv) (struct-out srv)
rr-rdata/cast
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
@ -39,42 +53,39 @@
(require racket/match) (require racket/match)
(require racket-typed-matrix/struct-map) (require racket-typed-matrix/struct-map)
;; (These utilities need to be defined ahead of the domain struct
;; definition.)
(define (domain=? a b recursive-equal?)
(recursive-equal? (domain-downcased-labels a)
(domain-downcased-labels b)))
(define (domain-hash-1/2 d recursive-hash)
(recursive-hash (domain-downcased-labels d)))
;; 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").
(struct domain (labels downcased-labels) (require/typed "api-untyped.rkt"
#:transparent [#:struct domain ([labels : (Listof Bytes)]
#:property prop:equal+hash (list domain=? domain-hash-1/2 domain-hash-1/2) [downcased-labels : (Listof Bytes)])])
#:property prop:struct-map (lambda (f seed x) (define-type DomainName domain)
(let-values (((labels seed) (f (domain-labels x) seed)))
(values (make-domain labels) seed))))
;; 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 question (name type class context) #:prefab) (struct: question
([name : DomainName] [type : QueryType] [class : QueryClass] [context : QuestionContext])
#:prefab)
(define-type Question question)
;; 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
@ -87,32 +98,44 @@
;; 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) #:prefab) (struct: subquestion ([parent : Question]) #:prefab)
(struct cname-subq subquestion () #:prefab) (struct: cname-subq subquestion () #:prefab)
(struct ns-subq subquestion () #:prefab) (struct: ns-subq subquestion () #:prefab)
(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 answered-question (q a) #:prefab) (struct: answered-question ([q : Question] [a : (Option CompleteAnswer)]) #:prefab)
(define-type AnsweredQuestion answered-question)
;; 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 (rrs authorities additional) #:prefab) (struct: complete-answer
([rrs : (Setof RR)] [authorities : (Setof RR)] [additional : (Setof RR)])
#:prefab)
(define-type CompleteAnswer complete-answer)
;; An RR is a (rr DomainName RRType RRClass Uint32 RData), ;; An RR is a (rr DomainName RRType RRClass Uint32 RData),
;; representing a resource record. ;; representing a resource record.
(struct rr (name type class ttl rdata) #:prefab) (struct: rr ([name : DomainName]
[type : RRType]
[class : RRClass]
[ttl : Nonnegative-Integer]
[rdata : RData])
#:prefab)
(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
;; - an IPv4, an "A" record ;; - an IPv4, an "A" record
;; - an IPv6, an "AAAA" record ;; - an IPv6, an "AAAA" record
;; - (hinfo ShortString ShortString), a host information record [O] ;; - (hinfo Bytes Bytes), a host information record [O]
;; - (minfo DomainName DomainName), a mailbox information record [O] ;; - (minfo DomainName DomainName), a mailbox information record [O]
;; - (mx Uint16 DomainName), a mail exchanger record ;; - (mx Uint16 DomainName), a mail exchanger record
;; - (soa DomainName DomainName Uint32 Uint32 Uint32 Uint32 Uint32), a ;; - (soa DomainName DomainName Uint32 Uint32 Uint32 Uint32 Uint32), a
;; start-of-authority record ;; start-of-authority record
;; - (wks IPv4 Byte Bytes), a Well-Known Service [O] ;; - (wks IPv4 Byte Bytes), a Well-Known Service [O]
;; - (srv Uint16 Uint16 Uint16 DomainName), an "SRV" record ;; - (srv Uint16 Uint16 Uint16 DomainName), an "SRV" record
;; - a ListOf<Bytes>, a txt record
;; - a Bytes, either a 'null type RR or any unrecognised RR type. ;; - a Bytes, either a 'null type RR or any unrecognised RR type.
;; ;;
;; In each case, the RData's variant MUST line up correctly with the ;; In each case, the RData's variant MUST line up correctly with the
@ -120,17 +143,36 @@
;; ;;
;; 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 hinfo (cpu os) #:prefab) (struct: hinfo ([cpu : Bytes] [os : Bytes]) #:prefab)
(struct minfo (rmailbx emailbx) #:prefab) (struct: minfo ([rmailbx : DomainName] [emailbx : DomainName]) #:prefab)
(struct mx (preference exchange) #:prefab) (struct: mx ([preference : Nonnegative-Integer] [exchange : DomainName]) #:prefab)
(struct soa (mname rname serial refresh retry expire minimum) #:prefab) (struct: soa ([mname : DomainName]
(struct wks (address protocol bitmap) #:prefab) [rname : DomainName]
(struct srv (priority weight port target) #:prefab) [serial : Nonnegative-Integer]
[refresh : Nonnegative-Integer]
[retry : Nonnegative-Integer]
[expire : Nonnegative-Integer]
[minimum : Nonnegative-Integer]) #:prefab)
(struct: wks ([address : IPv4] [protocol : Byte] [bitmap : Bytes]) #:prefab)
(struct: srv ([priority : Nonnegative-Integer]
[weight : Nonnegative-Integer]
[port : Nonnegative-Integer]
[target : DomainName]) #:prefab)
(define-type RData (U DomainName IPv4 IPv6 hinfo minfo mx soa wks srv (Listof Bytes) Bytes))
(define-syntax-rule (rr-rdata/cast Type)
(lambda: ([rr : RR]) (cast (rr-rdata rr) Type)))
;; An RRType is a Symbol or a Number, one of the possibilities given ;; An RRType is a Symbol or a Number, one of the possibilities given
;; 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
'mr 'null 'wks 'ptr 'hinfo 'minfo 'mx 'txt
'aaaa 'srv
Nonnegative-Integer))
(: type->value : RRType -> Nonnegative-Integer)
(: value->type : Nonnegative-Integer -> RRType)
(define-mapping type->value value->type (define-mapping type->value value->type
#:forward-default values #:forward-default values
#:backward-default values #:backward-default values
@ -156,6 +198,9 @@
;; 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)
(: 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
@ -168,6 +213,9 @@
;; 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)
(: 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
@ -179,6 +227,9 @@
;; 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)
(: 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
@ -187,6 +238,7 @@
;; ListOf<Bytes> -> ListOf<Bytes> ;; ListOf<Bytes> -> ListOf<Bytes>
;; Converts the 7-bit ASCII bytes in the argument to lower-case ;; Converts the 7-bit ASCII bytes in the argument to lower-case
;; equivalents. Used to normalize case for domain-name comparisons. ;; equivalents. Used to normalize case for domain-name comparisons.
(: downcase-labels : (Listof Bytes) -> (Listof Bytes))
(define (downcase-labels labels) (define (downcase-labels labels)
(for/list ([label labels]) (for/list ([label labels])
(define b (make-bytes (bytes-length label))) (define b (make-bytes (bytes-length label)))
@ -198,24 +250,25 @@
;; ListOf<Bytes> -> DomainName ;; ListOf<Bytes> -> DomainName
;; Replacement constructor for domain structs. Automatically downcases ;; Replacement constructor for domain structs. Automatically downcases
;; labels appropriately. ;; labels appropriately.
(: make-domain : (Listof Bytes) -> DomainName)
(define (make-domain labels) (define (make-domain labels)
(domain labels (downcase-labels labels))) (domain labels (downcase-labels labels)))
;; DomainName -> Boolean (: domain-root? : DomainName -> Boolean)
(define (domain-root? d) (define (domain-root? d)
(null? (domain-labels d))) (null? (domain-labels d)))
;; DomainName -> Maybe<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)))))
;; -> CompleteAnswer (: empty-complete-answer : -> CompleteAnswer)
(define (empty-complete-answer) (define (empty-complete-answer)
(complete-answer (set) (set) (set))) (complete-answer (set) (set) (set)))
;; 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)
@ -223,7 +276,7 @@
(set-union u1 u2) (set-union u1 u2)
(set-union d1 d2))) (set-union d1 d2)))
;; DomainName Maybe<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.
@ -231,27 +284,29 @@
[(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 (set)) (ips ((inst set IPv4)))
(seen (set))) (seen ((inst set DomainName))))
(if (null? names) (if (null? names)
ips ips
(let* ((name (car names)) (let* ((name (car names))
(records (filter (lambda (rr) (equal? name (rr-name rr))) rrs))) (records (filter (lambda: ([rr : RR]) (equal? name (rr-name rr))) rrs)))
(if (set-member? seen name) (if (set-member? seen name)
(loop (cdr names) ips seen) (loop (cdr names) ips seen)
(let ((a-records (filter (lambda (rr) (equal? 'a (rr-type rr))) records)) (let ((a-records (filter (lambda: ([rr : RR]) (equal? 'a (rr-type rr))) records))
(cname-records (filter (lambda (rr) (equal? 'cname (rr-type rr))) records))) (cname-records
(loop (append (map rr-rdata cname-records) (cdr names)) (filter (lambda: ([rr : RR]) (equal? 'cname (rr-type rr))) records)))
(set-union ips (list->set (map rr-rdata a-records))) (loop (append (map (rr-rdata/cast DomainName) cname-records) (cdr names))
(set-union ips (list->set (map (rr-rdata/cast IPv4) a-records)))
(set-add seen name)))))))])) (set-add seen name)))))))]))
;; Question -> Boolean ;; Question -> Boolean
;; #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)
(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 ((ancestor parent)) (let: search : Boolean ((ancestor : QuestionContext 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
@ -263,9 +318,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)
(define (question-too-glueless? q) (define (question-too-glueless? q)
(define count (define count
(let search ((q q) (acc 0)) (let: search : Integer ((q : Question q) (acc : Integer 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))]
@ -281,6 +337,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)
(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))
@ -292,16 +349,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)
(define (restart-question q) (define (restart-question q)
(struct-copy question 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)
(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)
(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 ?

254
codec.rkt
View File

@ -1,9 +1,17 @@
#lang racket/base #lang typed/racket/base
;; DNS wire-protocol codec. ;; DNS wire-protocol codec.
(provide value->query-opcode query-opcode->value (provide Opcode
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
@ -17,12 +25,18 @@
(require "api.rkt") (require "api.rkt")
(require "mapping.rkt") (require "mapping.rkt")
(domain (list #"hello"))
(require racket/match) (require racket/match)
(require racket-bitsyntax) (require racket-bitsyntax)
;; 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)
(: 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
@ -33,6 +47,11 @@
;; 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
'name-error 'not-implemented 'refused
Nonnegative-Integer))
(: value->query-response-code : Nonnegative-Integer -> ResponseCode)
(: query-response-code->value : ResponseCode -> Nonnegative-Integer)
(define-mapping value->query-response-code query-response-code->value (define-mapping value->query-response-code query-response-code->value
(0 no-error) (0 no-error)
(1 format-error) (1 format-error)
@ -48,57 +67,82 @@
;; ;;
;; 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 (struct: dns-message ([id : Nonnegative-Integer]
direction [direction : Direction]
opcode [opcode : Opcode]
authoritative [authoritative : Authoritativeness]
truncated [truncated : Truncatedness]
recursion-desired [recursion-desired : RecursionDesired]
recursion-available [recursion-available : RecursionAvailable]
response-code [response-code : ResponseCode]
questions [questions : (Listof Question)]
answers [answers : (Listof RR)]
authorities [authorities : (Listof RR)]
additional) [additional : (Listof RR)])
#:prefab) #:prefab)
(define-type DNSMessage dns-message)
(define-type Direction (U 'request 'response))
(define-type Authoritativeness (U 'non-authoritative 'authoritative))
(define-type Truncatedness (U 'not-truncated 'truncated))
(define-type RecursionDesired (U 'no-recursion-desired 'recursion-desired))
(define-type RecursionAvailable (U 'no-recursion-available 'recursion-available))
;; Bit-syntax type for counted repeats of a value. ;; 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:
;; (bit-string-case input ([ len (vals :: (t:ntimes len bits 32)) ] vals)) ;; (bit-string-case input ([ len (vals :: (t:ntimes Integer len bits 32)) ] vals))
;; (bit-string (vals :: (t:ntimes bits 32))) ;; (bit-string (vals :: (t:ntimes Integer bits 32)))
(define-syntax t:ntimes (define-syntax t:ntimes
(syntax-rules () (syntax-rules ()
((_ #t input ks kf times-to-repeat option ...) ((_ #t input0 ks kf Type times-to-repeat option ...)
(let loop ((count times-to-repeat) (let ()
(acc '()) ;; A simple loop without multiple-values or #f is much cleaner
(input input)) ;; here, but I can't find a way of expressing the types
(cond ;; required while making that work. This way, we avoid needing
((positive? count) (bit-string-case input ;; to mention the type of the result of calls to ks.
([ (v :: option ...) (rest :: binary) ] (: loop : Integer (Listof Type) BitString -> (Values (Option (Listof Type)) BitString))
(loop (- count 1) (cons v acc) rest)) (define (loop count acc input)
(else (kf)))) (cond
(else (ks (reverse acc) input))))) ((positive? count) (bit-string-case input
((_ #f vs option ...) ([ (v :: option ...) (rest :: binary) ]
(t:listof #f vs option ...)))) (loop (- count 1) (cons v acc) rest))
(else
(values #f input))))
(else (values (reverse acc) input))))
(let-values (((vs rest) (loop times-to-repeat '() input0)))
(if vs
(ks vs rest)
(kf)))))
((_ #f val Type option ...)
(t:listof #f val Type option ...))))
;; Bit-syntax type for repeats of a value until no more input available. ;; Bit-syntax type for repeats of a value until no more input available.
;; Example: List of 32-bit unsigned words: ;; Example: List of 32-bit unsigned words:
;; (bit-string-case input ([ (vals :: (t:listof bits 32)) ] vals)) ;; (bit-string-case input ([ (vals :: (t:listof Integer bits 32)) ] vals))
;; (bit-string (vals :: (t:listof bits 32))) ;; (bit-string (vals :: (t:listof Integer bits 32)))
(define-syntax t:listof (define-syntax t:listof
(syntax-rules () (syntax-rules ()
((_ #t input ks kf option ...) ((_ #t input0 ks kf Type option ...)
(let loop ((acc '()) ;; The loop is unrolled once here to let Typed Racket propagate
(input input)) ;; the type of v0 into the type of acc in the loop. When not
(bit-string-case input ;; unrolled, it gives acc type (Listof Any).
([ (v :: option ...) (rest :: binary) ] ;; TODO: come up with some other way of doing this that avoids the duplication.
(loop (cons v acc) rest)) (bit-string-case input0
([] ([ (v0 :: option ...) (input1 :: binary) ]
(ks (reverse acc) #"")) (let loop ((acc (list v0))
(else (input input1))
(kf))))) (bit-string-case input
((_ #f vs option ...) ([ (v :: option ...) (rest :: binary) ]
(let loop ((vs vs)) (loop (cons v acc) rest))
([]
(ks (reverse acc) #""))
(else
(kf)))))
([]
(ks '() #""))
(else
(kf))))
((_ #f vs Type option ...)
(let: loop : BitString ((vs : (Listof Type) vs))
(cond (cond
((pair? vs) (bit-string ((car vs) :: option ...) ((pair? vs) (bit-string ((car vs) :: option ...)
((loop (cdr vs)) :: binary))) ((loop (cdr vs)) :: binary)))
@ -142,7 +186,7 @@
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ ;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; </rfc1035> ;; </rfc1035>
;; Bytes -> 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)
@ -163,16 +207,16 @@
(ancount :: bits 16) (ancount :: bits 16)
(nscount :: bits 16) (nscount :: bits 16)
(arcount :: bits 16) (arcount :: bits 16)
(q-section :: (t:ntimes qdcount (t:question packet))) (q-section :: (t:ntimes Question qdcount (t:question packet)))
(a-section :: (t:ntimes ancount (t:rr packet))) (a-section :: (t:ntimes RR ancount (t:rr packet)))
(auth-section :: (t:ntimes nscount (t:rr packet))) (auth-section :: (t:ntimes RR nscount (t:rr packet)))
(additional-section :: (t:ntimes arcount (t:rr packet))) ] (additional-section :: (t:ntimes RR arcount (t:rr packet))) ]
(dns-message id qr (value->query-opcode opcode) (dns-message id qr (value->query-opcode opcode)
aa tc rd ra aa tc rd ra
(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))))
;; 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
@ -191,10 +235,10 @@
((length (dns-message-answers m)) :: bits 16) ((length (dns-message-answers m)) :: bits 16)
((length (dns-message-authorities m)) :: bits 16) ((length (dns-message-authorities m)) :: bits 16)
((length (dns-message-additional m)) :: bits 16) ((length (dns-message-additional m)) :: bits 16)
((dns-message-questions m) :: (t:ntimes (t:question))) ((dns-message-questions m) :: (t:ntimes Question (t:question)))
((dns-message-answers m) :: (t:ntimes (t:rr))) ((dns-message-answers m) :: (t:ntimes RR (t:rr)))
((dns-message-authorities m) :: (t:ntimes (t:rr))) ((dns-message-authorities m) :: (t:ntimes RR (t:rr)))
((dns-message-additional m) :: (t:ntimes (t:rr)))))) ((dns-message-additional m) :: (t:ntimes RR (t:rr))))))
;; Bit-syntax type for a single bit, represented in Racket as one of ;; Bit-syntax type for a single bit, represented in Racket as one of
;; two possible symbolic values. ;; two possible symbolic values.
@ -228,13 +272,14 @@
((_ #f val) ((_ #f val)
(encode-domain-name val)))) (encode-domain-name val))))
;; 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 (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!
;; Bytes Bytes ListOf<Natural> -> ListOf<Bytes> (: parse-domain-name :
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
@ -273,13 +318,14 @@
([ len (body :: binary bytes len) (rest :: binary) ] ([ len (body :: binary bytes len) (rest :: binary) ]
(ks (bit-string->bytes body) rest)) (ks (bit-string->bytes body) rest))
(else (kf)))) (else (kf))))
((_ #f s) ((_ #f val)
(t:pascal-string #f s "Character-string" 256)) (t:pascal-string #f val "Character-string" 256))
((_ #f s string-kind length-limit) ((_ #f val string-kind length-limit)
(let ((len (bytes-length s))) (let: ([s : Bytes val])
(when (>= len length-limit) (let ((len (bytes-length s)))
(error 't:pascal-string "~s too long: ~v" string-kind s)) (when (>= len length-limit)
(bit-string len (s :: binary)))))) (error 't:pascal-string "~s too long: ~v" string-kind s))
(bit-string len (s :: binary)))))))
;; <rfc1035> ;; <rfc1035>
;; The question section is used to carry the "question" in most queries, ;; The question section is used to carry the "question" in most queries,
@ -314,10 +360,11 @@
(value->qclass qclass) (value->qclass qclass)
#f) #f)
tail)))) tail))))
((_ #f q) ((_ #f val)
(bit-string ((question-name q) :: (t:domain-name)) (let: ([q : Question val])
((qtype->value (question-type q)) :: bits 16) (bit-string ((question-name q) :: (t:domain-name))
((qclass->value (question-class q)) :: bits 16))))) ((qtype->value (question-type 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:
@ -348,43 +395,35 @@
;; packet because the RR may contain nested domain-names. ;; packet because the RR may contain nested domain-names.
(define-syntax t:rr (define-syntax t:rr
(syntax-rules () (syntax-rules ()
((_ #t input ks kf whole-packet) ((_ #t input ks kf whole-packet0)
(decode-rr whole-packet input ks kf)) (let ((whole-packet whole-packet0))
((_ #f rr) (bit-string-case input
(encode-rr rr)))) ([ (name :: (t:domain-name whole-packet))
(type-number :: bits 16)
(class :: bits 16)
(ttl :: bits 32)
(rdlength :: bits 16)
(rdata :: binary bytes rdlength)
(tail :: binary) ]
(let ((type (value->type type-number)))
(ks (rr name
type
(value->class class)
ttl
(decode-rdata whole-packet type rdata))
tail)))
(else (kf)))))
((_ #f val)
(let: ([rr : RR val])
(let ((encoded-rdata (encode-rdata (rr-type rr) (rr-rdata rr))))
(bit-string ((rr-name rr) :: (t:domain-name))
((type->value (rr-type rr)) :: bits 16)
((class->value (rr-class rr)) :: bits 16)
((rr-ttl rr) :: bits 32)
((quotient (bit-string-length encoded-rdata) 8) :: bits 16)
(encoded-rdata :: binary)))))))
;; Bytes Bytes (RR Bytes -> A) ( -> A) -> A (: decode-rdata : BitString RRType BitString -> RData)
;; Helper for t:rr.
(define (decode-rr whole-packet input ks kf)
(bit-string-case input
([ (name :: (t:domain-name whole-packet))
(type-number :: bits 16)
(class :: bits 16)
(ttl :: bits 32)
(rdlength :: bits 16)
(rdata :: binary bytes rdlength)
(tail :: binary) ]
(let ((type (value->type type-number)))
(ks (rr name
type
(value->class class)
ttl
(decode-rdata whole-packet type rdata))
tail)))
(else (kf))))
;; RR -> Bitstring
;; Helper for t:rr.
(define (encode-rr rr)
(let ((encoded-rdata (encode-rdata (rr-type rr) (rr-rdata rr))))
(bit-string ((rr-name rr) :: (t:domain-name))
((type->value (rr-type rr)) :: bits 16)
((class->value (rr-class rr)) :: bits 16)
((rr-ttl rr) :: bits 32)
((/ (bit-string-length encoded-rdata) 8) :: bits 16)
(encoded-rdata :: binary))))
;; Bytes RRType Bytes -> 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)
@ -413,7 +452,7 @@
(minimum :: bits 32) ] (minimum :: bits 32) ]
(soa mname rname serial refresh retry expire minimum)))) (soa mname rname serial refresh retry expire minimum))))
((txt) (bit-string-case rdata ((txt) (bit-string-case rdata
([ (strs :: (t:listof (t:pascal-string))) ] ([ (strs :: (t:listof Bytes (t:pascal-string))) ]
strs))) strs)))
((a) (bit-string-case rdata ((a) (bit-string-case rdata
([ a b c d ] ([ a b c d ]
@ -423,7 +462,7 @@
(list->vector (bytes->list (bit-string->bytes ipv6-addr)))))) (list->vector (bytes->list (bit-string->bytes ipv6-addr))))))
((wks) (bit-string-case rdata ((wks) (bit-string-case rdata
([ a b c d protocol (bitmap :: binary) ] ([ a b c d protocol (bitmap :: binary) ]
(wks (vector a b c d) protocol bitmap)))) (wks (vector a b c d) protocol (bit-string->bytes bitmap)))))
((srv) (bit-string-case rdata ((srv) (bit-string-case rdata
([ (priority :: bits 16) ([ (priority :: bits 16)
(weight :: bits 16) (weight :: bits 16)
@ -432,7 +471,7 @@
(srv priority weight port target)))) (srv priority weight port target))))
(else (bit-string->bytes rdata)))) (else (bit-string->bytes rdata))))
;; RRType RData -> Bitstring (: encode-rdata : RRType RData -> BitString)
;; Encode RData according to the RRType. ;; Encode RData according to the RRType.
(define (encode-rdata type rdata) (define (encode-rdata type rdata)
(case type (case type
@ -451,7 +490,7 @@
((soa-retry rdata) :: bits 32) ((soa-retry rdata) :: bits 32)
((soa-expire rdata) :: bits 32) ((soa-expire rdata) :: bits 32)
((soa-minimum rdata) :: bits 32))) ((soa-minimum rdata) :: bits 32)))
((txt) (bit-string (rdata :: (t:listof (t:pascal-string))))) ((txt) (bit-string (rdata :: (t:listof Bytes (t:pascal-string)))))
((a) (match rdata ((vector a b c d) (bit-string a b c d)))) ((a) (match rdata ((vector a b c d) (bit-string a b c d))))
((aaaa) (bit-string ((list->bytes (vector->list rdata)) :: binary bits 128))) ((aaaa) (bit-string ((list->bytes (vector->list rdata)) :: binary bits 128)))
((wks) (match (wks-address rdata) ((wks) (match (wks-address rdata)
@ -464,4 +503,5 @@
(else rdata))) (else rdata)))
;; UInt32 ;; UInt32
(: max-ttl : Nonnegative-Integer)
(define max-ttl #xffffffff) (define max-ttl #xffffffff)

14
mapping.rkt
View File

@ -1,4 +1,4 @@
#lang racket/base #lang typed/racket/base
;; Macros for defining weak and extensible mappings between sets of values ;; Macros for defining weak and extensible mappings between sets of values
(provide define-mapping) (provide define-mapping)
@ -13,13 +13,13 @@
((_ fn bn fd bd (lhs rhs) ...) ((_ fn bn fd bd (lhs rhs) ...)
(begin (begin
(define (fn l) (define (fn l)
(case l (cond
((lhs) 'rhs) ... ((eqv? l 'lhs) 'rhs) ...
(else (fd l)))) (else (fd l))))
(define (bn r) (define (bn r)
(case r (cond
((rhs) 'lhs) ... ((eqv? r 'rhs) 'lhs) ...
(else (bd r)))))))) (else (bd r))))))))
;; Symbol -> raised exn:fail:contract ;; Symbol -> raised exn:fail:contract
;; Used by default to complain when no specific mapping is found. ;; Used by default to complain when no specific mapping is found.

87
tk-dns.rkt
View File

@ -1,11 +1,11 @@
#lang racket/base #lang typed/racket/base
;; DNS drivers using racket-typed-matrix. ;; DNS drivers using racket-typed-matrix.
(require racket/set) (require racket/set)
(require racket/match) (require racket/match)
(require "codec.rkt") (require "codec.rkt")
(require racket-typed-matrix/sugar-untyped) (require racket-typed-matrix/sugar-typed)
(require racket-typed-matrix/drivers/udp-untyped) (require racket-typed-matrix/drivers/udp)
(provide (struct-out bad-dns-packet) (provide (struct-out bad-dns-packet)
(struct-out dns-request) (struct-out dns-request)
@ -14,25 +14,27 @@
dns-write-driver dns-write-driver
dns-spy) dns-spy)
(struct bad-dns-packet (detail source sink reason) #:prefab) (struct: bad-dns-packet
(struct dns-request (message source sink) #:prefab) ([detail : Any] [source : UdpAddress] [sink : UdpAddress] [reason : Symbol]) #:prefab)
(struct dns-reply (message source sink) #:prefab) (struct: dns-request ([message : DNSMessage] [source : UdpAddress] [sink : UdpAddress]) #:prefab)
(struct: dns-reply ([message : DNSMessage] [source : UdpAddress] [sink : UdpAddress]) #:prefab)
(define (dns-read-driver s) (define (dns-read-driver s)
(transition 'no-state (transition: (void) : Void
(at-meta-level (at-meta-level
(endpoint #:subscriber (udp-packet-pattern (wild) s (wild)) (endpoint: : Void
[(udp-packet source (== s) #"") #:subscriber (udp-packet-pattern (wild) s (wild))
(begin (log-info "Debug dump packet received") [(udp-packet source (== s) #"")
(send-message `(debug-dump)))] (begin (log-info "Debug dump packet received")
[(udp-packet source (== s) body) (send-message `(debug-dump)))]
(send-message [(udp-packet source (== s) body)
(with-handlers ((exn:fail? (lambda (e) (send-message
(bad-dns-packet body source s 'unparseable)))) (with-handlers ((exn:fail? (lambda (e)
(define message (packet->dns-message body)) (bad-dns-packet body source s 'unparseable))))
(case (dns-message-direction message) (define message (packet->dns-message body))
((request) (dns-request message source s)) (case (dns-message-direction message)
((response) (dns-reply message source s)))))])))) ((request) (dns-request message source s))
((response) (dns-reply message source s)))))]))))
(define (dns-write-driver s) (define (dns-write-driver s)
(define (translate message sink) (define (translate message sink)
@ -40,26 +42,31 @@
(send-message (bad-dns-packet message s sink 'unencodable))))) (send-message (bad-dns-packet message s sink 'unencodable)))))
(at-meta-level (at-meta-level
(send-message (udp-packet s sink (dns-message->packet message)))))) (send-message (udp-packet s sink (dns-message->packet message))))))
(transition 'no-state (transition: (void) : Void
(endpoint #:subscriber (dns-request (wild) s (wild)) (endpoint: : Void
[(dns-request message (== s) sink) (translate message sink)]) #:subscriber (dns-request (wild) s (wild))
(endpoint #:subscriber (dns-reply (wild) s (wild)) [(dns-request message (== s) sink) (translate message sink)])
[(dns-reply message (== s) sink) (translate message sink)]))) (endpoint: : Void
#:subscriber (dns-reply (wild) s (wild))
[(dns-reply message (== s) sink) (translate message sink)])))
(: dns-spy : (All (ParentState) -> (Action ParentState)))
(define (dns-spy) (define (dns-spy)
(spawn #:child (spawn: #:parent : ParentState
(transition 'none #:child : Void
(endpoint #:subscriber (wild) #:observer (transition: (void) : Void
[(dns-request message source sink) (endpoint: : Void
(begin (log-info (format "DNS: ~v asks ~v ~v~n : ~v" #:subscriber (wild) #:observer
source sink (dns-message-id message) [(dns-request message source sink)
(dns-message-questions message))) (begin (log-info (format "DNS: ~v asks ~v ~v~n : ~v"
(void))] source sink (dns-message-id message)
[(dns-reply message source sink) (dns-message-questions message)))
(begin (log-info (format "DNS: ~v answers ~v~n : ~v" (void))]
source sink [(dns-reply message source sink)
message)) (begin (log-info (format "DNS: ~v answers ~v~n : ~v"
(void))] source sink
[x message))
(begin (log-info (format "DNS: ~v" x)) (void))]
(void))])))) [x
(begin (log-info (format "DNS: ~v" x))
(void))]))))