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