Fix RData type using substructs.
This commit is contained in:
Tony Garnock-Jones
parent
7215888fcb
commit
316834d681
76
api.rkt
76
api.rkt
|
|
@ -31,13 +31,19 @@
|
|||
extract-addresses
|
||||
|
||||
RData
|
||||
(struct-out hinfo)
|
||||
(struct-out minfo)
|
||||
(struct-out mx)
|
||||
(struct-out soa)
|
||||
(struct-out wks)
|
||||
(struct-out srv)
|
||||
rr-rdata/cast
|
||||
(struct-out rdata)
|
||||
(struct-out rdata-domain)
|
||||
(struct-out rdata-ipv4)
|
||||
(struct-out rdata-ipv6)
|
||||
(struct-out rdata-hinfo)
|
||||
(struct-out rdata-minfo)
|
||||
(struct-out rdata-mx)
|
||||
(struct-out rdata-soa)
|
||||
(struct-out rdata-wks)
|
||||
(struct-out rdata-srv)
|
||||
(struct-out rdata-txt)
|
||||
(struct-out rdata-raw)
|
||||
rdata-type-pred
|
||||
|
||||
RRType
|
||||
QueryType
|
||||
|
|
@ -117,7 +123,6 @@
|
|||
;; An RR is a (rr DomainName RRType RRClass Uint32 RData),
|
||||
;; representing a resource record.
|
||||
(struct: rr ([name : DomainName]
|
||||
[type : RRType]
|
||||
[class : RRClass]
|
||||
[ttl : Nonnegative-Integer]
|
||||
[rdata : RData])
|
||||
|
|
@ -143,25 +148,32 @@
|
|||
;;
|
||||
;; Many of these variants are obsolete in today's DNS database (marked
|
||||
;; [O] above).
|
||||
(struct: hinfo ([cpu : Bytes] [os : Bytes]) #:prefab)
|
||||
(struct: minfo ([rmailbx : DomainName] [emailbx : DomainName]) #:prefab)
|
||||
(struct: mx ([preference : Nonnegative-Integer] [exchange : DomainName]) #:prefab)
|
||||
(struct: soa ([mname : DomainName]
|
||||
[rname : DomainName]
|
||||
[serial : Nonnegative-Integer]
|
||||
[refresh : Nonnegative-Integer]
|
||||
[retry : Nonnegative-Integer]
|
||||
[expire : Nonnegative-Integer]
|
||||
[minimum : Nonnegative-Integer]) #:prefab)
|
||||
(struct: wks ([address : IPv4] [protocol : Byte] [bitmap : Bytes]) #:prefab)
|
||||
(struct: srv ([priority : Nonnegative-Integer]
|
||||
[weight : Nonnegative-Integer]
|
||||
[port : Nonnegative-Integer]
|
||||
[target : DomainName]) #:prefab)
|
||||
(define-type RData (U DomainName IPv4 IPv6 hinfo minfo mx soa wks srv (Listof Bytes) Bytes))
|
||||
(struct: rdata ([type : RRType]) #:prefab)
|
||||
(struct: rdata-domain rdata ([name : DomainName]) #:prefab)
|
||||
(struct: rdata-ipv4 rdata ([address : IPv4]) #:prefab)
|
||||
(struct: rdata-ipv6 rdata ([address : IPv6]) #:prefab)
|
||||
(struct: rdata-hinfo rdata ([cpu : Bytes] [os : Bytes]) #:prefab)
|
||||
(struct: rdata-minfo rdata ([rmailbx : DomainName] [emailbx : DomainName]) #:prefab)
|
||||
(struct: rdata-mx rdata ([preference : Nonnegative-Integer] [exchange : DomainName]) #:prefab)
|
||||
(struct: rdata-soa rdata ([mname : DomainName]
|
||||
[rname : DomainName]
|
||||
[serial : Nonnegative-Integer]
|
||||
[refresh : Nonnegative-Integer]
|
||||
[retry : Nonnegative-Integer]
|
||||
[expire : Nonnegative-Integer]
|
||||
[minimum : Nonnegative-Integer]) #:prefab)
|
||||
(struct: rdata-wks rdata ([address : IPv4] [protocol : Byte] [bitmap : Bytes]) #:prefab)
|
||||
(struct: rdata-srv rdata ([priority : Nonnegative-Integer]
|
||||
[weight : Nonnegative-Integer]
|
||||
[port : Nonnegative-Integer]
|
||||
[target : DomainName]) #:prefab)
|
||||
(struct: rdata-txt rdata ([strings : (Listof Bytes)]) #:prefab)
|
||||
(struct: rdata-raw rdata ([body : Bytes]) #:prefab)
|
||||
(define-type RData rdata)
|
||||
|
||||
(define-syntax-rule (rr-rdata/cast Type)
|
||||
(lambda: ([rr : RR]) (cast (rr-rdata rr) Type)))
|
||||
(: rdata-type-pred : RRType -> (RData -> Boolean))
|
||||
(define ((rdata-type-pred t) d)
|
||||
(eq? (rdata-type d) t))
|
||||
|
||||
;; An RRType is a Symbol or a Number, one of the possibilities given
|
||||
;; in the following define-mapping. It represents the type of an
|
||||
|
|
@ -289,14 +301,14 @@
|
|||
(if (null? names)
|
||||
ips
|
||||
(let* ((name (car names))
|
||||
(records (filter (lambda: ([rr : RR]) (equal? name (rr-name rr))) rrs)))
|
||||
(records (filter (lambda: ([rr : RR]) (equal? name (rr-name rr))) rrs))
|
||||
(data (map rr-rdata records)))
|
||||
(if (set-member? seen name)
|
||||
(loop (cdr names) ips seen)
|
||||
(let ((a-records (filter (lambda: ([rr : RR]) (equal? 'a (rr-type rr))) records))
|
||||
(cname-records
|
||||
(filter (lambda: ([rr : RR]) (equal? 'cname (rr-type rr))) records)))
|
||||
(loop (append (map (rr-rdata/cast DomainName) cname-records) (cdr names))
|
||||
(set-union ips (list->set (map (rr-rdata/cast IPv4) a-records)))
|
||||
(let ((a-data (filter rdata-ipv4? (filter (rdata-type-pred 'a) data)))
|
||||
(cname-data (filter rdata-domain? (filter (rdata-type-pred 'cname) data))))
|
||||
(loop (append (map rdata-domain-name cname-data) (cdr names))
|
||||
(set-union ips (list->set (map rdata-ipv4-address a-data)))
|
||||
(set-add seen name)))))))]))
|
||||
|
||||
;; Question -> Boolean
|
||||
|
|
|
|||
90
codec.rkt
90
codec.rkt
|
|
@ -407,7 +407,6 @@
|
|||
(tail :: binary) ]
|
||||
(let ((type (value->type type-number)))
|
||||
(ks (rr name
|
||||
type
|
||||
(value->class class)
|
||||
ttl
|
||||
(decode-rdata whole-packet type rdata))
|
||||
|
|
@ -415,9 +414,9 @@
|
|||
(else (kf)))))
|
||||
((_ #f val)
|
||||
(let: ([rr : RR val])
|
||||
(let ((encoded-rdata (encode-rdata (rr-type rr) (rr-rdata rr))))
|
||||
(let ((encoded-rdata (encode-rdata (rr-rdata rr))))
|
||||
(bit-string ((rr-name rr) :: (t:domain-name))
|
||||
((type->value (rr-type rr)) :: bits 16)
|
||||
((type->value (rdata-type (rr-rdata rr))) :: bits 16)
|
||||
((class->value (rr-class rr)) :: bits 16)
|
||||
((rr-ttl rr) :: bits 32)
|
||||
((quotient (bit-string-length encoded-rdata) 8) :: bits 16)
|
||||
|
|
@ -429,19 +428,20 @@
|
|||
(define (decode-rdata whole-packet type rdata)
|
||||
(case type
|
||||
((cname mb md mf mg mr ns ptr) (bit-string-case rdata
|
||||
([ (name :: (t:domain-name whole-packet)) ] name)))
|
||||
([ (name :: (t:domain-name whole-packet)) ]
|
||||
(rdata-domain type name))))
|
||||
((hinfo) (bit-string-case rdata
|
||||
([ (cpu :: (t:pascal-string)) (os :: (t:pascal-string)) ]
|
||||
(hinfo cpu os))))
|
||||
(rdata-hinfo type cpu os))))
|
||||
((minfo) (bit-string-case rdata
|
||||
([ (rmailbx :: (t:domain-name whole-packet))
|
||||
(emailbx :: (t:domain-name whole-packet)) ]
|
||||
(minfo rmailbx emailbx))))
|
||||
(rdata-minfo type rmailbx emailbx))))
|
||||
((mx) (bit-string-case rdata
|
||||
([ (preference :: bits 16)
|
||||
(exchange :: (t:domain-name whole-packet)) ]
|
||||
(mx preference exchange))))
|
||||
((null) (bit-string->bytes rdata))
|
||||
(rdata-mx type preference exchange))))
|
||||
((null) (rdata-raw type (bit-string->bytes rdata)))
|
||||
((soa) (bit-string-case rdata
|
||||
([ (mname :: (t:domain-name whole-packet))
|
||||
(rname :: (t:domain-name whole-packet))
|
||||
|
|
@ -450,57 +450,57 @@
|
|||
(retry :: bits 32)
|
||||
(expire :: bits 32)
|
||||
(minimum :: bits 32) ]
|
||||
(soa mname rname serial refresh retry expire minimum))))
|
||||
(rdata-soa type mname rname serial refresh retry expire minimum))))
|
||||
((txt) (bit-string-case rdata
|
||||
([ (strs :: (t:listof Bytes (t:pascal-string))) ]
|
||||
strs)))
|
||||
(rdata-txt type strs))))
|
||||
((a) (bit-string-case rdata
|
||||
([ a b c d ]
|
||||
(ann (vector a b c d) IPv4))))
|
||||
(rdata-ipv4 type (vector a b c d)))))
|
||||
((aaaa) (bit-string-case rdata
|
||||
([ a b c d e f g h i j k l m n o p ]
|
||||
(ann (vector a b c d e f g h i j k l m n o p) IPv6))))
|
||||
(rdata-ipv6 type (vector a b c d e f g h i j k l m n o p)))))
|
||||
((wks) (bit-string-case rdata
|
||||
([ a b c d protocol (bitmap :: binary) ]
|
||||
(wks (vector a b c d) protocol (bit-string->bytes bitmap)))))
|
||||
(rdata-wks type (vector a b c d) protocol (bit-string->bytes bitmap)))))
|
||||
((srv) (bit-string-case rdata
|
||||
([ (priority :: bits 16)
|
||||
(weight :: bits 16)
|
||||
(port :: bits 16)
|
||||
(target :: (t:domain-name whole-packet)) ]
|
||||
(srv priority weight port target))))
|
||||
(else (bit-string->bytes rdata))))
|
||||
(rdata-srv type priority weight port target))))
|
||||
(else (rdata-raw type (bit-string->bytes rdata)))))
|
||||
|
||||
(: encode-rdata : RRType RData -> BitString)
|
||||
;; Encode RData according to the RRType.
|
||||
(define (encode-rdata type rdata)
|
||||
(case type
|
||||
((cname mb md mf mg mr ns ptr) (encode-domain-name rdata))
|
||||
((hinfo) (bit-string ((hinfo-cpu rdata) :: (t:pascal-string))
|
||||
((hinfo-os rdata) :: (t:pascal-string))))
|
||||
((minfo) (bit-string ((minfo-rmailbx rdata) :: (t:domain-name))
|
||||
((minfo-emailbx rdata) :: (t:domain-name))))
|
||||
((mx) (bit-string ((mx-preference rdata) :: bits 16)
|
||||
((mx-exchange rdata) :: (t:domain-name))))
|
||||
((null) rdata)
|
||||
((soa) (bit-string ((soa-mname rdata) :: (t:domain-name))
|
||||
((soa-rname rdata) :: (t:domain-name))
|
||||
((soa-serial rdata) :: bits 32)
|
||||
((soa-refresh rdata) :: bits 32)
|
||||
((soa-retry rdata) :: bits 32)
|
||||
((soa-expire rdata) :: bits 32)
|
||||
((soa-minimum rdata) :: bits 32)))
|
||||
((txt) (bit-string (rdata :: (t:listof Bytes (t:pascal-string)))))
|
||||
((a) (match rdata ((vector a b c d) (bit-string a b c d))))
|
||||
((aaaa) (bit-string ((list->bytes (vector->list rdata)) :: binary bits 128)))
|
||||
((wks) (match (wks-address rdata)
|
||||
((vector a b c d)
|
||||
(bit-string a b c d (wks-protocol rdata) ((wks-bitmap rdata) :: binary)))))
|
||||
((srv) (bit-string ((srv-priority rdata) :: bits 16)
|
||||
((srv-weight rdata) :: bits 16)
|
||||
((srv-port rdata) :: bits 16)
|
||||
((srv-target rdata) :: (t:domain-name))))
|
||||
(else rdata)))
|
||||
(: encode-rdata : RData -> BitString)
|
||||
;; Encode RData according to its RRType.
|
||||
(define (encode-rdata rdata)
|
||||
(match rdata
|
||||
[(rdata-domain _ name) (encode-domain-name name)]
|
||||
[(rdata-hinfo _ cpu os) (bit-string (cpu :: (t:pascal-string))
|
||||
(os :: (t:pascal-string)))]
|
||||
[(rdata-minfo _ rmailbx emailbx) (bit-string (rmailbx :: (t:domain-name))
|
||||
(emailbx :: (t:domain-name)))]
|
||||
[(rdata-mx _ preference exchange) (bit-string (preference :: bits 16)
|
||||
(exchange :: (t:domain-name)))]
|
||||
[(rdata-soa _ mname rname serial refresh retry expire minimum)
|
||||
(bit-string (mname :: (t:domain-name))
|
||||
(rname :: (t:domain-name))
|
||||
(serial :: bits 32)
|
||||
(refresh :: bits 32)
|
||||
(retry :: bits 32)
|
||||
(expire :: bits 32)
|
||||
(minimum :: bits 32))]
|
||||
[(rdata-txt _ strings) (bit-string (strings :: (t:listof Bytes (t:pascal-string))))]
|
||||
[(rdata-ipv4 _ (vector a b c d)) (bit-string a b c d)]
|
||||
[(rdata-ipv6 _ aaaa) (bit-string ((list->bytes (vector->list aaaa)) :: binary bits 128))]
|
||||
[(rdata-wks _ (vector a b c d) protocol bitmap)
|
||||
(bit-string a b c d protocol (bitmap :: binary))]
|
||||
[(rdata-srv _ priority weight port target)
|
||||
(bit-string (priority :: bits 16)
|
||||
(weight :: bits 16)
|
||||
(port :: bits 16)
|
||||
(target :: (t:domain-name)))]
|
||||
[(rdata-raw _ bs) bs]))
|
||||
|
||||
;; UInt32
|
||||
(: max-ttl : Nonnegative-Integer)
|
||||
|
|
|
|||
Loading…
Reference in New Issue