Implement more Resource Records, including tests.

Makefile

@@ -9,6 +9,7 @@ tests = state.scm \
 	object.scm \
 	types-round-trip.scm \
 	header.scm \
+	rr.scm \
 
 sources = dns.scm \
 	$(shell find dns -type f -name \*.scm)

dns/internal/bv.scm

@@ -26,7 +26,7 @@
   (values (bytevector-u8-ref bv ptr)
           (1+ ptr)))
 
-;; Endianess is big by default for these, since we are working with network
+;; Endianness is big by default for these, since we are working with network
 ;; stuff.
 
 (define* ((u16 bv optional: (e (endianness big))) ptr)
@@ -53,6 +53,7 @@
       (return (bytevector-uint-ref vec 0 (endianness big) len))))
 
 (define (double-bv bv)
+  "Return a fresh bytevector twice the size of the given, contents copied over."
   (define new-bv (make-bytevector (* 2 (max 1 (bytevector-length bv)))))
   (bytevector-copy! bv 0 new-bv 0 (bytevector-length bv))
   new-bv)

dns/internal/state-monad.scm

@@ -11,7 +11,7 @@
   :use-module (ice-9 curried-definitions)
   :replace (do mod)
   :export (with-temp-state
-           <$> return get get* put sequence lift))
+           <$> return get get* put put* sequence lift))
 
 (define-syntax do
   (syntax-rules (<- let =)
@@ -43,11 +43,12 @@
                            (apply (do rest ...)
                             next-state)))))))
 
+
 (define (with-temp-state state* op)
   (do old <- (get*)
-      (apply put state*)
+      (apply put* state*)
       ret-value <- op
-      (apply put old)
+      (apply put* old)
       (return ret-value)))
 
 
@@ -73,6 +74,10 @@
       (apply values fst new-state)
       (apply values (cons fst old-state) new-state)))
 
+;; Like put, but doesn't return anything (useful)
+(define ((put* . new-state) . _)
+  (apply values #f new-state))
+
 (define (mod proc)
   (do
     a <- (get)

dns/label.scm

@@ -9,6 +9,7 @@
 
 ;; Encodes the scheme list of strings into a bytevector on the label format
 ;; expected by the DNS wire protocol.
+;; TODO shouldn't this be in the state monad?
 (define (string-list->labels lst*)
   (define trans (native-transcoder))
   (define lst
@@ -35,11 +36,8 @@
            (do
              (mod 1-) ; unreads first char
              ptr* <- (u16 bv)
-             old-ptr <- (get)
-             (put (logand ptr* #x1FFF))
-             str-list <- (labels->string-list bv)
-             (put old-ptr)
-             (return str-list)))
+             (with-temp-state (list (logand ptr* #x1FFF))
+                              (labels->string-list bv))))
           ((zero? len) (return '()))
           (else
             (do

dns/types/rr-data.scm

@@ -4,6 +4,8 @@
   :use-module (dns label)
   :use-module (dns util)
 
+  :use-module (rnrs bytevectors)
+
   :export (register-rr-handler!
            get-serializer
            get-deserializer
@@ -76,15 +78,32 @@ deserializer :: bv → State ptr <value>
               (uint-get bv (/ 128 8)))))
 
 (register-rr-handler!
- '(NS CNAME PTR TXT)
- (lambda (data) (string-list->labels (list data)))
+ '(NS CNAME PTR)
+ (lambda (data) (bv-copy! (string-list->labels (string-split data #\.))))
+ (lambda (bv len)
+   (do labels <- (labels->string-list bv)
+       (return (string-join labels ".")))))
+
+(register-rr-handler!
+ 'TXT
+ (lambda (data) (bv-copy! (string-list->labels (list data))))
  (lambda (bv len)
    (do labels <- (labels->string-list bv)
        (return (string-join labels ".")))))
 
 (register-rr-handler!
  'SOA
- (not-implemented "SOA serializer")
+ (lambda (data)
+   (call-with-values (lambda () (apply values data))
+     (lambda (mname rname serial refresh retry expire nttl)
+       (do
+           (bv-copy! (string-list->labels (string-split mname #\.)))
+           (bv-copy! (string-list->labels (string-split rname #\.)))
+         (u32! serial)
+         (u32! refresh)
+         (u32! retry)
+         (u32! expire)
+         (u32! nttl)))))
  (lambda (bv len)
   (do
       mname   <- (<$> domain-join (labels->string-list bv))
@@ -98,7 +117,9 @@ deserializer :: bv → State ptr <value>
 
 (register-rr-handler!
  'HINFO
- (not-implemented "HINFO Serializer")
+ (lambda (data)
+   (do (bv-copy! (string-list->labels (string-split (list-ref data 0) #\.)))
+       (bv-copy! (string-list->labels (string-split (list-ref data 1) #\.)))))
  (lambda (bv len)
   (lift list
         (<$> domain-join (labels->string-list bv))
@@ -106,5 +127,18 @@ deserializer :: bv → State ptr <value>
 
 (register-rr-handler!
  'MX
- (not-implemented "MX serializer")
+ (lambda (data)
+   (do (u16! (list-ref data 0))
+       (bv-copy! (string-list->labels (string-split (list-ref data 1) #\.)))))
  (lambda (bv len) (lift list (u16 bv) (<$> domain-join (labels->string-list bv)))))
+
+;; priority weight port target
+(register-rr-handler!
+ 'SRV
+ (not-implemented "SRV serializer")
+ (lambda (bv len)
+   (do priority <- (u16 bv)
+       weight   <- (u16 bv)
+       port     <- (u16 bv)
+       target   <- (<$> domain-join (labels->string-list bv))
+       (return (list priority weight port target)))))

tests/bv.scm

@@ -2,7 +2,8 @@
              (srfi srfi-1)
              (rnrs bytevectors)
              (rnrs io ports)
-             (dns internal bv))
+             (dns internal bv)
+             (dns internal state-monad))
 
 (test-begin "Bytevectors in state monad")
 

tests/rr.scm

+(use-modules (srfi srfi-64)
+             (rnrs bytevectors)
+             (rnrs io ports)
+             (dns types rr-data))
+
+(test-begin "DNS Resource Records")
+
+(define (bytevector-subvector bv from len)
+  (let ((bv* (make-bytevector len)))
+    (bytevector-copy! bv from
+                      bv* 0
+                      len)
+    bv*))
+
+(define (test-serialize type src expected)
+  (call-with-values
+      (lambda ()
+        (((get-serializer type) src)
+         (make-bytevector 100)
+         0))
+    (lambda (_ bv ptr)
+      ;; (test-equal "Ptr incremented correctly" 6 ptr)
+      (test-equal "Data written correctly"
+        expected
+        (bytevector-subvector bv 0 ptr)))))
+
+(define (test-deserialize type src expected)
+ (call-with-values
+     (lambda ()
+       (((get-deserializer type) src (bytevector-length src))
+        0))
+   (lambda (str ptr)
+     (test-equal "Data parsed correctly"
+       expected str))))
+
+
+(test-serialize   'A "10.20.30.40" #vu8(0 4 10 20 30 40))
+(test-deserialize 'A #vu8(10 20 30 40) "10.20.30.40")
+
+(test-serialize   'AAAA "::1" #vu8(0 16 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1))
+(test-deserialize 'AAAA #vu8(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1) "::1")
+
+(define codec (make-transcoder (latin-1-codec)))
+(define (s->bv s) (string->bytevector s codec))
+
+(test-serialize 'TXT "Hello, World!" (s->bv "\x00\x0F\x0DHello, World!\x00"))
+(test-deserialize 'TXT (s->bv "\x05Hello\0") "Hello")
+(test-deserialize 'TXT (s->bv "\x05Hello\x05World\0") "Hello.World")
+
+(let ((soa-bytes
+       #vu8(                    ;;
+            3 110 115 49        ; ns1
+            6 97 100 114 105 102 116    ; adrift
+            5 115 112 97 99 101         ; space
+            0
+            4 104 117 103 111                ; hugo
+            9 104 111 114 110 113 117 105 115 116 ; hornquist
+            2 115 101                             ; se
+            0
+            120 134 209 52              ; serial
+            0 18 117 0                  ; refresh
+            0 0 28 32                   ; retry
+            0 54 238 128                ; expire
+            0 0 1 44                    ; nttl
+            ))
+
+      (soa-record (list "ns1.adrift.space"
+                        "hugo.hornquist.se"
+                        2022101300
+                        1209600
+                        7200
+                        3600000
+                        300)))
+
+  (test-serialize 'SOA soa-record
+                  (let* ((len (bytevector-length soa-bytes))
+                         (bv (make-bytevector (+ 2 len))))
+                    (bytevector-copy! soa-bytes 0 bv 2 len)
+                    (bytevector-u16-set! bv 0 len (endianness big))
+                    bv))
+  (test-deserialize 'SOA soa-bytes soa-record))
+
+
+(test-end)