[WIP] Add knot tests

OpenSubmitted by Julien Lepiller.
Details
4 participants
  • Julien Lepiller
  • Ludovic Courtès
  • Christopher Baines
  • Ricardo Wurmus
Owner
unassigned
Severity
normal
J
J
Julien Lepiller wrote on 11 Aug 2017 21:04
(address . guix-patches@gnu.org)
20170811210341.10ab9965@lepiller.eu
Hi,
This patch aims at adding a system test for knot. I've implemented theDNS protocol to be able to communicate with the server and try somequeries. Unfortunately, although the server seems to be launched (thefirst test passes), it then refuses to answer. Do you see anythingwrong, or anything I could do to understand why it doesn't pass?
Thanks :)
From 71daf1a3baac37fe079e0fc282ce5447b8fbb140 Mon Sep 17 00:00:00 2001From: Julien Lepiller <julien@lepiller.eu>Date: Sun, 18 Jun 2017 09:53:00 +0200Subject: [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
Toggle diff (346 lines)diff --git a/gnu/local.mk b/gnu/local.mkindex 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.scmnew file mode 100644index 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
R
R
Ricardo Wurmus wrote on 16 Aug 2017 11:09
(name . Julien Lepiller)(address . julien@lepiller.eu)(address . 28055@debbugs.gnu.org)
87tw17khg0.fsf@elephly.net
Hi Julien,
Toggle quote (6 lines)> 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 fromthe ground up. Is there not an easier way to make a DNS test?
-- Ricardo
GPG: BCA6 89B6 3655 3801 C3C6 2150 197A 5888 235F ACAChttps://elephly.net
J
J
Julien Lepiller wrote on 16 Aug 2017 15:02
(address . 28055@debbugs.gnu.org)
FD67B377-F3AB-4467-8720-340CF97C7835@lepiller.eu
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 :
Toggle quote (19 lines)>>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: file
L
L
Ludovic Courtès wrote on 26 Sep 2017 10:27
(name . Ricardo Wurmus)(address . rekado@elephly.net)
87r2ut27cb.fsf@gnu.org
Howdy,
Ricardo Wurmus <rekado@elephly.net> skribis:
Toggle quote (9 lines)>> 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), andthen 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 docstringsas 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
L
L
Ludovic Courtès wrote on 1 Dec 2017 11:23
(name . Julien Lepiller)(address . julien@lepiller.eu)
878temiw5i.fsf@gnu.org
Julien,
Did you have a chance to look into that?
TIA,Ludo’.
ludo@gnu.org (Ludovic Courtès) skribis:
Toggle quote (29 lines)> 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
J
J
Julien Lepiller wrote on 2 Dec 2017 12:18
(address . 28055@debbugs.gnu.org)
20171202121815.553c0b93@lepiller.eu
Le Fri, 01 Dec 2017 11:23:53 +0100,ludo@gnu.org (Ludovic Courtès) a écrit :
Toggle quote (8 lines)> 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 sendthe request to the server.
From ecc02fe8098d8763b95d2c71215a62e669f49568 Mon Sep 17 00:00:00 2001From: Julien Lepiller <julien@lepiller.eu>Date: Sat, 2 Dec 2017 10:51:18 +0100Subject: [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
Toggle diff (383 lines)diff --git a/Makefile.am b/Makefile.amindex 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.scmnew file mode 100644index 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
From 5146714c6615161fe3e496909f5a157c24d57ea0 Mon Sep 17 00:00:00 2001From: Julien Lepiller <julien@lepiller.eu>Date: Sat, 2 Dec 2017 12:15:28 +0100Subject: [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
Toggle diff (138 lines)diff --git a/gnu/local.mk b/gnu/local.mkindex 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.scmnew file mode 100644index 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
L
L
Ludovic Courtès wrote on 15 Dec 2017 11:53
(name . Julien Lepiller)(address . julien@lepiller.eu)(address . 28055@debbugs.gnu.org)
87fu8cjm99.fsf@gnu.org
Hello,
Julien Lepiller <julien@lepiller.eu> skribis:
Toggle quote (11 lines)> 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.
[...]
Toggle quote (3 lines)> +;;; Commentary:> +;;;> +;;; This module provides a DNS implementation. This modules helps construct
^^^^^^^^^^^^“It”. :-)
Maybe add that it’s primarily for test purposes.
Very nice stuff!
Toggle quote (8 lines)> 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.
[...]
Toggle quote (9 lines)> +(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?
Toggle quote (3 lines)> + (test-eq "get the correct answer"> + #$%ip4-addr
Should be ‘test-equal’ since you’re comparing strings.
Toggle quote (7 lines)> + (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 fromhttps://serverfault.com/questions/181956/is-it-true-that-a-nameserver-have-to-answer-queries-over-tcpthat DNS servers are now supposed to listen for TCP requests, but are wesure this is the case here?
What error do you get? Does the ‘connect’ call fail? Does the messagego through?
Thanks!
Ludo’.
C
C
Christopher Baines wrote on 19 Mar 2018 09:20
control message for bug #28055
(address . control@debbugs.gnu.org)
87k1u85ve2.fsf@cbaines.net
tags 28055 patch
?
Your comment

Commenting via the web interface is currently disabled.

To comment on this conversation send email to 28055@debbugs.gnu.org