diff --git a/api-untyped.rkt b/api-untyped.rkt index 4665075..4c9dce1 100644 --- a/api-untyped.rkt +++ b/api-untyped.rkt @@ -22,7 +22,9 @@ (require marketplace/struct-map) -(provide (struct-out domain)) +(provide (struct-out domain) + downcase-labels + make-domain) ;; (These utilities need to be defined ahead of the domain struct ;; definition.) diff --git a/api.rkt b/api.rkt index 309c94e..1067e68 100644 --- a/api.rkt +++ b/api.rkt @@ -1,4 +1,4 @@ -#lang typed/racket/base +#lang racket/base ;; Definitions for use in the API to the functionality of the library. ;; ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones @@ -19,18 +19,12 @@ ;;; along with marketplace-dns. If not, see ;;; . -(provide DomainName - (except-out (struct-out domain) domain) +(provide (except-out (struct-out domain) domain) (rename-out [make-domain domain]) domain-root? domain-parent - IPv4 - IPv6 - - (struct-out question-repr) - Question question question? - QuestionPattern question-pattern question-pattern? + (struct-out question) question-cyclic? question-too-glueless? @@ -39,19 +33,14 @@ cname-question ns-question - (struct-out answered-question-repr) - AnsweredQuestion answered-question answered-question? - AnsweredQuestionPattern answered-question-pattern answered-question-pattern? + (struct-out answered-question) (struct-out rr) - RR - CompleteAnswer (struct-out complete-answer) empty-complete-answer merge-answers extract-addresses - RData (struct-out rdata) (struct-out rdata-domain) (struct-out rdata-ipv4) @@ -66,10 +55,6 @@ (struct-out rdata-raw) rdata-type-pred - RRType - QueryType - RRClass - QueryClass type->value value->type qtype->value value->qtype class->value value->class @@ -80,48 +65,29 @@ (require racket/match) (require marketplace) (require marketplace/struct-map) -(require marketplace/support/pseudo-substruct) ;; A DomainName is a (domain ListOf), representing a domain ;; name. The head of the list is the leftmost label; for example, ;; www.google.com is represented as '(#"www" #"google" #"com"). -(require/typed "api-untyped.rkt" - [#:struct domain ([labels : (Listof Bytes)] - [downcased-labels : (Listof Bytes)])]) -(define-type DomainName domain) +(require "api-untyped.rkt") ;; A ShortString is a String with length 255 or shorter. ;; An IPv4 is a (vector Byte Byte Byte Byte), representing an IPv4 ;; address. For example, 127.0.0.1 is represented as (vector 127 0 0 ;; 1). -(define-type IPv4 (Vector Byte Byte Byte Byte)) ;; An IPv6 is a Vector of length 16 containing Bytes, representing an ;; IPv6 address. For example, 2001:0db8:85a3:0000:0000:8a2e:0370:7334 ;; is represented as (vector #x20 #x01 #x0d #xb8 #x85 #xa3 #x00 #x00 ;; #x00 #x00 #x8a #x2e #x03 #x70 #x73 #x34). -(define-type IPv6 (Vector Byte Byte Byte Byte - Byte Byte Byte Byte - Byte Byte Byte Byte - Byte Byte Byte Byte)) ;; A Question is a (question DomainName QueryType QueryClass ;; QuestionContext), representing a DNS question: "What are the RRs ;; for the given name, type and class?" as well as a possible parent ;; question that the answer to this question is to contribute to the ;; answer to. -(struct: (TName TType TClass TContext) - question-repr - ([name : TName] [type : TType] [class : TClass] [context : TContext]) - #:transparent) -(pseudo-substruct: (question-repr DomainName QueryType QueryClass QuestionContext) - Question question question?) -(pseudo-substruct: (question-repr (U Wild DomainName) - (U Wild QueryType) - (U Wild QueryClass) - (U Wild QuestionContext)) - QuestionPattern question-pattern question-pattern?) +(struct question (name type class context) #:transparent) ;; A QuestionContext is one of ;; -- (cname-subq Question), resulting from the expansion of a CNAME @@ -134,33 +100,20 @@ ;; excessively-glueless subquestion not represented here, and should ;; *not* in turn be considered for gluelessness-restarting: this is ;; needed to avoid a different kind of infinite loop. -(struct: subquestion ([parent : Question]) #:transparent) -(struct: cname-subq subquestion () #:transparent) -(struct: ns-subq subquestion () #:transparent) -(define-type QuestionContext (U subquestion cname-subq ns-subq False 'restart)) +(struct subquestion (parent) #:transparent) +(struct cname-subq subquestion () #:transparent) +(struct ns-subq subquestion () #:transparent) ;; An AnsweredQuestion is an (answered-question Question ;; Maybe). -(struct: (TQ TA) answered-question-repr ([q : TQ] [a : TA]) #:transparent) -(pseudo-substruct: (answered-question-repr Question (Option CompleteAnswer)) - AnsweredQuestion answered-question answered-question?) -(pseudo-substruct: (answered-question-repr (U Wild Question) (U Wild (Option CompleteAnswer))) - AnsweredQuestionPattern answered-question-pattern answered-question-pattern?) +(struct answered-question (q a) #:transparent) ;; A CompleteAnswer is a (complete-answer Set Set Set) -(struct: complete-answer - ([rrs : (Setof RR)] [authorities : (Setof RR)] [additional : (Setof RR)]) - #:transparent) -(define-type CompleteAnswer complete-answer) +(struct complete-answer (rrs authorities additional) #:transparent) -;; An RR is a (rr DomainName RRType RRClass Uint32 RData), +;; An RR is a (rr DomainName RRClass Uint32 RData), ;; representing a resource record. -(struct: rr ([name : DomainName] - [class : RRClass] - [ttl : Nonnegative-Integer] - [rdata : RData]) - #:transparent) -(define-type RR rr) +(struct rr (name class ttl rdata) #:transparent) ;; An RData is one of ;; - a DomainName, for CNAME, MB, MD, MF, MG, MR, NS and PTR records @@ -181,30 +134,20 @@ ;; ;; Many of these variants are obsolete in today's DNS database (marked ;; [O] above). -(struct: rdata ([type : RRType]) #:transparent) -(struct: rdata-domain rdata ([name : DomainName]) #:transparent) -(struct: rdata-ipv4 rdata ([address : IPv4]) #:transparent) -(struct: rdata-ipv6 rdata ([address : IPv6]) #:transparent) -(struct: rdata-hinfo rdata ([cpu : Bytes] [os : Bytes]) #:transparent) -(struct: rdata-minfo rdata ([rmailbx : DomainName] [emailbx : DomainName]) #:transparent) -(struct: rdata-mx rdata ([preference : Nonnegative-Integer] [exchange : DomainName]) #:transparent) -(struct: rdata-soa rdata ([mname : DomainName] - [rname : DomainName] - [serial : Nonnegative-Integer] - [refresh : Nonnegative-Integer] - [retry : Nonnegative-Integer] - [expire : Nonnegative-Integer] - [minimum : Nonnegative-Integer]) #:transparent) -(struct: rdata-wks rdata ([address : IPv4] [protocol : Byte] [bitmap : Bytes]) #:transparent) -(struct: rdata-srv rdata ([priority : Nonnegative-Integer] - [weight : Nonnegative-Integer] - [port : Nonnegative-Integer] - [target : DomainName]) #:transparent) -(struct: rdata-txt rdata ([strings : (Listof Bytes)]) #:transparent) -(struct: rdata-raw rdata ([body : Bytes]) #:transparent) -(define-type RData rdata) +(struct rdata (type) #:transparent) +(struct rdata-domain rdata (name) #:transparent) +(struct rdata-ipv4 rdata (address) #:transparent) +(struct rdata-ipv6 rdata (address) #:transparent) +(struct rdata-hinfo rdata (cpu os) #:transparent) +(struct rdata-minfo rdata (rmailbx emailbx) #:transparent) +(struct rdata-mx rdata (preference exchange) #:transparent) +(struct rdata-soa rdata (mname rname serial refresh retry expire minimum) #:transparent) +(struct rdata-wks rdata (address protocol bitmap) #:transparent) +(struct rdata-srv rdata (priority weight port target) #:transparent) +(struct rdata-txt rdata (strings) #:transparent) +(struct rdata-raw rdata (body) #:transparent) -(: rdata-type-pred : RRType -> (RData -> Boolean)) +;; (: rdata-type-pred : RRType -> (RData -> Boolean)) (define ((rdata-type-pred t) d) (eq? (rdata-type d) t)) @@ -212,12 +155,8 @@ ;; in the following define-mapping. It represents the type of an ;; RR. When used in an RR with an RData, the RRType and the RData ;; variant must correspond. -(define-type RRType (U 'a 'ns 'md 'mf 'cname 'soa 'mb 'mg - 'mr 'null 'wks 'ptr 'hinfo 'minfo 'mx 'txt - 'aaaa 'srv - Nonnegative-Integer)) -(: type->value : RRType -> Nonnegative-Integer) -(: value->type : Nonnegative-Integer -> RRType) +;; (: type->value : RRType -> Nonnegative-Integer) +;; (: value->type : Nonnegative-Integer -> RRType) (define-mapping type->value value->type #:forward-default values #:backward-default values @@ -243,9 +182,8 @@ ;; A QueryType is a Symbol or Number (as given in the following ;; define-mapping) or an RRType. It specifies the kinds of records ;; being sought after in a DNS query. -(define-type QueryType (U RRType 'axfr 'mailb 'maila '*)) -(: qtype->value : QueryType -> Nonnegative-Integer) -(: value->qtype : Nonnegative-Integer -> QueryType) +;; (: qtype->value : QueryType -> Nonnegative-Integer) +;; (: value->qtype : Nonnegative-Integer -> QueryType) (define-mapping qtype->value value->qtype #:forward-default type->value #:backward-default value->type @@ -258,9 +196,8 @@ ;; in the following define-mapping. It represents the "class" of DNS ;; records being discussed. All classes except 'in are obsolete in ;; today's DNS databases. -(define-type RRClass (U 'in 'cs 'ch 'hs Nonnegative-Integer)) -(: class->value : RRClass -> Nonnegative-Integer) -(: value->class : Nonnegative-Integer -> RRClass) +;; (: class->value : RRClass -> Nonnegative-Integer) +;; (: value->class : Nonnegative-Integer -> RRClass) (define-mapping class->value value->class #:forward-default values #:backward-default values @@ -272,48 +209,28 @@ ;; A QueryClass is a Symbol or Number (as given in the following ;; define-mapping) or an RRClass. It specifies the "class" of records ;; being sought after in a DNS query. -(define-type QueryClass (U RRClass '*)) -(: qclass->value : QueryClass -> Nonnegative-Integer) -(: value->qclass : Nonnegative-Integer -> QueryClass) +;; (: qclass->value : QueryClass -> Nonnegative-Integer) +;; (: value->qclass : Nonnegative-Integer -> QueryClass) (define-mapping qclass->value value->qclass #:forward-default class->value #:backward-default value->class (* 255)) -;; ListOf -> ListOf -;; Converts the 7-bit ASCII bytes in the argument to lower-case -;; equivalents. Used to normalize case for domain-name comparisons. -(: downcase-labels : (Listof Bytes) -> (Listof Bytes)) -(define (downcase-labels labels) - (for/list ([label labels]) - (define b (make-bytes (bytes-length label))) - (for ([i (bytes-length label)]) - (define v (bytes-ref label i)) - (bytes-set! b i (if (<= 65 v 90) (+ 32 v) v))) - b)) - -;; ListOf -> DomainName -;; Replacement constructor for domain structs. Automatically downcases -;; labels appropriately. -(: make-domain : (Listof Bytes) -> DomainName) -(define (make-domain labels) - (domain labels (downcase-labels labels))) - -(: domain-root? : DomainName -> Boolean) +;; (: domain-root? : DomainName -> Boolean) (define (domain-root? d) (null? (domain-labels d))) -(: domain-parent : DomainName -> (Option DomainName)) +;; (: domain-parent : DomainName -> (Option DomainName)) (define (domain-parent d) (and (pair? (domain-labels d)) (domain (cdr (domain-labels d)) (cdr (domain-downcased-labels d))))) -(: empty-complete-answer : -> CompleteAnswer) +;; (: empty-complete-answer : -> CompleteAnswer) (define (empty-complete-answer) (complete-answer (set) (set) (set))) -(: merge-answers : CompleteAnswer CompleteAnswer -> CompleteAnswer) +;; (: merge-answers : CompleteAnswer CompleteAnswer -> CompleteAnswer) (define (merge-answers a1 a2) (match-define (complete-answer n1 u1 d1) a1) (match-define (complete-answer n2 u2 d2) a2) @@ -321,7 +238,7 @@ (set-union u1 u2) (set-union d1 d2))) -(: extract-addresses : DomainName (Option CompleteAnswer) -> (Setof IPv4)) +;; (: extract-addresses : DomainName (Option CompleteAnswer) -> (Setof IPv4)) (define (extract-addresses name ans) (match ans [#f ;; name-error/NXDOMAIN, so definitely no addresses. @@ -329,12 +246,12 @@ [(complete-answer ns us ds) (define rrs (set->list (set-union ns us ds))) (let loop ((names (list name)) - (ips ((inst set IPv4))) - (seen ((inst set DomainName)))) + (ips (set)) + (seen (set))) (if (null? names) ips (let* ((name (car names)) - (records (filter (lambda: ([rr : RR]) (equal? name (rr-name rr))) rrs)) + (records (filter (lambda (rr) (equal? name (rr-name rr))) rrs)) (data (map rr-rdata records))) (if (set-member? seen name) (loop (cdr names) ips seen) @@ -348,10 +265,10 @@ ;; #t iff this question is being asked in order to supply answers ;; contributing to a parent context that's trying to answer exactly ;; this question. -(: question-cyclic? : Question -> Boolean) +;; (: question-cyclic? : Question -> Boolean) (define (question-cyclic? q) (match-define (question name type class parent) q) - (let: search : Boolean ((ancestor : QuestionContext parent)) + (let search ((ancestor parent)) (match ancestor [(subquestion (question (== name) (== type) (== class) _)) #t] ;; uh-oh! A cycle! [(subquestion (question _ _ _ ancestor-parent)) (search ancestor-parent)] ;; recursive case @@ -363,10 +280,10 @@ ;; from the outside world, then that's too glueless. See ;; http://cr.yp.to/djbdns/notes.html in the sections "Gluelessness" ;; and "Expiring glue". -(: question-too-glueless? : Question -> Boolean) +;; (: question-too-glueless? : Question -> Boolean) (define (question-too-glueless? q) (define count - (let: search : Integer ((q : Question q) (acc : Integer 0)) + (let search ((q q) (acc 0)) (match-define (question _ _ _ parent) q) (cond [(ns-subq? parent) (search (subquestion-parent parent) (+ acc 1))] @@ -382,7 +299,7 @@ ;; Question -> Boolean ;; #t iff this question is being asked in the context of some ;; excessively glueless subquestion. -(: question-restarted? : Question -> Boolean) +;; (: question-restarted? : Question -> Boolean) (define (question-restarted? q) (match-define (question name type class parent) q) (let search ((ancestor parent)) @@ -394,19 +311,19 @@ ;; Question -> Question ;; Returns a question equivalent to q, but in a 'restart context, for ;; retracing from the roots in cases of excessive gluelessness. -(: restart-question : Question -> Question) +;; (: restart-question : Question -> Question) (define (restart-question q) - (struct-copy question-repr q [context 'restart])) + (struct-copy question q [context 'restart])) ;; DomainName Question -> Question ;; Produces a new question with CNAME context. -(: cname-question : DomainName Question -> Question) +;; (: cname-question : DomainName Question -> Question) (define (cname-question name q) (match-define (question _ type class _) q) (question name type class (cname-subq q))) ;; DomainName Question -> Question ;; Produces a new question with NS context. -(: ns-question : DomainName Question -> Question) +;; (: ns-question : DomainName Question -> Question) (define (ns-question name q) (question name 'a 'in (ns-subq q))) ;; TODO: 'aaaa ? diff --git a/codec.rkt b/codec.rkt index efc148c..9930c78 100644 --- a/codec.rkt +++ b/codec.rkt @@ -1,4 +1,4 @@ -#lang typed/racket/base +#lang racket/base ;; DNS wire-protocol codec. ;; ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones @@ -19,17 +19,9 @@ ;;; along with marketplace-dns. If not, see ;;; . -(provide Opcode - ResponseCode - value->query-opcode query-opcode->value +(provide value->query-opcode query-opcode->value value->query-response-code query-response-code->value - DNSMessage - Direction - Authoritativeness - Truncatedness - RecursionDesired - RecursionAvailable (struct-out dns-message) packet->dns-message @@ -50,9 +42,8 @@ ;; An Opcode is a Symbol or a Number, one of the possibilities given ;; in the following define-mapping. It represents a DNS message ;; operation; see the RFC for details. -(define-type Opcode (U 'query 'iquery 'status Nonnegative-Integer)) -(: value->query-opcode : Nonnegative-Integer -> Opcode) -(: query-opcode->value : Opcode -> Nonnegative-Integer) +;; (: value->query-opcode : Nonnegative-Integer -> Opcode) +;; (: query-opcode->value : Opcode -> Nonnegative-Integer) (define-mapping value->query-opcode query-opcode->value #:forward-default values #:backward-default values @@ -63,11 +54,8 @@ ;; A ResponseCode is a Symbol or a Number, one of the possibilities ;; given in the following define-mapping. It represents the outcome of ;; a DNS query. -(define-type ResponseCode (U 'no-error 'format-error 'server-failure - 'name-error 'not-implemented 'refused - Nonnegative-Integer)) -(: value->query-response-code : Nonnegative-Integer -> ResponseCode) -(: query-response-code->value : ResponseCode -> Nonnegative-Integer) +;; (: value->query-response-code : Nonnegative-Integer -> ResponseCode) +;; (: query-response-code->value : ResponseCode -> Nonnegative-Integer) (define-mapping value->query-response-code query-response-code->value (0 no-error) (1 format-error) @@ -83,25 +71,24 @@ ;; ;; Interpreted as either a DNS request or reply, depending on the ;; Direction. -(struct: dns-message ([id : Nonnegative-Integer] - [direction : Direction] - [opcode : Opcode] - [authoritative : Authoritativeness] - [truncated : Truncatedness] - [recursion-desired : RecursionDesired] - [recursion-available : RecursionAvailable] - [response-code : ResponseCode] - [questions : (Listof Question)] - [answers : (Listof RR)] - [authorities : (Listof RR)] - [additional : (Listof RR)]) - #:transparent) -(define-type DNSMessage dns-message) -(define-type Direction (U 'request 'response)) -(define-type Authoritativeness (U 'non-authoritative 'authoritative)) -(define-type Truncatedness (U 'not-truncated 'truncated)) -(define-type RecursionDesired (U 'no-recursion-desired 'recursion-desired)) -(define-type RecursionAvailable (U 'no-recursion-available 'recursion-available)) +(struct dns-message (id + direction + opcode + authoritative + truncated + recursion-desired + recursion-available + response-code + questions + answers + authorities + additional) + #:transparent) +;; (define-type Direction (U 'request 'response)) +;; (define-type Authoritativeness (U 'non-authoritative 'authoritative)) +;; (define-type Truncatedness (U 'not-truncated 'truncated)) +;; (define-type RecursionDesired (U 'no-recursion-desired 'recursion-desired)) +;; (define-type RecursionAvailable (U 'no-recursion-available 'recursion-available)) ;; Bit-syntax type for counted repeats of a value. ;; Example: Length-prefixed list of 32-bit unsigned words: @@ -115,7 +102,7 @@ ;; here, but I can't find a way of expressing the types ;; required while making that work. This way, we avoid needing ;; to mention the type of the result of calls to ks. - (: loop : Integer (Listof Type) BitString -> (Values (Option (Listof Type)) BitString)) + ;; (: loop : Integer (Listof Type) BitString -> (Values (Option (Listof Type)) BitString)) (define (loop count acc input) (cond ((positive? count) (bit-string-case input @@ -158,7 +145,7 @@ (else (kf)))) ((_ #f vs Type option ...) - (let: loop : BitString ((vs : (Listof Type) vs)) + (let loop ((vs vs)) (cond ((pair? vs) (bit-string ((car vs) :: option ...) ((loop (cdr vs)) :: binary))) @@ -202,7 +189,7 @@ ;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ ;; -(: packet->dns-message : BitString -> DNSMessage) +;; (: packet->dns-message : BitString -> DNSMessage) ;; Parse an encoded DNS message packet into the corresponding Racket ;; structure. Raises an exception on failure. (define (packet->dns-message packet) @@ -232,7 +219,7 @@ (value->query-response-code rcode) q-section a-section auth-section additional-section)))) -(: dns-message->packet : DNSMessage -> Bytes) +;; (: dns-message->packet : DNSMessage -> Bytes) ;; Render a Racket structured DNS message using the DNS binary encoding. (define (dns-message->packet m) (bit-string->bytes @@ -288,14 +275,14 @@ ((_ #f val) (encode-domain-name val)))) -(: encode-domain-name : DomainName -> BitString) +;; (: encode-domain-name : DomainName -> BitString) (define (encode-domain-name name) (define labels (domain-labels name)) (bit-string (labels :: (t:listof Bytes (t:pascal-string "Label" 64))) (0 :: integer bytes 1))) ;; end of list of labels! -(: parse-domain-name : - BitString BitString (Listof Natural) -> (Values (Listof Bytes) BitString)) +;; (: parse-domain-name : +;; BitString BitString (Listof Natural) -> (Values (Listof Bytes) BitString)) ;; PRECONDITION: input never empty ;; INVARIANT: pointers-followed contains every "jump target" we have ;; jumped to so far during decoding of this domain-name, in order to @@ -337,7 +324,7 @@ ((_ #f val) (t:pascal-string #f val "Character-string" 256)) ((_ #f val string-kind length-limit) - (let: ([s : Bytes val]) + (let ([s val]) (let ((len (bytes-length s))) (when (>= len length-limit) (error 't:pascal-string "~s too long: ~v" string-kind s)) @@ -377,10 +364,10 @@ #f) tail)))) ((_ #f val) - (let: ([q : Question val]) - (bit-string ((question-repr-name q) :: (t:domain-name)) - ((qtype->value (question-repr-type q)) :: bits 16) - ((qclass->value (question-repr-class q)) :: bits 16)))))) + (let ([q val]) + (bit-string ((question-name q) :: (t:domain-name)) + ((qtype->value (question-type q)) :: bits 16) + ((qclass->value (question-class q)) :: bits 16)))))) ;; ;; All RRs have the same top level format shown below: @@ -429,7 +416,7 @@ tail))) (else (kf))))) ((_ #f val) - (let: ([rr : RR val]) + (let ([rr val]) (let ((encoded-rdata (encode-rdata (rr-rdata rr)))) (bit-string ((rr-name rr) :: (t:domain-name)) ((type->value (rdata-type (rr-rdata rr))) :: bits 16) @@ -438,7 +425,7 @@ ((quotient (bit-string-length encoded-rdata) 8) :: bits 16) (encoded-rdata :: binary))))))) -(: decode-rdata : BitString RRType BitString -> RData) +;; (: decode-rdata : BitString RRType BitString -> RData) ;; Decode RData according to the RRType. Takes the whole packet for ;; the same reason as t:rr does. (define (decode-rdata whole-packet type rdata) @@ -487,7 +474,7 @@ (rdata-srv type priority weight port target)))) (else (rdata-raw type (bit-string->bytes rdata))))) -(: encode-rdata : RData -> BitString) +;; (: encode-rdata : RData -> BitString) ;; Encode RData according to its RRType. (define (encode-rdata rdata) (match rdata @@ -519,5 +506,5 @@ [(rdata-raw _ bs) bs])) ;; UInt32 -(: max-ttl : Nonnegative-Integer) +;; (: max-ttl : Nonnegative-Integer) (define max-ttl #xffffffff) diff --git a/driver.rkt b/driver.rkt index 5aaa0f1..897578f 100644 --- a/driver.rkt +++ b/driver.rkt @@ -1,4 +1,4 @@ -#lang typed/racket/base +#lang racket/base ;; DNS server using os-big-bang.rkt and os-udp.rkt. ;; ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones @@ -28,7 +28,7 @@ (require "codec.rkt") (require "zonedb.rkt") (require "resolver.rkt") -(require marketplace/sugar-typed) +(require marketplace/sugar) (require marketplace/support/spy) (require marketplace/drivers/udp) (require "tk-dns.rkt") @@ -46,7 +46,7 @@ ;; determines subzones based on the RRs it is configured with at ;; startup. -(: start-server : Nonnegative-Integer RR (Listof RR) -> Void) +;; (: start-server : Nonnegative-Integer RR (Listof RR) -> Void) ;; Starts a server that will answer questions received on the given ;; UDP port based on the RRs it is given and the zone origin specified ;; in the soa-rr given. @@ -58,26 +58,26 @@ (display ";; Ready.\n") - (ground-vm: ((inst udp-driver Void)) - ((inst generic-spy Void) 'UDP) - (spawn-vm: : Void - (spawn: #:parent : Void #:child : Void (dns-spy)) - (spawn: #:parent : Void #:child : Void (dns-read-driver local-addr)) - (spawn: #:parent : Void #:child : Void (dns-write-driver local-addr)) - (subscriber: Void (bad-dns-packet-pattern (wild) (wild) (wild) (wild)) - (on-message [p (begin (log-error (pretty-format p)) '())])) - (subscriber: Void (dns-request-pattern (wild) (wild) (wild)) - (on-message [(? dns-request? r) - (let ((reply (handle-request soa-rr zone r))) - (when reply (send-message reply)))]))))) + (ground-vm (udp-driver) + (generic-spy 'UDP) + (spawn-vm + (spawn (dns-spy)) + (spawn (dns-read-driver local-addr)) + (spawn (dns-write-driver local-addr)) + (subscriber (bad-dns-packet (wild) (wild) (wild) (wild)) + (on-message [p (begin (log-error (pretty-format p)) '())])) + (subscriber (dns-request (wild) (wild) (wild)) + (on-message [(? dns-request? r) + (let ((reply (handle-request soa-rr zone r))) + (when reply (send-message reply)))]))))) -(define-type ReplyMaker (DomainName Boolean (Setof RR) (Setof RR) (Setof RR) -> DNSMessage)) +;; (define-type ReplyMaker (DomainName Boolean (Setof RR) (Setof RR) (Setof RR) -> DNSMessage)) -(: handle-request : RR CompiledZone DNSRequest -> (Option DNSReply)) +;; (: handle-request : RR CompiledZone DNSRequest -> (Option DNSReply)) (define (handle-request soa-rr zone request) (match-define (dns-request request-message request-source request-sink) request) - (: make-reply : ReplyMaker) + ;; (: make-reply : ReplyMaker) (define (make-reply name send-name-error? answers authorities additional) (dns-message (dns-message-id request-message) 'response @@ -92,7 +92,7 @@ (rr-set->list authorities) (rr-set->list additional))) - (: answer-question : Question ReplyMaker -> DNSMessage) + ;; (: answer-question : Question ReplyMaker -> DNSMessage) (define (answer-question q make-reply) ;; Notice that we claim to be authoritative for our configured ;; zone. If we ever answer name-error, that means there are no RRs @@ -110,7 +110,7 @@ ;; here. Reexamine the rules for doing so. (match-define (question qname qtype qclass #f) q) - (: expand-cnames : (Listof DomainName) CompleteAnswer -> DNSMessage) + ;; (: expand-cnames : (Listof DomainName) CompleteAnswer -> DNSMessage) (define (expand-cnames worklist ans) (match worklist ['() @@ -120,7 +120,7 @@ (define a (resolve-from-zone (cname-question next-cname q) zone soa-rr (set))) (incorporate-answer a rest ans)])) - (: incorporate-answer : Answer (Listof DomainName) CompleteAnswer -> DNSMessage) + ;; (: incorporate-answer : Answer (Listof DomainName) CompleteAnswer -> DNSMessage) (define (incorporate-answer this-answer worklist ans) (match this-answer [(partial-answer new-info more-cnames) diff --git a/mapping.rkt b/mapping.rkt index 0f2b5d5..3fcfba2 100644 --- a/mapping.rkt +++ b/mapping.rkt @@ -1,4 +1,4 @@ -#lang typed/racket/base +#lang racket/base ;; Macros for defining weak and extensible mappings between sets of values ;; ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones diff --git a/network-query.rkt b/network-query.rkt index 4b46008..bebaf30 100644 --- a/network-query.rkt +++ b/network-query.rkt @@ -1,4 +1,4 @@ -#lang typed/racket/base +#lang racket/base ;; ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones ;;; @@ -23,17 +23,13 @@ (require "api.rkt") (require "codec.rkt") (require "zonedb.rkt") -(require marketplace/sugar-typed) +(require marketplace/sugar) (require marketplace/drivers/udp) (require marketplace/drivers/timer) -(require marketplace/support/pseudo-substruct) (require "tk-dns.rkt") -(require (rename-in marketplace/tr-struct-copy [tr-struct-copy struct-copy])) ;; PR13149 (provide network-query - (struct-out network-reply-repr) - NetworkReply network-reply network-reply? - NetworkReplyPattern network-reply-pattern network-reply-pattern?) + (struct-out network-reply)) ;; DJB's rules for handling DNS responses. Some of these are handled ;; here (specifically, rules 2 through 5, in the action of @@ -130,45 +126,32 @@ ;; A NetworkRequest is a (network-request UdpAddress Question ;; DomainName NEListOf UniqueID) representing the ;; parameters used to start and process a network query. -(struct: network-request ([client-socket : UdpAddress] - [question : Question] - [zone-origin : DomainName] - [server-names : (Listof DomainName)] - [unique-id : Any]) - #:transparent) -(define-type NetworkRequest network-request) +(struct network-request (client-socket question zone-origin server-names unique-id) #:transparent) ;; A NetworkReply is a (network-reply UniqueID Maybe) ;; representing the final result of a network query. -(struct: (TId TAnswer) - network-reply-repr - ([unique-id : TId] [answer : TAnswer]) #:transparent) -(pseudo-substruct: (network-reply-repr Any (Option CompleteAnswer)) - NetworkReply network-reply network-reply?) -(pseudo-substruct: (network-reply-repr (U Wild Any) (U Wild (Option CompleteAnswer))) - NetworkReplyPattern network-reply-pattern network-reply-pattern?) +(struct network-reply (unique-id answer) #:transparent) ;; A NetworkQueryState is a (network-query-state NetworkRequest ;; Integer Map> ListOf ;; Maybe ListOf), representing an in-progress ;; DNS network query. -(struct: network-query-state ([request : NetworkRequest] - [timeout : (Option Natural)] - [known-addresses : (HashTable DomainName (Listof UdpAddress))] - [remaining-addresses : (Listof UdpAddress)] - [current-name : (Option DomainName)] - [remaining-names : (Listof DomainName)]) - #:transparent) -(define-type NetworkQueryState network-query-state) +(struct network-query-state (request + timeout + known-addresses + remaining-addresses + current-name + remaining-names) + #:transparent) -(: next-timeout : Natural -> (Option Natural)) +;; (: next-timeout : Natural -> (Option Natural)) (define (next-timeout timeout) (cond [(equal? timeout 3) 11] [(equal? timeout 11) 45] [else #f])) -(: make-dns-query-message : Question Nonnegative-Integer -> DNSMessage) +;; (: make-dns-query-message : Question Nonnegative-Integer -> DNSMessage) (define (make-dns-query-message q query-id) (dns-message query-id 'request @@ -183,9 +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 ;; of the passed-in `message`, returning the set of RRs surviving the ;; filter. RRs are only accepted if their `rr-name` falls in the @@ -200,25 +183,24 @@ (define (filter-dns-reply q message zone-origin) (case (dns-message-response-code message) [(no-error) - (: f : (Listof RR) -> (Setof RR)) + ;; (: f : (Listof RR) -> (Setof RR)) (define (f l) - (list->set (filter (lambda: ([claim-rr : RR]) - (in-bailiwick? (rr-name claim-rr) zone-origin)) l))) + (list->set (filter (lambda (claim-rr) (in-bailiwick? (rr-name claim-rr) zone-origin)) l))) ;; Here's where we do the "lame referral" check. This code is ;; nice and simple (though wrong) without it. Ho hum. (define answers (f (dns-message-answers message))) (define unfiltered-authorities (dns-message-authorities message)) (define non-subzone-ns-rrs ;; all NS authorities not for a STRICT subzone of our zone-origin - (filter (lambda: ([rr : RR]) (and (eqv? (rdata-type (rr-rdata rr)) 'ns) - (or (equal? (rr-name rr) zone-origin) - (not (in-bailiwick? (rr-name rr) zone-origin))))) + (filter (lambda (rr) (and (eqv? (rdata-type (rr-rdata rr)) 'ns) + (or (equal? (rr-name rr) zone-origin) + (not (in-bailiwick? (rr-name rr) zone-origin))))) unfiltered-authorities)) (define authorities (f unfiltered-authorities)) (define answers-to-q ;; answers specifically to the question we asked - (set-filter (lambda: ([rr : RR]) (equal? (rr-name rr) (question-repr-name q))) answers)) + (set-filter (lambda (rr) (equal? (rr-name rr) (question-name q))) answers)) (define lame? (and (set-empty? (filter-by-type answers-to-q 'cname)) - (set-empty? (filter-rrs answers-to-q (question-repr-type q) (question-repr-class q))) + (set-empty? (filter-rrs answers-to-q (question-type q) (question-class q))) (set-empty? (filter-by-type authorities 'soa)) (not (null? non-subzone-ns-rrs)))) (if lame? @@ -233,31 +215,29 @@ (dns-message-questions message))) 'bad-answer])) -(: ip->host-name : IPv4 -> String) +;; (: ip->host-name : IPv4 -> String) (define (ip->host-name ip-address) (match-define (vector a b c d) ip-address) (format "~a.~a.~a.~a" a b c d)) -(: make-dns-address : IPv4 -> UdpAddress) +;; (: make-dns-address : IPv4 -> UdpAddress) (define (make-dns-address ip-address) (udp-remote-address (ip->host-name ip-address) 53)) -(: network-query : (All (ParentState) - UdpAddress Question DomainName (Listof DomainName) Any -> - (Action ParentState))) +;; (: network-query : (All (ParentState) +;; UdpAddress Question DomainName (Listof DomainName) Any -> +;; (Action ParentState))) (define (network-query s q zone-origin server-names unique-id) (name-process (list 'network-query q) - (spawn: #:parent : ParentState - #:child : NetworkQueryState - (try-next-server - (network-query-state (network-request s q zone-origin server-names unique-id) - first-timeout - (ann #hash() (HashTable DomainName (Listof UdpAddress))) - '() - #f - server-names))))) + (spawn (try-next-server + (network-query-state (network-request s q zone-origin server-names unique-id) + first-timeout + #hash() + '() + #f + server-names))))) -(: try-next-server : NetworkQueryState -> (Transition NetworkQueryState)) +;; (: try-next-server : NetworkQueryState -> (Transition NetworkQueryState)) (define (try-next-server w) (define timeout (network-query-state-timeout w)) (if (not timeout) @@ -280,31 +260,31 @@ [current-name current-name] [remaining-names remaining-names])) (let ((subq (ns-question current-name (network-request-question req)))) - (transition: (struct-copy network-query-state w - [current-name current-name] - [remaining-names remaining-names]) : NetworkQueryState + (transition (struct-copy network-query-state w + [current-name current-name] + [remaining-names remaining-names]) (send-message subq) (let-fresh (subq-id) (name-endpoint subq-id - (subscriber: NetworkQueryState (answered-question-pattern subq (wild)) + (subscriber (answered-question subq (wild)) (match-state w (on-message [(answered-question (== subq) ans) (let ((ips (map make-dns-address (set->list (extract-addresses current-name ans))))) (sequence-actions - (try-next-server (struct-copy network-query-state w - [known-addresses (hash-set known-addresses - current-name - ips)] - [remaining-addresses ips])) - (delete-endpoint subq-id)))]))))))))] + (try-next-server (struct-copy network-query-state w + [known-addresses (hash-set known-addresses + current-name + ips)] + [remaining-addresses ips])) + (delete-endpoint subq-id)))]))))))))] [(network-query-state req _ _ (cons current-ip remaining-ips) _ _) (define rpc-id (gensym 'network-query/allocate-query-id)) - (transition: w : NetworkQueryState + (transition w (send-message `(request ,rpc-id allocate-query-id)) (name-endpoint rpc-id - (subscriber: NetworkQueryState `(reply ,rpc-id ,(wild)) + (subscriber `(reply ,rpc-id ,(wild)) (match-state w (on-message [`(reply ,(== rpc-id) ,(? exact-nonnegative-integer? id)) @@ -313,10 +293,10 @@ id timeout current-ip) - (delete-endpoint rpc-id))])))))]))) + (delete-endpoint rpc-id))])))))]))) -(: on-answer : NetworkQueryState CheckedAnswer (Option UdpAddress) - -> (Transition NetworkQueryState)) +;; (: on-answer : NetworkQueryState CheckedAnswer (Option UdpAddress) +;; -> (Transition NetworkQueryState)) (define (on-answer w ans server-ip) (match ans ['bad-answer ;; can come from filter-dns-reply @@ -334,17 +314,16 @@ (struct-copy network-query-state w [known-addresses (hash-update known-addresses current-name - (lambda: ([addrs : (Listof - UdpAddress)]) + (lambda (addrs) (remove server-ip addrs)))]) w))] [(and (or (? complete-answer?) #f) ans) - (transition: w : NetworkQueryState + (transition w (send-message (network-reply (network-request-unique-id (network-query-state-request w)) ans)))])) -(: send-request : NetworkQueryState Nonnegative-Integer Natural UdpAddress - -> (Transition NetworkQueryState)) +;; (: send-request : NetworkQueryState Nonnegative-Integer Natural UdpAddress +;; -> (Transition NetworkQueryState)) (define (send-request w query-id timeout server-ip) (match-define (network-request s q zone-origin _ _) (network-query-state-request w)) (define query (make-dns-query-message q query-id)) @@ -355,12 +334,12 @@ q query-id zone-origin server-ip timeout)) - (transition: w : NetworkQueryState + (transition w (send-message (dns-request query s server-ip)) (send-message (set-timer timeout-id (* timeout 1000) 'relative)) ;; TODO: Restore this to a "join" when proper pattern-unions are implemented (name-endpoint timeout-id - (subscriber: NetworkQueryState (timer-expired-pattern timeout-id (wild)) + (subscriber (timer-expired timeout-id (wild)) (match-state w (on-message [(timer-expired (== timeout-id) _) @@ -370,11 +349,11 @@ zone-origin server-ip timeout)) (sequence-actions (try-next-server w) - (delete-endpoint timeout-id) - (delete-endpoint reply-wait-id) - (send-message (list 'release-query-id query-id))))])))) + (delete-endpoint timeout-id) + (delete-endpoint reply-wait-id) + (send-message (list 'release-query-id query-id))))])))) (name-endpoint reply-wait-id - (subscriber: NetworkQueryState (dns-reply-pattern (wild) (wild) s) + (subscriber (dns-reply (wild) (wild) s) (match-state w (on-message [(dns-reply reply-message source (== s)) @@ -389,10 +368,10 @@ (dns-message-authorities reply-message) (dns-message-additional reply-message))) (if (not (= (dns-message-id reply-message) (dns-message-id query))) - (transition: w : NetworkQueryState) + (transition w) (sequence-actions (on-answer w (filter-dns-reply q reply-message zone-origin) server-ip) - (delete-endpoint timeout-id) - (delete-endpoint reply-wait-id) - (send-message (list 'release-query-id query-id)))))])))))) + (delete-endpoint timeout-id) + (delete-endpoint reply-wait-id) + (send-message (list 'release-query-id query-id)))))])))))) diff --git a/proxy.rkt b/proxy.rkt index 596f396..597879e 100644 --- a/proxy.rkt +++ b/proxy.rkt @@ -1,4 +1,4 @@ -#lang typed/racket/base +#lang racket/base ;; DNS proxy using os-big-bang.rkt and os-udp.rkt. ;; ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones @@ -28,7 +28,7 @@ (require "zonedb.rkt") (require "network-query.rkt") (require "resolver.rkt") -(require marketplace/sugar-typed) +(require marketplace/sugar) (require marketplace/support/spy) (require marketplace/drivers/timer) (require marketplace/drivers/udp) @@ -40,70 +40,59 @@ ;; searches from. Performs recursive queries. ;; For discarding retransmitted requests that we're still working on. -(struct: active-request ([source : UdpAddress] [id : Natural]) #:transparent) -(define-type ActiveRequest active-request) +(struct active-request (source id) #:transparent) -(: start-proxy : Natural CompiledZone CompiledZone -> Void) +;; (: start-proxy : Natural CompiledZone CompiledZone -> Void) (define (start-proxy port-number zone roots-only) (define server-addr (udp-listener port-number)) (define client-addr (udp-handle 'dns-client)) (log-info "Ready.") - (ground-vm: - ((inst generic-spy Void) 'UDP) - ((inst udp-driver Void)) - ((inst timer-driver Void)) - (spawn-vm: : Void - #:debug-name 'dns-vm - (name-process 'dns-spy (spawn: #:parent : Void #:child : Void (dns-spy))) - ((inst timer-relay Void) 'timer-relay:dns) - (name-process 'query-id-allocator (spawn: #:parent : Void #:child : (Setof Natural) - (query-id-allocator))) - (name-process 'server-dns-reader (spawn: #:parent : Void #:child : Void - (dns-read-driver server-addr))) - (name-process 'server-dns-writer (spawn: #:parent : Void #:child : Void - (dns-write-driver server-addr))) - (name-process 'client-dns-reader (spawn: #:parent : Void #:child : Void - (dns-read-driver client-addr))) - (name-process 'client-dns-writer (spawn: #:parent : Void #:child : Void - (dns-write-driver client-addr))) - (name-process 'packet-dispatcher (spawn: #:parent : Void - #:child : (Setof ActiveRequest) - (packet-dispatcher server-addr))) - (name-process 'question-dispatcher (spawn: #:parent : Void - #:child : CompiledZone - (question-dispatcher zone - roots-only - client-addr)))))) + (ground-vm + (generic-spy 'UDP) + (udp-driver) + (timer-driver) + (spawn-vm #:debug-name 'dns-vm + (name-process 'dns-spy (spawn (dns-spy))) + (timer-relay 'timer-relay:dns) + (name-process 'query-id-allocator (spawn (query-id-allocator))) + (name-process 'server-dns-reader (spawn (dns-read-driver server-addr))) + (name-process 'server-dns-writer (spawn (dns-write-driver server-addr))) + (name-process 'client-dns-reader (spawn (dns-read-driver client-addr))) + (name-process 'client-dns-writer (spawn (dns-write-driver client-addr))) + (name-process 'packet-dispatcher (spawn (packet-dispatcher server-addr))) + (name-process 'question-dispatcher (spawn (question-dispatcher zone + roots-only + client-addr)))))) -(: query-id-allocator : -> (Transition (Setof Natural))) +;; (: query-id-allocator : -> (Transition (Setof Natural))) (define (query-id-allocator) ;; TODO: track how many are allocated and throttle requests if too ;; many are in flight - (transition: ((inst set Natural)) : (Setof Natural) ;; all active query IDs - (subscriber: (Setof Natural) `(request ,(wild) allocate-query-id) + (transition (set) ;; all active query IDs + (subscriber `(request ,(wild) allocate-query-id) (match-state allocated (on-message [`(request ,reply-addr allocate-query-id) - (let: recheck : (Transition (Setof Natural)) () - (define n (random 65536)) - (if (set-member? allocated n) - (recheck) - (transition: (set-add allocated n) : (Setof Natural) - (send-message `(reply ,reply-addr ,n)))))]))) - (subscriber: (Setof Natural) `(release-query-id ,(wild)) + (let recheck () + (define n (random 65536)) + (if (set-member? allocated n) + (recheck) + (transition (set-add allocated n) + (send-message `(reply ,reply-addr ,n)))))]))) + (subscriber `(release-query-id ,(wild)) (match-state allocated (on-message [`(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) - (transition: ((inst set ActiveRequest)) : (Setof ActiveRequest) - (subscriber: (Setof ActiveRequest) (bad-dns-packet-pattern (wild) (wild) (wild) (wild)) + (transition (set) + (subscriber (bad-dns-packet (wild) (wild) (wild) (wild)) (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 (on-message [(and r (dns-request m source (== s))) @@ -112,23 +101,22 @@ ;; TODO: when we have presence/error-handling, remove req-id ;; from active requests once request-handler pseudothread exits. (if (set-member? old-active-requests req-id) - (transition: old-active-requests : (Setof ActiveRequest)) + (transition old-active-requests) ;; ^ 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) - (spawn: #:parent : (Setof ActiveRequest) - #:child : Void (packet-relay req-id r))))))]))) - (subscriber: (Setof ActiveRequest) (dns-reply-pattern (wild) s (wild)) + (spawn (packet-relay req-id r))))))]))) + (subscriber (dns-reply (wild) s (wild)) (match-state old-active-requests (on-message [(and r (dns-reply m (== s) sink)) (let ((req-id (active-request sink (dns-message-id m)))) - (transition: (set-remove old-active-requests req-id) : (Setof ActiveRequest)))]))))) + (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) (match-define (dns-request request-message request-source request-sink) request) - (: answer->reply : (Option Question) (Option CompleteAnswer) -> DNSReply) + ;; (: answer->reply : (Option Question) (Option CompleteAnswer) -> DNSReply) (define (answer->reply q a) (define-values (response-code ns us ds) (match a @@ -165,7 +153,7 @@ (send-message original-question) (let-fresh (wait-id) (name-endpoint wait-id - (subscriber: Void (answered-question-pattern original-question (wild)) + (subscriber (answered-question original-question (wild)) (on-message [(answered-question (== original-question) answer) (begin (log-debug (format "Final answer to ~v with query id ~v is ~v" @@ -175,14 +163,14 @@ (list (delete-endpoint wait-id) (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) ;; Restart q, an overly-glueless question, from the roots. (define restarted-question (restart-question q)) (transition/no-state (let-fresh (relay) (name-endpoint relay - (subscriber: Void (answered-question-pattern restarted-question (wild)) + (subscriber (answered-question restarted-question (wild)) (on-message [(answered-question (== restarted-question) ans) ;; We got the answer to our restarted question; now transform @@ -191,23 +179,21 @@ (list (delete-endpoint relay) (send-message (answered-question q ans)))])))) (name-process (list 'glueless-question-handler-inner restarted-question) - (spawn: #:parent : Void - #:child : QHState - (question-handler roots-only-zone restarted-question client-sock))))) + (spawn (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) - (: transition-and-set-timers : CompiledZone (Setof (Pairof DomainName Real)) - -> (Transition CompiledZone)) + ;; (: transition-and-set-timers : CompiledZone (Setof (Pairof DomainName Real)) + ;; -> (Transition CompiledZone)) (define (transition-and-set-timers new-zone timers) - (transition: new-zone : CompiledZone - (for/list: : (Listof (Action CompiledZone)) ([timerspec timers]) + (transition new-zone + (for/list ([timerspec timers]) (match-define (cons name ttl) timerspec) (send-message (set-timer (list 'check-dns-expiry name) (* ttl 1000) 'relative))))) (define-values (cleaned-seed-zone initial-timers) (zone-expire seed-zone)) (sequence-actions (transition-and-set-timers cleaned-seed-zone initial-timers) ;; TODO: consider deduping questions here too? - (subscriber: CompiledZone `(debug-dump) + (subscriber `(debug-dump) (match-state zone (on-message [`(debug-dump) @@ -222,9 +208,9 @@ (display "----------------------------------------------------------------------\n") (display (seconds->date (current-seconds))) (newline) - (for: ([name (in-hash-keys zone)]) + (for ([name (in-hash-keys zone)]) (define rrmap (hash-ref zone name)) - (for: ([rr (in-hash-keys rrmap)]) + (for ([rr (in-hash-keys rrmap)]) (define expiry (hash-ref rrmap rr)) (write (list rr expiry)) (newline))) @@ -239,12 +225,12 @@ ;; (pretty-write current-ground-transition)) ;; #:mode 'text ;; #:exists 'append) - (transition: zone : CompiledZone))]))) - (subscriber: CompiledZone (question-pattern (wild) (wild) (wild) (wild)) + (transition zone))]))) + (subscriber (question (wild) (wild) (wild) (wild)) (match-state zone (on-message [(? question? q) - (transition: zone : CompiledZone + (transition zone (cond [(question-cyclic? q) (log-warning (format "Cyclic question ~v" q)) @@ -252,49 +238,37 @@ [(question-too-glueless? q) (log-warning (format "Overly-glueless question ~v" q)) (name-process (list 'glueless-question-handler-outer q) - (spawn: #:parent : CompiledZone - #:child : Void - (glueless-question-handler roots-only q client-sock)))] + (spawn (glueless-question-handler roots-only q client-sock)))] [else (name-process (list 'question-handler q) - (spawn: #:parent : CompiledZone - #:child : QHState - (question-handler zone q client-sock)))]))]))) - (subscriber: CompiledZone (network-reply-pattern (wild) (wild)) + (spawn (question-handler zone q client-sock)))]))]))) + (subscriber (network-reply (wild) (wild)) (match-state zone (on-message [(network-reply _ answer) (let-values (((new-zone timers) (incorporate-complete-answer answer zone #t))) (transition-and-set-timers new-zone timers))]))) - (subscriber: CompiledZone (timer-expired-pattern (list 'check-dns-expiry (wild)) (wild)) + (subscriber (timer-expired (list 'check-dns-expiry (wild)) (wild)) (match-state zone (on-message [(timer-expired (list 'check-dns-expiry (? domain? name)) (? number? now-msec)) - (transition: (zone-expire-name zone name (/ now-msec 1000.0)) : CompiledZone)]))))) + (transition (zone-expire-name zone name (/ now-msec 1000.0)))]))))) -(struct: question-state ([zone : CompiledZone] - [q : Question] - [client-sock : UdpAddress] - [nameservers-tried : (Setof DomainName)] - [retry-count : Natural]) #:transparent) -(define-type QuestionState question-state) +(struct question-state (zone q client-sock nameservers-tried retry-count) #:transparent) -(struct: expanding-cnames ([q : Question] - [accumulator : CompleteAnswer] - [remaining-count : Integer]) #:transparent) -(define-type ExpandingCNAMEs expanding-cnames) +(struct expanding-cnames (q accumulator remaining-count) #:transparent) -(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) - (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) (transition w (send-message (answered-question q (empty-complete-answer))))) -(: retry-question : QHState -> (Transition QHState)) +;; (: retry-question : QHState -> (Transition QHState)) (define (retry-question w) (match w [(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" q referral-id (domain-labels zone-origin) (map domain-labels (set-map nameserver-rrs rr-rdata-domain-name)))) - (transition: w : QHState - ((inst network-query QHState) client-sock - q - zone-origin - (map rr-rdata-domain-name (set->list nameserver-rrs)) - referral-id) + (transition w + (network-query client-sock + q + zone-origin + (map rr-rdata-domain-name (set->list nameserver-rrs)) + referral-id) (name-endpoint referral-id - (subscriber: QHState (network-reply-pattern referral-id (wild)) + (subscriber (network-reply referral-id (wild)) (match-state w (on-message [(network-reply (== referral-id) #f) ;; name-error/NXDOMAIN - (transition: w : QHState + (transition w (delete-endpoint referral-id) (send-message (answered-question q #f)))] [(network-reply (== referral-id) ans) @@ -342,9 +316,8 @@ (log-debug "=-=-=-=-=-=")) (define nameserver-names (list->set - (for/list: : (Listof DomainName) - ([rr nameserver-rrs]) - (rr-rdata-domain-name rr)))) + (for/list ([rr nameserver-rrs]) + (rr-rdata-domain-name rr)))) (sequence-actions (retry-question (struct-copy question-state w [nameservers-tried (set-union nameservers-tried @@ -353,30 +326,29 @@ [retry-count (+ old-retry-count 1)])) (delete-endpoint referral-id)))])))))] [(? complete-answer? ans) - (transition: w : QHState (send-message (answered-question q ans)))] + (transition w (send-message (answered-question q ans)))] [(partial-answer base cnames) - (transition: (expanding-cnames q base (length cnames)) : QHState - ((inst map (ActionTree QHState) DomainName) - (lambda: ([cname : DomainName]) - ;; TODO: record chains of CNAMEs to avoid pathologically-long chains - (define cname-q (cname-question cname q)) - (list (send-message cname-q) - (let-fresh (subscription-id) - (name-endpoint subscription-id - (subscriber: QHState (answered-question-pattern cname-q (wild)) - (match-state (expanding-cnames q acc remaining) - (on-message - [(answered-question (== cname-q) ans) - (let () - (define new-acc (if ans (merge-answers acc ans) acc)) - (define new-remaining (- remaining 1)) - (define new-w (expanding-cnames q new-acc new-remaining)) - (transition: new-w : QHState - (delete-endpoint subscription-id) - (if (zero? new-remaining) - (send-message (answered-question q new-acc)) - '())))]))))))) - cnames))])])) + (transition (expanding-cnames q base (length cnames)) + (map (lambda (cname) + ;; TODO: record chains of CNAMEs to avoid pathologically-long chains + (define cname-q (cname-question cname q)) + (list (send-message cname-q) + (let-fresh (subscription-id) + (name-endpoint subscription-id + (subscriber (answered-question cname-q (wild)) + (match-state (expanding-cnames q acc remaining) + (on-message + [(answered-question (== cname-q) ans) + (let () + (define new-acc (if ans (merge-answers acc ans) acc)) + (define new-remaining (- remaining 1)) + (define new-w (expanding-cnames q new-acc new-remaining)) + (transition new-w + (delete-endpoint subscription-id) + (if (zero? new-remaining) + (send-message (answered-question q new-acc)) + '())))]))))))) + cnames))])])) (require "test-rrs.rkt") (require racket/file) diff --git a/resolver.rkt b/resolver.rkt index 00de29f..af25fd7 100644 --- a/resolver.rkt +++ b/resolver.rkt @@ -1,4 +1,4 @@ -#lang typed/racket/base +#lang racket/base ;; ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones ;;; @@ -27,12 +27,8 @@ (require "codec.rkt") (require "zonedb.rkt") -(provide PartialAnswer - Referral - Answer - (struct-out partial-answer) +(provide (struct-out partial-answer) (struct-out referral) - resolve-from-zone) ;; Rules: @@ -67,27 +63,22 @@ ;; -- a CompleteAnswer (a complete answer ready to send), ;; -- #f (the domain name does not exist in the CompiledZone given), ;; -- a Referral (a referral to some other nameserver). -(define-type Answer (U CompleteAnswer PartialAnswer Referral #f)) ;; A PartialAnswer is a (partial-answer CompleteAnswer ListOf) ;; A collection of relevant RRs together with some CNAMEs that need expanding. -(struct: partial-answer ([base : CompleteAnswer] [cnames : (Listof DomainName)]) #:transparent) -(define-type PartialAnswer partial-answer) +(struct partial-answer (base cnames) #:transparent) ;; A Referral is a (referral DomainName Set Set) -(struct: referral ([zone-origin : DomainName] - [nameserver-rrs : (Setof RR)] - [additional : (Setof RR)]) #:transparent) -(define-type Referral referral) +(struct referral (zone-origin nameserver-rrs additional) #:transparent) -(: answer-from-zone : Question CompiledZone (Option RR) -> Answer) +;; (: answer-from-zone : Question CompiledZone (Option RR) -> Answer) ;; An answer of #f here does NOT indicate a missing domain-name ;; (name-error/NXDOMAIN), but instead indicates that there are no ;; records matching the query in the database given. It's up to the ;; caller to decide what to do about that. (define (answer-from-zone q zone start-of-authority) (match-define (question name qtype qclass _) q) - (define: rrset : (Setof RR) (or (zone-ref zone name) (set))) + (define rrset (or (zone-ref zone name) (set))) (define filtered-rrs (filter-rrs rrset qtype qclass)) (define cnames (filter-by-type rrset 'cname)) ;; TODO: filter by class too?? (define answer-set (set-union cnames filtered-rrs)) @@ -105,9 +96,9 @@ [else ;; Kick off the algorithm for CNAME expansion from RFC 1034 4.3.2 step 3a (partial-answer base (set-map cnames rr-rdata-domain-name))])) -(: closest-nameservers : DomainName CompiledZone -> (Setof RR)) +;; (: closest-nameservers : DomainName CompiledZone -> (Setof RR)) (define (closest-nameservers name zone) - (let: search ((name : (Option DomainName) name)) + (let search ((name name)) (cond ((not name) ;; We've walked up the tree past the root. Give up. @@ -124,45 +115,44 @@ ;; Remove a label and keep looking. (search (domain-parent name)))))) -(: closest-untried-nameservers : Question CompiledZone (Setof DomainName) -> (Setof RR)) +;; (: closest-untried-nameservers : Question CompiledZone (Setof DomainName) -> (Setof RR)) ;; Returns a set of NS RRs in an arbitrary order. (define (closest-untried-nameservers q zone nameservers-tried) - (define name (question-repr-name q)) + (define name (question-name q)) (define ns-rrset (closest-nameservers name zone)) (list->set - (for/list: : (Listof RR) ([rr : RR ns-rrset] - #:when (not (set-member? nameservers-tried (rr-rdata-domain-name rr)))) - rr))) + (for/list ([rr ns-rrset] #:when (not (set-member? nameservers-tried (rr-rdata-domain-name rr)))) + rr))) -(: empty-answer : Question CompiledZone (Option RR) -> (Option CompleteAnswer)) +;; (: empty-answer : Question CompiledZone (Option RR) -> (Option CompleteAnswer)) (define (empty-answer q zone start-of-authority) (if (and start-of-authority ;; we are authoritative for something - (in-bailiwick? (question-repr-name q) (rr-name start-of-authority)) + (in-bailiwick? (question-name q) (rr-name start-of-authority)) ;; ^ for this in particular - (not (zone-includes-name? zone (question-repr-name q)))) + (not (zone-includes-name? zone (question-name q)))) ;; ^ there are no RRs at all for this q ;; NXDOMAIN/name-error: we definitely know there are no RRs at all for this q. #f ;; A normal no-answers packet otherwise. (empty-complete-answer))) -(: additional-section/a : CompiledZone (Listof DomainName) -> (Setof RR)) +;; (: additional-section/a : CompiledZone (Listof DomainName) -> (Setof RR)) ;; Implements the "additional section" rules from RFC 1035 (and the ;; rules for IPv6 from RFC 3596). Provides A and AAAA records for ;; names mentioned in the "names" list that have entries in "zone". (define (additional-section/a zone names) ;; RFC 3596 (section 3) requires that we process AAAA here as well ;; as A. - (foldl (lambda: ([name : DomainName] [section : (Setof RR)]) + (foldl (lambda (name section) (set-union section - (set-filter (lambda: ([rr : RR]) + (set-filter (lambda (rr) (and (memv (rdata-type (rr-rdata rr)) '(a aaaa)) (eqv? (rr-class rr) 'in))) - (or (zone-ref zone name) ((inst set RR)))))) - ((inst set RR)) + (or (zone-ref zone name) (set))))) + (set) names)) -(: resolve-from-zone : Question CompiledZone (Option RR) (Setof DomainName) -> Answer) +;; (: resolve-from-zone : Question CompiledZone (Option RR) (Setof DomainName) -> Answer) (define (resolve-from-zone q zone start-of-authority nameservers-tried) (or (answer-from-zone q zone start-of-authority) (let ((best-nameservers (closest-untried-nameservers q zone nameservers-tried))) diff --git a/test-rrs.rkt b/test-rrs.rkt index 202bc88..ea77659 100644 --- a/test-rrs.rkt +++ b/test-rrs.rkt @@ -1,4 +1,4 @@ -#lang typed/racket/base +#lang racket/base ;; ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones ;;; @@ -33,16 +33,16 @@ 30 10))) -(: A : (Listof Bytes) (Vector Integer Integer Integer Integer) -> RR) -(: A/ttl : (Listof Bytes) (Vector Integer Integer Integer Integer) Nonnegative-Integer -> RR) -(: MX : (Listof Bytes) Nonnegative-Integer (Listof Bytes) -> RR) -(: CNAME : (Listof Bytes) (Listof Bytes) -> RR) -(: NS : (Listof Bytes) (Listof Bytes) -> RR) -(: NS/ttl : (Listof Bytes) (Listof Bytes) Nonnegative-Integer -> RR) -(: TXT : (Listof Bytes) (Listof Bytes) -> RR) +;; (: A : (Listof Bytes) (Vector Integer Integer Integer Integer) -> RR) +;; (: A/ttl : (Listof Bytes) (Vector Integer Integer Integer Integer) Nonnegative-Integer -> RR) +;; (: MX : (Listof Bytes) Nonnegative-Integer (Listof Bytes) -> RR) +;; (: CNAME : (Listof Bytes) (Listof Bytes) -> RR) +;; (: NS : (Listof Bytes) (Listof Bytes) -> RR) +;; (: NS/ttl : (Listof Bytes) (Listof Bytes) Nonnegative-Integer -> RR) +;; (: TXT : (Listof Bytes) (Listof Bytes) -> RR) (define (A n ip) (A/ttl n ip 30)) -(define (A/ttl n ip ttl) (rr (domain n) 'in ttl (rdata-ipv4 'a (cast ip IPv4)))) +(define (A/ttl n ip ttl) (rr (domain n) 'in ttl (rdata-ipv4 'a ip))) (define (MX n p t) (rr (domain n) 'in 30 (rdata-mx 'mx p (domain t)))) (define (CNAME n1 n2) (rr (domain n1) 'in 30 (rdata-domain 'cname (domain n2)))) (define (NS n1 n2) (NS/ttl n1 n2 30)) @@ -93,7 +93,7 @@ (list (NS '(#"a") '(#"ns" #"b")) (NS '(#"b") '(#"ns" #"a")))) -(: test-port-number : -> Nonnegative-Integer) +;; (: test-port-number : -> Nonnegative-Integer) (define (test-port-number) (define p (string->number diff --git a/tk-dns.rkt b/tk-dns.rkt index 4858579..9e80332 100644 --- a/tk-dns.rkt +++ b/tk-dns.rkt @@ -1,4 +1,4 @@ -#lang typed/racket/base +#lang racket/base ;; DNS drivers using marketplace. ;; ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones @@ -22,62 +22,25 @@ (require racket/set) (require racket/match) (require "codec.rkt") -(require marketplace/sugar-typed) +(require marketplace/sugar) (require marketplace/drivers/udp) -(require marketplace/support/pseudo-substruct) - -(provide (struct-out bad-dns-packet-repr) - BadDnsPacket bad-dns-packet bad-dns-packet? - BadDnsPacketPattern bad-dns-packet-pattern bad-dns-packet-pattern? - - (struct-out dns-request-repr) - DNSRequest dns-request dns-request? - DNSRequestPattern dns-request-pattern dns-request-pattern? - - (struct-out dns-reply-repr) - DNSReply dns-reply dns-reply? - DNSReplyPattern dns-reply-pattern dns-reply-pattern? +(provide (struct-out bad-dns-packet) + (struct-out dns-request) + (struct-out dns-reply) dns-read-driver dns-write-driver dns-spy) -(struct: (TDetail TSource TSink TReason) - bad-dns-packet-repr - ([detail : TDetail] [source : TSource] [sink : TSink] [reason : TReason]) #:transparent) -(pseudo-substruct: (bad-dns-packet-repr Any UdpAddress UdpAddress Symbol) - BadDnsPacket bad-dns-packet bad-dns-packet?) -(pseudo-substruct: (bad-dns-packet-repr Any - (U Wild UdpAddressPattern) - (U Wild UdpAddressPattern) - (U Wild Symbol)) - BadDnsPacketPattern bad-dns-packet-pattern bad-dns-packet-pattern?) +(struct bad-dns-packet (detail source sink reason) #:transparent) +(struct dns-request (message source sink) #:transparent) +(struct dns-reply (message source sink) #:transparent) -(struct: (TMessage TSource TSink) - dns-request-repr - ([message : TMessage] [source : TSource] [sink : TSink]) #:transparent) -(pseudo-substruct: (dns-request-repr DNSMessage UdpAddress UdpAddress) - DNSRequest dns-request dns-request?) -(pseudo-substruct: (dns-request-repr (U Wild DNSMessage) - (U Wild UdpAddressPattern) - (U Wild UdpAddressPattern)) - DNSRequestPattern dns-request-pattern dns-request-pattern?) - -(struct: (TMessage TSource TSink) - dns-reply-repr - ([message : TMessage] [source : TSource] [sink : TSink]) #:transparent) -(pseudo-substruct: (dns-reply-repr DNSMessage UdpAddress UdpAddress) - DNSReply dns-reply dns-reply?) -(pseudo-substruct: (dns-reply-repr (U Wild DNSMessage) - (U Wild UdpAddressPattern) - (U Wild UdpAddressPattern)) - DNSReplyPattern dns-reply-pattern dns-reply-pattern?) - -(: dns-read-driver : UdpAddress -> (Transition Void)) +;; (: dns-read-driver : UdpAddress -> (Transition Void)) (define (dns-read-driver s) - (transition: (void) : Void - (at-meta-level: Void - (subscriber: Void (udp-packet-pattern (wild) s (wild)) + (transition (void) + (at-meta-level + (subscriber (udp-packet (wild) s (wild)) (on-message [(udp-packet source (== s) #"") (begin (log-info "Debug dump packet received") @@ -91,26 +54,26 @@ ((request) (dns-request 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) - (: translate : DNSMessage UdpAddress -> (ActionTree Void)) + ;; (: translate : DNSMessage UdpAddress -> (ActionTree Void)) (define (translate message sink) (with-handlers ((exn:fail? (lambda (e) (send-message (bad-dns-packet message s sink 'unencodable))))) - (at-meta-level: Void + (at-meta-level (send-message (udp-packet s sink (dns-message->packet message)))))) - (transition: (void) : Void - (subscriber: Void (dns-request-pattern (wild) s (wild)) + (transition (void) + (subscriber (dns-request (wild) s (wild)) (on-message [(dns-request message (== s) sink) (translate message sink)])) - (subscriber: Void (dns-reply-pattern (wild) s (wild)) + (subscriber (dns-reply (wild) s (wild)) (on-message [(dns-reply message (== s) sink) (translate message sink)])))) -(: dns-spy : -> (Transition Void)) +;; (: dns-spy : -> (Transition Void)) (define (dns-spy) - (transition: (void) : Void - (observe-publishers: Void (wild) + (transition (void) + (observe-publishers (wild) (on-message [(dns-request message source sink) (begin (log-info (format "DNS: ~v asks ~v ~v~n : ~v" diff --git a/zonedb.rkt b/zonedb.rkt index 5d9dd35..cffd167 100644 --- a/zonedb.rkt +++ b/zonedb.rkt @@ -1,4 +1,4 @@ -#lang typed/racket/base +#lang racket/base ;; Noddy representation of a zone, and various zone and RRSet utilities. ;; ;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones @@ -25,10 +25,8 @@ (require "api.rkt") (require "codec.rkt") (require bitsyntax) -(require (rename-in marketplace/tr-struct-copy [tr-struct-copy struct-copy])) ;; PR13149 -(provide CompiledZone - zone-ref +(provide zone-ref zone-includes-name? incorporate-complete-answer zone-expire-name @@ -45,52 +43,47 @@ zone->bit-string bit-string->zone) -(define-type RelativeSeconds Real) -(define-type AbsoluteSeconds Real) -(define-predicate absolute-seconds? AbsoluteSeconds) +;; (define-type RelativeSeconds Real) +;; (define-type AbsoluteSeconds Real) +;; (define-predicate absolute-seconds? AbsoluteSeconds) +(define absolute-seconds? real?) ;; An InfiniteLifetime is an (infinite-lifetime RelativeSeconds), a ;; specification of the TTL to use when sending a non-expiring RR to a ;; peer. -(struct: infinite-lifetime ([ttl : RelativeSeconds]) #:transparent) -(define-type InfiniteLifetime infinite-lifetime) +(struct infinite-lifetime (ttl) #:transparent) ;; An Expiry is either an AbsoluteSeconds or an InfiniteLifetime. -(define-type Expiry (U AbsoluteSeconds InfiniteLifetime)) ;; A CompiledZone is a Hash>, representing a collection of DNS RRSets ;; indexed by DomainName. Each RR in an RRSet either has an expiry ;; time associated with it or has an InfiniteLifetime associated with ;; it, in which case it should not expire. -(define-type CompiledZone (HashTable DomainName (HashTable RR Expiry))) ;; A Timers is a SetOf<(cons DomainName RelativeSeconds)>, ;; representing a collection of timeouts that should be set against ;; names to to see if their associated RRs have expired. -(define-type Timer (Pairof DomainName RelativeSeconds)) -(define-type Timers (Setof Timer)) ;; TODO: maybe store domain names big-end first? It'd make bailiwick ;; and subzone checks into prefix rather than suffix checks. It makes ;; domain names into paths through the DNS DB tree. -(: current-inexact-seconds : -> AbsoluteSeconds) +;; (: current-inexact-seconds : -> AbsoluteSeconds) (define (current-inexact-seconds) (/ (current-inexact-milliseconds) 1000.0)) -(: still-valid? : Expiry AbsoluteSeconds -> Boolean) +;; (: still-valid? : Expiry AbsoluteSeconds -> Boolean) (define (still-valid? expiry now) (or (infinite-lifetime? expiry) (>= expiry now))) -(: zone-ref : CompiledZone DomainName -> (Option (Setof RR))) +;; (: zone-ref : CompiledZone DomainName -> (Option (Setof RR))) (define (zone-ref db name) (define expirymap (hash-ref db name (lambda () #f))) (and expirymap (let ((now (current-inexact-seconds))) - (for/fold: ([acc : (Setof RR) (set)]) - ([resource : RR (in-hash-keys expirymap)]) + (for/fold ([acc (set)]) ([resource (in-hash-keys expirymap)]) (define expiry (hash-ref expirymap resource)) (if (still-valid? expiry now) (let ((new-ttl (if (infinite-lifetime? expiry) @@ -98,14 +91,14 @@ (- expiry now)))) (set-add acc (struct-copy rr resource - [ttl (cast (exact-floor new-ttl) Nonnegative-Integer)]))) + [ttl (exact-floor new-ttl)]))) acc))))) -(: zone-includes-name? : CompiledZone DomainName -> Boolean) +;; (: zone-includes-name? : CompiledZone DomainName -> Boolean) (define (zone-includes-name? db name) (hash-has-key? db name)) -(: incorporate-rr : (Option AbsoluteSeconds) -> (RR CompiledZone -> CompiledZone)) +;; (: incorporate-rr : (Option AbsoluteSeconds) -> (RR CompiledZone -> CompiledZone)) ;; Incorporates the given RR into our database. If base-time is a ;; number of seconds, we treat the RR as having a TTL that decreases ;; as time goes by; otherwise base-time is #f, and we treat the RR as @@ -129,7 +122,7 @@ (infinite-lifetime (rr-ttl resource0)))) (define resource (struct-copy rr resource0 [ttl 0])) (define name (rr-name resource)) - (define old-expirymap (hash-ref db name (lambda () (ann #hash() (HashTable rr Expiry))))) + (define old-expirymap (hash-ref db name (lambda () #hash()))) (define old-expiry (hash-ref old-expirymap resource (lambda () 0))) (cond [(infinite-lifetime? old-expiry) ;; don't update TTL: the existing record should live forever @@ -139,15 +132,15 @@ [else ;; old record finite-lifetime but expiring after the new expiry: leave it alone db])) -(: incorporate-complete-answer : - (Option CompleteAnswer) CompiledZone Boolean -> (Values CompiledZone Timers)) +;; (: incorporate-complete-answer : +;; (Option CompleteAnswer) CompiledZone Boolean -> (Values CompiledZone Timers)) (define (incorporate-complete-answer ans db is-cache?) (match ans [#f (values db (set))] [(complete-answer ns us ds) (define now (current-inexact-seconds)) - (for/fold ([db db] [timers ((inst set Timer))]) + (for/fold ([db db] [timers (set)]) ([rr (in-list (append (set->list ns) (set->list us) (set->list ds)))]) ;; no in-sequences in typed racket @@ -156,15 +149,14 @@ (values ((incorporate-rr now) rr db) (set-add timers (cons (rr-name rr) (rr-ttl rr))))))])) -(: zone-expire-name : CompiledZone DomainName AbsoluteSeconds -> CompiledZone) +;; (: zone-expire-name : CompiledZone DomainName AbsoluteSeconds -> CompiledZone) ;; Checks the given name to see if there are any expiring records, and ;; if so, removes them. (define (zone-expire-name db name now-seconds) - (define empty-expirymap (ann #hash() (HashTable RR Expiry))) + (define empty-expirymap #hash()) (define old-expirymap (hash-ref db name (lambda () empty-expirymap))) (define new-expirymap - (for/fold: ([acc : (HashTable RR Expiry) empty-expirymap]) - ([resource : RR (in-hash-keys old-expirymap)]) + (for/fold ([acc empty-expirymap]) ([resource (in-hash-keys old-expirymap)]) (define expiry (hash-ref old-expirymap resource)) (if (still-valid? expiry now-seconds) (hash-set acc resource expiry) @@ -173,33 +165,33 @@ (hash-remove db name) (hash-set db name new-expirymap))) -(: zone-expire : CompiledZone -> (Values CompiledZone Timers)) +;; (: zone-expire : CompiledZone -> (Values CompiledZone Timers)) ;; Used to freshen a saved zone when it is loaded from disk. (define (zone-expire zone) (define now-seconds (current-inexact-seconds)) - (for/fold: ([zone : CompiledZone zone] [timers : Timers (set)]) - ([name : DomainName (in-hash-keys zone)]) + (for/fold ([zone zone] [timers (set)]) + ([name (in-hash-keys zone)]) (define new-zone (zone-expire-name zone name now-seconds)) (define expirymap (hash-ref new-zone name (lambda () #f))) (values new-zone (if expirymap (set-union (list->set - (map (lambda: ([e : AbsoluteSeconds]) (cons name (- e now-seconds))) + (map (lambda (e) (cons name (- e now-seconds))) (filter absolute-seconds? (hash-values expirymap)))) timers) timers)))) -(: empty-zone-db : -> CompiledZone) +;; (: empty-zone-db : -> CompiledZone) (define (empty-zone-db) (make-immutable-hash)) -(: compile-zone-db : (Listof RR) -> CompiledZone) +;; (: compile-zone-db : (Listof RR) -> CompiledZone) ;; Builds an immutable hash table from the given RRs, suitable for ;; quickly looking up answers to queries. (define (compile-zone-db rrs) (foldl (incorporate-rr #f) (empty-zone-db) rrs)) -(: in-bailiwick? : DomainName DomainName -> Boolean) +;; (: in-bailiwick? : DomainName DomainName -> Boolean) ;; Answers #t iff dn falls within the bailiwick of the zone with ;; origin o. (define (in-bailiwick? dn o) @@ -207,23 +199,23 @@ (let ((p (domain-parent dn))) (and p (in-bailiwick? p o))))) -(: set-filter : (All (X) (X -> Boolean) (Setof X) -> (Setof X))) +;; (: set-filter : (All (X) (X -> Boolean) (Setof X) -> (Setof X))) ;; Retains only those elements of its argument for which the predicate ;; answers #t. (define (set-filter predicate in) - (for/fold: ([acc : (Setof X) (set)]) ([x : X (in-list (set->list in))]) + (for/fold ([acc (set)]) ([x (in-list (set->list in))]) (if (predicate x) (set-add acc x) acc))) -(: filter-by-type : (Setof RR) RRType -> (Setof RR)) +;; (: filter-by-type : (Setof RR) RRType -> (Setof RR)) ;; Selects only those members of rrset having rr-type type. (define (filter-by-type rrset type) (define p? (rdata-type-pred type)) - (set-filter (lambda: ([rr : RR]) (p? (rr-rdata rr))) rrset)) + (set-filter (lambda (rr) (p? (rr-rdata rr))) rrset)) -(: no-rrs : (Setof RR)) +;; (: no-rrs : (Setof RR)) (define no-rrs (set)) -(: filter-rrs : (Setof RR) QueryType QueryClass -> (Setof RR)) +;; (: filter-rrs : (Setof RR) QueryType QueryClass -> (Setof RR)) ;; Returns a set like its argument with RRs not matching the given ;; type and class removed. (define (filter-rrs rrs qtype qclass) @@ -237,10 +229,10 @@ (define filtered-by-type-and-class (case qclass ((*) filtered-by-type) - (else (set-filter (lambda: ([rr : RR]) (eqv? (rr-class rr) qclass)) filtered-by-type)))) + (else (set-filter (lambda (rr) (eqv? (rr-class rr) qclass)) filtered-by-type)))) filtered-by-type-and-class) -(: rr-set->list : (Setof RR) -> (Listof RR)) +;; (: rr-set->list : (Setof RR) -> (Listof RR)) ;; Like set->list, but places all CNAME records first. ;; This is apparently to work around bugs in old versions of BIND? ;; @@ -264,11 +256,11 @@ (append (cname-sort (set->list cnames)) (set->list (set-subtract rrs cnames)))) -(: rr-rdata-domain-name : RR -> DomainName) +;; (: rr-rdata-domain-name : RR -> DomainName) (define (rr-rdata-domain-name rr) - (rdata-domain-name (cast (rr-rdata rr) rdata-domain))) + (rdata-domain-name (rr-rdata rr))) -(: cname-sort : (Listof RR) -> (Listof RR)) +;; (: cname-sort : (Listof RR) -> (Listof RR)) ;; Produce an ordering of the CNAMEs given that respects their ;; "causality". For example, if a CNAME b and b CNAME c, then the RRs ;; will be presented in that order (and not the other order, with b @@ -277,11 +269,9 @@ (define lhss (list->set (map rr-name cnames))) (define rhss (list->set (map rr-rdata-domain-name cnames))) (define roots (set->list (set-subtract lhss rhss))) ;; Nodes not the targets of some edge. - (: targets-of : DomainName -> (Listof RR)) - (define (targets-of name) (filter (lambda: ([rr : RR]) (equal? (rr-name rr) name)) cnames)) - (let: iterate ((remaining : (Listof DomainName) roots) - (seen : (Setof DomainName) (set)) - (acc : (Listof RR) '())) + ;; (: targets-of : DomainName -> (Listof RR)) + (define (targets-of name) (filter (lambda (rr) (equal? (rr-name rr) name)) cnames)) + (let iterate ((remaining roots) (seen (set)) (acc '())) (if (null? remaining) (reverse acc) (let ((source (car remaining))) @@ -293,12 +283,12 @@ (set-add seen source) (append rrs acc)))))))) -(: zone->bit-string : CompiledZone -> BitString) +;; (: zone->bit-string : CompiledZone -> BitString) ;; Produces a serialized form of the zone suitable for saving to disk. (define (zone->bit-string zone) - (for/fold: ([acc : BitString (bit-string)]) ([name : DomainName (in-hash-keys zone)]) + (for/fold ([acc (bit-string)]) ([name (in-hash-keys zone)]) (define rrmap (hash-ref zone name)) - (for/fold: ([acc : BitString acc]) ([rr : RR (in-hash-keys rrmap)]) + (for/fold ([acc acc]) ([rr (in-hash-keys rrmap)]) (define expiry (hash-ref rrmap rr)) (bit-string-append acc @@ -308,7 +298,7 @@ [else (bit-string (rr :: (t:rr)) 0 ((exact-truncate expiry) :: bits 32))]))))) -(: bit-string->zone : BitString -> CompiledZone) +;; (: bit-string->zone : BitString -> CompiledZone) ;; Produces a deserialized form of the zone. Suitable for use in loading from disk. (define (bit-string->zone bs) (define now (current-inexact-seconds))