diff --git a/Makefile b/Makefile index c4fece0d78f59d123e26abc1ebb76d66051f1a71..830b9de8c2da008db3514a95475a1c371a12cfe1 100644 --- a/Makefile +++ b/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) diff --git a/dns/internal/bv.scm b/dns/internal/bv.scm index 39fd88a4f33fdc8671a2e0b21df2648965971bf2..9c1330c82976bedb0344d57f385a98e6cc241420 100644 --- a/dns/internal/bv.scm +++ b/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) diff --git a/dns/internal/state-monad.scm b/dns/internal/state-monad.scm index 1730ff95dad8cd151f7c5275512b34c9c29ad093..d2aa2f2578ac7b49c582c164bb79fc5dc01e16fc 100644 --- a/dns/internal/state-monad.scm +++ b/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) diff --git a/dns/label.scm b/dns/label.scm index d1de47fcd8ef0005b66c6ae4fc99bcfadeb4b801..7e8c272ab4a2fdf400625f549346b040574a5ea1 100644 --- a/dns/label.scm +++ b/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 diff --git a/dns/types/rr-data.scm b/dns/types/rr-data.scm index bf9404fd236035d277b1099d2319e2261d539308..817320ad5131779e9c07d8d7d18870268273e58b 100644 --- a/dns/types/rr-data.scm +++ b/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))))) diff --git a/tests/bv.scm b/tests/bv.scm index 1c6add822653d7299d268d9ac765620b6d16e39a..c27d3a9e17a4529ea403132b9a2ef98cdf5254d2 100644 --- a/tests/bv.scm +++ b/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") diff --git a/tests/rr.scm b/tests/rr.scm new file mode 100644 index 0000000000000000000000000000000000000000..3a3391210b35bdfe3ffb4821b0559869d231254b --- /dev/null +++ b/tests/rr.scm @@ -0,0 +1,84 @@ +(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)