* [bug#28055] [WIP] Add knot tests @ 2017-08-11 19:04 Julien Lepiller 2017-08-16 9:09 ` Ricardo Wurmus 0 siblings, 1 reply; 12+ messages in thread From: Julien Lepiller @ 2017-08-11 19:04 UTC (permalink / raw) To: 28055 [-- 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 ^ permalink raw reply related [flat|nested] 12+ messages in thread
* [bug#28055] [WIP] Add knot tests 2017-08-11 19:04 [bug#28055] [WIP] Add knot tests Julien Lepiller @ 2017-08-16 9:09 ` Ricardo Wurmus 2017-08-16 13:02 ` Julien Lepiller 2017-09-26 8:27 ` Ludovic Courtès 0 siblings, 2 replies; 12+ messages in thread From: Ricardo Wurmus @ 2017-08-16 9:09 UTC (permalink / raw) To: Julien Lepiller; +Cc: 28055 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 ^ permalink raw reply [flat|nested] 12+ messages in thread
* [bug#28055] [WIP] Add knot tests 2017-08-16 9:09 ` Ricardo Wurmus @ 2017-08-16 13:02 ` Julien Lepiller 2017-09-26 8:27 ` Ludovic Courtès 1 sibling, 0 replies; 12+ messages in thread From: Julien Lepiller @ 2017-08-16 13:02 UTC (permalink / raw) Cc: 28055 [-- 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 --] ^ permalink raw reply [flat|nested] 12+ messages in thread
* [bug#28055] [WIP] Add knot tests 2017-08-16 9:09 ` 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 1 sibling, 1 reply; 12+ messages in thread From: Ludovic Courtès @ 2017-09-26 8:27 UTC (permalink / raw) To: Ricardo Wurmus; +Cc: 28055 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 ^ permalink raw reply [flat|nested] 12+ messages in thread
* [bug#28055] [WIP] Add knot tests 2017-09-26 8:27 ` Ludovic Courtès @ 2017-12-01 10:23 ` Ludovic Courtès 2017-12-02 11:18 ` Julien Lepiller 0 siblings, 1 reply; 12+ messages in thread From: Ludovic Courtès @ 2017-12-01 10:23 UTC (permalink / raw) To: Julien Lepiller; +Cc: Ricardo Wurmus, 28055 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 ^ permalink raw reply [flat|nested] 12+ messages in thread
* [bug#28055] [WIP] Add knot tests 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 0 siblings, 2 replies; 12+ messages in thread From: Julien Lepiller @ 2017-12-02 11:18 UTC (permalink / raw) To: 28055 [-- 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 ^ permalink raw reply related [flat|nested] 12+ messages in thread
* [bug#28055] [WIP] Add knot tests 2017-12-02 11:18 ` Julien Lepiller @ 2017-12-15 10:53 ` Ludovic Courtès 2022-01-13 15:12 ` zimoun 1 sibling, 0 replies; 12+ messages in thread From: Ludovic Courtès @ 2017-12-15 10:53 UTC (permalink / raw) To: Julien Lepiller; +Cc: 28055 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’. ^ permalink raw reply [flat|nested] 12+ messages in thread
* [bug#28055] [WIP] Add knot tests 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 1 sibling, 1 reply; 12+ messages in thread From: zimoun @ 2022-01-13 15:12 UTC (permalink / raw) To: Julien Lepiller; +Cc: 28055 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 ^ permalink raw reply [flat|nested] 12+ messages in thread
* [bug#28055] [WIP] Add knot tests 2022-01-13 15:12 ` zimoun @ 2022-03-23 10:48 ` zimoun 2022-06-23 9:55 ` zimoun 0 siblings, 1 reply; 12+ messages in thread From: zimoun @ 2022-03-23 10:48 UTC (permalink / raw) To: Julien Lepiller; +Cc: 28055 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 ^ permalink raw reply [flat|nested] 12+ messages in thread
* [bug#28055] [WIP] Add knot tests 2022-03-23 10:48 ` zimoun @ 2022-06-23 9:55 ` zimoun 2022-09-18 18:28 ` Julien Lepiller 0 siblings, 1 reply; 12+ messages in thread From: zimoun @ 2022-06-23 9:55 UTC (permalink / raw) To: Julien Lepiller; +Cc: 28055 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 ^ permalink raw reply [flat|nested] 12+ messages in thread
* [bug#28055] [WIP] Add knot tests 2022-06-23 9:55 ` zimoun @ 2022-09-18 18:28 ` Julien Lepiller 2023-10-23 21:00 ` Simon Tournier 0 siblings, 1 reply; 12+ messages in thread From: Julien Lepiller @ 2022-09-18 18:28 UTC (permalink / raw) To: zimoun; +Cc: 28055 [-- 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 --] ^ permalink raw reply [flat|nested] 12+ messages in thread
* [bug#28055] [WIP] Add knot tests 2022-09-18 18:28 ` Julien Lepiller @ 2023-10-23 21:00 ` Simon Tournier 0 siblings, 0 replies; 12+ messages in thread From: Simon Tournier @ 2023-10-23 21:00 UTC (permalink / raw) To: Julien Lepiller; +Cc: 28055 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 ^ permalink raw reply [flat|nested] 12+ messages in thread
end of thread, other threads:[~2023-10-24 9:02 UTC | newest] Thread overview: 12+ messages (download: mbox.gz follow: Atom feed -- links below jump to the message on this page -- 2017-08-11 19:04 [bug#28055] [WIP] Add knot tests Julien Lepiller 2017-08-16 9:09 ` 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
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).