From 5da7f0ac1520a01123f5806b7c44313416b506c3 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 20 Mar 2013 10:59:45 -0400 Subject: [PATCH] Pollute structure definitions with pseudo-substruct --- api.rkt | 23 ++++++++++++++++------ codec.rkt | 6 +++--- driver.rkt | 2 +- network-query.rkt | 4 ++-- resolver.rkt | 8 +++++--- tk-dns.rkt | 50 ++++++++++++++++++++++++++++++++++++++++------- 6 files changed, 71 insertions(+), 22 deletions(-) diff --git a/api.rkt b/api.rkt index 6fe2475..ee05018 100644 --- a/api.rkt +++ b/api.rkt @@ -10,8 +10,10 @@ IPv4 IPv6 - Question - (struct-out question) + (struct-out question-repr) + Question question question? + QuestionPattern question-pattern question-pattern? + question-cyclic? question-too-glueless? question-restarted? @@ -57,7 +59,9 @@ (require "mapping.rkt") (require racket/set) (require racket/match) +(require racket-typed-matrix) (require racket-typed-matrix/struct-map) +(require racket-typed-matrix/support/pseudo-substruct) ;; A DomainName is a (domain ListOf), representing a domain ;; name. The head of the list is the leftmost label; for example, @@ -88,10 +92,17 @@ ;; 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: question - ([name : DomainName] [type : QueryType] [class : QueryClass] [context : QuestionContext]) +(struct: (TName TType TClass TContext) + question-repr + ([name : TName] [type : TType] [class : TClass] [context : TContext]) #:prefab) -(define-type Question question) +(pseudo-substruct: (question-repr DomainName QueryType QueryClass QuestionContext) + Question question question?) +(pseudo-substruct: (question-repr (U Wild DomainName) + (U Wild QueryType) + (U Wild QueryClass) + (U Wild QuestionContext)) + QuestionPattern question-pattern question-pattern?) ;; A QuestionContext is one of ;; -- (cname-subq Question), resulting from the expansion of a CNAME @@ -363,7 +374,7 @@ ;; retracing from the roots in cases of excessive gluelessness. (: restart-question : Question -> Question) (define (restart-question q) - (struct-copy question q [context 'restart])) + (struct-copy question-repr q [context 'restart])) ;; DomainName Question -> Question ;; Produces a new question with CNAME context. diff --git a/codec.rkt b/codec.rkt index 8f5743a..4710238 100644 --- a/codec.rkt +++ b/codec.rkt @@ -360,9 +360,9 @@ tail)))) ((_ #f val) (let: ([q : Question val]) - (bit-string ((question-name q) :: (t:domain-name)) - ((qtype->value (question-type q)) :: bits 16) - ((qclass->value (question-class q)) :: bits 16)))))) + (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)))))) ;; ;; All RRs have the same top level format shown below: diff --git a/driver.rkt b/driver.rkt index d183def..33e304a 100644 --- a/driver.rkt +++ b/driver.rkt @@ -56,7 +56,7 @@ (define-type ReplyMaker (DomainName Boolean (Setof RR) (Setof RR) (Setof RR) -> DNSMessage)) -(: handle-request : RR CompiledZone dns-request -> (Option dns-reply)) +(: 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) diff --git a/network-query.rkt b/network-query.rkt index 7a8ea64..da34e19 100644 --- a/network-query.rkt +++ b/network-query.rkt @@ -188,10 +188,10 @@ 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-name q))) answers)) + (set-filter (lambda: ([rr : RR]) (equal? (rr-name rr) (question-repr-name q))) answers)) (define lame? (and (set-empty? (filter-by-type answers-to-q 'cname)) - (set-empty? (filter-rrs answers-to-q (question-type q) (question-class q))) + (set-empty? (filter-rrs answers-to-q (question-repr-type q) (question-repr-class q))) (set-empty? (filter-by-type authorities 'soa)) (not (null? non-subzone-ns-rrs)))) (if lame? diff --git a/resolver.rkt b/resolver.rkt index 25779ae..bde708d 100644 --- a/resolver.rkt +++ b/resolver.rkt @@ -109,7 +109,7 @@ (: 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 name (question-repr-name q)) (define ns-rrset (closest-nameservers name zone)) (list->set (for/list: : (Listof RR) ([rr : RR ns-rrset] @@ -119,8 +119,10 @@ (: 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 - (not (zone-includes-name? zone (question-name q)))) ;; there are no RRs at all for this q + (in-bailiwick? (question-repr-name q) (rr-name start-of-authority)) + ;; ^ for this in particular + (not (zone-includes-name? zone (question-repr-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. diff --git a/tk-dns.rkt b/tk-dns.rkt index 2ee2744..07e2b3d 100644 --- a/tk-dns.rkt +++ b/tk-dns.rkt @@ -6,18 +6,54 @@ (require "codec.rkt") (require racket-typed-matrix/sugar-typed) (require racket-typed-matrix/drivers/udp) +(require racket-typed-matrix/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: bad-dns-packet - ([detail : Any] [source : UdpAddress] [sink : UdpAddress] [reason : Symbol]) #:prefab) -(struct: dns-request ([message : DNSMessage] [source : UdpAddress] [sink : UdpAddress]) #:prefab) -(struct: dns-reply ([message : DNSMessage] [source : UdpAddress] [sink : UdpAddress]) #:prefab) +(struct: (TDetail TSource TSink TReason) + bad-dns-packet-repr + ([detail : TDetail] [source : TSource] [sink : TSink] [reason : TReason]) #:prefab) +(pseudo-substruct: (bad-dns-packet-repr Any UdpAddress UdpAddress Symbol) + BadDnsPacket bad-dns-packet bad-dns-packet?) +(pseudo-substruct: (bad-dns-packet-repr Any + (U Wild UdpAddressPattern) + (U Wild UdpAddressPattern) + (U Wild Symbol)) + BadDnsPacketPattern bad-dns-packet-pattern bad-dns-packet-pattern?) + +(struct: (TMessage TSource TSink) + dns-request-repr + ([message : TMessage] [source : TSource] [sink : TSink]) #:prefab) +(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]) #:prefab) +(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 : (All (ParentState) UdpAddress -> (Action ParentState))) (define (dns-read-driver s)