From 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 = \ %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 +;;; +;;; 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 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 + (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 (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