diff --git a/dns/types/header.scm b/dns/types/header.scm index 0e34b52f27a7cca232c31c2ba28da6149a5bd3d6..f4484c823e3701b7798a3934ad136ef93c1aafac 100644 --- a/dns/types/header.scm +++ b/dns/types/header.scm @@ -7,6 +7,7 @@ :use-module (dns internal object) :use-module (dns enum) :use-module (dns types) + :use-module (dns util) :re-export (id qr opcode aa tc rd ra z rcode qdcount ancount nscount arcount) :export (make-dns-header dns-header? @@ -20,16 +21,17 @@ (define-record-type dns-header - (fields (id default: 0) ; integer, u16 + (fields (id default: 0 type: u16?) ;; flags - qr ; boolean - (opcode default: 'QUERY) ; symbol, on of (@ (dns enum) opcode-types) - aa tc rd ra ; booleans - (z default: 0) ; Always 0 - (rcode default: 'NOERROR) ; symbol v on of (@ (dns enum) rcode-types) - ;; lengths, all u16 integers - (qdcount default: 0) (ancount default: 0) - (nscount default: 0) (arcount default: 0))) + (qr type: boolean?) + (opcode default: 'QUERY + type: (or (uint? 4) (assq (@ (dns enum) opcode-types)))) + (aa type: boolean?) (tc type: boolean?) (rd type: boolean?) (ra type: boolean?) + (z default: 0 type: zero?) + (rcode default: 'NOERROR type: (or (uint? 4) (assq (@ (dns enum) rcode-types)))) + ;; lengths + (qdcount default: 0 type: u16?) (ancount default: 0 type: u16?) + (nscount default: 0 type: u16?) (arcount default: 0 type: u16?))) (define (encode-dns-header-flags msg) diff --git a/dns/types/message.scm b/dns/types/message.scm index ae4fb0a0bdf54c12ebd21e3d7c94061223cd572f..937f54d4bcd7a2ef8c98071a230c0c963e8ad4d3 100644 --- a/dns/types/message.scm +++ b/dns/types/message.scm @@ -1,5 +1,6 @@ (define-module (dns types message) :use-module (srfi srfi-88) + :use-module ((srfi srfi-1) :select (every)) :use-module (rnrs lists) :use-module (rnrs bytevectors) :use-module (dns internal util) @@ -18,12 +19,16 @@ bytes->dns-message dns-message->bytes )) +(define (rr-list? x) + (and list? (every dns-rr-data? x))) + (define-record-type dns-message - (fields header ; dns-header - (questions default: '()) ; list of dns-question - (answers default: '()) ; list of dns-rr-data - (authorities default: '()) ; list of dns-rr-data - (additionals default: '()))) ; list of dns-rr-data + (fields (header type: dns-header?) + (questions default: '() + type: (and list? ((flip every) dns-question?))) + (answers default: '() type: rr-list?) + (authorities default: '() type: rr-list?) + (additionals default: '() type: rr-list?))) (define (dns-message->bytes msg) diff --git a/dns/types/question.scm b/dns/types/question.scm index 83af6be68ced8b03aa01ab74b5ac15022a31bbe9..c270df297ac0f2d6c44b498ab44da5b1b5595572 100644 --- a/dns/types/question.scm +++ b/dns/types/question.scm @@ -5,6 +5,7 @@ :use-module (dns internal state-monad) :use-module (dns internal bv) :use-module (dns internal object) + :use-module (dns util) :use-module (dns label) :use-module (dns enum) :use-module (dns types) @@ -19,9 +20,9 @@ (define-record-type dns-question - (fields name ; string - type ; symbol, on of (@ (dns enum) rr-types) - (class default: 'IN))) ; symbol, on of (@ (dns enum) class-types) + (fields (name type: string?) ; string + (type type: (or u16? (assq (@ (dns enum) rr-types)))) + (class default: 'IN type: (or u16? (assq (@ (dns enum) class-types)))))) (define (dns-question->bytes q) (define bv-base (-> q diff --git a/dns/types/rr.scm b/dns/types/rr.scm index ebabe136c97f5102528392f0152396b073bc8cce..d991501cdc56ce428febb76ef84531d36064f4e6 100644 --- a/dns/types/rr.scm +++ b/dns/types/rr.scm @@ -15,11 +15,14 @@ ) (define-record-type dns-rr-data - (fields name ; string - type ; symbol, one of (@ (dns enum) rr-types) - (class default: 'IN) ; symbol, one of (@ (dns enum) class-types) - ttl ; integer, 0 ≤ x ≤ 2¹⁶-1 - rdata)) ; dependant on type + (fields (name type: string?) + (type type: (or u16? (assq (@ (dns enum) rr-types)))) + (class + default: 'IN + type: (or u16? (assq (@ (dns enum) class-types)))) + (ttl type: (uint? 32)) + ;; Rdata's type is dependant on the type field, and is therefore left blank. + rdata)) ;; (define (dns-rr-data->bytes data) diff --git a/dns/util.scm b/dns/util.scm index e3b85f3cd0c0832d6c36417b1068064386ee2e38..7e0bf99a133d9a9333683e33ba7f10fefaee57bf 100644 --- a/dns/util.scm +++ b/dns/util.scm @@ -1,5 +1,14 @@ (define-module (dns util) - :export (domain-join)) + :export (domain-join + uint? u16?)) (define (domain-join lst) (string-join lst ".")) + + +(define (uint? x max) + (and (exact-integer? x) + (<= 0 x (1- (expt max 16))))) + +(define (u16? x) + (uint? x 16))