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