From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:46865) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1eL5r0-0000TM-27 for guix-patches@gnu.org; Sat, 02 Dec 2017 06:21:09 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1eL5qw-0001m4-NV for guix-patches@gnu.org; Sat, 02 Dec 2017 06:21:06 -0500 Received: from debbugs.gnu.org ([208.118.235.43]:60575) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1eL5qw-0001lE-GO for guix-patches@gnu.org; Sat, 02 Dec 2017 06:21:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1eL5qw-0002p7-5b for guix-patches@gnu.org; Sat, 02 Dec 2017 06:21:02 -0500 Subject: [bug#28055] [WIP] Add knot tests Resent-Message-ID: Date: Sat, 2 Dec 2017 12:18:15 +0100 From: Julien Lepiller Message-ID: <20171202121815.553c0b93@lepiller.eu> In-Reply-To: <878temiw5i.fsf@gnu.org> References: <20170811210341.10ab9965@lepiller.eu> <87tw17khg0.fsf@elephly.net> <87r2ut27cb.fsf@gnu.org> <878temiw5i.fsf@gnu.org> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="MP_/wmRWkbLac1SLyOCrxrnow1F" List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 28055@debbugs.gnu.org --MP_/wmRWkbLac1SLyOCrxrnow1F Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable Content-Disposition: inline Le Fri, 01 Dec 2017 11:23:53 +0100, ludo@gnu.org (Ludovic Court=C3=A8s) a =C3=A9crit : > Julien, >=20 > Did you have a chance to look into that? >=20 > TIA, > Ludo=E2=80=99. >=20 Here is a new version. The tests still don't pass though. It can't send the request to the server. --MP_/wmRWkbLac1SLyOCrxrnow1F Content-Type: text/x-patch Content-Transfer-Encoding: quoted-printable Content-Disposition: attachment; filename=0001-guix-Add-DNS-implementation.patch =46rom ecc02fe8098d8763b95d2c71215a62e669f49568 Mon Sep 17 00:00:00 2001 From: Julien Lepiller 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 =3D \ 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 =C2=A9 2017 Julien Lepiller +;;; +;;; 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 . + +(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 ( 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 + + make-dns-query dns-query? + dns-query-flags + dns-query-queries + dns-query-answers + dns-query-nameservers + dns-query-additionals + + make-query query? + query-name + query-type + query-class + + 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 + (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 + (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 + (make-query name type class) + query? + (name query-name) + (type query-type) + (class query-class)) + +(define-record-type + (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 + (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 conta= ining +the size of the component, and the last component is followed by the nul b= yte. +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 b= ig)) + 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 networ= k. +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 name= servers additionals)) + (len (fold (lambda (bv l) (+ l (bytevector-length bv))) 0 parts-l= ist)) + (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. Oth= erwise, + ;; 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) (- cou= nt 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 @co= de{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)) f= lags) (* 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 answe= rs) + (pos-value-value nameservers) (pos-value-value additio= nals)))) + +(define (simple-a-query domain) + "Creates a simple query object that can be passed to @code{dns-query->by= tevector}." + (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)))) --=20 2.15.0 --MP_/wmRWkbLac1SLyOCrxrnow1F Content-Type: text/x-patch Content-Transfer-Encoding: quoted-printable Content-Disposition: attachment; filename=0002-gnu-tests-Add-knot-test.patch =46rom 5146714c6615161fe3e496909f5a157c24d57ea0 Mon Sep 17 00:00:00 2001 From: Julien Lepiller 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 =3D \ %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 =C2=A9 2017 Julien Lepiller +;;; +;;; 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 . + +(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 10= 53))) + (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 (=3D (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "knot-test" test)) + +(define %test-knot + (system-test + (name "knot") + (description "Send a DNS=C2=A0request to a running Knot server.") + (value (run-knot-test)))) --=20 2.15.0 --MP_/wmRWkbLac1SLyOCrxrnow1F--