diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..9e3e8fbcf0def5ab7d75df3e9d53c1e045fffd69
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,38 @@
+.PHONY: all install check clean
+
+# Tests are run in the order noted here
+tests = state.scm \
+ bv.scm \
+ label.scm \
+ enum.scm
+
+sources = dns.scm \
+ $(shell find dns -type f -name \*.scm)
+
+targets = $(sources:%.scm=obj/%.go)
+
+GUILE = guile
+
+TEST_ENV = GUILE_AUTO_COMPILE=0 GUILE_LOAD_PATH=$(PWD)
+TEST_FLAGS = $(if $(VERBOSE),--verbose) --coverage coverage.info
+PREFIX = /usr
+
+GUILE_CFLAGS = -O2 --warn=unused-variable,unused-toplevel,shadowed-toplevel,unbound-variable,macro-use-before-definition,arity-mismatch,duplicate-case-datum,bad-case-datum,format
+
+obj/%.go: %.scm
+ guild compile -L $(PWD) -o $@ $<
+
+all: $(targets) doc/guile-dns.info
+
+install: all
+ install -m644 -D -t $(DESTDIR)/$(PREFIX)/share doc/guile-dns.info
+
+check: all
+ env $(TEST_ENV) $(GUILE) --debug -e main -s run-tests.scm $(TEST_FLAGS) $(tests)
+
+coverage/index.html: coverage.info
+ genhtml --output-directory coverage $<
+
+clean:
+ -rm -r coverage
+ -rm -r obj
diff --git a/README b/README
new file mode 100644
index 0000000000000000000000000000000000000000..aeff5def092bb97893ff62baf7bb342bd6a18475
--- /dev/null
+++ b/README
@@ -0,0 +1,3 @@
+See RFC1035 for a description of DNS
+See doc/guile-dns.info for information about the library
+See main.scm for example usage.
diff --git a/TODO.org b/TODO.org
new file mode 100644
index 0000000000000000000000000000000000000000..d904ee009712e7eed8a101f83152cd7987aa44f1
--- /dev/null
+++ b/TODO.org
@@ -0,0 +1,9 @@
+** TODO Write rr-data->bytes
+** TODO Extend define-record-type to generate type validators
+** TODO Standardized names for rcode types?
+Currently the following are used, but are there more standardized names?
+- NOERROR :: 0
+- NXDOMAIN :: 1
+- SERVFIL :: 2
+** TODO [#A] Install SCM and GO files
+In the Makefile
diff --git a/dns.scm b/dns.scm
index 9ffa3f8c1848d667f220b12e439804f9c7d0390b..0c48130fa2505de7379e66339d74c9037f80931d 100644
--- a/dns.scm
+++ b/dns.scm
@@ -1,490 +1,15 @@
(define-module (dns)
:use-module (rnrs base)
- :use-module (rnrs lists)
:use-module (rnrs bytevectors)
;; :use-module (rnrs records syntactic)
- :use-module (rnrs io ports)
:use-module (ice-9 curried-definitions)
:use-module (srfi srfi-88)
:use-module (srfi srfi-9 gnu)
- :use-module (object)
- :use-module (util)
- :export ()
- )
-
-;; See RFC1035 for most stuff
-
-;; TODO add type annotations to define-record-type, and generate code
-;; for validating them.
-
-
-(define (flip-cons c)
- (cons (cdr c) (car c)))
-
-(define (make-mappings table)
- (values
- (lambda (i)
- (cond ((assv i (map flip-cons table)) => cdr)
- (else i)))
-
- (lambda (value)
- (cond ((number? value) value)
- ((assv value table) => cdr)
- (else (scm-error 'wrong-type-arg "<something>->int"
- "Unknown value ~s"
- (list value) #f))) )))
-(define rr-types
- '((A . 1)
- (NS . 2)
- (MD . 3)
- (MF . 4)
- (CNAME . 5)
- (SOA . 6)
- (MB . 7)
- (MG . 8)
- (MR . 9)
- (NULL . 10)
- (WKS . 11)
- (PTR . 12)
- (HINFO . 13)
- (MINFO . 14)
- (MX . 15)
- (TXT . 16)
- ;; I don't know where this is specified
- (AAAA . 28)))
-
-(define-values (int->rr rr->int)
- (make-mappings rr-types))
-
-(define class-types
- '((IN . 1)
- (CS . 2)
- (CH . 3)
- (HS . 4)))
-
-(define-values (int->class class->int)
- (make-mappings class-types))
-
-;; TODO what are the standard names?
-(define rcode-types
- '((NOERROR . 0) ; no error condition
- (NXDOMAIN . 1) ; format error - name server can't interpret
- (SERVFAIL . 2) ; server failure
- ;; 3 ; name error
- ))
-
-(define-values (int->rcode rcode->int)
- (make-mappings rcode-types))
-
-
-(define opcode-types
- '((QUERY . 0)
- (IQUERY . 1)
- (STATUS . 2)))
-
-(define-values (int->opcode opcode->int)
- (make-mappings opcode-types))
-
-(define-record-type dns-question
- (fields name type (class default: 'IN)))
-
-(define ((u8 bv) ptr)
- (values (bytevector-u8-ref bv ptr)
- (1+ ptr)))
-
-(define* ((u16 bv optional: (e (endianness big))) ptr)
- (values (bytevector-u16-ref bv ptr e)
- (+ ptr 2)))
-
-(define* ((u32 bv optional: (e (endianness big))) ptr)
- (values (bytevector-u32-ref bv ptr e)
- (+ ptr 4)))
-
-
-(define ((bv-get bv len) ptr)
- (define ret (make-bytevector len))
- (bytevector-copy! bv ptr
- ret 0
- len)
- (values ret (+ ptr len)))
-
-(define (uint-get bv len)
- (do vec <- (bv-get bv len)
- (return (bytevector-uint-ref vec 0 (endianness big) len))))
-
-(define-record-type dns-header
- (fields (id default: 0)
- ;; flags
- qr (opcode default: 'QUERY)
- aa tc rd ra
- (z default: 0)
- (rcode default: 'NOERROR)
- ;; lengths
- (qdcount default: 0) (ancount default: 0)
- (nscount default: 0) (arcount default: 0)))
-
-#;
-(set-record-type-printer!
- dns-header
- (lambda (record port)
- (format port "#<dns-header id: ~a, qr: ~a, ~s, rcode: ~aqd: ~a, an: ~a, ns: ~a, ar: ~a>"
- (dns-header-id record)
- (dns-header-qr record)
- (dns-header-opcode record)
- (string-append
- (if (dns-header-aa record) "AA, " "")
- (if (dns-header-tc record) "TC, " "")
- (if (dns-header-rd record) "RD, " "")
- (if (dns-header-ra record) "RA, " ""))
- (dns-header-qdcount record)
- (dns-header-ancount record)
- (dns-header-nscount record)
- (dns-header-arcount record))))
-
-
-#;
-(define* (make-dns-header*
- key:
- (id 0)
- qr
- (opcode 0) ; TODO symbols for this
- aa
- tc
- rd
- ra
- (z 0)
- (rcode 0)
- (qdcount 0)
- (ancount 0)
- (nscount 0)
- (arcount 0))
- (make-dns-header id qr opcode aa tc rd ra z rcode
- qdcount ancount nscount arcount))
-
-
-(define (encode-dns-header-flags msg)
- (logior
- (if (qr msg) (ash 1 15) 0)
- (cond ((opcode msg) => (lambda (op) (ash (opcode->int op) 11))) (else 0))
- (if (aa msg) (ash 1 10) 0)
- (if (tc msg) (ash 1 9) 0)
- (if (rd msg) (ash 1 8) 0)
- (if (ra msg) (ash 1 7) 0)
- (cond ((z msg) => (lambda (z) (ash z 4))) (else 0))
- (cond ((rcode msg) => rcode->int) (else 0))))
-
-(define (decode-dns-header-flags u16)
- (define (byte x)
- (not (zero? (logand u16 (ash 1 x)))))
- (list
- (byte 15)
- (logand #xF (ash u16 -11))
- (byte 10)
- (byte 9)
- (byte 8)
- (byte 7)
- (logand 7 (ash u16 -4))
- (logand #xF u16)))
-
-(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) (endianness little))
- (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)
-
-(define (bytes->dns-header bv)
- (do
- id <- (u16 bv)
- flags <- (<$> decode-dns-header-flags (u16 bv))
- qd <- (u16 bv)
- an <- (u16 bv)
- ns <- (u16 bv)
- ar <- (u16 bv)
- ;; TODO
- (return (make-dns-header
- id: id
- qr: (list-ref flags 0)
- opcode: (int->opcode (list-ref flags 1))
- aa: (list-ref flags 2)
- tc: (list-ref flags 3)
- rd: (list-ref flags 4)
- ra: (list-ref flags 5)
- z: (list-ref flags 6)
- rcode: (int->rcode (list-ref flags 7))
- qdcount: qd
- ancount: an
- nscount: ns
- arcount: ar))))
-
-(define (string-list->labels lst*)
- (define trans (native-transcoder))
- (define lst
- (let ((last (last-pair lst*)))
- (cond ((null? last) '(""))
- ((string-null? (car last)) lst*)
- (else (append lst* '(""))))))
- (call-with-values (lambda () (open-bytevector-output-port))
- (lambda (port get-bytevector)
- (for-each (lambda (s)
- (define bv (string->bytevector s trans))
- (put-u8 port (bytevector-length bv))
- (put-bytevector port bv))
- lst)
- (get-bytevector))))
-
-(define (label-pointer? byte)
- (= 3 (ash byte -6)))
-
-(define (labels->string-list bv)
- (do len <- (u8 bv)
- (cond ((label-pointer? len)
- (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)))
- ((zero? len) (return '()))
- (else
- (do
- this <- (bv-get bv len)
- rest <- (labels->string-list bv)
- (return
- (cons (bytevector->string this (native-transcoder))
- rest)))))))
-
-#;
-(set-record-type-printer!
- dns-question
- (lambda (record port)
- (format port "<dns-question name: ~s, type: ~a, class: ~a>"
- (dns-question-name record)
- (dns-question-type record)
- (dns-question-class record))))
-
-(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)
-
-(define (bytes->dns-question bv)
- (do
- name <- (labels->string-list bv)
- type <- (<$> int->rr (u16 bv))
- class <- (<$> int->class (u16 bv))
- (return (make-dns-question name: (string-join name ".") type: type class: class))))
-
-(define-record-type dns-rr-data
- (fields name type (class default: 'IN) ttl rdata))
-
-#;
-(set-record-type-printer!
- dns-rr-data
- (lambda (record port)
- (format port "#<dns-rr-data name: ~s, type: ~a, class: ~a, ttl: ~a, rdata: ~s>"
- (dns-rr-data-name record)
- (dns-rr-data-type record)
- (dns-rr-data-class record)
- (dns-rr-data-ttl record)
- ;; TODO interpret dependin on type
- (dns-rr-data-rdata record))))
-
-;; (define (dns-rr-data->bytes data)
-;; (string-list->labels (dns-rr-data-name data))
-;; (rr->int (dns-rr-data-type rr))
-;; 1 ; class = IN
-;; u
-;; )
-
-(define (domain-join lst)
- (string-join lst "."))
-
-(define (bytes->rr-data bv)
- (do
- name <- (<$> domain-join (labels->string-list bv))
- type <- (<$> int->rr (u16 bv))
- class <- (<$> int->class (u16 bv))
- ttl <- (u32 bv)
- rdlength <- (u16 bv)
- rdata <- (case type
- ((A) (<$> (lambda (n) (inet-ntop AF_INET n)) (u32 bv)))
- ((AAAA) (<$> (lambda (n) (inet-ntop AF_INET6 n))
- (uint-get bv rdlength)))
- ((NS CNAME PTR TXT) (do labels <- (labels->string-list bv)
- (return (string-join labels "."))))
- ((SOA)
- (do
- mname <- (<$> domain-join (labels->string-list bv))
- rname <- (<$> domain-join (labels->string-list bv))
- serial <- (u32 bv)
- refresh <- (u32 bv)
- retry <- (u32 bv)
- expire <- (u32 bv)
- nttl <- (u32 bv)
- (return (list mname rname serial refresh retry expire nttl))))
- ((HINFO)
- ;; TODO replace with lift
- (do
- cpu <- (<$> domain-join (labels->string-list bv))
- os <- (<$> domain-join (labels->string-list bv))
- (return (list cpu os))))
- ((MX)
- (do
- priority <- (u16 bv)
- exchange <- (<$> domain-join (labels->string-list bv))
- (return (list priority exchange))))
- (else (bv-get bv rdlength)))
- (return (make-dns-rr-data name: name type: type class: class
- ttl: ttl rdata: rdata))))
-
-(define-record-type dns-message
- (fields header
- (questions default: '())
- (answers default: '())
- (authorities default: '())
- (additionals default: '())))
-
-#;
-(set-record-type-printer!
- dns-message
- (lambda (record port)
- (format port "#<dns-message header: ~s, qs: ~s, an: ~s, ns: ~s, ar: ~s> "
- (dns-message-header record)
- (dns-message-questions record)
- (dns-message-answers record)
- (dns-message-authorities record)
- (dns-message-additionals record)
- )))
-
-(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)
-
-(define (bytes->dns-message bv)
- (do
- header <- (bytes->dns-header bv)
- qs <- (sequence
- (repeat (qdcount header)
- (bytes->dns-question bv)))
- an <- (sequence
- (repeat (ancount header)
- (bytes->rr-data bv)))
- ns <- (sequence
- (repeat (nscount header)
- (bytes->rr-data bv)))
- ar <- (sequence
- (repeat (arcount header)
- (bytes->rr-data bv)))
- (return (make-dns-message header: header questions: qs answers: an
- authorities: ns additionals: ar))))
-
-
-(define serial-id 100)
-
-(define (sample-message)
- (make-dns-message
- header: (make-dns-header id: serial-id rd: #f qdcount: 1)
- questions: (list (make-dns-question name: "www.lysator.liu.se." type: 'A))))
-
-(define (setup-sock addr)
- (define ai (car (getaddrinfo addr "domain" 0 0 SOCK_DGRAM)))
- (define sock (socket (addrinfo:fam ai)
- (addrinfo:socktype ai)
- (addrinfo:protocol ai)))
- (connect sock (addrinfo:addr ai))
- sock)
-
-(define (run addr msg)
- (define sock (setup-sock addr))
- (define resp (make-bytevector 512))
- (send sock (dns-message->bytes msg))
- (recv! sock resp)
- resp)
-
-;; (define (format-bytevector bv)
-;; (format #f "~{~2,'0x~^ ~}" (bytevector->u8-list bv)))
-
-;; (define (format-question record)
-;; (format #t "; ~s ~a ~a~%"
-;; (dns-question-name record)
-;; (dns-question-type record)
-;; (dns-question-class record)
-
-;; ))
-
-;; (define (format-rr record)
-;; (format #t "~s ~a ~a ~a ~a~%"
-;; (dns-rr-data-name record)
-;; (dns-rr-data-ttl record)
-;; (dns-rr-data-class record)
-;; (dns-rr-data-type record)
-;; ;; TODO interpret dependin on type
-;; (dns-rr-data-rdata record)))
-
-;; (define (format-dns-message msg)
-;; ;; (define head (dns-message-header msg))
-;; (format #t ";; Questions~%")
-;; (for-each format-question (dns-message-questions msg))
-;; (format #t ";; Answers~%")
-;; (for-each format-rr (dns-message-answers msg))
-;; (format #t ";; Authorities~%")
-;; (for-each format-rr (dns-message-authorities msg))
-;; (format #t ";; Additionals~%")
-;; (for-each format-rr (dns-message-additionals msg)))
-
-
-;; https://datatracker.ietf.org/doc/html/draft-bortzmeyer-dns-json
-;; for dns->json mapping
-
-(use-modules (ice-9 match)
- (ice-9 getopt-long))
-
-(define option-spec
- '((server (value #t))
- (recurse (value #f))
- (norecurse (value #f))))
-
-(define-public (main args)
- (define options (getopt-long args option-spec
- stop-at-first-non-option: #f))
- (define msg
- (let loop ((rest (option-ref options '() '())))
- (match rest
- ((record type)
- (make-dns-message
- header: (make-dns-header id: serial-id rd: #f qdcount: 1)
- questions: (list (make-dns-question name: record
- type: (string->symbol type)))))
- ((record) (loop (list record "A")))
- (() (exit 1)))))
- (define addr
- (or (option-ref options 'server #f)
- (car ((@ (resolvconf) resolvconf)))))
- ((@ (ice-9 format) format) #t "~y" (serialize msg))
- ((@ (ice-9 format) format) #t "~y"
- (serialize
- (call-with-values (lambda () ((bytes->dns-message (run addr msg)) 0))
- (lambda (resp _) resp)))))
+ :use-module (dns util)
+ :use-module (dns internal object)
+ :use-module (dns internal util)
+ :use-module (dns internal state-monad)
+ :use-module (dns internal bv)
+ :use-module (dns enum)
+ :use-module (dns label)
+ :export ())
diff --git a/dns/enum.scm b/dns/enum.scm
new file mode 100644
index 0000000000000000000000000000000000000000..18ce9ec561e90a552e1981f51f228f1bdc6dae2c
--- /dev/null
+++ b/dns/enum.scm
@@ -0,0 +1,79 @@
+(define-module (dns enum)
+ :export (rr-types
+ int->rr rr->int
+ class-types
+ int->class class->int
+ rcode-types
+ int->rcode rcode->int
+ opcode-types
+ int->opcode opcode->int))
+
+(define (flip-cons c)
+ (cons (cdr c) (car c)))
+
+(define (make-mappings table)
+ (values
+ (lambda (i)
+ (cond ((assv i (map flip-cons table)) => cdr)
+ ((integer? i) (inexact->exact i))
+ (else (scm-error 'wrong-type-arg "int-><something>"
+ "Unknown value ~s, expected known integer or one of ~a"
+ (list i (map car table)) (list (map car table))))))
+
+ (lambda (value)
+ (cond ((integer? value) (inexact->exact value))
+ ((assv value table) => cdr)
+ (else (scm-error 'wrong-type-arg "<something>->int"
+ "Unknown value ~s"
+ (list value) #f))) )))
+
+(define rr-types
+ '((A . 1)
+ (NS . 2)
+ (MD . 3)
+ (MF . 4)
+ (CNAME . 5)
+ (SOA . 6)
+ (MB . 7)
+ (MG . 8)
+ (MR . 9)
+ (NULL . 10)
+ (WKS . 11)
+ (PTR . 12)
+ (HINFO . 13)
+ (MINFO . 14)
+ (MX . 15)
+ (TXT . 16)
+ ;; I don't know where this is specified
+ (AAAA . 28)))
+
+(define-values (int->rr rr->int)
+ (make-mappings rr-types))
+
+(define class-types
+ '((IN . 1)
+ (CS . 2)
+ (CH . 3)
+ (HS . 4)))
+
+(define-values (int->class class->int)
+ (make-mappings class-types))
+
+(define rcode-types
+ '((NOERROR . 0) ; no error condition
+ (NXDOMAIN . 1) ; format error - name server can't interpret
+ (SERVFAIL . 2) ; server failure
+ ;; 3 ; name error
+ ))
+
+(define-values (int->rcode rcode->int)
+ (make-mappings rcode-types))
+
+
+(define opcode-types
+ '((QUERY . 0)
+ (IQUERY . 1)
+ (STATUS . 2)))
+
+(define-values (int->opcode opcode->int)
+ (make-mappings opcode-types))
diff --git a/dns/internal/bv.scm b/dns/internal/bv.scm
new file mode 100644
index 0000000000000000000000000000000000000000..3de20a4db45e7ec909133209c3805bf69efbc2be
--- /dev/null
+++ b/dns/internal/bv.scm
@@ -0,0 +1,50 @@
+;;; Commentary:
+;;; These procedures uses our state monad to read bytes from a bytevector, while
+;;; keeping a seek pointer as the implicit explicit state.
+;;;
+;;; So all use the state as the offset into the vector, and "sets" the state to
+;;; the new offset after the read.
+;;; Code:
+
+(define-module (dns internal bv)
+ :use-module (ice-9 curried-definitions)
+ :use-module (dns internal state-monad)
+ :use-module (rnrs bytevectors)
+ :use-module (srfi srfi-88)
+ :export (u8 u16 u32 bv-get uint-get)
+ )
+
+
+;;; The procedures u8, u16, and u32 reads an unsigned integer of the respective
+;;; width from @var{bv}, and updates the seek pointer appropriately.
+
+
+(define ((u8 bv) ptr)
+ (values (bytevector-u8-ref bv ptr)
+ (1+ ptr)))
+
+;; Endianess is big by default for these, since we are working with network
+;; stuff.
+
+(define* ((u16 bv optional: (e (endianness big))) ptr)
+ (values (bytevector-u16-ref bv ptr e)
+ (+ ptr 2)))
+
+(define* ((u32 bv optional: (e (endianness big))) ptr)
+ (values (bytevector-u32-ref bv ptr e)
+ (+ ptr 4)))
+
+;; Copies @var{len} bytes from @var{bv}, and updates the seek pointer
+;; accordingly.
+(define ((bv-get bv len) ptr)
+ (define ret (make-bytevector len))
+ (bytevector-copy! bv ptr
+ ret 0
+ len)
+ (values ret (+ ptr len)))
+
+;; Reads an unsigned integer @var{len} octets wide, and updates the seek
+;; pointer accordingly
+(define (uint-get bv len)
+ (do vec <- (bv-get bv len)
+ (return (bytevector-uint-ref vec 0 (endianness big) len))))
diff --git a/object.scm b/dns/internal/object.scm
similarity index 70%
rename from object.scm
rename to dns/internal/object.scm
index e6885c8570560abf99a9528139c905c111d9d71d..3a1bc8700e0c92426489ca4bad4cbcb4b235f956 100644
--- a/object.scm
+++ b/dns/internal/object.scm
@@ -1,9 +1,23 @@
-(define-module (object)
+;;; Commentary:
+;;; Another definition of define-record-type.
+;;; Aims to be syntastically compatible with (rnrs records syntastic),
+;;; But instead declares the object as a GOOPS object,
+;;; creates a constructor which takes keyword arguments,
+;;; sets a propper write method,
+;;; and names all its getters directly be their fields
+;;; Code:
+
+(define-module (dns internal object)
:use-module (rnrs base)
:use-module (oop goops)
- :use-module (util)
- :export (define-record-type serialize))
+ :use-module (dns internal util)
+ :use-module (srfi srfi-88)
+ ;; Define-record-type exported and not #:replace:d, since we want a warning if
+ ;; multiple instances of it is imported at once.
+ :export (define-record-type))
+;;; Internal method ONLY used for `write'.
+(define-generic serialize)
(define-method (serialize (this <top>))
this)
@@ -19,9 +33,11 @@
(define-method (serialize (this <hashtable>))
(hash-map->list (lambda (key value)
- (cons key (serialize value)))
+ (list key (serialize value)))
this))
+;; Helper procedure for define-record-type macro, which if @var{stx} is a syntax
+;; object of a list takes the first argument of it, keeping it a syntax object
(define (unlist stx)
(if (list? (syntax->datum stx))
(->> stx syntax->datum car (datum->syntax stx))
@@ -71,6 +87,10 @@
(map unlist #'(field ...)))
(define-method (serialize (this name))
`(#,@(map (lambda (name)
- #`(#,name . ,(serialize (#,name this))))
+ #`(#,name ,(#,name this)))
(map unlist #'(field ...)))))
+ (define-method (write (this name) port)
+ ((@ (ice-9 format) format) port "#<~a~:{ ~a=~s~}>"
+ (class-name name)
+ (serialize this)))
))))))
diff --git a/util.scm b/dns/internal/state-monad.scm
similarity index 55%
rename from util.scm
rename to dns/internal/state-monad.scm
index f2c63071554d251586134dfcf0a6d5d2aebe5ce2..253c88821fb292b5aed0b40f0936834875c2639c 100644
--- a/util.scm
+++ b/dns/internal/state-monad.scm
@@ -1,36 +1,31 @@
-(define-module (util)
+;;; Commentary:
+;;; A state monad similar to (and directly influenced by) the one found in in
+;;; Haskell
+;;; Each procedure can either explicitly take the state as a curried last
+;;; argument, or use the `do' notation, which handles that implicitly.
+;;; Each procedure MUST return two values, where the second value is the state
+;;; value which will be chained.
+;;; Code:
+
+(define-module (dns internal state-monad)
:use-module (ice-9 curried-definitions)
:replace (do mod)
- :export (-> ->>
- <$> return get put
- sequence repeat flip))
-
-
-(define-syntax ->
- (syntax-rules ()
- [(-> obj) obj]
- [(-> obj (func args ...) rest ...)
- (-> (func obj args ...) rest ...)]
- [(-> obj func rest ...)
- (-> (func obj) rest ...)]))
-
-(define-syntax ->>
- (syntax-rules ()
- ((->> obj)
- obj)
- ((->> obj (func args ...) rest ...)
- (->> (func args ... obj) rest ...))
- ((->> obj func rest ...)
- (->> (func obj) rest ...))))
+ :export (<$> return get put sequence))
(define-syntax do
- (syntax-rules (<-)
+ (syntax-rules (<- let =)
((_ a <- b rest ...)
(lambda (ptr)
(call-with-values (lambda () (b ptr))
(lambda (a next-ptr)
((do rest ...)
next-ptr)))))
+ ;; let is unused in the actual code, and fails to expand in some circumstanses.
+ ;; See relevant tests.
+ #;
+ ((_ let a = b rest ...)
+ (let ((a b))
+ (do rest ...)))
((_ a)
(lambda (ptr) (a ptr)))
((_ a rest ...)
@@ -40,10 +35,9 @@
((do rest ...)
next-ptr)))))))
-
(define (<$> f y)
(do tmp <- y
- (return (f tmp))))
+ (return (f tmp))))
(define ((return x) y)
(values x y))
@@ -51,8 +45,8 @@
(define ((get) ptr)
(values ptr ptr))
-(define ((put ptr) _)
- (values #f ptr))
+(define ((put ptr) old-ptr)
+ (values old-ptr ptr))
(define (mod proc)
(do
@@ -68,10 +62,3 @@
rest <- (sequence (cdr ms))
(return (cons fst rest)))))
-(define (repeat times proc)
- (map (lambda _ proc)
- (iota times)))
-
-(define (flip f)
- (lambda args
- (apply f (reverse args))))
diff --git a/dns/internal/util.scm b/dns/internal/util.scm
new file mode 100644
index 0000000000000000000000000000000000000000..3daf0eef97cde176d82e931c86a66919293f1168
--- /dev/null
+++ b/dns/internal/util.scm
@@ -0,0 +1,29 @@
+(define-module (dns internal util)
+ :export (-> ->> repeat flip))
+
+(define-syntax ->
+ (syntax-rules ()
+ [(-> obj) obj]
+ [(-> obj (func args ...) rest ...)
+ (-> (func obj args ...) rest ...)]
+ [(-> obj func rest ...)
+ (-> (func obj) rest ...)]))
+
+(define-syntax ->>
+ (syntax-rules ()
+ ((->> obj)
+ obj)
+ ((->> obj (func args ...) rest ...)
+ (->> (func args ... obj) rest ...))
+ ((->> obj func rest ...)
+ (->> (func obj) rest ...))))
+
+
+
+(define (repeat times proc)
+ (map (lambda _ proc)
+ (iota times)))
+
+(define (flip f)
+ (lambda args
+ (apply f (reverse args))))
diff --git a/dns/label.scm b/dns/label.scm
new file mode 100644
index 0000000000000000000000000000000000000000..d1de47fcd8ef0005b66c6ae4fc99bcfadeb4b801
--- /dev/null
+++ b/dns/label.scm
@@ -0,0 +1,51 @@
+(define-module (dns label)
+ :use-module (rnrs io ports)
+ :use-module (dns internal util)
+ :use-module (dns internal state-monad)
+ :use-module (dns internal bv)
+ :use-module (rnrs bytevectors)
+ :export (string-list->labels labels->string-list
+ ))
+
+;; Encodes the scheme list of strings into a bytevector on the label format
+;; expected by the DNS wire protocol.
+(define (string-list->labels lst*)
+ (define trans (native-transcoder))
+ (define lst
+ (let ((last (last-pair lst*)))
+ (cond ((null? last) '(""))
+ ((string-null? (car last)) lst*)
+ (else (append lst* '(""))))))
+ (call-with-values (lambda () (open-bytevector-output-port))
+ (lambda (port get-bytevector)
+ (for-each (lambda (s)
+ (define bv (string->bytevector s trans))
+ (put-u8 port (bytevector-length bv))
+ (put-bytevector port bv))
+ lst)
+ (get-bytevector))))
+
+;; Is the byte starting this label a pointer somewhere else?
+(define (label-pointer? byte)
+ (= 3 (ash byte -6)))
+
+(define (labels->string-list bv)
+ (do len <- (u8 bv)
+ (cond ((label-pointer? len)
+ (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)))
+ ((zero? len) (return '()))
+ (else
+ (do
+ this <- (bv-get bv len)
+ rest <- (labels->string-list bv)
+ (return
+ (cons (bytevector->string this (native-transcoder))
+ rest)))))))
+
diff --git a/dns/types.scm b/dns/types.scm
new file mode 100644
index 0000000000000000000000000000000000000000..e8b9077e9822c4b01cc059c8e030b87549803a97
--- /dev/null
+++ b/dns/types.scm
@@ -0,0 +1,27 @@
+(define-module (dns types)
+ :use-module (oop goops)
+ :export (aa additionals ancount answers arcount authorities class header id name nscount opcode qdcount qr questions ra rcode rd rdata tc ttl type z))
+
+(define-generic aa)
+(define-generic additionals)
+(define-generic ancount)
+(define-generic answers)
+(define-generic arcount)
+(define-generic authorities)
+(define-generic class)
+(define-generic header)
+(define-generic id)
+(define-generic name)
+(define-generic nscount)
+(define-generic opcode)
+(define-generic qdcount)
+(define-generic qr)
+(define-generic questions)
+(define-generic ra)
+(define-generic rcode)
+(define-generic rd)
+(define-generic rdata)
+(define-generic tc)
+(define-generic ttl)
+(define-generic type)
+(define-generic z)
diff --git a/dns/types/header.scm b/dns/types/header.scm
new file mode 100644
index 0000000000000000000000000000000000000000..0e34b52f27a7cca232c31c2ba28da6149a5bd3d6
--- /dev/null
+++ b/dns/types/header.scm
@@ -0,0 +1,90 @@
+(define-module (dns types header)
+ :use-module (srfi srfi-88)
+ :use-module (rnrs bytevectors)
+ :use-module (dns internal util)
+ :use-module (dns internal state-monad)
+ :use-module (dns internal bv)
+ :use-module (dns internal object)
+ :use-module (dns enum)
+ :use-module (dns types)
+ :re-export (id qr opcode aa tc rd ra z rcode qdcount ancount nscount arcount)
+ :export (make-dns-header
+ dns-header?
+
+ dns-header->bytes
+ bytes->dns-header
+
+ encode-dns-header-flags
+ decode-dns-header-flags
+ ))
+
+
+(define-record-type dns-header
+ (fields (id default: 0) ; integer, 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)))
+
+
+(define (encode-dns-header-flags msg)
+ (logior
+ (if (qr msg) (ash 1 15) 0)
+ (cond ((opcode msg) => (lambda (op) (ash (opcode->int op) 11))) (else 0))
+ (if (aa msg) (ash 1 10) 0)
+ (if (tc msg) (ash 1 9) 0)
+ (if (rd msg) (ash 1 8) 0)
+ (if (ra msg) (ash 1 7) 0)
+ (cond ((z msg) => (lambda (z) (ash z 4))) (else 0))
+ (cond ((rcode msg) => rcode->int) (else 0))))
+
+(define (decode-dns-header-flags u16)
+ (define (byte x)
+ (not (zero? (logand u16 (ash 1 x)))))
+ (list
+ (byte 15) ; qr
+ (logand #xF (ash u16 -11)) ; opcode
+ (byte 10) ; aa
+ (byte 9) ; tc
+ (byte 8) ; rd
+ (byte 7) ; ra
+ (logand 7 (ash u16 -4)) ; z
+ (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)
+
+(define (bytes->dns-header bv)
+ (do
+ id <- (u16 bv)
+ flags <- (<$> decode-dns-header-flags (u16 bv))
+ qd <- (u16 bv)
+ an <- (u16 bv)
+ ns <- (u16 bv)
+ ar <- (u16 bv)
+ (return (make-dns-header
+ id: id
+ qr: (list-ref flags 0)
+ opcode: (int->opcode (list-ref flags 1))
+ aa: (list-ref flags 2)
+ tc: (list-ref flags 3)
+ rd: (list-ref flags 4)
+ ra: (list-ref flags 5)
+ z: (list-ref flags 6)
+ rcode: (int->rcode (list-ref flags 7))
+ qdcount: qd
+ ancount: an
+ nscount: ns
+ arcount: ar))))
diff --git a/dns/types/message.scm b/dns/types/message.scm
new file mode 100644
index 0000000000000000000000000000000000000000..ae4fb0a0bdf54c12ebd21e3d7c94061223cd572f
--- /dev/null
+++ b/dns/types/message.scm
@@ -0,0 +1,57 @@
+(define-module (dns types message)
+ :use-module (srfi srfi-88)
+ :use-module (rnrs lists)
+ :use-module (rnrs bytevectors)
+ :use-module (dns internal util)
+ :use-module (dns internal state-monad)
+ :use-module (dns internal bv)
+ :use-module (dns internal object)
+
+ :use-module (dns types)
+ :use-module (dns types header)
+ :use-module (dns types question)
+ :use-module (dns types rr)
+
+ :re-export (header questions answers authorities additionals)
+ :export (make-dns-message
+ dns-message?
+ bytes->dns-message dns-message->bytes
+ ))
+
+(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
+
+
+(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)
+
+(define (bytes->dns-message bv)
+ (do
+ header <- (bytes->dns-header bv)
+ qs <- (sequence
+ (repeat (qdcount header)
+ (bytes->dns-question bv)))
+ an <- (sequence
+ (repeat (ancount header)
+ (bytes->rr-data bv)))
+ ns <- (sequence
+ (repeat (nscount header)
+ (bytes->rr-data bv)))
+ ar <- (sequence
+ (repeat (arcount header)
+ (bytes->rr-data bv)))
+ (return (make-dns-message header: header questions: qs answers: an
+ authorities: ns additionals: ar))))
diff --git a/dns/types/question.scm b/dns/types/question.scm
new file mode 100644
index 0000000000000000000000000000000000000000..83af6be68ced8b03aa01ab74b5ac15022a31bbe9
--- /dev/null
+++ b/dns/types/question.scm
@@ -0,0 +1,45 @@
+(define-module (dns types question)
+ :use-module (srfi srfi-88)
+ :use-module (rnrs bytevectors)
+ :use-module (dns internal util)
+ :use-module (dns internal state-monad)
+ :use-module (dns internal bv)
+ :use-module (dns internal object)
+ :use-module (dns label)
+ :use-module (dns enum)
+ :use-module (dns types)
+ :use-module (dns types rr)
+ :re-export (name type class)
+ :export (make-dns-question
+ dns-question?
+
+ dns-question->bytes
+ bytes->dns-question
+ ))
+
+
+(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)
+
+(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)
+
+(define (bytes->dns-question bv)
+ (do
+ name <- (labels->string-list bv)
+ type <- (<$> int->rr (u16 bv))
+ class <- (<$> int->class (u16 bv))
+ (return (make-dns-question name: (string-join name ".") type: type class: class))))
diff --git a/dns/types/rr.scm b/dns/types/rr.scm
new file mode 100644
index 0000000000000000000000000000000000000000..ebabe136c97f5102528392f0152396b073bc8cce
--- /dev/null
+++ b/dns/types/rr.scm
@@ -0,0 +1,67 @@
+(define-module (dns types rr)
+ :use-module (srfi srfi-88)
+ :use-module (dns internal util)
+ :use-module (dns internal object)
+ :use-module (dns internal state-monad)
+ :use-module (dns internal bv)
+ :use-module (dns util)
+ :use-module (dns label)
+ :use-module (dns enum)
+ :use-module (dns types)
+ :re-export (name type class ttl rdata)
+ :export (make-dns-rr-data
+ dns-rr-data?
+ bytes->rr-data)
+ )
+
+(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
+
+
+;; (define (dns-rr-data->bytes data)
+;; (string-list->labels (dns-rr-data-name data))
+;; (rr->int (dns-rr-data-type rr))
+;; 1 ; class = IN
+;; u
+;; )
+
+(define (bytes->rr-data bv)
+ (do
+ name <- (<$> domain-join (labels->string-list bv))
+ type <- (<$> int->rr (u16 bv))
+ class <- (<$> int->class (u16 bv))
+ ttl <- (u32 bv)
+ rdlength <- (u16 bv)
+ rdata <- (case type
+ ((A) (<$> (lambda (n) (inet-ntop AF_INET n)) (u32 bv)))
+ ((AAAA) (<$> (lambda (n) (inet-ntop AF_INET6 n))
+ (uint-get bv rdlength)))
+ ((NS CNAME PTR TXT) (do labels <- (labels->string-list bv)
+ (return (string-join labels "."))))
+ ((SOA)
+ (do
+ mname <- (<$> domain-join (labels->string-list bv))
+ rname <- (<$> domain-join (labels->string-list bv))
+ serial <- (u32 bv)
+ refresh <- (u32 bv)
+ retry <- (u32 bv)
+ expire <- (u32 bv)
+ nttl <- (u32 bv)
+ (return (list mname rname serial refresh retry expire nttl))))
+ ((HINFO)
+ (do
+ cpu <- (<$> domain-join (labels->string-list bv))
+ os <- (<$> domain-join (labels->string-list bv))
+ (return (list cpu os))))
+ ((MX)
+ (do
+ priority <- (u16 bv)
+ exchange <- (<$> domain-join (labels->string-list bv))
+ (return (list priority exchange))))
+ (else (bv-get bv rdlength)))
+ (return (make-dns-rr-data name: name type: type class: class
+ ttl: ttl rdata: rdata))))
diff --git a/dns/util.scm b/dns/util.scm
new file mode 100644
index 0000000000000000000000000000000000000000..e3b85f3cd0c0832d6c36417b1068064386ee2e38
--- /dev/null
+++ b/dns/util.scm
@@ -0,0 +1,5 @@
+(define-module (dns util)
+ :export (domain-join))
+
+(define (domain-join lst)
+ (string-join lst "."))
diff --git a/doc/guile-dns.texi b/doc/guile-dns.texi
new file mode 100644
index 0000000000000000000000000000000000000000..790d24517c74f9c081661d9b8ec280ba18491c0e
--- /dev/null
+++ b/doc/guile-dns.texi
@@ -0,0 +1,190 @@
+\input texinfo
+@settitle Guile DNS
+
+@copying
+Copyright @copyright{} 2022 Hugo Hörnquist
+@end copying
+
+@dircategory The Algorithmic Language Scheme
+@direntry
+* Guile-DNS: (guile-dns). A DNS library for Guile
+@end direntry
+
+@titlepage
+@title Guile DNS
+@author Hugo Hörnquist
+
+@page
+@vskip 0pt plus 1filll
+@insertcopying
+@end titlepage
+
+@contents
+
+@ifnottex
+@node Top
+@top Guile DNS
+@end ifnottex
+
+@node Enumerations
+@chapter Enumerations
+
+@defvar rr-types
+Association list from RR-type symbols (such as @code{'A}, @code{'MX},
+and so on, to their numerical equivalents.
+@end defvar
+
+@defun int->rr int
+Translates integers into their respective RR-symbols. Or return the
+given integer if of an unknown type.
+@end defun
+
+@defun rr->int rr
+Translate a given RR symbol into an integer. If given an integer,
+return it directly.
+@end defun
+
+@defvar class-types
+@end defvar
+
+@defun int->class int
+@end defun
+
+@defun class->int class-symbol
+@end defun
+
+@defvar rcode-types
+@end defvar
+
+@defun int->rcode int
+@end defun
+
+@defun rcode->int rcode-symbol
+@end defun
+
+@defvar opcode-types
+@end defvar
+
+@defun int->opcode int
+@end defun
+
+@defun opcode->int opcode-symbol
+@end defun
+
+@node Types
+@chapter Types
+
+@defun make-dns-question #:name name #:type type [#:class='IN]
+@tindex dns-question
+
+@defun dns-question? x
+@end defun
+
+@defun name question
+@end defun
+
+@defun type question
+@end defun
+
+@defun class question
+@end defun
+@end defun
+
+@defun make-dns-header [#:id=0] [#:qr qr] [#:opcode='QUERY] [#:aa aa] [#:tc tc] [#:rd rd] [#:ra ra] [#:z=0] [#:rcode='NOERROR] [#:qdcount=0] [#:ancount=0] [#:nscount=0] [#:arcount=0]
+@tindex dns-header
+
+@defun dns-header? x
+@end defun
+
+@defun id header
+@end defun
+
+@defun qr header
+@end defun
+
+@defun opcode header
+@end defun
+
+@defun aa header
+@end defun
+
+@defun tc header
+@end defun
+
+@defun rd header
+@end defun
+
+@defun ra header
+@end defun
+
+@defun z header
+@end defun
+
+@defun rcode header
+@end defun
+
+@defun qdcount header
+@end defun
+
+@defun ancount header
+@end defun
+
+@defun nscount header
+@end defun
+
+@defun arcount header
+@end defun
+@end defun
+
+
+@defun make-dns-message #:header header-value [#:questions='()] [#:answers='()] [#:authorities='()] [#:additionals='()]
+@tindex dns-message
+Create a new DNS message, usable both as a question and a response.
+
+The header field must be a dns-header object @c TODO link
+which also must have the qdcount (and similar) set correctly by the user.
+
+All the remaining fields should be lists of dns-questions @c TODO
+@c link, and check if that is correct
+
+@defun dns-message? x
+@end defun
+
+
+@defun header msg
+@end defun
+
+@defun questions msg
+@end defun
+
+@defun answers msg
+@end defun
+
+@defun authorities msg
+@end defun
+
+@defun additionals msg
+@end defun
+
+@end defun
+
+
+
+
+@defun dns-message->bytes
+@end defun
+
+@defun bytes->dns-message
+@end defun
+
+
+@node Index
+@unnumbered Index
+@printindex cp
+@printindex fn
+@printindex ky
+@printindex pg
+@printindex tp
+@printindex vr
+
+@bye
diff --git a/main.scm b/main.scm
new file mode 100755
index 0000000000000000000000000000000000000000..fca586660d49ed6dec7f29d4686221e2b3bc2466
--- /dev/null
+++ b/main.scm
@@ -0,0 +1,116 @@
+#!/usr/bin/guile \
+-L . -e main -s
+!#
+
+(add-to-load-path (dirname (current-filename)))
+
+(use-modules (dns)
+
+ (dns types header)
+ (dns types message)
+ (dns types question)
+ (dns types rr)
+
+ (rnrs bytevectors)
+ (ice-9 match)
+ (ice-9 getopt-long)
+ (ice-9 format)
+ (texinfo string-utils))
+
+(define serial-id 100)
+
+(define (setup-sock addr)
+ (define ai (car (getaddrinfo addr "domain" 0 0 SOCK_DGRAM)))
+ (define sock (socket (addrinfo:fam ai)
+ (addrinfo:socktype ai)
+ (addrinfo:protocol ai)))
+ (connect sock (addrinfo:addr ai))
+ sock)
+
+(define (run addr msg)
+ (define sock (setup-sock addr))
+ (define resp (make-bytevector 512))
+ (send sock (dns-message->bytes msg))
+ (recv! sock resp)
+ resp)
+
+;; https://datatracker.ietf.org/doc/html/draft-bortzmeyer-dns-json
+;; for dns->json mapping
+
+(define option-spec
+ '((server (value #t))
+ ;; (recurse (value #f))
+ ;; (norecurse (value #f))
+ ))
+
+
+
+
+(define* (format-header header optional: (port #t))
+ (format port ";; ->>HEADER<<- opcode: ~a, status: ~a, id: ~a~%"
+ (opcode header) (rcode header) (id header))
+ (format port ";; flags:~{ ~a~}; QUERY: ~a, ANSWER: ~a, AUTHORITY: ~a, ADDITIONAL: ~a~%"
+ (list (if (aa header) 'aa "")
+ (if (tc header) 'tc "")
+ (if (rd header) 'rd "")
+ (if (ra header) 'ra ""))
+ (qdcount header)
+ (ancount header)
+ (nscount header)
+ (arcount header)))
+
+(define* (format-question question optional: (port (current-output-port)))
+ (display ";" port)
+ (display (left-justify-string (format #f "~a.~/" (name question)) 23) port)
+ (format port "~/~/~a~/~a~%"
+ (class question)
+ (type question)))
+
+(define* (format-record rr optional: (port (current-output-port)))
+ (display (left-justify-string (format #f "~a.~/" (name rr)) 24) port)
+ (format port "~a~/~a~/~a~/~a~%"
+ (ttl rr)
+ (class rr)
+ (type rr)
+ (rdata rr)))
+
+;; Both question and answer should me dns-message objects
+(define* (format-everything question answer optional: (port (current-output-port)))
+ (format-header (header question) port)
+ (format-header (header answer) port)
+ (format port "~%;; QUESTION SECTION:~%")
+ (for-each format-question (questions question))
+ (format port "~%;; ANSWER SECTION:~%")
+ (for-each format-record (answers answer))
+ (format port "~%;; AUTHORITY SECTION:~%")
+ (for-each format-record (authorities answer))
+ (format port "~%;; ADDITIONAL SECTION:~%")
+ (for-each format-record (additionals answer))
+ )
+
+
+
+(define (main args)
+ (define options (getopt-long args option-spec
+ stop-at-first-non-option: #f))
+ (define msg
+ (let loop ((rest (option-ref options '() '())))
+ (match rest
+ ((record type)
+ (make-dns-message
+ header: (make-dns-header id: serial-id rd: #t qdcount: 1)
+ questions: (list (make-dns-question name: record
+ type: (string->symbol type)))))
+ ((record) (loop (list record "A")))
+ (() (exit 1)))))
+
+ (define dns-server-address
+ (or (option-ref options 'server #f)
+ (car ((@ (resolvconf) resolvconf)))))
+
+ ;; (highlight-record (format #f "~s~%" msg))
+ (call-with-values (lambda () ((bytes->dns-message (run dns-server-address msg)) 0))
+ (lambda (resp _) (format-everything msg resp)))
+
+ (newline)
+ (format #t ";; Server: ~a (UDP)~%" dns-server-address))
diff --git a/run b/run
deleted file mode 100755
index d7641e8795a3459b85735efd644c574cb54dd29d..0000000000000000000000000000000000000000
--- a/run
+++ /dev/null
@@ -1,4 +0,0 @@
-#!/usr/bin/guile \
--L . -e main -s
-!#
-(define main (@ (dns) main))
diff --git a/run-tests.scm b/run-tests.scm
new file mode 100644
index 0000000000000000000000000000000000000000..86b61ed027957a8b803cd24afa555f0bcce93b34
--- /dev/null
+++ b/run-tests.scm
@@ -0,0 +1,112 @@
+#!/usr/bin/guile \
+--debug -e main -s
+!#
+
+(use-modules (srfi srfi-64)
+ (srfi srfi-71)
+ (ice-9 getopt-long)
+ (ice-9 format)
+ (ice-9 match)
+ (system vm coverage))
+
+(define (µs x)
+ (* x #e1e6))
+
+(define (transform-time-of-day tod)
+ (+ (* (µs 1) (car tod))
+ (cdr tod)))
+
+(define* (construct-test-runner #:key verbose?)
+ (lambda ()
+ (define runner (test-runner-null))
+ ;; end of individual test case
+ (test-runner-on-test-begin! runner
+ (lambda (runner)
+ (test-runner-aux-value! runner (transform-time-of-day (gettimeofday)))))
+ (test-runner-on-test-end! runner
+ (lambda (runner)
+ (case (test-result-kind runner)
+ ((pass) (display "\x1b[0;32mX\x1b[m"))
+ ((fail) (newline) (display "\x1b[0;31mE\x1b[m"))
+ ((xpass) (display "\x1b[0;33mX\x1b[m"))
+ ((xfail) (display "\x1b[0;33mE\x1b[m"))
+ ((skip) (display "\x1B[0;33m-\x1b[m")))
+ (when (or verbose? (eq? 'fail (test-result-kind)))
+ (format #t " ~a~%" (test-runner-test-name runner)))
+ (when (eq? 'fail (test-result-kind))
+ (cond ((test-result-ref runner 'actual-error)
+ => (match-lambda
+ ((err-type proc fmt args data)
+ (catch #t (lambda () (format #t "~a in ~a: ~?~%" err-type proc fmt args))
+ (lambda err-err
+ (format #t "~a~%" err-err)
+ (format #t "~s ~s ~s ~s ~s~%"
+ err-type proc fmt args data))))
+ (err (format #t "Error: ~s~%" err))))
+ (else
+ (format #t "Expected: ~s~%Received: ~s~%"
+ (test-result-ref runner 'expected-value "[UNKNOWN]")
+ (test-result-ref runner 'actual-value "[UNKNOWN]"))))
+ (format #t "Near ~a:~a~%~y"
+ (test-result-ref runner 'source-file)
+ (test-result-ref runner 'source-line)
+ (test-result-ref runner 'source-form)))
+
+ (let ((start (test-runner-aux-value runner))
+ (end (transform-time-of-day (gettimeofday))))
+ (when (< (µs 1) (- end start))
+ (format #t "~%Slow test: ~s, took ~a~%"
+ (test-runner-test-name runner)
+ (exact->inexact (/ (- end start) (µs 1)))
+ )))))
+
+ ;; on start of group
+ (test-runner-on-group-begin! runner
+ ;; count is number of #f
+ (lambda (runner name count)
+ (format #t "~a ~a ~a~%"
+ (make-string 10 #\=)
+ name
+ (make-string 10 #\=))))
+ (test-runner-on-group-end! runner
+ (lambda (runner) (newline)))
+ ;; after everything else is done
+ (test-runner-on-final! runner
+ (lambda (runner)
+ (format #t "Guile version ~a~%~%" (version))
+ (format #t "pass: ~a~%" (test-runner-pass-count runner))
+ (format #t "fail: ~a~%" (test-runner-fail-count runner))
+ (format #t "xpass: ~a~%" (test-runner-xpass-count runner))
+ (format #t "xfail: ~a~%" (test-runner-xfail-count runner))
+ ))
+
+ runner))
+
+
+
+(define (run-test-file test-file)
+ (format #t "Running test in ~a~%" test-file)
+ (load
+ (format #f "~a/tests/~a"
+ (dirname (current-filename))
+ test-file)))
+
+(define option-spec
+ '((verbose (single-char #\v) (value #f))
+ (coverage (value #t))))
+
+(define (main args)
+ (define options (getopt-long args option-spec))
+ (define verbose? (option-ref options 'verbose #f))
+ (define coverage-file )
+ (define tests (option-ref options '() '()))
+ (define run-tests (lambda () (for-each run-test-file tests)))
+ (test-runner-factory (construct-test-runner #:verbose? verbose?))
+ (test-begin "All Tests")
+ (cond ((option-ref options 'coverage #f)
+ => (lambda (file)
+ (let ((coverage _ (with-code-coverage run-tests)))
+ (call-with-output-file file
+ (lambda (port) (coverage-data->lcov coverage port))))))
+ (else (run-tests)))
+ (test-end))
diff --git a/tests/bv.scm b/tests/bv.scm
new file mode 100644
index 0000000000000000000000000000000000000000..1c6add822653d7299d268d9ac765620b6d16e39a
--- /dev/null
+++ b/tests/bv.scm
@@ -0,0 +1,46 @@
+(use-modules (srfi srfi-64)
+ (srfi srfi-1)
+ (rnrs bytevectors)
+ (rnrs io ports)
+ (dns internal bv))
+
+(test-begin "Bytevectors in state monad")
+
+
+(define bv (string->bytevector "Hello, World"
+ (make-transcoder (utf-8-codec))))
+
+
+;; Returns in `do' allow arbitrary code to be run for side effects
+;; order is guaranteed to be maintained, since each procedure in a
+;; state monad depends on the procedures before it.
+((do c1 <- (u8 bv)
+ (return (test-equal "Get first u8 from bv" (char->integer #\H) c1))
+ c2 <- (u8 bv)
+ (return (test-equal "Get second u8 from bv" (char->integer #\e) c2))
+ i <- (u16 bv)
+ (return (test-equal "Get u16 (endianess unspecified)"
+ (let ((l (char->integer #\l)))
+ (logior (ash l 8) l))
+ i))
+ j <- (u32 bv)
+ (return (test-equal "Get u32, and check that endianess is big"
+ (apply logior
+ (map ash (map char->integer (string->list "o, Wo"))
+ (reverse (iota 4 0 8))))
+ j))
+ (return #f))
+ 0)
+
+(test-equal "Bv-get"
+ #vu8(2 3)
+ ((bv-get #vu8(1 2 3 4) 2) 1))
+
+
+(test-equal "Uint-get"
+ #x010203 ((uint-get #vu8(1 2 3 4) 3) 0))
+(test-equal "Uint-get, with an offset"
+ #x020304 ((uint-get #vu8(1 2 3 4) 3) 1))
+
+
+(test-end)
diff --git a/tests/enum.scm b/tests/enum.scm
new file mode 100644
index 0000000000000000000000000000000000000000..abd19e1c01a71c0aa02f49ba59661d71d220dcfd
--- /dev/null
+++ b/tests/enum.scm
@@ -0,0 +1,34 @@
+(use-modules (srfi srfi-64)
+ (dns enum))
+
+;;; These tests claim to be testing rr->int, but is really testing make-mappings.
+;;; Explicit data could be checked, but a test for that would just be duplicating the data
+
+(test-assert "rr->int returns a number for a valid symbol" (integer? (rr->int 'A)))
+
+(let ((r (rr->int 10)))
+ (test-assert "rr->int returns an integer given an integer" (integer? r))
+ (test-assert "rr->int returns an exact integer given an exact integer" (exact? r)))
+
+(let ((r (rr->int 10.0)))
+ (test-assert "rr->int returns an integer given an inexact integer" (integer? r))
+ (test-assert "rr->int returns an exact integer an inexact integer" (exact? r)))
+
+(catch 'wrong-type-arg
+ (lambda ()
+ (rr->int 'INVALID-SYMBOL)
+ (test-assert "rr->int didn't fail on invalid symbol" #f))
+ (lambda _ (test-assert "rr->int fails on an unknown symbol" #t)))
+
+
+(test-equal "Int->rr returns a symbol for a known value" 'A (int->rr 1))
+(test-equal "Int->rr is effectivly `identity' for unknown integers" 100 (int->rr 100))
+(test-equal "Int->rr is effectivly `inexact->exact' for unknown inexact integers" 100 (int->rr 100.0))
+(catch 'wrong-type-arg
+ (lambda ()
+ (int->rr 27.5)
+ (test-assert "Int->rr didn't fail on invalid data" #f))
+ (lambda (err proc fmt args data)
+ (test-assert "Int->rr failed on invalid data" #t)
+ (test-assert "Int->rr returned a list of valid symbols as aux data upon failure"
+ (every symbol? (car data)))))
diff --git a/tests/header.scm b/tests/header.scm
new file mode 100644
index 0000000000000000000000000000000000000000..c4e9b4736d907468a1fead5834c6df52023404ad
--- /dev/null
+++ b/tests/header.scm
@@ -0,0 +1,12 @@
+(use-modules (srfi srfi-64)
+ (srfi srfi-88)
+ (dns types header))
+
+(test-equal 256 (encode-dns-header-flags (make-dns-header rd: #t)))
+
+(test-equal '(#f 0 #f #f #t #f 0 0)
+ (decode-dns-header-flags 256))
+
+;; TODO more tests here
+;;
+;; TODO also test all the something->bytevector and back procedures
diff --git a/tests/label.scm b/tests/label.scm
new file mode 100644
index 0000000000000000000000000000000000000000..490b24995f1ccadfb1efbf5046c35d00490908d9
--- /dev/null
+++ b/tests/label.scm
@@ -0,0 +1,46 @@
+(use-modules (srfi srfi-64)
+ (rnrs io ports)
+ (dns label))
+
+(define codec (make-transcoder (latin-1-codec)))
+
+(test-begin "DNS labels")
+
+(test-equal "Empty list to null label"
+ #vu8(0)
+ (string-list->labels '()))
+
+(test-equal "Empty label set gives empty list"
+ '() ((labels->string-list #vu8(0)) 0))
+
+(let* ((bv (string->bytevector "\x05Hello\0" codec)))
+ (test-equal "Single string to label"
+ bv (string-list->labels (list "Hello")))
+ (test-equal "Single label to strirng"
+ '("Hello")
+ ((labels->string-list bv) 0)))
+
+(let* ((bv (string->bytevector "\x05Hello\x04Test\0" codec)))
+ (test-equal "Actual list to labels"
+ bv (string-list->labels (list "Hello" "Test")))
+ (test-equal "Multiple labels to list"
+ '("Hello" "Test")
+ ((labels->string-list bv) 0)))
+
+(let* ((bv (string->bytevector "\x05Hello\x05Hello\x05Hello\0" codec)))
+ (test-equal "Test that pointers are still not implented"
+ bv (string-list->labels (list "Hello" "Hello" "Hello"))))
+
+(let* ((bv (string->bytevector "\xC0\x02\x05Hello\0" codec)))
+ (test-equal "Test simple label pointer"
+ '("Hello")
+ ((labels->string-list bv) 0)))
+
+(let* ((bv (string->bytevector "\x05Hello\0\xC0\x00" codec)))
+ (test-equal "Test pointer to label before start."
+ '("Hello")
+ ((labels->string-list bv)
+ 7 ; Index of \xC0
+ )))
+
+(test-end)
diff --git a/tests/state.scm b/tests/state.scm
new file mode 100644
index 0000000000000000000000000000000000000000..a29bf0bda0142f1c5b684c6b7556db6d51da4b8f
--- /dev/null
+++ b/tests/state.scm
@@ -0,0 +1,83 @@
+(use-modules (srfi srfi-64)
+ (dns internal state-monad))
+
+(test-begin "State Monad")
+
+(call-with-values (lambda () ((return 1) 2))
+ (lambda (value state)
+ (test-equal "Return returns the value unmodified" 1 value)
+ (test-equal "Return also returns the state as a second value" 2 state)))
+
+(test-equal "Get returns the current state as primary value, while kepping the state"
+ '(state state)
+ (call-with-values (lambda () ((get) 'state)) list))
+
+;; Return value of put untested, since it's undefined
+(test-equal "Put replaces the old state with a new one, and return old one"
+ '(old-state new-state)
+ (call-with-values (lambda () ((put 'new-state) 'old-state))
+ list))
+
+(test-equal "A simple do is effectively a `values' call"
+ '(value initial-state)
+ (call-with-values (lambda () ((do (return 'value)) 'initial-state))
+ list))
+
+;; Something with the let "statement" in the do notation causes the macro
+;; expander to fail with the following error in some cases:
+
+;; $ env GUILE_AUTO_COMPILE=1 GUILE_LOAD_PATH=/home/hugo/code/guile-dns guile -e main -s run-tests.scm --coverage coverage.info state.scm bv.scm label.scm
+;; ice-9/psyntax.scm:1585:32: In procedure expand-macro:
+;; Syntax error:
+;; tests/state.scm:28:31: source expression failed to match any pattern in form (let ptr)
+
+#;
+(test-equal "Let statement in do"
+ '(10 state)
+ (call-with-values (lambda () ((do let x = 10
+ (return x))
+ 'state))
+ list))
+
+
+(test-equal "Set and get through do, along with <- in do."
+ '(5 1)
+ (call-with-values (lambda () ((do old <- (get)
+ (put (1+ old))
+ (return 5))
+ 0))
+ list))
+
+
+
+(test-equal "<$> Updates stuff before being removed from the monad context"
+ '(11 10)
+ (call-with-values (lambda ()
+ ((do x <- (<$> 1+ (get))
+ (return x))
+ 10))
+ list))
+
+(test-equal "Sequence should update the state accordingly"
+ 3
+ (call-with-values
+ (lambda ()
+ ((sequence
+ (list (mod 1+)
+ (mod 1+)
+ (mod 1+)))
+ 0))
+ (lambda (_ st) st)))
+
+(test-equal "Sequence should also act as map on the primary value"
+ '((0 1 2) 3)
+ (call-with-values
+ (lambda ()
+ ((sequence
+ (list (mod 1+)
+ (mod 1+)
+ (mod 1+)))
+ 0))
+ list))
+
+(test-end "State Monad")