From: Julien Lepiller <julien@lepiller.eu>
To: 28055@debbugs.gnu.org
Subject: [bug#28055] [WIP] Add knot tests
Date: Fri, 11 Aug 2017 21:04:53 +0200 [thread overview]
Message-ID: <20170811210341.10ab9965@lepiller.eu> (raw)
[-- 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
next reply other threads:[~2017-08-11 19:06 UTC|newest]
Thread overview: 12+ messages / expand[flat|nested] mbox.gz Atom feed top
2017-08-11 19:04 Julien Lepiller [this message]
2017-08-16 9:09 ` [bug#28055] [WIP] Add knot tests Ricardo Wurmus
2017-08-16 13:02 ` Julien Lepiller
2017-09-26 8:27 ` Ludovic Courtès
2017-12-01 10:23 ` Ludovic Courtès
2017-12-02 11:18 ` Julien Lepiller
2017-12-15 10:53 ` Ludovic Courtès
2022-01-13 15:12 ` zimoun
2022-03-23 10:48 ` zimoun
2022-06-23 9:55 ` zimoun
2022-09-18 18:28 ` Julien Lepiller
2023-10-23 21:00 ` Simon Tournier
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20170811210341.10ab9965@lepiller.eu \
--to=julien@lepiller.eu \
--cc=28055@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).