;;; 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))))