[bug#28055] [WIP] Add knot tests

[bug#28055] [WIP] Add knot tests

[Julien Lepiller]

[-- Attachment #1: Type: text/plain, Size: 356 bytes --]

Hi,

This patch aims at adding a system test for knot. I've implemented the
DNS protocol to be able to communicate with the server and try some
queries. Unfortunately, although the server seems to be launched (the
first test passes), it then refuses to answer. Do you see anything
wrong, or anything I could do to understand why it doesn't pass?

Thanks :)

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-gnu-tests-Add-dns-test.patch --]
[-- Type: text/x-patch, Size: 14892 bytes --]

From 71daf1a3baac37fe079e0fc282ce5447b8fbb140 Mon Sep 17 00:00:00 2001
From: Julien Lepiller <julien@lepiller.eu>
Date: Sun, 18 Jun 2017 09:53:00 +0200
Subject: [PATCH] gnu: tests: Add dns test.

* gnu/tests/dns.scm: New file.
* gnu/local.mk: Add it.
---
 gnu/local.mk      |   1 +
 gnu/tests/dns.scm | 326 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 327 insertions(+)
 create mode 100644 gnu/tests/dns.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index b1ff72d6a..f787b29de 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -484,6 +484,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/tests/base.scm				\
   %D%/tests/databases.scm			\
   %D%/tests/dict.scm				\
+  %D%/tests/dns.scm				\
   %D%/tests/nfs.scm				\
   %D%/tests/install.scm				\
   %D%/tests/mail.scm				\
diff --git a/gnu/tests/dns.scm b/gnu/tests/dns.scm
new file mode 100644
index 000000000..7782cfcea
--- /dev/null
+++ b/gnu/tests/dns.scm
@@ -0,0 +1,326 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Julien Lepiller <julien@lepiller.eu>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu tests dns)
+  #:use-module (gnu tests)
+  #:use-module (gnu system)
+  #:use-module (gnu system vm)
+  #:use-module (gnu services)
+  #:use-module (gnu services dns)
+  #:use-module (gnu services networking)
+  #:use-module (guix gexp)
+  #:use-module (guix store)
+  #:use-module (ice-9 ftw)
+  #:export (%test-knot))
+
+(define %ip4-addr
+;; a random IPv4 address
+  "136.12.251.84")
+
+(define-zone-entries %test-entries
+;; Test entries, with no real data
+;; Name TTL Class Type Data
+  ("@"  ""  "IN"  "A"  "1.2.3.4")
+  ("@"  ""  "IN"  "MX" "10 mail")
+  ("mail" "" "IN" "A"  %ip4-addr))
+
+(define %test-zone
+;; A test zone that uses the fake data
+  (knot-zone-configuration
+    (domain "guix-test.org")
+    (zone (zone-file
+            (origin "guix-test.org")
+            (entries %test-entries)))))
+
+(define %knot-zones
+  (list %test-zone))
+
+(define %knot-os
+  (simple-operating-system
+   (dhcp-client-service)
+   (service knot-service-type
+            (knot-configuration
+              (zones %knot-zones)))))
+
+(define (run-knot-test)
+  "Return a test of an OS running Knot service."
+  (define vm
+    (virtual-machine
+     (operating-system (marionette-operating-system
+                        %knot-os
+                        #:imported-modules '((gnu services herd))))
+     (port-forwardings '((1053 . 53)))))
+
+  (define test
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (rnrs base)
+                       (srfi srfi-9)
+                       (srfi srfi-64)
+                       (ice-9 binary-ports)
+                       (ice-9 iconv)
+                       (ice-9 match)
+                       (ice-9 rdelim)
+                       (ice-9 regex)
+                       (rnrs bytevectors)
+                       (rnrs arithmetic bitwise)
+                       (gnu build marionette))
+
+          (define marionette
+            (make-marionette '(#$vm)))
+
+          (define (qtype-num type)
+            (match type
+              ("A" 1)
+              ("AAAA" 28)))
+
+          (define (type->string type)
+            (match type
+              (1 "A")
+              (28 "AAAA")))
+
+          (define (make-request type domain)
+            (let* ((size (+ 2 ;TCP needs two bytes for the size before the header
+                            12 ;Header
+                            (string-length domain)
+                            2 ;size of the domain + first component and zero
+                            2 ;QTYPE
+                            2)) ;QCLASS
+                   (bv (make-bytevector size)))
+              (bytevector-u16-set! bv 0 (- size 2) (endianness big))
+              ;; Header
+              (bytevector-u16-set! bv 2 15326 (endianness big))
+              (bytevector-u16-set! bv 4 256 (endianness big))
+              (bytevector-u16-set! bv 6 1 (endianness big))
+              (bytevector-u16-set! bv 8 0 (endianness big))
+              (bytevector-u16-set! bv 10 0 (endianness big))
+              (bytevector-u16-set! bv 12 0 (endianness big))
+              (let ((pos (write-domain bv (string-split domain #\.) 14)))
+                (bytevector-u16-set! bv pos (qtype-num type) (endianness big))
+                (bytevector-u16-set! bv (+ pos 2) 1 (endianness big)))
+              bv))
+
+          (define (write-domain bv components pos)
+            "Updates @var{bv} starting at @var{pos} with the @var{components}.
+The DNS protocol specifies that each component is preceded by a byte containing
+the size of the component, and the last component is followed by the nul byte.
+We do not implement the compression algorithm in the query."
+            (match components
+              ('()
+               (begin
+                 (bytevector-u8-set! bv pos 0)
+                 (+ pos 1)))
+              ((component rest ...)
+               (begin
+                 (bytevector-u8-set! bv pos (string-length component))
+                 (bytevector-copy! (string->bytevector component "UTF-8") 0
+                                   bv (+ pos 1) (string-length component))
+                 (write-domain bv rest (+ pos (string-length component) 1))))))
+
+          ;(inet-pton AF_INET host)
+          (define (run-query host port type domain)
+            (let* ((request (make-request type domain))
+                   (dns (socket AF_INET SOCK_STREAM 0))
+                   (addr (make-socket-address AF_INET host port)))
+              (connect dns addr)
+              (put-bytevector dns request)
+              (get-bytevector-n dns 500)))
+
+          (define-record-type <dns-query>
+            (make-dns-query flags queries answers nameservers additionals)
+            dns-query?
+            (flags dns-query-flags)
+            (queries dns-query-queries)
+            (answers dns-query-answers)
+            (nameservers dns-query-nameservers)
+            (additionals dns-query-additionals))
+
+          (define-record-type <query>
+            (make-query name type class)
+            query?
+            (name query-name)
+            (type query-type)
+            (class query-class))
+
+          (define-record-type <dns-record>
+            (make-dns-record name type class ttl rdata)
+            dns-record?
+            (name dns-record-name)
+            (type dns-record-type)
+            (class dns-record-class)
+            (ttl dns-record-ttl)
+            (rdata dns-record-rdata))
+
+          (define (make-pos-val pos val)
+            (cons pos val))
+          (define (get-pos m)
+            (car m))
+          (define (get-val m)
+            (cdr m))
+
+          (define (decode-domain bv pos)
+            (let* ((component-size (bytevector-u8-ref bv pos))
+                   (vect (make-bytevector component-size)))
+              (if (eq? component-size 0)
+                  (make-pos-val (+ pos 1) "")
+                  (begin
+                    (if (eq? (bitwise-and 192 component-size) 0)
+                        (begin
+                          (bytevector-copy! bv (+ pos 1)
+                                            vect 0 component-size)
+                          (let ((rest (decode-domain bv (+ pos 1 component-size))))
+                            (make-pos-val (get-pos rest)
+                              (string-append (bytevector->string vect "UTF-8") "."
+                                           (get-val rest)))))
+                        (let ((pointer (bitwise-and
+                                         (bytevector-u16-ref bv pos (endianness big))
+                                         (- 65535 (* 256 192)))))
+                          (make-pos-val (+ pos 2)
+                            (get-val (decode-domain bv (+ 2 pointer))))))))))
+
+          (define (decode-query count bv pos)
+            (if (> count 0)
+                (let* ((result (decode-domain bv pos))
+                       (domain (get-val result))
+                       (npos (get-pos result))
+                       (qtype (bytevector-u16-ref bv npos (endianness big)))
+                       (qclass (bytevector-u16-ref bv (+ npos 2) (endianness big)))
+                       (q (decode-query (- count 1) bv (+ npos 4))))
+                  (make-pos-val (get-pos q)
+                    (cons (make-query domain qtype qclass) (get-val q))))
+                (make-pos-val pos '())))
+
+          (define (decode-ans count bv pos)
+            (if (> count 0)
+                (let* ((result (decode-domain bv pos))
+                       (domain (get-val result))
+                       (npos (get-pos result))
+                       (type (bytevector-u16-ref bv npos (endianness big)))
+                       (class (bytevector-u16-ref bv (+ npos 2) (endianness big)))
+                       (ttl (bytevector-u32-ref bv (+ npos 4) (endianness big)))
+                       (rdlength (bytevector-u16-ref bv (+ npos 8) (endianness big)))
+                       (data (make-bytevector rdlength))
+                       (q (decode-ans (- count 1) bv (+ npos 10 rdlength))))
+                  (bytevector-copy! bv (+ npos 10)
+                                    data 0 rdlength)
+                  (make-pos-val (get-pos q)
+                    (cons (make-dns-record domain type class ttl data) (get-val q))))
+                (make-pos-val pos '())))
+
+          (define (analyze-answer bv)
+            (let* ((len (bytevector-u16-ref bv 0 (endianness big)))
+                   (ans-id (bytevector-u16-ref bv 2 (endianness big)))
+                   (h1 (bytevector-u8-ref bv 4))
+                   (h2 (bytevector-u8-ref bv 5))
+                   (rcode (bitwise-and h2 15))
+                   (qdcount (bytevector-u16-ref bv 6 (endianness big)))
+                   (ancount (bytevector-u16-ref bv 8 (endianness big)))
+                   (nscount (bytevector-u16-ref bv 10 (endianness big)))
+                   (arcount (bytevector-u16-ref bv 12 (endianness big)))
+                   (pos 14)
+                   (query-result (decode-query qdcount bv pos))
+                   (answer-result (decode-ans ancount bv (get-pos query-result)))
+                   (nameserver-result (decode-ans nscount bv pos))
+                   (additional-result (decode-ans arcount bv pos)))
+              (make-dns-query
+                (append (if (eq? 0 (bitwise-and h1 4)) '() '(AA))
+                        (if (eq? 0 (bitwise-and h1 2)) '() '(TC))
+                    (if (eq? 0 (bitwise-and h1 1)) '() '(RD))
+                    (if (eq? 0 (bitwise-and h2 128)) '() '(RA)))
+                (get-val query-result) (get-val answer-result)
+                (get-val nameserver-result) (get-val additional-result))))
+
+          (define (make-ipv4 bv pos)
+            (if (eq? (+ pos 1) (bytevector-length bv))
+                (number->string (bytevector-u8-ref bv pos))
+                (string-append
+                  (number->string (bytevector-u8-ref bv pos)) "."
+                  (make-ipv4 bv (+ pos 1)))))
+
+          (define (make-ipv6 bv pos)
+            (let ((component (with-output-to-string
+                               (lambda _
+                                 (format #t "~x"
+                                         (bytevector-u16-ref
+                                           bv pos (endianness big)))))))
+              (if (eq? (+ pos 1) (bytevector-length bv))
+                  component
+                  (string-append
+                    component ":" (make-ipv6 bv (+ pos 1))))))
+
+          (define (get-addr-v4 q)
+            (let ((bv (dns-record-rdata (car (dns-query-answers q)))))
+              (make-ipv4 bv 0)))
+
+          (define (get-addr-v6 q)
+            (let ((bv (dns-record-rdata (car (dns-query-answers q)))))
+              (make-ipv6 bv 0)))
+
+          (define (resolv host port type domain)
+            (let* ((ans (run-query host port type domain))
+                   (q (analyze-answer ans)))
+              (match type
+                ("A" (get-addr-v4 q))
+                ("AAAA" (get-addr-v6 q)))))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "knot")
+
+          (test-assert "service is running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (start-service 'knot)
+                #t)
+             marionette))
+
+          (test-eq "get the correct answer"
+            #$%ip4-addr
+            (begin
+              (format #t "test:\n")
+              (let* ((request (make-request "A" "mail.guix-test.org"))
+                     (dns (socket AF_INET SOCK_STREAM 0))
+                     (addr (make-socket-address AF_INET INADDR_LOOPBACK 1053)))
+                (display request)
+                (newline)
+                (connect dns addr)
+                (display request)
+                (newline)
+                (put-bytevector dns request)
+                (display request)
+                (newline)
+                (display (get-bytevector-n dns 500))
+                (newline))
+              (display (run-query INADDR_LOOPBACK 1053 "A" "mail.guix-test.org"))
+              (newline)
+              (display (resolv INADDR_LOOPBACK 1053 "A" "mail.guix-test.org"))
+              (newline)
+              (resolv INADDR_LOOPBACK 1053 "A" "mail.guix-test.org")))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "knot-test" test))
+
+(define %test-knot
+  (system-test
+   (name "knot")
+   (description "Send a DNS request to a running Knot server.")
+   (value (run-knot-test))))
-- 
2.14.1

[bug#28055] [WIP] Add knot tests

[Ricardo Wurmus]

Hi Julien,

> This patch aims at adding a system test for knot. I've implemented the
> DNS protocol to be able to communicate with the server and try some
> queries. Unfortunately, although the server seems to be launched (the
> first test passes), it then refuses to answer. Do you see anything
> wrong, or anything I could do to understand why it doesn't pass?

It looks like overkill to implement DNS queries with bytevectors from
the ground up.  Is there not an easier way to make a DNS test?

-- 
Ricardo

GPG: BCA6 89B6 3655 3801 C3C6  2150 197A 5888 235F ACAC
https://elephly.net

[bug#28055] [WIP] Add knot tests

[Julien Lepiller]

[-- Attachment #1: Type: text/plain, Size: 1214 bytes --]

Hm... I followed the example of mail.scm and implemented the protocol. I also thought a pure scheme implementation would be prefered. I didn't really think of anything else.

I guess I could use the host utility to query the test server. Or if I can change the default dns server, I could use hostent:addr-list that I have just found in the manual. That would be better I think.

I'll try these methods.

Le 16 août 2017 11:09:03 GMT+02:00, Ricardo Wurmus <rekado@elephly.net> a écrit :
>
>Hi Julien,
>
>> This patch aims at adding a system test for knot. I've implemented
>the
>> DNS protocol to be able to communicate with the server and try some
>> queries. Unfortunately, although the server seems to be launched (the
>> first test passes), it then refuses to answer. Do you see anything
>> wrong, or anything I could do to understand why it doesn't pass?
>
>It looks like overkill to implement DNS queries with bytevectors from
>the ground up.  Is there not an easier way to make a DNS test?
>
>-- 
>Ricardo
>
>GPG: BCA6 89B6 3655 3801 C3C6  2150 197A 5888 235F ACAC
>https://elephly.net

-- 
Envoyé de mon appareil Android avec Courriel K-9 Mail. Veuillez excuser ma brièveté.

[-- Attachment #2: Type: text/html, Size: 1549 bytes --]

[bug#28055] [WIP] Add knot tests

[Ludovic Courtès]

Howdy,

Ricardo Wurmus <rekado@elephly.net> skribis:

>> This patch aims at adding a system test for knot. I've implemented the
>> DNS protocol to be able to communicate with the server and try some
>> queries. Unfortunately, although the server seems to be launched (the
>> first test passes), it then refuses to answer. Do you see anything
>> wrong, or anything I could do to understand why it doesn't pass?
>
> It looks like overkill to implement DNS queries with bytevectors from
> the ground up.  Is there not an easier way to make a DNS test?

It’s a bit overkill indeed… but I like it.  :-)

Julien: could you move the DNS code to a new module, say (guix dns), and
then add the Knot test?

(So first patch adds (guix dns), second patch adds the test.)

In passing, for (guix dns) it would be nice if you could add docstrings
as you see fit, and attempt to use full words in identifiers (“address”
rather than “addr”, “resolve” rather than “resolv”, etc.¹).

This looks really nice, thanks for working on it!

Ludo’.

¹ https://www.gnu.org/software/guix/manual/html_node/Formatting-Code.html

[bug#28055] [WIP] Add knot tests

[Ludovic Courtès]

Julien,

Did you have a chance to look into that?

TIA,
Ludo’.

ludo@gnu.org (Ludovic Courtès) skribis:

> Howdy,
>
> Ricardo Wurmus <rekado@elephly.net> skribis:
>
>>> This patch aims at adding a system test for knot. I've implemented the
>>> DNS protocol to be able to communicate with the server and try some
>>> queries. Unfortunately, although the server seems to be launched (the
>>> first test passes), it then refuses to answer. Do you see anything
>>> wrong, or anything I could do to understand why it doesn't pass?
>>
>> It looks like overkill to implement DNS queries with bytevectors from
>> the ground up.  Is there not an easier way to make a DNS test?
>
> It’s a bit overkill indeed… but I like it.  :-)
>
> Julien: could you move the DNS code to a new module, say (guix dns), and
> then add the Knot test?
>
> (So first patch adds (guix dns), second patch adds the test.)
>
> In passing, for (guix dns) it would be nice if you could add docstrings
> as you see fit, and attempt to use full words in identifiers (“address”
> rather than “addr”, “resolve” rather than “resolv”, etc.¹).
>
> This looks really nice, thanks for working on it!
>
> Ludo’.
>
> ¹ https://www.gnu.org/software/guix/manual/html_node/Formatting-Code.html

[bug#28055] [WIP] Add knot tests

[Julien Lepiller]

[-- Attachment #1: Type: text/plain, Size: 275 bytes --]

Le Fri, 01 Dec 2017 11:23:53 +0100,
ludo@gnu.org (Ludovic Courtès) a écrit :

> Julien,
> 
> Did you have a chance to look into that?
> 
> TIA,
> Ludo’.
> 

Here is a new version. The tests still don't pass though. It can't send
the request to the server.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-guix-Add-DNS-implementation.patch --]
[-- Type: text/x-patch, Size: 15371 bytes --]

From ecc02fe8098d8763b95d2c71215a62e669f49568 Mon Sep 17 00:00:00 2001
From: Julien Lepiller <julien@lepiller.eu>
Date: Sat, 2 Dec 2017 10:51:18 +0100
Subject: [PATCH 1/2] guix: Add DNS implementation.

* guix/dns.scm: New file.
* Makefile.am: Add it.
---
 Makefile.am  |   1 +
 guix/dns.scm | 363 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 364 insertions(+)
 create mode 100644 guix/dns.scm

diff --git a/Makefile.am b/Makefile.am
index 24a803a21..1f325ca97 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -73,6 +73,7 @@ MODULES =					\
   guix/graph.scm				\
   guix/cache.scm				\
   guix/cve.scm					\
+  guix/dns.scm					\
   guix/workers.scm				\
   guix/zlib.scm					\
   guix/build-system.scm				\
diff --git a/guix/dns.scm b/guix/dns.scm
new file mode 100644
index 000000000..6eb17a7e0
--- /dev/null
+++ b/guix/dns.scm
@@ -0,0 +1,363 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Julien Lepiller <julien@lepiller.eu>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix dns)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 iconv)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs arithmetic bitwise)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:export (<dns-flags> make-dns-flags dns-flags?
+            dns-flags-response?
+            dns-flags-opcode
+            dns-flags-authoritative-answer?
+            dns-flags-truncation?
+            dns-flags-recursion-desired?
+            dns-flags-recursion-available?
+            dns-flags-rcode
+
+            <dns-query> make-dns-query dns-query?
+            dns-query-flags
+            dns-query-queries
+            dns-query-answers
+            dns-query-nameservers
+            dns-query-additionals
+
+            <query> make-query query?
+            query-name
+            query-type
+            query-class
+
+            <dns-record> make-dns-record dns-record?
+            dns-record-name
+            dns-record-type
+            dns-record-class
+            dns-record-ttl
+            dns-record-rdata
+
+            simple-a-query
+            dns-query->bytevector
+            bytevector->dns-query
+            bytevector->ipv4))
+
+;;; Commentary:
+;;;
+;;; This module provides a DNS implementation. This modules helps construct
+;;; valid DNS requests and analyze responses from servers.
+;;;
+;;; Code:
+
+(define-record-type <dns-flags>
+  (make-dns-flags response? opcode authoritative-answer? truncation?
+                  recursion-desired? recursion-available? rcode)
+  dns-flags?
+  (response? dns-flags-response?)
+  (opcode dns-flags-opcode)
+  (authoritative-answer? dns-flags-authoritative-answer?)
+  (truncation? dns-flags-truncation?)
+  (recursion-desired? dns-flags-recursion-desired?)
+  (recursion-available? dns-flags-recursion-available?)
+  (rcode dns-flags-rcode))
+
+(define-record-type <dns-query>
+  (make-dns-query flags queries answers nameservers additionals)
+  dns-query?
+  (flags dns-query-flags)
+  (queries dns-query-queries)
+  (answers dns-query-answers)
+  (nameservers dns-query-nameservers)
+  (additionals dns-query-additionals))
+
+(define-record-type <query>
+  (make-query name type class)
+  query?
+  (name query-name)
+  (type query-type)
+  (class query-class))
+
+(define-record-type <dns-record>
+  (make-dns-record name type class ttl rdata)
+  dns-record?
+  (name dns-record-name)
+  (type dns-record-type)
+  (class dns-record-class)
+  (ttl dns-record-ttl)
+  (rdata dns-record-rdata))
+
+(define-record-type <pos-value>
+  (make-pos-value pos value)
+  pos-value?
+  (pos pos-value-pos)
+  (value pos-value-value))
+
+;; query type from/to number
+
+(define (type->number type)
+  (match type
+    ("A" 1)
+    ("AAAA" 28)))
+
+(define (type->string type)
+  (match type
+    (1 "A")
+    (28 "AAAA")))
+
+(define (opcode->number opcode)
+  (match opcode
+    ("QUERY" 0)
+    ("IQUERY" 1)
+    ("STATUS" 2)))
+
+(define (opcode->string opcode)
+  (match opcode
+    (0 "QUERY")
+    (1 "IQUERY")
+    (2 "STATUS")))
+
+(define (rcode->number rcode)
+  (match rcode
+    ("NOERROR" 0)
+    ("FORMATERROR" 1)
+    ("SERVFAIL" 2)
+    ("NAMEERROR" 3)
+    ("NOTIMPLEMENTED" 4)
+    ("REFUSED" 5)))
+
+(define (rcode->string rcode)
+  (match rcode
+    (0 "NOERROR")
+    (1 "FORMATERROR")
+    (2 "SERVFAIL")
+    (3 "NAMEERROR")
+    (4 "NOTIMPLEMENTED")
+    (5 "REFUSED")))
+
+(define (class->number class)
+  (match class
+    ("IN" 1)
+    ("CS" 2)
+    ("CH" 3)
+    ("HS" 4)))
+
+(define (class->string class)
+  (match class
+    (1 "IN")
+    (2 "CS")
+    (3 "CH")
+    (4 "HS")))
+
+(define (write-domain bv components pos)
+  "Updates @var{bv} starting at @var{pos} with the @var{components}.
+The DNS protocol specifies that each component is preceded by a byte containing
+the size of the component, and the last component is followed by the nul byte.
+We do not implement the compression algorithm in the query."
+  (match components
+    ('()
+     (begin
+       (bytevector-u8-set! bv pos 0)
+       (+ pos 1)))
+    ((component rest ...)
+     (begin
+       (bytevector-u8-set! bv pos (string-length component))
+       (bytevector-copy! (string->bytevector component "UTF-8") 0
+                         bv (+ pos 1) (string-length component))
+       (write-domain bv rest (+ pos (string-length component) 1))))))
+
+(define (boolean->number b)
+  (if b 1 0))
+
+(define (number->boolean n)
+  (not (eq? n 0)))
+
+(define (query-flags->number flags)
+  "Returns a number corresponding to the flag bitfield in the DNS header."
+  (+ (* 256 128 (boolean->number (dns-flags-response? flags)))
+     (* 256 8 (opcode->number (dns-flags-opcode flags)))
+     (* 256 4 (boolean->number (dns-flags-authoritative-answer? flags)))
+     (* 256 2 (boolean->number (dns-flags-truncation? flags)))
+     (* 256   (boolean->number (dns-flags-recursion-desired? flags)))
+     (* 128   (boolean->number (dns-flags-recursion-available? flags)))
+     (rcode->number (dns-flags-rcode flags))))
+
+(define (create-dns-header flags qdcount ancount nscount arcount)
+  "Creates a bytevector containing the header of a DNS query."
+  (let ((bv (make-bytevector 12)))
+    (bytevector-u16-set! bv 0 15326 (endianness big))
+    (bytevector-u16-set! bv 2 (query-flags->number flags) (endianness big))
+    (bytevector-u16-set! bv 4 qdcount (endianness big))
+    (bytevector-u16-set! bv 6 ancount (endianness big))
+    (bytevector-u16-set! bv 8 nscount (endianness big))
+    (bytevector-u16-set! bv 10 arcount (endianness big))
+    bv))
+
+(define (create-dns-query query)
+  "Creates a bytevector containing a question section of a DNS query"
+  (let* ((domain (query-name query))
+         (len (+ 2 (string-length domain) 4))
+         (bv (make-bytevector len)))
+    (write-domain bv (string-split domain #\.) 0)
+    (bytevector-u16-set! bv (+ 2 (string-length domain))
+                         (type->number (query-type query)) (endianness big))
+    (bytevector-u16-set! bv (+ 4 (string-length domain))
+                         (class->number (query-class query)) (endianness big))
+    bv))
+
+(define (create-dns-queries queries)
+  (map create-dns-query queries))
+
+;; TODO
+(define (create-dns-answers answers)
+  '())
+(define create-dns-nameservers create-dns-answers)
+(define create-dns-additionals create-dns-answers)
+
+(define (dns-query->bytevector query tcp?)
+  "Creates a bytevector representing the DNS query to send over the network.
+If @code{tcp?} is @code{#t}, the query is suitable for being sent over TCP.
+Otherwise, it is suitable to be sent over UDP."
+  (let* ((header (create-dns-header
+                   (dns-query-flags query)
+                   (length (dns-query-queries query))
+                   (length (dns-query-answers query))
+                   (length (dns-query-nameservers query))
+                   (length (dns-query-additionals query))))
+         (queries (create-dns-queries (dns-query-queries query)))
+         (answers (create-dns-answers (dns-query-answers query)))
+         (nameservers (create-dns-answers (dns-query-nameservers query)))
+         (additionals (create-dns-answers (dns-query-additionals query)))
+         (tcp-header (if tcp? (make-bytevector 2) (make-bytevector 0)))
+         (parts-list (append (list tcp-header header) queries answers nameservers additionals))
+         (len (fold (lambda (bv l) (+ l (bytevector-length bv))) 0 parts-list))
+         (bv (make-bytevector len)))
+    (begin
+      (if tcp?
+        (bytevector-u16-set! tcp-header 0 (- len 2) (endianness big)))
+      (fold (lambda (part l)
+              (begin
+                (bytevector-copy! part 0 bv l (bytevector-length part))
+                (+ l (bytevector-length part))))
+            0 parts-list)
+      bv)))
+
+(define (bytevector->name bv pos)
+  "Extracts a name at position @code{pos} in bytevector @code{bv}. This
+procedure supports the compression algorithm of DNS names."
+  (let* ((component-size (bytevector-u8-ref bv pos))
+         (vect (make-bytevector component-size)))
+    (if (eq? component-size 0)
+        (make-pos-value (+ pos 1) "")
+        (begin
+          ;; If the first two bytes are 0, the name is not compressed. Otherwise,
+          ;; it is compressed and the rest of the field is the position at
+          ;; which the complete name can be found.
+          (if (eq? (bitwise-and 192 component-size) 0)
+              (begin
+                (bytevector-copy! bv (+ pos 1)
+                                  vect 0 component-size)
+                (let ((rest (bytevector->name bv (+ pos 1 component-size))))
+                  (make-pos-value (pos-value-pos rest)
+                    (string-append (bytevector->string vect "UTF-8") "."
+                                 (pos-value-value rest)))))
+              (let ((pointer (bitwise-and
+                               (bytevector-u16-ref bv pos (endianness big))
+                               (- 65535 (* 256 192)))))
+                (make-pos-value (+ pos 2)
+                  (pos-value-value (bytevector->name bv (+ 2 pointer))))))))))
+
+(define (bytevector->query bv pos)
+  (let* ((name (bytevector->name bv pos))
+         (type (type->string (bytevector-u16-ref bv (pos-value-pos name)
+                                                 (endianness big))))
+         (class (class->string (bytevector-u16-ref bv (+ 2 (pos-value-pos name))
+                                                   (endianness big)))))
+    (make-pos-value (+ 4 (pos-value-pos name))
+                    (make-query (pos-value-value name) type class))))
+
+(define (bytevector->queries bv pos num)
+  (if (eq? num 0)
+    (make-pos-value pos '())
+    (let* ((q (bytevector->query bv pos))
+           (rest (bytevector->queries bv (pos-value-pos q) (- num 1))))
+      (make-pos-value
+        (pos-value-pos rest)
+        (cons (pos-value-value q)
+              (pos-value-value rest))))))
+
+(define (bytevector->dns-records bv pos count)
+  (if (> count 0)
+      (let* ((result (bytevector->name bv pos))
+             (domain (pos-value-value result))
+             (npos (pos-value-pos result))
+             (type (bytevector-u16-ref bv npos (endianness big)))
+             (class (bytevector-u16-ref bv (+ npos 2) (endianness big)))
+             (ttl (bytevector-u32-ref bv (+ npos 4) (endianness big)))
+             (rdlength (bytevector-u16-ref bv (+ npos 8) (endianness big)))
+             (data (make-bytevector rdlength))
+             (rest (bytevector->dns-records bv (+ npos 10 rdlength) (- count 1))))
+        (bytevector-copy! bv (+ npos 10)
+                          data 0 rdlength)
+        (make-pos-value (pos-value-pos rest)
+          (cons (make-dns-record domain (type->string type)
+                                 (class->string class) ttl data)
+                (pos-value-value rest))))
+      (make-pos-value pos '())))
+
+(define (bytevector->dns-query bv tcp?)
+  "Creates a @code{dns-query} object from the @code{bv} bytevector. If @code{tcp?}
+is #t, the message is assumed to come from a TCP connection, otherwise it is
+treated as if it came from a UDP message."
+  (let* ((pos (if tcp? 2 0))
+         ;; decode header
+         (flags (bytevector-u16-ref bv (+ pos 2) (endianness big)))
+         (flags (make-dns-flags
+                  (number->boolean (bitwise-and (* 256 128) flags))
+                  (opcode->string (/ (bitwise-and (* 256 (+ 8 16 32 64)) flags) (* 256 8)))
+                  (number->boolean (bitwise-and (* 256 4) flags))
+                  (number->boolean (bitwise-and (* 256 2) flags))
+                  (number->boolean (bitwise-and 256 flags))
+                  (number->boolean (bitwise-and 128 flags))
+                  (rcode->string (bitwise-and 15 flags))))
+         (qdcount (bytevector-u16-ref bv (+ pos 4) (endianness big)))
+         (ancount (bytevector-u16-ref bv (+ pos 6) (endianness big)))
+         (nscount (bytevector-u16-ref bv (+ pos 8) (endianness big)))
+         (arcount (bytevector-u16-ref bv (+ pos 10) (endianness big)))
+         (pos (+ pos 12))
+         (queries (bytevector->queries bv pos qdcount))
+         (pos (pos-value-pos queries))
+         (answers (bytevector->dns-records bv pos ancount))
+         (pos (pos-value-pos answers))
+         (nameservers (bytevector->dns-records bv pos nscount))
+         (pos (pos-value-pos nameservers))
+         (additionals (bytevector->dns-records bv pos arcount)))
+    (make-dns-query flags (pos-value-value queries) (pos-value-value answers)
+                    (pos-value-value nameservers) (pos-value-value additionals))))
+
+(define (simple-a-query domain)
+  "Creates a simple query object that can be passed to @code{dns-query->bytevector}."
+  (make-dns-query (make-dns-flags #f "QUERY" #f #f #t #t "NOERROR")
+                  (list (make-query domain "A" "IN"))
+                  '() '() '()))
+
+(define (bytevector->ipv4 bv)
+  "Extracts the rdata section of an A record."
+  (string-append
+    (number->string (bytevector-u8-ref bv 0)) "."
+    (number->string (bytevector-u8-ref bv 1)) "."
+    (number->string (bytevector-u8-ref bv 2)) "."
+    (number->string (bytevector-u8-ref bv 3))))
-- 
2.15.0


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-gnu-tests-Add-knot-test.patch --]
[-- Type: text/x-patch, Size: 4976 bytes --]

From 5146714c6615161fe3e496909f5a157c24d57ea0 Mon Sep 17 00:00:00 2001
From: Julien Lepiller <julien@lepiller.eu>
Date: Sat, 2 Dec 2017 12:15:28 +0100
Subject: [PATCH 2/2] gnu: tests: Add knot test.

* gnu/tests/dns.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
---
 gnu/local.mk      |   1 +
 gnu/tests/dns.scm | 118 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 119 insertions(+)
 create mode 100644 gnu/tests/dns.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index 2e74c4d81..2fa736523 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -507,6 +507,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/tests/databases.scm			\
   %D%/tests/desktop.scm				\
   %D%/tests/dict.scm				\
+  %D%/tests/dns.scm				\
   %D%/tests/nfs.scm				\
   %D%/tests/install.scm				\
   %D%/tests/mail.scm				\
diff --git a/gnu/tests/dns.scm b/gnu/tests/dns.scm
new file mode 100644
index 000000000..228204e31
--- /dev/null
+++ b/gnu/tests/dns.scm
@@ -0,0 +1,118 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Julien Lepiller <julien@lepiller.eu>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu tests dns)
+  #:use-module (gnu tests)
+  #:use-module (gnu system)
+  #:use-module (gnu system vm)
+  #:use-module (gnu services)
+  #:use-module (gnu services dns)
+  #:use-module (gnu services networking)
+  #:use-module (guix dns)
+  #:use-module (guix gexp)
+  #:use-module (guix store)
+  #:use-module (ice-9 ftw)
+  #:export (%test-knot))
+
+(define %ip4-addr
+;; a random IPv4 address
+  "136.12.251.84")
+
+(define-zone-entries %test-entries
+;; Test entries, with no real data
+;; Name TTL Class Type Data
+  ("@"  ""  "IN"  "A"  "1.2.3.4")
+  ("@"  ""  "IN"  "MX" "10 mail")
+  ("mail" "" "IN" "A"  %ip4-addr))
+
+(define %test-zone
+;; A test zone that uses the fake data
+  (knot-zone-configuration
+    (domain "guix-test.org")
+    (zone (zone-file
+            (origin "guix-test.org")
+            (entries %test-entries)))))
+
+(define %knot-zones
+  (list %test-zone))
+
+(define %knot-os
+  (simple-operating-system
+   (dhcp-client-service)
+   (service knot-service-type
+            (knot-configuration
+              (zones %knot-zones)))))
+
+(define (run-knot-test)
+  "Return a test of an OS running Knot service."
+  (define vm
+    (virtual-machine
+     (operating-system (marionette-operating-system
+                        %knot-os
+                        #:imported-modules '((gnu services herd))))
+     (port-forwardings '((1053 . 53)))))
+
+  (define test
+    (with-imported-modules '((gnu build marionette)
+                             (guix dns))
+      #~(begin
+          (use-modules (guix dns)
+                       (gnu build marionette)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette '(#$vm)))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "knot")
+
+          (test-assert "service is running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (start-service 'knot)
+                #t)
+             marionette))
+
+          (test-eq "get the correct answer"
+            #$%ip4-addr
+            (begin
+              (format #t "test:\n")
+              (let* ((query (simple-a-query "mail.guix-test.org"))
+                     (dns (socket AF_INET SOCK_STREAM 0))
+                     (addr (make-socket-address AF_INET INADDR_LOOPBACK 1053)))
+                (connect dns addr)
+                (put-bytevector dns (dns-query->bytevector query #t))
+                (bytevector->ipv4
+                  (dns-record-rdata
+                    (car (dns-query-answers
+                           (bytevector->dns-query
+                             (get-bytevector-n dns 500)))))))))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "knot-test" test))
+
+(define %test-knot
+  (system-test
+   (name "knot")
+   (description "Send a DNS request to a running Knot server.")
+   (value (run-knot-test))))
-- 
2.15.0

[bug#28055] [WIP] Add knot tests

[Ludovic Courtès]

Hello,

Julien Lepiller <julien@lepiller.eu> skribis:

> Here is a new version. The tests still don't pass though. It can't send
> the request to the server.
>
> From ecc02fe8098d8763b95d2c71215a62e669f49568 Mon Sep 17 00:00:00 2001
> From: Julien Lepiller <julien@lepiller.eu>
> Date: Sat, 2 Dec 2017 10:51:18 +0100
> Subject: [PATCH 1/2] guix: Add DNS implementation.
>
> * guix/dns.scm: New file.
> * Makefile.am: Add it.

[...]

> +;;; Commentary:
> +;;;
> +;;; This module provides a DNS implementation. This modules helps construct
                                                  ^^^^^^^^^^^^
“It”.  :-)

Maybe add that it’s primarily for test purposes.

Very nice stuff!

> From 5146714c6615161fe3e496909f5a157c24d57ea0 Mon Sep 17 00:00:00 2001
> From: Julien Lepiller <julien@lepiller.eu>
> Date: Sat, 2 Dec 2017 12:15:28 +0100
> Subject: [PATCH 2/2] gnu: tests: Add knot test.
>
> * gnu/tests/dns.scm: New file.
> * gnu/local.mk (GNU_SYSTEM_MODULES): Add it.

[...]

> +(define (run-knot-test)
> +  "Return a test of an OS running Knot service."
> +  (define vm
> +    (virtual-machine
> +     (operating-system (marionette-operating-system
> +                        %knot-os
> +                        #:imported-modules '((gnu services herd))))
> +     (port-forwardings '((1053 . 53)))))

Note that this creates *TCP* port forwardings (see
‘port-forwardings->qemu-options’ in (gnu system vm)).

Perhaps you’ll want UDP forwarding?

> +          (test-eq "get the correct answer"
> +            #$%ip4-addr

Should be ‘test-equal’ since you’re comparing strings.

> +            (begin
> +              (format #t "test:\n")
> +              (let* ((query (simple-a-query "mail.guix-test.org"))
> +                     (dns (socket AF_INET SOCK_STREAM 0))
> +                     (addr (make-socket-address AF_INET INADDR_LOOPBACK 1053)))
> +                (connect dns addr)

I learned from
<https://serverfault.com/questions/181956/is-it-true-that-a-nameserver-have-to-answer-queries-over-tcp>
that DNS servers are now supposed to listen for TCP requests, but are we
sure this is the case here?

What error do you get?  Does the ‘connect’ call fail?  Does the message
go through?

Thanks!

Ludo’.

[bug#28055] [WIP] Add knot tests

[zimoun]

Hi Julien,

On Sat, 02 Dec 2017 at 12:18, Julien Lepiller <julien@lepiller.eu> wrote:

> Here is a new version. The tests still don't pass though. It can't send
> the request to the server.

What is the status of this patch [1] adding DNS system tests for knot?

It seems almost ready, no?

1: <http://issues.guix.gnu.org/issue/28055>


Cheers,
simon

[bug#28055] [WIP] Add knot tests

[zimoun]

Hi,

On Thu, 13 Jan 2022 at 16:12, zimoun <zimon.toutoune@gmail.com> wrote:
> On Sat, 02 Dec 2017 at 12:18, Julien Lepiller <julien@lepiller.eu> wrote:
>
>> Here is a new version. The tests still don't pass though. It can't send
>> the request to the server.
>
> What is the status of this patch [1] adding DNS system tests for knot?
>
> It seems almost ready, no?
>
> 1: <http://issues.guix.gnu.org/issue/28055>

What is the status of this old patch [1]?  It is there since a long time
and not a comment since the past 9 weeks.  Therefore, I am going to
close it in the coming weeks.


1: <http://issues.guix.gnu.org/issue/28055>


Cheers,
simon

[bug#28055] [WIP] Add knot tests

[zimoun]

Hi,

On Wed, 23 Mar 2022 at 11:48, zimoun <zimon.toutoune@gmail.com> wrote:
> On Thu, 13 Jan 2022 at 16:12, zimoun <zimon.toutoune@gmail.com> wrote:
>> On Sat, 02 Dec 2017 at 12:18, Julien Lepiller <julien@lepiller.eu> wrote:
>>
>>> Here is a new version. The tests still don't pass though. It can't send
>>> the request to the server.
>>
>> What is the status of this patch [1] adding DNS system tests for knot?
>>
>> It seems almost ready, no?
>>
>> 1: <http://issues.guix.gnu.org/issue/28055>
>
> What is the status of this old patch [1]?  It is there since a long time
> and not a comment since the past 9 weeks.  Therefore, I am going to
> close it in the coming weeks.

Any objection for closing?


Cheers,
simon

[bug#28055] [WIP] Add knot tests

[Julien Lepiller]

[-- Attachment #1: Type: text/plain, Size: 928 bytes --]

Hi Simon,

I think I have an idea for this patch, please keep it open :)

Le 23 juin 2022 11:55:25 GMT+02:00, zimoun <zimon.toutoune@gmail.com> a écrit :
>Hi,
>
>On Wed, 23 Mar 2022 at 11:48, zimoun <zimon.toutoune@gmail.com> wrote:
>> On Thu, 13 Jan 2022 at 16:12, zimoun <zimon.toutoune@gmail.com> wrote:
>>> On Sat, 02 Dec 2017 at 12:18, Julien Lepiller <julien@lepiller.eu> wrote:
>>>
>>>> Here is a new version. The tests still don't pass though. It can't send
>>>> the request to the server.
>>>
>>> What is the status of this patch [1] adding DNS system tests for knot?
>>>
>>> It seems almost ready, no?
>>>
>>> 1: <http://issues.guix.gnu.org/issue/28055>
>>
>> What is the status of this old patch [1]?  It is there since a long time
>> and not a comment since the past 9 weeks.  Therefore, I am going to
>> close it in the coming weeks.
>
>Any objection for closing?
>
>
>Cheers,
>simon

[-- Attachment #2: Type: text/html, Size: 1655 bytes --]

[bug#28055] [WIP] Add knot tests

[Simon Tournier]

Hi Julien,

On Sun, 18 Sep 2022 at 20:28, Julien Lepiller <julien@lepiller.eu> wrote:

> I think I have an idea for this patch, please keep it open :)

We are now more than one year later, about #28055 [1].  Did you have a
chance to look into this?

Cheers,
simon


1: https://issues.guix.gnu.org/issue/28055