Subject: [bug#28055] [WIP] Add knot tests

From: Julien Lepiller <[email-masked]>
Date: Fri, 11 Aug 2017 21:04:53 +0200

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 :)

From 71daf1a3baac37fe079e0fc282ce5447b8fbb140 Mon Sep 17 00:00:00 2001
From: Julien Lepiller <[email-masked]>
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 <[email-masked]>
+;;;
+;;; 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