From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:54670) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dgFG2-0004n9-7A for guix-patches@gnu.org; Fri, 11 Aug 2017 15:06:08 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dgFFy-0003Lx-VV for guix-patches@gnu.org; Fri, 11 Aug 2017 15:06:06 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:47324) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1dgFFy-0003Lk-SG for guix-patches@gnu.org; Fri, 11 Aug 2017 15:06:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1dgFFy-0007iL-FK for guix-patches@gnu.org; Fri, 11 Aug 2017 15:06:02 -0400 Subject: [bug#28055] [WIP] Add knot tests Resent-Message-ID: Received: from eggs.gnu.org ([2001:4830:134:3::10]:54617) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dgFFh-0004iB-M5 for guix-patches@gnu.org; Fri, 11 Aug 2017 15:05:47 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dgFFd-0003Ch-VD for guix-patches@gnu.org; Fri, 11 Aug 2017 15:05:45 -0400 Received: from static-176-182-42-79.ncc.abo.bbox.fr ([176.182.42.79]:43402 helo=metebelis3) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1dgFFd-0003BW-F1 for guix-patches@gnu.org; Fri, 11 Aug 2017 15:05:41 -0400 Received: from localhost (bbox.lan [192.168.1.254]) by metebelis3 (OpenSMTPD) with ESMTPSA id ddd79601 (TLSv1.2:ECDHE-RSA-AES256-GCM-SHA384:256:NO) for ; Fri, 11 Aug 2017 19:05:36 +0000 (UTC) Date: Fri, 11 Aug 2017 21:04:53 +0200 From: Julien Lepiller Message-ID: <20170811210341.10ab9965@lepiller.eu> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="MP_/KUud_29NR7r7cA7.9Xmlrfw" 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_/KUud_29NR7r7cA7.9Xmlrfw Content-Type: text/plain; charset=US-ASCII Content-Transfer-Encoding: 7bit Content-Disposition: inline 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 :) --MP_/KUud_29NR7r7cA7.9Xmlrfw Content-Type: text/x-patch Content-Transfer-Encoding: quoted-printable Content-Disposition: attachment; filename=0001-gnu-tests-Add-dns-test.patch =46rom 71daf1a3baac37fe079e0fc282ce5447b8fbb140 Mon Sep 17 00:00:00 2001 From: Julien Lepiller 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 =3D \ %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 =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 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 ze= ro + 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 b= ig)) + (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{componen= ts}. +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)= ))))) + + ;(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 + (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 (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 (endia= nness 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) (endianne= ss 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) (endiannes= s big))) + (ttl (bytevector-u32-ref bv (+ npos 4) (endianness = big))) + (rdlength (bytevector-u16-ref bv (+ npos 8) (endian= ness 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) (ge= t-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-re= sult))) + (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 10= 53))) + (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.or= g")) + (newline) + (resolv INADDR_LOOPBACK 1053 "A" "mail.guix-test.org"))) + + (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.14.1 --MP_/KUud_29NR7r7cA7.9Xmlrfw--