From bdafaa619916b9d188934df2224aba3ec5c27296 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 18 Mar 2013 15:45:55 -0400 Subject: [PATCH] Final TR conversion of driver --- codec.rkt | 2 - driver.rkt | 50 +++++++++++-------- resolver.rkt | 54 ++++++++++++++------- test-rrs.rkt | 135 +++++++++++++++++++++++++++------------------------ tk-dns.rkt | 51 ++++++++++--------- zonedb.rkt | 12 +++-- 6 files changed, 173 insertions(+), 131 deletions(-) diff --git a/codec.rkt b/codec.rkt index 1868b75..8f5743a 100644 --- a/codec.rkt +++ b/codec.rkt @@ -25,8 +25,6 @@ (require "api.rkt") (require "mapping.rkt") -(domain (list #"hello")) - (require racket/match) (require racket-bitsyntax) diff --git a/driver.rkt b/driver.rkt index 265b784..d183def 100644 --- a/driver.rkt +++ b/driver.rkt @@ -1,4 +1,4 @@ -#lang racket/base +#lang typed/racket/base ;; DNS server using os-big-bang.rkt and os-udp.rkt. @@ -10,9 +10,9 @@ (require "codec.rkt") (require "zonedb.rkt") (require "resolver.rkt") -(require racket-typed-matrix/sugar-untyped) +(require racket-typed-matrix/sugar-typed) (require racket-typed-matrix/support/spy) -(require racket-typed-matrix/drivers/udp-untyped) +(require racket-typed-matrix/drivers/udp) (require "tk-dns.rkt") ;; Instantiated with a SOA record for the zone it is serving as well @@ -28,7 +28,7 @@ ;; determines subzones based on the RRs it is configured with at ;; startup. -;; start-server : UInt16 RR ListOf -> 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. @@ -40,21 +40,27 @@ (display ";; Ready.\n") - (ground-vm (udp-driver) - (generic-spy 'UDP) - (nested-vm - (dns-spy) - (spawn #:child (dns-read-driver local-addr)) - (spawn #:child (dns-write-driver local-addr)) - (endpoint #:subscriber (bad-dns-packet (wild) (wild) (wild) (wild)) - [p (begin (log-error (pretty-format p)) - '())]) - (endpoint #:subscriber (dns-request (wild) (wild) (wild)) - [r (map send-message (handle-request soa-rr zone r))])))) + (ground-vm: ((inst udp-driver Void)) + ((inst generic-spy Void) 'UDP) + (nested-vm: : Void + ((inst dns-spy Void)) + ((inst dns-read-driver Void) local-addr) + ((inst dns-write-driver Void) local-addr) + (endpoint: : Void #:subscriber (bad-dns-packet (wild) (wild) (wild) (wild)) + [p (begin (log-error (pretty-format p)) + '())]) + (endpoint: : Void #:subscriber (dns-request (wild) (wild) (wild)) + [(? dns-request? r) + (begin (define reply (handle-request soa-rr zone r)) + (when reply (send-message reply)))])))) +(define-type ReplyMaker (DomainName Boolean (Setof RR) (Setof RR) (Setof RR) -> DNSMessage)) + +(: handle-request : RR CompiledZone dns-request -> (Option dns-reply)) (define (handle-request soa-rr zone request) (match-define (dns-request request-message request-source request-sink) request) + (: make-reply : ReplyMaker) (define (make-reply name send-name-error? answers authorities additional) (dns-message (dns-message-id request-message) 'response @@ -69,6 +75,7 @@ (rr-set->list authorities) (rr-set->list additional))) + (: 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 @@ -86,23 +93,24 @@ ;; here. Reexamine the rules for doing so. (match-define (question qname qtype qclass #f) q) + (: expand-cnames : (Listof DomainName) CompleteAnswer -> DNSMessage) (define (expand-cnames worklist ans) (match worklist ['() (match-define (complete-answer ns us ds) ans) (make-reply qname #f ns us ds)] [(cons next-cname rest) - (define a (resolve-from-zone (question next-cname qtype qclass q) zone soa-rr (set))) + (define a (resolve-from-zone (cname-question next-cname q) zone soa-rr (set))) (incorporate-answer a rest ans)])) + (: incorporate-answer : Answer (Listof DomainName) CompleteAnswer -> DNSMessage) (define (incorporate-answer this-answer worklist ans) (match this-answer [(partial-answer new-info more-cnames) (expand-cnames (append worklist more-cnames) (merge-answers new-info ans))] - [(? complete-answer?) - (expand-cnames worklist - (merge-answers this-answer ans))] + [(? complete-answer? c) + (expand-cnames worklist (merge-answers c ans))] [_ ;; #f or a referral (expand-cnames worklist ans)])) @@ -117,9 +125,9 @@ ;; TODO: check opcode and direction in request ;; TODO: think again about multiple questions in one packet (match (dns-message-questions request-message) - ['() '()] + ['() #f] [(cons q _) - (list (dns-reply (answer-question q make-reply) request-sink request-source))])) + (dns-reply (answer-question q make-reply) request-sink request-source)])) (require "test-rrs.rkt") (start-server (test-port-number) test-soa-rr test-rrs) diff --git a/resolver.rkt b/resolver.rkt index 430b63c..25779ae 100644 --- a/resolver.rkt +++ b/resolver.rkt @@ -1,4 +1,4 @@ -#lang racket/base +#lang typed/racket/base (require racket/pretty) @@ -9,7 +9,10 @@ (require "codec.rkt") (require "zonedb.rkt") -(provide (struct-out partial-answer) +(provide PartialAnswer + Referral + Answer + (struct-out partial-answer) (struct-out referral) resolve-from-zone) @@ -46,21 +49,27 @@ ;; -- a CompleteAnswer (a complete answer ready to send), ;; -- #f (the domain name does not exist in the CompiledZone given), ;; -- a Referral (a referral to some other nameserver). +(define-type Answer (U CompleteAnswer PartialAnswer Referral #f)) ;; A PartialAnswer is a (partial-answer CompleteAnswer ListOf) ;; A collection of relevant RRs together with some CNAMEs that need expanding. -(struct partial-answer (base cnames) #:prefab) +(struct: partial-answer ([base : CompleteAnswer] [cnames : (Listof DomainName)]) #:prefab) +(define-type PartialAnswer partial-answer) ;; A Referral is a (referral DomainName Set Set) -(struct referral (zone-origin nameserver-rrs additional) #:prefab) +(struct: referral ([zone-origin : DomainName] + [nameserver-rrs : (Setof RR)] + [additional : (Setof RR)]) #:prefab) +(define-type Referral referral) +(: answer-from-zone : Question CompiledZone (Option RR) -> Answer) ;; An answer of #f here does NOT indicate a missing domain-name ;; (name-error/NXDOMAIN), but instead indicates that there are no ;; records matching the query in the database given. It's up to the ;; caller to decide what to do about that. (define (answer-from-zone q zone start-of-authority) (match-define (question name qtype qclass _) q) - (define rrset (or (zone-ref zone name) (set))) + (define: rrset : (Setof RR) (or (zone-ref zone name) (set))) (define filtered-rrs (filter-rrs rrset qtype qclass)) (define cnames (filter-by-type rrset 'cname)) ;; TODO: filter by class too?? (define answer-set (set-union cnames filtered-rrs)) @@ -76,11 +85,15 @@ [(or (eq? qtype 'cname) (set-empty? cnames)) ;; Either asking for CNAMEs, or no CNAMEs to expand base] [else ;; Kick off the algorithm for CNAME expansion from RFC 1034 4.3.2 step 3a - (partial-answer base (set-map cnames rr-rdata))])) + (partial-answer base (set-map cnames rr-rdata-domain-name))])) +(: closest-nameservers : DomainName CompiledZone -> (Setof RR)) (define (closest-nameservers name zone) - (let search ((name name)) + (let: search ((name : (Option DomainName) name)) (cond + ((not name) + ;; We've walked up the tree past the root. Give up. + (set)) ((zone-ref zone name) => ;; There's an entry for this suffix of the original name. Check ;; to see if it has an NS record indicating a subzone. @@ -89,19 +102,21 @@ (if (set-empty? ns-rrset) (search (domain-parent name)) ;; no NS records for this suffix. Keep looking. ns-rrset))) - ((domain-root? name) - ;; The root, and we don't have an RRSet for it. Give up. - (set)) (else ;; Remove a label and keep looking. (search (domain-parent name)))))) +(: closest-untried-nameservers : Question CompiledZone (Setof DomainName) -> (Setof RR)) ;; Returns a set of NS RRs in an arbitrary order. (define (closest-untried-nameservers q zone nameservers-tried) (define name (question-name q)) (define ns-rrset (closest-nameservers name zone)) - (for/set ([rr ns-rrset] #:when (not (set-member? nameservers-tried (rr-rdata rr)))) rr)) + (list->set + (for/list: : (Listof RR) ([rr : RR ns-rrset] + #:when (not (set-member? nameservers-tried (rr-rdata rr)))) + rr))) +(: empty-answer : Question CompiledZone (Option RR) -> (Option CompleteAnswer)) (define (empty-answer q zone start-of-authority) (if (and start-of-authority ;; we are authoritative for something (in-bailiwick? (question-name q) (rr-name start-of-authority)) ;; for this in particular @@ -111,21 +126,23 @@ ;; A normal no-answers packet otherwise. (empty-complete-answer))) -;; additional-section/a : CompiledZone ListOf -> Set +(: additional-section/a : CompiledZone (Listof DomainName) -> (Setof RR)) ;; Implements the "additional section" rules from RFC 1035 (and the ;; rules for IPv6 from RFC 3596). Provides A and AAAA records for ;; names mentioned in the "names" list that have entries in "zone". (define (additional-section/a zone names) ;; RFC 3596 (section 3) requires that we process AAAA here as well ;; as A. - (foldl (lambda (name section) + (foldl (lambda: ([name : DomainName] [section : (Setof RR)]) (set-union section - (set-filter (lambda (rr) (and (memv (rr-type rr) '(a aaaa)) - (eqv? (rr-class rr) 'in))) - (or (zone-ref zone name) (set))))) - (set) + (set-filter (lambda: ([rr : 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)) names)) +(: 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))) @@ -134,4 +151,5 @@ (let ((zone-origin (rr-name (car (set->list best-nameservers))))) ;; any entry will do (referral zone-origin best-nameservers - (additional-section/a zone (set-map best-nameservers rr-rdata)))))))) + (additional-section/a zone (set-map best-nameservers + rr-rdata-domain-name)))))))) diff --git a/test-rrs.rkt b/test-rrs.rkt index 4978a87..2a1d806 100644 --- a/test-rrs.rkt +++ b/test-rrs.rkt @@ -1,77 +1,86 @@ -#lang racket/base +#lang typed/racket/base (require "api.rkt") (provide (all-defined-out)) (define test-soa-rr - (rr (domain '(#"example")) 'soa 'in 30 - (soa (domain '(#"ns" #"example")) - (domain '(#"tonyg" #"example")) - 1 - 24 - 24 - 30 - 10))) + (rr (domain '(#"example")) 'in 30 + (rdata-soa 'soa + (domain '(#"ns" #"example")) + (domain '(#"tonyg" #"example")) + 1 + 24 + 24 + 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) + +(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 (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)) +(define (NS/ttl n1 n2 ttl) (rr (domain n1) 'in ttl (rdata-domain 'ns (domain n2)))) +(define (TXT n strs) (rr (domain n) 'in 30 (rdata-txt 'txt strs))) (define test-rrs - (list (rr (domain '(#"localhost" #"example")) 'a 'in 30 '#(127 0 0 1)) - (rr (domain '(#"example")) 'mx 'in 30 (mx 5 (domain '(#"localhost" #"example")))) - (rr (domain '(#"example")) 'mx 'in 30 (mx 10 (domain '(#"subns" #"example")))) - (rr (domain '(#"google" #"example")) 'cname 'in 30 (domain '(#"www" #"google" #"com"))) - (rr (domain '(#"roar" #"example")) 'a 'in 30 '#(192 168 1 1)) - (rr (domain '(#"alias" #"example")) 'cname 'in 30 (domain '(#"roar" #"example"))) - (rr (domain '(#"ns" #"example")) 'a 'in 30 '#(127 0 0 1)) - (rr (domain '(#"hello" #"example")) 'txt 'in 30 '(#"Hello CRASH")) - (rr (domain '(#"subzone" #"example")) 'ns 'in 30 (domain '(#"subns" #"example"))) - (rr (domain '(#"subns" #"example")) 'a 'in 30 '#(127 0 0 2)))) - -;; (define test-roots -;; (list (rr (domain '()) 'ns 'in 30 (domain '(#"f" #"root-servers" #"net"))) -;; (rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(198 41 0 4)) -;; (rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(192 228 79 201)) -;; (rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(192 33 4 12)) -;; (rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(192 203 230 10)) -;; (rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(192 112 36 4)) -;; (rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(128 63 2 53)) -;; (rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(192 58 128 30)) -;; (rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 30 '#(193 0 14 129)))) + (list (A '(#"localhost" #"example") '#(127 0 0 1)) + (MX '(#"example") 5 '(#"localhost" #"example")) + (MX '(#"example") 10 '(#"subns" #"example")) + (CNAME '(#"google" #"example")'(#"www" #"google" #"com")) + (A '(#"roar" #"example") '#(192 168 1 1)) + (CNAME '(#"alias" #"example") '(#"roar" #"example")) + (A '(#"ns" #"example") '#(127 0 0 1)) + (TXT '(#"hello" #"example") '(#"Hello CRASH")) + (NS '(#"subzone" #"example") '(#"subns" #"example")) + (A '(#"subns" #"example") '#(127 0 0 2)))) (define test-roots - (list (rr (domain '(#"a" #"root-servers" #"net")) 'a 'in 3600000 '#(198 41 0 4)) - (rr (domain '(#"b" #"root-servers" #"net")) 'a 'in 3600000 '#(192 228 79 201)) - (rr (domain '(#"c" #"root-servers" #"net")) 'a 'in 3600000 '#(192 33 4 12)) - ;; (rr (domain '(#"d" #"root-servers" #"net")) 'a 'in 3600000 '#(128 8 10 90)) - ;; ^ changed on 1 Jan 2013 to the below: - (rr (domain '(#"d" #"root-servers" #"net")) 'a 'in 3600000 '#(199 7 91 13)) - (rr (domain '(#"e" #"root-servers" #"net")) 'a 'in 3600000 '#(192 203 230 10)) - (rr (domain '(#"f" #"root-servers" #"net")) 'a 'in 3600000 '#(192 5 5 241)) - (rr (domain '(#"g" #"root-servers" #"net")) 'a 'in 3600000 '#(192 112 36 4)) - (rr (domain '(#"h" #"root-servers" #"net")) 'a 'in 3600000 '#(128 63 2 53)) - (rr (domain '(#"i" #"root-servers" #"net")) 'a 'in 3600000 '#(192 36 148 17)) - (rr (domain '(#"j" #"root-servers" #"net")) 'a 'in 3600000 '#(192 58 128 30)) - (rr (domain '(#"k" #"root-servers" #"net")) 'a 'in 3600000 '#(193 0 14 129)) - (rr (domain '(#"l" #"root-servers" #"net")) 'a 'in 3600000 '#(199 7 83 42)) - (rr (domain '(#"m" #"root-servers" #"net")) 'a 'in 3600000 '#(202 12 27 33)) - (rr (domain '()) 'ns 'in 3600000 (domain '(#"a" #"root-servers" #"net"))) - (rr (domain '()) 'ns 'in 3600000 (domain '(#"b" #"root-servers" #"net"))) - (rr (domain '()) 'ns 'in 3600000 (domain '(#"c" #"root-servers" #"net"))) - (rr (domain '()) 'ns 'in 3600000 (domain '(#"d" #"root-servers" #"net"))) - (rr (domain '()) 'ns 'in 3600000 (domain '(#"e" #"root-servers" #"net"))) - (rr (domain '()) 'ns 'in 3600000 (domain '(#"f" #"root-servers" #"net"))) - (rr (domain '()) 'ns 'in 3600000 (domain '(#"g" #"root-servers" #"net"))) - (rr (domain '()) 'ns 'in 3600000 (domain '(#"h" #"root-servers" #"net"))) - (rr (domain '()) 'ns 'in 3600000 (domain '(#"i" #"root-servers" #"net"))) - (rr (domain '()) 'ns 'in 3600000 (domain '(#"j" #"root-servers" #"net"))) - (rr (domain '()) 'ns 'in 3600000 (domain '(#"k" #"root-servers" #"net"))) - (rr (domain '()) 'ns 'in 3600000 (domain '(#"l" #"root-servers" #"net"))) - (rr (domain '()) 'ns 'in 3600000 (domain '(#"m" #"root-servers" #"net"))))) + (list (A/ttl '(#"a" #"root-servers" #"net") '#(198 41 0 4) 3600000) + (A/ttl '(#"b" #"root-servers" #"net") '#(192 228 79 201) 3600000) + (A/ttl '(#"c" #"root-servers" #"net") '#(192 33 4 12) 3600000) + (A/ttl '(#"d" #"root-servers" #"net") '#(199 7 91 13) 3600000) + (A/ttl '(#"e" #"root-servers" #"net") '#(192 203 230 10) 3600000) + (A/ttl '(#"f" #"root-servers" #"net") '#(192 5 5 241) 3600000) + (A/ttl '(#"g" #"root-servers" #"net") '#(192 112 36 4) 3600000) + (A/ttl '(#"h" #"root-servers" #"net") '#(128 63 2 53) 3600000) + (A/ttl '(#"i" #"root-servers" #"net") '#(192 36 148 17) 3600000) + (A/ttl '(#"j" #"root-servers" #"net") '#(192 58 128 30) 3600000) + (A/ttl '(#"k" #"root-servers" #"net") '#(193 0 14 129) 3600000) + (A/ttl '(#"l" #"root-servers" #"net") '#(199 7 83 42) 3600000) + (A/ttl '(#"m" #"root-servers" #"net") '#(202 12 27 33) 3600000) + (NS/ttl '() '(#"a" #"root-servers" #"net") 3600000) + (NS/ttl '() '(#"b" #"root-servers" #"net") 3600000) + (NS/ttl '() '(#"c" #"root-servers" #"net") 3600000) + (NS/ttl '() '(#"d" #"root-servers" #"net") 3600000) + (NS/ttl '() '(#"e" #"root-servers" #"net") 3600000) + (NS/ttl '() '(#"f" #"root-servers" #"net") 3600000) + (NS/ttl '() '(#"g" #"root-servers" #"net") 3600000) + (NS/ttl '() '(#"h" #"root-servers" #"net") 3600000) + (NS/ttl '() '(#"i" #"root-servers" #"net") 3600000) + (NS/ttl '() '(#"j" #"root-servers" #"net") 3600000) + (NS/ttl '() '(#"k" #"root-servers" #"net") 3600000) + (NS/ttl '() '(#"l" #"root-servers" #"net") 3600000) + (NS/ttl '() '(#"m" #"root-servers" #"net") 3600000))) (define pathological-roots - (list (rr (domain '(#"a")) 'ns 'in 30 (domain '(#"ns" #"b"))) - (rr (domain '(#"b")) 'ns 'in 30 (domain '(#"ns" #"a"))))) + (list (NS '(#"a") '(#"ns" #"b")) + (NS '(#"b") '(#"ns" #"a")))) +(: test-port-number : -> Nonnegative-Integer) (define (test-port-number) - (string->number - (or (getenv "DNSPORT") - (error 'test-port-number "Please set your DNSPORT environment variable.")))) + (define p + (string->number + (or (getenv "DNSPORT") + (error 'test-port-number "Please set your DNSPORT environment variable.")))) + (if (or (not p) (not (exact? p)) (not (integer? p)) (negative? p)) + (error 'test-port-number "Invalid DNSPORT setting.") + p)) diff --git a/tk-dns.rkt b/tk-dns.rkt index aa99c8e..2ee2744 100644 --- a/tk-dns.rkt +++ b/tk-dns.rkt @@ -19,36 +19,43 @@ (struct: dns-request ([message : DNSMessage] [source : UdpAddress] [sink : UdpAddress]) #:prefab) (struct: dns-reply ([message : DNSMessage] [source : UdpAddress] [sink : UdpAddress]) #:prefab) +(: dns-read-driver : (All (ParentState) UdpAddress -> (Action ParentState))) (define (dns-read-driver s) - (transition: (void) : Void - (at-meta-level - (endpoint: : Void - #:subscriber (udp-packet-pattern (wild) s (wild)) - [(udp-packet source (== s) #"") - (begin (log-info "Debug dump packet received") - (send-message `(debug-dump)))] - [(udp-packet source (== s) body) - (send-message - (with-handlers ((exn:fail? (lambda (e) - (bad-dns-packet body source s 'unparseable)))) - (define message (packet->dns-message body)) - (case (dns-message-direction message) - ((request) (dns-request message source s)) - ((response) (dns-reply message source s)))))])))) + (spawn: #:parent : ParentState + #:child : Void + (transition: (void) : Void + (at-meta-level + (endpoint: : Void + #:subscriber (udp-packet-pattern (wild) s (wild)) + [(udp-packet source (== s) #"") + (begin (log-info "Debug dump packet received") + (send-message `(debug-dump)))] + [(udp-packet source (== s) body) + (send-message + (with-handlers ((exn:fail? (lambda (e) + (bad-dns-packet body source s 'unparseable)))) + (define message (packet->dns-message body)) + (case (dns-message-direction message) + ((request) (dns-request message source s)) + ((response) (dns-reply message source s)))))]))))) +(: dns-write-driver : (All (ParentState) UdpAddress -> (Action ParentState))) (define (dns-write-driver s) + (: translate : DNSMessage UdpAddress -> (ActionTree Void)) (define (translate message sink) (with-handlers ((exn:fail? (lambda (e) (send-message (bad-dns-packet message s sink 'unencodable))))) (at-meta-level (send-message (udp-packet s sink (dns-message->packet message)))))) - (transition: (void) : Void - (endpoint: : Void - #:subscriber (dns-request (wild) s (wild)) - [(dns-request message (== s) sink) (translate message sink)]) - (endpoint: : Void - #:subscriber (dns-reply (wild) s (wild)) - [(dns-reply message (== s) sink) (translate message sink)]))) + (spawn: #:parent : ParentState + #:child : Void + (transition: (void) : Void + (endpoint: : Void + #:subscriber (dns-request (wild) s (wild)) + [(dns-request 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) diff --git a/zonedb.rkt b/zonedb.rkt index 607a1a5..1bed798 100644 --- a/zonedb.rkt +++ b/zonedb.rkt @@ -10,7 +10,8 @@ (require racket-bitsyntax) (require (rename-in racket-typed-matrix/tr-struct-copy [tr-struct-copy struct-copy])) ;; PR13149 -(provide zone-ref +(provide CompiledZone + zone-ref zone-includes-name? incorporate-complete-answer zone-expire-name @@ -22,6 +23,7 @@ filter-by-type filter-rrs rr-set->list + rr-rdata-domain-name cname-sort ;; provided for unit tests zone->bit-string bit-string->zone) @@ -245,8 +247,8 @@ (append (cname-sort (set->list cnames)) (set->list (set-subtract rrs cnames)))) -(: cname-target : RR -> DomainName) -(define (cname-target rr) +(: rr-rdata-domain-name : RR -> DomainName) +(define (rr-rdata-domain-name rr) (rdata-domain-name (cast (rr-rdata rr) rdata-domain))) (: cname-sort : (Listof RR) -> (Listof RR)) @@ -256,7 +258,7 @@ ;; CNAME c first). (define (cname-sort cnames) (define lhss (list->set (map rr-name cnames))) - (define rhss (list->set (map cname-target 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)) @@ -269,7 +271,7 @@ (if (set-member? seen source) (iterate (cdr remaining) seen acc) (let* ((rrs (targets-of source)) - (targets (map cname-target rrs))) + (targets (map rr-rdata-domain-name rrs))) (iterate (append targets (cdr remaining)) (set-add seen source) (append rrs acc))))))))