From 9f2de39dc95f9b293811d28901e8c0617b27093d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Wed, 1 Jun 2022 18:53:03 +0200
Subject: [PATCH] Reworet all ->bytes to use state monad.

---
 dns/types/header.scm   | 15 +++++++--------
 dns/types/message.scm  | 15 +++++----------
 dns/types/question.scm | 15 +++------------
 3 files changed, 15 insertions(+), 30 deletions(-)

diff --git a/dns/types/header.scm b/dns/types/header.scm
index f4484c8..9784c10 100644
--- a/dns/types/header.scm
+++ b/dns/types/header.scm
@@ -59,14 +59,13 @@
     (logand #xF u16)))                  ; rcode
 
 (define* (dns-header->bytes msg optional: (bv (make-bytevector 12)))
-  (define e (endianness big))
-  (bytevector-u16-set! bv 0  (or (id msg) 0) e)
-  (bytevector-u16-set! bv 2  (encode-dns-header-flags msg) e)
-  (bytevector-u16-set! bv 4  (or (qdcount msg) 0) e)
-  (bytevector-u16-set! bv 6  (or (ancount msg) 0) e)
-  (bytevector-u16-set! bv 8  (or (nscount msg) 0) e)
-  (bytevector-u16-set! bv 10 (or (arcount msg) 0) e)
-  bv)
+  (do
+      (u16! (or (id msg) 0))
+      (u16! (encode-dns-header-flags msg))
+    (u16! (or (qdcount msg) 0))
+    (u16! (or (ancount msg) 0))
+    (u16! (or (nscount msg) 0))
+    (u16! (or (arcount msg) 0))))
 
 (define (bytes->dns-header bv)
   (do
diff --git a/dns/types/message.scm b/dns/types/message.scm
index 937f54d..40c4e51 100644
--- a/dns/types/message.scm
+++ b/dns/types/message.scm
@@ -32,16 +32,11 @@
 
 
 (define (dns-message->bytes msg)
-  (define bvs
-    (cons (dns-header->bytes (header msg))
-          (map dns-question->bytes (questions msg))))
-  (define bv (make-bytevector (apply + (map bytevector-length bvs))))
-  (fold-left (lambda (off v)
-               (bytevector-copy! v 0 bv off (bytevector-length v))
-               (bytevector-length v))
-             0
-             bvs)
-  bv)
+  (do (dns-header->bytes (header msg))
+      (sequence (map dns-question->bytes (questions msg)))
+    (sequence (map rr-data->bytes (answers msg)))
+    (sequence (map rr-data->bytes (authorities msg)))
+    (sequence (map rr-data->bytes (additionals msg)))))
 
 (define (bytes->dns-message bv)
   (do
diff --git a/dns/types/question.scm b/dns/types/question.scm
index c270df2..b41576d 100644
--- a/dns/types/question.scm
+++ b/dns/types/question.scm
@@ -25,18 +25,9 @@
           (class default: 'IN type: (or u16? (assq (@ (dns enum) class-types))))))
 
 (define (dns-question->bytes q)
-  (define bv-base (-> q
-                      name
-                      (string-split #\.)
-                      string-list->labels))
-  (define bv (make-bytevector (+ 4 (bytevector-length bv-base))))
-  (bytevector-copy! bv-base 0 bv 0 (bytevector-length bv-base))
-  (bytevector-u16-set! bv (+ 0 (bytevector-length bv-base))
-                       (rr->int (type q))
-                       (endianness big))
-  (bytevector-u16-set! bv (+ 2 (bytevector-length bv-base))
-                       (class->int (class q)) (endianness big))
-  bv)
+  (do (bv-copy! (-> q name (string-split #\.) string-list->labels))
+      (u16! (rr->int (type q)))
+    (u16! (class->int (class q)))))
 
 (define (bytes->dns-question bv)
   (do
-- 
GitLab