From 316834d681e1de6112c81d1382fd8073528be9e2 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 16 Mar 2013 10:26:56 -0400 Subject: [PATCH] Fix RData type using substructs. --- api.rkt | 76 ++++++++++++++++++++++++++-------------------- codec.rkt | 90 +++++++++++++++++++++++++++---------------------------- 2 files changed, 89 insertions(+), 77 deletions(-) diff --git a/api.rkt b/api.rkt index 1d6c76d..6fe2475 100644 --- a/api.rkt +++ b/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 diff --git a/codec.rkt b/codec.rkt index 99716b9..1868b75 100644 --- a/codec.rkt +++ b/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)