Pollute structure definitions with pseudo-substruct
This commit is contained in:
Tony Garnock-Jones
parent
1b2e842a15
commit
5da7f0ac15
23
api.rkt
23
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<Bytes>), 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.
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
||||
;; <rfc1035>
|
||||
;; All RRs have the same top level format shown below:
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
50
tk-dns.rkt
50
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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue