code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; 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 base)
  #:use-module (gnu tests)
  #:use-module (gnu system)
  #:use-module (gnu system shadow)
  #:use-module (gnu system nss)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services dbus)
  #:use-module (gnu services avahi)
  #:use-module (gnu services mcron)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services networking)
  #:use-module (gnu packages base)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages imagemagick)
  #:use-module (gnu packages ocr)
  #:use-module (gnu packages package-management)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages tmux)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix packages)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:export (run-basic-test
            %test-basic-os
            %test-halt
            %test-cleanup
            %test-mcron
            %test-nss-mdns))

(define %simple-os
  (simple-operating-system))

(define* (run-basic-test os command #:optional (name "basic")
                         #:key
                         initialization
                         root-password
                         desktop?)
  "Return a derivation called NAME that tests basic features of the OS started
using COMMAND, a gexp that evaluates to a list of strings.  Compare some
properties of running system to what's declared in OS, an <operating-system>.

When INITIALIZATION is true, it must be a one-argument procedure that is
passed a gexp denoting the marionette, and it must return gexp that is
inserted before the first test.  This is used to introduce an extra
initialization step, such as entering a LUKS passphrase.

When ROOT-PASSWORD is true, enter it as the root password when logging in.
Otherwise assume that there is no password for root."
  (define special-files
    (service-value
     (fold-services (operating-system-services os)
                    #:target-type special-files-service-type)))

  (define guix&co
    (match (package-transitive-propagated-inputs guix)
      (((labels packages) ...)
       (cons guix packages))))

  (define test
    (with-imported-modules '((gnu build marionette)
                             (guix build syscalls))
      #~(begin
          (use-modules (gnu build marionette)
                       (guix build syscalls)
                       (srfi srfi-1)
                       (srfi srfi-26)
                       (srfi srfi-64)
                       (ice-9 match))

          (define marionette
            (make-marionette #$command))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "basic")

          #$(and initialization
                 (initialization #~marionette))

          (test-assert "uname"
            (match (marionette-eval '(uname) marionette)
              (#("Linux" host-name version _ architecture)
               (and (string=? host-name
                              #$(operating-system-host-name os))
                    (string-prefix? #$(package-version
                                       (operating-system-kernel os))
                                    version)
                    (string-prefix? architecture %host-type)))))

          ;; Shepherd reads the config file *before* binding its control
          ;; socket, so /var/run/shepherd/socket might not exist yet when the
          ;; 'marionette' service is started.
          (test-assert "shepherd socket ready"
            (marionette-eval
             `(begin
                (use-modules (gnu services herd))
                (let loop ((i 10))
                  (cond ((file-exists? (%shepherd-socket-file))
                         #t)
                        ((> i 0)
                         (sleep 1)
                         (loop (- i 1)))
                        (else
                         #f))))
             marionette))

          (test-eq "stdin is /dev/null"
            'eof
            ;; Make sure services can no longer read from stdin once the
            ;; system has booted.
            (marionette-eval
             `(begin
                (use-modules (gnu services herd))
                (start 'user-processes)
                ((@@ (gnu services herd) eval-there)
                 '(let ((result (read (current-input-port))))
                    (if (eof-object? result)
                        'eof
                        result))))
             marionette))

          (test-assert "shell and user commands"
            ;; Is everything in $PATH?
            (zero? (marionette-eval '(system "
. /etc/profile
set -e -x
guix --version
ls --version
grep --version
info --version")
                                    marionette)))

          (test-equal "special files"
            '#$special-files
            (marionette-eval
             '(begin
                (use-modules (ice-9 match))

                (map (match-lambda
                       ((file target)
                        (list file (readlink file))))
                     '#$special-files))
             marionette))

          (test-assert "accounts"
            (let ((users (marionette-eval '(begin
                                             (use-modules (ice-9 match))
                                             (let loop ((result '()))
                                               (match (getpw)
                                                 (#f (reverse result))
                                                 (x  (loop (cons x result))))))
                                          marionette)))
              (lset= equal?
                     (map (lambda (user)
                            (list (passwd:name user)
                                  (passwd:dir user)))
                          users)
                     (list
                      #$@(map (lambda (account)
                                `(list ,(user-account-name account)
                                       ,(user-account-home-directory account)))
                              (operating-system-user-accounts os))))))

          (test-assert "shepherd services"
            (let ((services (marionette-eval
                             '(begin
                                (use-modules (gnu services herd))

                                (map (compose car live-service-provision)
                                     (current-services)))
                             marionette)))
              (lset= eq?
                     (pk 'services services)
                     '(root #$@(operating-system-shepherd-service-names os)))))

          (test-equal "/var/log/messages is not world-readable"
            #o640                                ;<https://bugs.gnu.org/40405>
            (begin
              (wait-for-file "/var/log/messages" marionette
                             #:read 'get-u8)
              (marionette-eval '(stat:perms (lstat "/var/log/messages"))
                               marionette)))

          (test-assert "homes"
            (let ((homes
                   '#$(map user-account-home-directory
                           (filter user-account-create-home-directory?
                                   (operating-system-user-accounts os)))))
              (marionette-eval
               `(begin
                  (use-modules (gnu services herd) (srfi srfi-1))

                  ;; Home directories are supposed to exist once 'user-homes'
                  ;; has been started.
                  (start-service 'user-homes)

                  (every (lambda (home)
                           (and (file-exists? home)
                                (file-is-directory? home)))
                         ',homes))
               marionette)))

          (test-assert "skeletons in home directories"
            (let ((users+homes
                   '#$(filter-map (lambda (account)
                                    (and (user-account-create-home-directory?
                                          account)
                                         (not (user-account-system? account))
                                         (list (user-account-name account)
                                               (user-account-home-directory
                                                account))))
                                  (operating-system-user-accounts os))))
              (marionette-eval
               `(begin
                  (use-modules (guix build utils) (srfi srfi-1)
                               (ice-9 ftw) (ice-9 match))

                  (every (match-lambda
                           ((user home)
                            ;; Make sure HOME has all the skeletons...
                            (and (null? (lset-difference string=?
                                                         (scandir "/etc/skel/")
                                                         (scandir home)))

                                 ;; ... and that everything is user-owned.
                                 (let* ((pw  (getpwnam user))
                                        (uid (passwd:uid pw))
                                        (gid (passwd:gid pw))
                                        (st  (lstat home)))
                                   (define (user-owned? file)
                                     (= uid (stat:uid (lstat file))))

                                   (and (= uid (stat:uid st))
                                        (eq? 'directory (stat:type st))
                                        (every user-owned?
                                               (find-files home
                                                           #:directories? #t)))))))
                         ',users+homes))
               marionette)))

          (test-equal "permissions on /root"
            #o700
            (let ((root-home #$(any (lambda (account)
                                      (and (zero? (user-account-uid account))
                                           (user-account-home-directory
                                            account)))
                                    (operating-system-user-accounts os))))
              (stat:perms (marionette-eval `(stat ,root-home) marionette))))

          (test-equal "ownership and permissions of /var/empty"
            '(0 0 #o555)
            (let ((st (marionette-eval `(stat "/var/empty") marionette)))
              (list (stat:uid st) (stat:gid st)
                    (stat:perms st))))

          (test-equal "no extra home directories"
            '()

            ;; Make sure the home directories that are not supposed to be
            ;; created are indeed not created.
            (let ((nonexistent
                   '#$(filter-map (lambda (user)
                                    (and (not
                                          (user-account-create-home-directory?
                                           user))
                                         (user-account-home-directory user)))
                                  (operating-system-user-accounts os))))
              (marionette-eval
               `(begin
                  (use-modules (srfi srfi-1))

                  ;; Note: Do not flag "/var/empty".
                  (filter file-exists?
                          ',(remove (cut string-prefix? "/var/" <>)
                                    nonexistent)))
               marionette)))

          (test-equal "login on tty1"
            "root\n"
            (begin
              ;; XXX: On desktop, GDM3 will switch to TTY7. If this happens
              ;; after we switched to TTY1, we won't be able to login. Make
              ;; sure to wait long enough before switching to TTY1.
              (when #$desktop?
                (sleep 30))

              (marionette-control "sendkey ctrl-alt-f1" marionette)
              ;; Wait for the 'term-tty1' service to be running (using
              ;; 'start-service' is the simplest and most reliable way to do
              ;; that.)
              (marionette-eval
               '(begin
                  (use-modules (gnu services herd))
                  (start-service 'term-tty1))
               marionette)

              ;; Now we can type.
              (let ((password #$root-password))
                (if password
                    (begin
                      (marionette-type "root\n" marionette)
                      (wait-for-screen-text marionette
                                            (lambda (text)
                                              (string-contains text "Password"))
                                            #:ocrad
                                            #$(file-append ocrad "/bin/ocrad"))
                      (marionette-type (string-append password "\n\n")
                                       marionette))
                    (marionette-type "root\n\n" marionette)))
              (marionette-type "id -un > logged-in\n" marionette)

              ;; It can take a while before the shell commands are executed.
              (marionette-eval '(use-modules (rnrs io ports)) marionette)
              (wait-for-file "/root/logged-in" marionette
                             #:read 'get-string-all)))

          (test-equal "getlogin on tty1"
            "\"root\""
            (begin
              ;; Assume we logged in in the previous test and type.
              (marionette-type "guile -c '(write (getlogin))' > /root/login-id.tmp\n"
                               marionette)
              (marionette-type "mv /root/login-id{.tmp,}\n"
                               marionette)

              ;; It can take a while before the shell commands are executed.
              (marionette-eval '(use-modules (rnrs io ports)) marionette)
              (wait-for-file "/root/login-id" marionette
                             #:read 'get-string-all)))

          ;; There should be one utmpx entry for the user logged in on tty1.
          (test-equal "utmpx entry"
            '(("root" "tty1" #f))
            (marionette-eval
             '(begin
                (use-modules (guix build syscalls)
                             (srfi srfi-1))

                (filter-map (lambda (entry)
                              (and (equal? (login-type USER_PROCESS)
                                           (utmpx-login-type entry))
                                   (list (utmpx-user entry) (utmpx-line entry)
                                         (utmpx-host entry))))
                            (utmpx-entries)))
             marionette))

          ;; Likewise for /var/log/wtmp (used by 'last').
          (test-assert "wtmp entry"
            (match (marionette-eval
                    '(begin
                       (use-modules (guix build syscalls)
                                    (srfi srfi-1))

                       (define (entry->list entry)
                         (list (utmpx-user entry) (utmpx-line entry)
                               (utmpx-host entry) (utmpx-login-type entry)))

                       (call-with-input-file "/var/log/wtmp"
                         (lambda (port)
                           (let loop ((result '()))
                             (if (eof-object? (peek-char port))
                                 (map entry->list (reverse result))
                                 (loop (cons (read-utmpx port) result)))))))
                    marionette)
              (((users lines hosts types) ..1)
               (every (lambda (type)
                        (eqv? type (login-type LOGIN_PROCESS)))
                      types))))

          (test-assert "host name resolution"
            (match (marionette-eval
                    '(begin
                       ;; Wait for nscd or our requests go through it.
                       (use-modules (gnu services herd))
                       (start-service 'nscd)

                       (list (getaddrinfo "localhost")
                             (getaddrinfo #$(operating-system-host-name os))))
                    marionette)
              ((((? vector?) ..1) ((? vector?) ..1))
               #t)
              (x
               (pk 'failure x #f))))

          (test-equal "nscd invalidate action"
            '(#t)                                 ;one value, #t
            (marionette-eval '(with-shepherd-action 'nscd ('invalidate "hosts")
                                                    result
                                                    result)
                             marionette))

          ;; FIXME: The 'invalidate' action can't reliably obtain the exit
          ;; code of 'nscd' so skip this test.
          (test-skip 1)
          (test-equal "nscd invalidate action, wrong table"
            '(#f)                                 ;one value, #f
            (marionette-eval '(with-shepherd-action 'nscd ('invalidate "xyz")
                                                    result
                                                    result)
                             marionette))

          (test-equal "host not found"
            #f
            (marionette-eval
             '(false-if-exception (getaddrinfo "does-not-exist"))
             marionette))

          (test-equal "locale"
            "en_US.utf8"
            (marionette-eval '(let ((before (setlocale LC_ALL "en_US.utf8")))
                                (setlocale LC_ALL before))
                             marionette))

          (test-eq "/run/current-system is a GC root"
            'success!
            (marionette-eval '(begin
                                ;; Make sure the (guix …) modules are found.
                                (eval-when (expand load eval)
                                  (set! %load-path
                                    (append (map (lambda (package)
                                                   (string-append package
                                                                  "/share/guile/site/"
                                                                  (effective-version)))
                                                 '#$guix&co)
                                            %load-path)))

                                (use-modules (srfi srfi-34) (guix store))

                                (let ((system (readlink "/run/current-system")))
                                  (guard (c ((store-protocol-error? c)
                                             (and (file-exists? system)
                                                  'success!)))
                                    (with-store store
                                      (delete-paths store (list system))
                                      #f))))
                             marionette))

          ;; This symlink is currently unused, but better have it point to the
          ;; right place.  See
          ;; <https://lists.gnu.org/archive/html/guix-devel/2016-08/msg01641.html>.
          (test-equal "/var/guix/gcroots/profiles is a valid symlink"
            "/var/guix/profiles"
            (marionette-eval '(readlink "/var/guix/gcroots/profiles")
                             marionette))

          (test-equal "guix-daemon set-http-proxy action"
            '(#t)                                 ;one value, #t
            (marionette-eval '(with-shepherd-action 'guix-daemon
                                  ('set-http-proxy "http://localhost:8118")
                                  result
                                result)
                             marionette))

          (test-equal "guix-daemon set-http-proxy action, clear"
            '(#t)                                 ;one value, #t
            (marionette-eval '(with-shepherd-action 'guix-daemon
                                  ('set-http-proxy)
                                  result
                                result)
                             marionette))

          (test-assert "screendump"
            (begin
              (marionette-control (string-append "screendump " #$output
                                                 "/tty1.ppm")
                                  marionette)
              (file-exists? "tty1.ppm")))

          (test-assert "screen text"
            (let ((text (marionette-screen-text marionette
                                                #:ocrad
                                                #$(file-append ocrad
                                                               "/bin/ocrad"))))
              ;; Check whether the welcome message and shell prompt are
              ;; displayed.  Note: OCR confuses "y" and "V" for instance, so
              ;; we cannot reliably match the whole text.
              (and (string-contains text "This is the GNU")
                   (string-contains text
                                    (string-append
                                     "root@"
                                     #$(operating-system-host-name os))))))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation name test))

(define %test-basic-os
  (system-test
   (name "basic")
   (description
    "Instrument %SIMPLE-OS, run it in a VM, and run a series of basic
functionality tests.")
   (value
    (let* ((os  (marionette-operating-system
                 %simple-os
                 #:imported-modules '((gnu services herd)
                                      (guix combinators))))
           (vm  (virtual-machine os)))
      ;; XXX: Add call to 'virtualized-operating-system' to get the exact same
      ;; set of services as the OS produced by
      ;; 'system-qemu-image/shared-store-script'.
      (run-basic-test (virtualized-operating-system os '())
                      #~(list #$vm))))))

;;;
;;; Halt.
;;;

(define (run-halt-test vm)
  ;; As reported in <http://bugs.gnu.org/26931>, running tmux would previously
  ;; lead the 'stop' method of 'user-processes' to an infinite loop, with the
  ;; tmux server process as a zombie that remains in the list of processes.
  ;; This test reproduces this scenario.
  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette))

          (define marionette
            (make-marionette '(#$vm)))

          (define ocrad
            #$(file-append ocrad "/bin/ocrad"))

          ;; Wait for tty1 and log in.
          (marionette-eval '(begin
                              (use-modules (gnu services herd))
                              (start-service 'term-tty1))
                           marionette)
          (marionette-type "root\n" marionette)

          ;; Start tmux and wait for it to be ready.
          (marionette-type "tmux new-session 'echo 1 > /ready; bash'\n"
                           marionette)
          (wait-for-file "/ready" marionette)

          ;; Make sure to stop the test after a while.
          (sigaction SIGALRM (lambda _
                               (format (current-error-port)
                                       "FAIL: Time is up, but VM still running.\n")
                               (primitive-exit 1)))
          (alarm 10)

          ;; Get debugging info.
          (marionette-eval '(current-output-port
                             (open-file "/dev/console" "w0"))
                           marionette)
          (marionette-eval '(system* #$(file-append procps "/bin/ps")
                                     "-eo" "pid,ppid,stat,comm")
                           marionette)

          ;; See if 'halt' actually works.
          (marionette-eval '(system* "/run/current-system/profile/sbin/halt")
                           marionette)

          ;; If we reach this line, that means the VM was properly stopped in
          ;; a timely fashion.
          (alarm 0)
          (call-with-output-file #$output
            (lambda (port)
              (display "success!" port))))))

  (gexp->derivation "halt" test))

(define %test-halt
  (system-test
   (name "halt")
   (description
    "Use the 'halt' command and make sure it succeeds and does not get stuck
in a loop.  See <http://bugs.gnu.org/26931>.")
   (value
    (let ((os (marionette-operating-system
               (operating-system
                 (inherit %simple-os)
                 (packages (cons tmux %base-packages)))
               #:imported-modules '((gnu services herd)
                                    (guix combinators)))))
      (run-halt-test (virtual-machine os))))))

;;;
;;; Cleanup of /tmp, /var/run, etc.
;;;

(define %cleanup-os
  (simple-operating-system
   (simple-service 'dirty-things
                   boot-service-type
                   (let ((script (plain-file
                                  "create-utf8-file.sh"
                                  (string-append
                                   "echo $0: dirtying /tmp...\n"
                                   "set -e; set -x\n"
                                   "touch /witness\n"
                                   "exec touch /tmp/λαμβδα"))))
                     (with-imported-modules '((guix build utils))
                       #~(begin
                           (setenv "PATH"
                                   #$(file-append coreutils "/bin"))
                           (invoke #$(file-append bash "/bin/sh")
                                   #$script)))))))

(define (run-cleanup-test name)
  (define os
    (marionette-operating-system %cleanup-os
                                 #:imported-modules '((gnu services herd)
                                                      (guix combinators))))
  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette)
                       (srfi srfi-64)
                       (ice-9 match))

          (define marionette
            (make-marionette (list #$(virtual-machine os))))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "cleanup")

          (test-assert "dirty service worked"
            (marionette-eval '(file-exists? "/witness") marionette))

          (test-equal "/tmp cleaned up"
            '("." "..")
            (marionette-eval '(begin
                                (use-modules (ice-9 ftw))
                                (scandir "/tmp"))
                             marionette))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "cleanup" test))

(define %test-cleanup
  ;; See <https://bugs.gnu.org/26353>.
  (system-test
   (name "cleanup")
   (description "Make sure the 'cleanup' service can remove files with
non-ASCII names from /tmp.")
   (value (run-cleanup-test name))))

;;;
;;; Mcron.
;;;

(define %mcron-os
  ;; System with an mcron service, with one mcron job for "root" and one mcron
  ;; job for an unprivileged user.
  (let ((job1 #~(job '(next-second '(0 5 10 15 20 25 30 35 40 45 50 55))
                     (lambda ()
                       (unless (file-exists? "witness")
                        (call-with-output-file "witness"
                          (lambda (port)
                            (display (list (getuid) (getgid)) port)))))))
        (job2 #~(job next-second-from
                     (lambda ()
                       (call-with-output-file "witness"
                         (lambda (port)
                           (display (list (getuid) (getgid)) port))))
                     #:user "alice"))
        (job3 #~(job next-second-from             ;to test $PATH
                     "touch witness-touch")))
    (simple-operating-system
     (service mcron-service-type
              (mcron-configuration (jobs (list job1 job2 job3)))))))

(define (run-mcron-test name)
  (define os
    (marionette-operating-system
     %mcron-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette)
                       (srfi srfi-64)
                       (ice-9 match))

          (define marionette
            (make-marionette (list #$(virtual-machine os))))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "mcron")

          (test-assert "service running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'mcron))
             marionette))

          ;; Make sure root's mcron job runs, has its cwd set to "/root", and
          ;; runs with the right UID/GID.
          (test-equal "root's job"
            '(0 0)
            (wait-for-file "/root/witness" marionette))

          ;; Likewise for Alice's job.  We cannot know what its GID is since
          ;; it's chosen by 'groupadd', but it's strictly positive.
          (test-assert "alice's job"
            (match (wait-for-file "/home/alice/witness" marionette)
              ((1000 gid)
               (>= gid 100))))

          ;; Last, the job that uses a command; allows us to test whether
          ;; $PATH is sane.
          (test-equal "root's job with command"
            ""
            (wait-for-file "/root/witness-touch" marionette
                           #:read '(@ (ice-9 rdelim) read-string)))

          ;; Make sure the 'schedule' action is accepted.
          (test-equal "schedule action"
            '(#t)                                 ;one value, #t
            (marionette-eval '(with-shepherd-action 'mcron ('schedule) result
                                result)
                             marionette))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation name test))

(define %test-mcron
  (system-test
   (name "mcron")
   (description "Make sure the mcron service works as advertised.")
   (value (run-mcron-test name))))

;;;
;;; Avahi and NSS-mDNS.
;;;

(define %avahi-os
  (operating-system
    (inherit %simple-os)
    (name-service-switch %mdns-host-lookup-nss)
    (services (cons* (service avahi-service-type
                              (avahi-configuration (debug? #t)))
                     (dbus-service)
                     (service dhcp-client-service-type) ;needed for multicast

                     ;; Enable heavyweight debugging output.
                     (modify-services (operating-system-user-services
                                       %simple-os)
                       (nscd-service-type config
                                          => (nscd-configuration
                                              (inherit config)
                                              (debug-level 3)
                                              (log-file "/dev/console")))
                       (syslog-service-type config
                                            =>
                                            (syslog-configuration
                                             (inherit config)
                                             (config-file
                                              (plain-file
                                               "syslog.conf"
                                               "*.* /dev/console\n")))))))))

(define (run-nss-mdns-test)
  ;; Test resolution of '.local' names via libc.  Start the marionette service
  ;; *after* nscd.  Failing to do that, libc will try to connect to nscd,
  ;; fail, then never try again (see '__nss_not_use_nscd_hosts' in libc),
  ;; leading to '.local' resolution failures.
  (define os
    (marionette-operating-system
     %avahi-os
     #:requirements '(nscd)
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define mdns-host-name
    (string-append (operating-system-host-name os)
                   ".local"))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette)
                       (srfi srfi-1)
                       (srfi srfi-64)
                       (ice-9 match))

          (define marionette
            (make-marionette (list #$(virtual-machine os))))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "avahi")

          (test-assert "nscd PID file is created"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'nscd))
             marionette))

          (test-assert "nscd is listening on its socket"
            (marionette-eval
             ;; XXX: Work around a race condition in nscd: nscd creates its
             ;; PID file before it is listening on its socket.
             '(let ((sock (socket PF_UNIX SOCK_STREAM 0)))
                (let try ()
                  (catch 'system-error
                    (lambda ()
                      (connect sock AF_UNIX "/var/run/nscd/socket")
                      (close-port sock)
                      (format #t "nscd is ready~%")
                      #t)
                    (lambda args
                      (format #t "waiting for nscd...~%")
                      (usleep 500000)
                      (try)))))
             marionette))

          (test-assert "avahi is running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'avahi-daemon))
             marionette))

          (test-assert "network is up"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'networking))
             marionette))

          (test-equal "avahi-resolve-host-name"
            0
            (marionette-eval
             '(system*
               "/run/current-system/profile/bin/avahi-resolve-host-name"
               "-v" #$mdns-host-name)
             marionette))

          (test-equal "avahi-browse"
            0
            (marionette-eval
             '(system* "/run/current-system/profile/bin/avahi-browse" "-avt")
             marionette))

          (test-assert "getaddrinfo .local"
            ;; Wait for the 'avahi-daemon' service and perform a resolution.
            (match (marionette-eval
                    '(getaddrinfo #$mdns-host-name)
                    marionette)
              (((? vector? addrinfos) ..1)
               (pk 'getaddrinfo addrinfos)
               (and (any (lambda (ai)
                           (= AF_INET (addrinfo:fam ai)))
                         addrinfos)
                    (any (lambda (ai)
                           (= AF_INET6 (addrinfo:fam ai)))
                         addrinfos)))))

          (test-assert "gethostbyname .local"
            (match (pk 'gethostbyname
                       (marionette-eval '(gethostbyname #$mdns-host-name)
                                        marionette))
              ((? vector? result)
               (and (string=? (hostent:name result) #$mdns-host-name)
                    (= (hostent:addrtype result) AF_INET)))))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "nss-mdns" test))

(define %test-nss-mdns
  (system-test
   (name "nss-mdns")
   (description
    "Test Avahi's multicast-DNS implementation, and in particular, test its
glibc name service switch (NSS) module.")
   (value (run-nss-mdns-test))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2018, 2019, 2020, 2021 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr>
;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com>
;;;
;;; 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 ci)
  #:use-module (gnu tests)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system shadow)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #:use-module (gnu services ci)
  #:use-module (gnu services web)
  #:use-module (gnu services networking)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:export (%test-laminar))

(define %laminar-os
  ;; Operating system under test.
  (simple-operating-system
   (service dhcp-client-service-type)
   (service laminar-service-type)))

(define* (run-laminar-test #:optional (http-port 8080))
  "Run tests in %LAMINAR-OS, which has laminar running and listening on
HTTP-PORT."
  (define os
    (marionette-operating-system
     %laminar-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings `((,http-port . 8080)))))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (srfi srfi-11) (srfi srfi-64)
                       (ice-9 match)
                       (gnu build marionette)
                       (web uri)
                       (web client)
                       (web response))

          (define marionette
            ;; Forward the guest's HTTP-PORT, where laminar is listening, to
            ;; port 8080 in the host.
            (make-marionette (list #$vm)))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "laminar")

          (test-assert "service running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'laminar))
             marionette))

          (define* (retry-on-error f #:key times delay)
            (let loop ((attempt 1))
              (match (catch
                      #t
                      (lambda ()
                        (cons #t
                              (f)))
                      (lambda args
                        (cons #f
                              args)))
                ((#t . return-value)
                 return-value)
                ((#f . error-args)
                 (if (>= attempt times)
                     error-args
                     (begin
                       (sleep delay)
                       (loop (+ 1 attempt))))))))

          (test-equal "http-get"
            200
            (retry-on-error
             (lambda ()
               (let-values (((response text)
                             (http-get #$(format
                                          #f
                                          "http://localhost:~A/"
                                          http-port)
                                       ;; TODO: Why does decoding fail?
                                       #:decode-body? #f)))
                 (response-code response)))
             #:times 10
             #:delay 5))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "laminar-test" test))

(define %test-laminar
  (system-test
   (name "laminar")
   (description "Connect to a running Laminar server.")
   (value (run-laminar-test))))

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
;;;
;;; 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 cups)
  #:use-module (gnu tests)
  #:use-module (gnu system)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #:use-module (gnu services cups)
  #:use-module (gnu services networking)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:export (%test-cups))

;;;
;;; Test the Common Unix Printing System.
;;;

(define* (run-cups-test os-configuration #:optional (cups-port 631))
  (define os
    (marionette-operating-system os-configuration
                                 #:imported-modules '((gnu services herd))))

  (define forwarded-port 8080)

  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings `((,forwarded-port . ,cups-port)))))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette)
                       (srfi srfi-11) (srfi srfi-64)
                       (web client) (web response))

          (define marionette
            (make-marionette (list #$vm)))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "cups")

          ;; Wait for the web interface to become ready.
          (wait-for-tcp-port #$cups-port marionette)

          (test-equal "http-get default page"
            200
            (let-values
                (((response text)
                  (http-get #$(simple-format
                               #f "http://localhost:~A/" forwarded-port)
                            #:decode-body? #t)))
              (response-code response)))

          (test-equal "http-get admin page"
            200
            (let-values
                (((response text)
                  (http-get #$(simple-format
                               #f "http://localhost:~A/admin" forwarded-port)
                            #:decode-body? #t)))
              (response-code response)))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "cups-test" test))

(define %cups-os
  (simple-operating-system
   (service dhcp-client-service-type)
   (service cups-service-type
            (cups-configuration
             (web-interface? #t)
             ;; Listen on all interfaces instead of just localhost so we
             ;; can access the web interface "remotely".
             (listen '("*:631" "/var/run/cups/cups.sock"))
             ;; Add access controls for the Qemu-managed network.
             (location-access-controls
              (list (location-access-control
                     (path "/")
                     (access-controls '("Order allow,deny"
                                        "Allow from 10.0.0.0/8")))
                    (location-access-control
                     (path "/admin")
                     (access-controls '("Order allow,deny"
                                        "Allow from 10.0.0.0/8")))
                    (location-access-control
                     (path "/admin/conf")
                     (access-controls '("Order allow,deny"
                                        "AuthType Basic"
                                        "Require user @SYSTEM"
                                        "Allow localhost")))))))))

(define %test-cups
  (system-test
   (name "cups")
   (description "Test the CUPS print server")
   (value (run-cups-test %cups-os))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2020 Marius Bakke <marius@gnu.org>
;;;
;;; 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 databases)
  #:use-module (gnu tests)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system shadow)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #:use-module (gnu services databases)
  #:use-module (gnu services networking)
  #:use-module (gnu packages databases)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:export (%test-memcached
            %test-postgresql
            %test-mysql))

(define %memcached-os
  (simple-operating-system
   (service dhcp-client-service-type)
   (service memcached-service-type)))

(define* (run-memcached-test #:optional (port 11211))
  "Run tests in %MEMCACHED-OS, forwarding PORT."
  (define os
    (marionette-operating-system
     %memcached-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings `((11211 . ,port)))))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (srfi srfi-11) (srfi srfi-64)
                       (gnu build marionette)
                       (ice-9 rdelim))

          (define marionette
            (make-marionette (list #$vm)))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "memcached")

          ;; Wait for memcached to be up and running.
          (test-assert "service running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (match (start-service 'memcached)
                  (#f #f)
                  (('service response-parts ...)
                   (match (assq-ref response-parts 'running)
                     ((pid) (number? pid))))))
             marionette))

          (let* ((ai (car (getaddrinfo "localhost"
                                       #$(number->string port))))
                 (s  (socket (addrinfo:fam ai)
                             (addrinfo:socktype ai)
                             (addrinfo:protocol ai)))
                 (key "testkey")
                 (value "guix"))
            (connect s (addrinfo:addr ai))

            (test-equal "set"
              "STORED\r"
              (begin
                (simple-format s "set ~A 0 60 ~A\r\n~A\r\n"
                               key
                               (string-length value)
                               value)
                (read-line s)))

            (test-equal "get"
              (simple-format #f "VALUE ~A 0 ~A\r~A\r"
                             key
                             (string-length value)
                             value)
              (begin
                (simple-format s "get ~A\r\n" key)
                (string-append
                 (read-line s)
                 (read-line s))))

            (close-port s))

          ;; There should be a log file in here.
          (test-assert "log file"
            (marionette-eval
             '(file-exists? "/var/log/memcached")
             marionette))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "memcached-test" test))

(define %test-memcached
  (system-test
   (name "memcached")
   (description "Connect to a running MEMCACHED server.")
   (value (run-memcached-test))))

;;;
;;; The PostgreSQL service.
;;;

(define %postgresql-log-directory
  "/var/log/postgresql")

(define %role-log-file
  "/var/log/postgresql_roles.log")

(define %postgresql-os
  (simple-operating-system
   (service postgresql-service-type
            (postgresql-configuration
             (postgresql postgresql-10)
             (config-file
              (postgresql-config-file
               (extra-config
                '(("session_preload_libraries" "auto_explain")
                  ("random_page_cost" 2)
                  ("auto_explain.log_min_duration" "100 ms")
                  ("work_mem" "500 MB")
                  ("debug_print_plan" #t)))))))
   (service postgresql-role-service-type
            (postgresql-role-configuration
             (roles
              (list (postgresql-role
                     (name "root")
                     (create-database? #t))))))))

(define (run-postgresql-test)
  "Run tests in %POSTGRESQL-OS."
  (define os
    (marionette-operating-system
     %postgresql-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define vm
    (virtual-machine
     (operating-system os)
     (memory-size 512)))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (srfi srfi-64)
                       (gnu build marionette))

          (define marionette
            (make-marionette (list #$vm)))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "postgresql")

          (test-assert "service running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'postgres))
             marionette))

          (test-assert "log-file"
            (marionette-eval
             '(begin
                (use-modules (ice-9 ftw)
                             (ice-9 match))
                (current-output-port
                 (open-file "/dev/console" "w0"))
                (let ((server-log-file
                       (string-append #$%postgresql-log-directory
                                      "/pg_ctl.log")))
                  (and (file-exists? server-log-file)
                       (display
                        (call-with-input-file server-log-file
                          get-string-all)))
                  #t))
             marionette))

          (test-assert "database ready"
            (begin
              (marionette-eval
               '(begin
                  (let loop ((i 10))
                    (unless (or (zero? i)
                                (and (file-exists? #$%role-log-file)
                                     (string-contains
                                      (call-with-input-file #$%role-log-file
                                        get-string-all)
                                      ";\nCREATE DATABASE")))
                      (sleep 1)
                      (loop (- i 1)))))
               marionette)))

          (test-assert "database creation"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd)
                             (ice-9 popen))
                (current-output-port
                 (open-file "/dev/console" "w0"))
                (let* ((port (open-pipe*
                              OPEN_READ
                              #$(file-append postgresql "/bin/psql")
                              "-tAh" "/tmp"
                              "-c" "SELECT 1 FROM pg_database WHERE
 datname='root'"))
                       (output (get-string-all port)))
                  (close-pipe port)
                  (string-contains output "1")))
             marionette))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "postgresql-test" test))

(define %test-postgresql
  (system-test
   (name "postgresql")
   (description "Start the PostgreSQL service.")
   (value (run-postgresql-test))))

;;;
;;; The MySQL service.
;;;

(define %mysql-os
  (simple-operating-system
   (service mysql-service-type)))

(define* (run-mysql-test)
  "Run tests in %MYSQL-OS."
  (define os
    (marionette-operating-system
     %mysql-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define vm
    (virtual-machine
     (operating-system os)
     (memory-size 512)))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (srfi srfi-11) (srfi srfi-64)
                       (gnu build marionette))

          (define marionette
            (make-marionette (list #$vm)))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "mysql")

          (test-assert "service running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (match (start-service 'mysql)
                  (#f #f)
                  (('service response-parts ...)
                   (match (assq-ref response-parts 'running)
                     ((pid) (number? pid))))))
             marionette))

          (test-assert "mysql_upgrade completed"
            (wait-for-file "/var/lib/mysql/mysql_upgrade_info" marionette))

          (test-eq "create database"
            0
            (marionette-eval
             '(begin
                (system* #$(file-append mariadb "/bin/mysql")
                         "-e" "CREATE DATABASE guix;"))
             marionette))

          (test-eq "create table"
            0
            (marionette-eval
             '(begin
                (system*
                 #$(file-append mariadb "/bin/mysql") "guix"
                 "-e" "CREATE TABLE facts (id INT, data VARCHAR(12));"))
             marionette))

          (test-eq "insert data"
            0
            (marionette-eval
             '(begin
                (system* #$(file-append mariadb "/bin/mysql") "guix"
                         "-e" "INSERT INTO facts VALUES (1, 'awesome')"))
             marionette))

          (test-equal "retrieve data"
            "awesome\n"
            (marionette-eval
             '(begin
                (use-modules (ice-9 popen))
                (let* ((port (open-pipe*
                              OPEN_READ
                              #$(file-append mariadb "/bin/mysql") "guix"
                              "-NB" "-e" "SELECT data FROM facts WHERE id=1;"))
                       (output (get-string-all port)))
                  (close-pipe port)
                  output))
             marionette))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "mysql-test" test))

(define %test-mysql
  (system-test
   (name "mysql")
   (description "Start the MySQL service.")
   (value (run-mysql-test))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 desktop)
  #:use-module (gnu tests)
  #:use-module (gnu services)
  #:use-module (gnu services dbus)
  #:use-module (gnu services desktop)
  #:use-module (gnu system vm)
  #:use-module (guix gexp)
  #:use-module (srfi srfi-1)
  #:export (%test-elogind))

;;;
;;; Elogind.
;;;

(define (run-elogind-test vm)
  (define test
    (with-imported-modules '((gnu build marionette)
                             (guix build syscalls))
      #~(begin
          (use-modules (gnu build marionette)
                       (guix build syscalls)
                       (srfi srfi-64))

          (define marionette
            (make-marionette '(#$vm)))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "elogind")

          ;; Log in as root on tty1, and check what 'loginctl' returns.
          (test-equal "login on tty1"
            '(("c1" "0" "root" "seat0" "tty1")      ;session
              ("seat0")                             ;seat
              ("0" "root"))                         ;user

            (begin
              ;; Wait for tty1.
              (marionette-eval
               '(begin
                  (use-modules (gnu services herd))
                  (start-service 'term-tty1))
               marionette)
              (marionette-control "sendkey ctrl-alt-f1" marionette)

              ;; Now we can type.
              (marionette-type "root\n" marionette)
              (marionette-type "loginctl list-users --no-legend > users\n"
                               marionette)
              (marionette-type "loginctl list-seats --no-legend > seats\n"
                               marionette)
              (marionette-type "loginctl list-sessions --no-legend > sessions\n"
                               marionette)

              ;; Read the three files.
              (marionette-eval '(use-modules (rnrs io ports)) marionette)
              (let ((guest-file (lambda (file)
                                  (string-tokenize
                                   (wait-for-file file marionette
                                                  #:read 'get-string-all)))))
                (list (guest-file "/root/sessions")
                      (guest-file "/root/seats")
                      (guest-file "/root/users")))))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "elogind" test))

(define %test-elogind
  (system-test
   (name "elogind")
   (description
    "Test whether we can log in when elogind is enabled, and whether
'loginctl' reports accurate user, session, and seat information.")
   (value
    (let ((os (marionette-operating-system
               (simple-operating-system
                (service elogind-service-type)
                (service polkit-service-type)
                (service dbus-root-service-type))
               #:imported-modules '((gnu services herd)
                                    (guix combinators)))))
      (run-elogind-test (virtual-machine os))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; 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 dict)
  #:use-module (gnu tests)
  #:use-module (gnu system)
  #:use-module (gnu system nss)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #:use-module (gnu services dict)
  #:use-module (gnu services networking)
  #:use-module (gnu packages wordnet)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix packages)
  #:use-module (guix modules)
  #:export (%test-dicod))

(define %dicod-os
  (simple-operating-system
   (service dhcp-client-service-type)
   (service dicod-service-type
            (dicod-configuration
             (interfaces '("0.0.0.0"))
             (handlers (list (dicod-handler
                              (name "wordnet")
                              (module "dictorg")
                              (options
                               ;; XXX: Not useful since WordNet does not
                               ;; provide DICT-formatted data?
                               (list #~(string-append "dbdir=" #$wordnet))))))
             (databases (list (dicod-database
                               (name "wordnet")
                               (complex? #t)
                               (handler "wordnet")
                               (options '("database=wn")))
                              %dicod-database:gcide))))))

(define* (run-dicod-test)
  "Run tests of 'dicod-service-type'."
  (define os
    (marionette-operating-system
     %dicod-os
     #:imported-modules
     (source-module-closure '((gnu services herd)))))

  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings '((8000 . 2628)))))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (ice-9 rdelim)
                       (ice-9 regex)
                       (srfi srfi-64)
                       (gnu build marionette))
          (define marionette
            ;; Forward the guest's DICT port to local port 8000.
            (make-marionette (list #$vm)))

          (define %dico-socket
            (socket PF_INET SOCK_STREAM 0))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "dicod")

          ;; Wait for the service to be started.
          (test-assert "service is running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'dicod))
             marionette))

          ;; Wait until dicod is actually listening.
          ;; TODO: Use a PID file instead.
          (test-assert "connect inside"
            (wait-for-tcp-port 2628 marionette))

          (test-assert "connect"
            (let ((addr (make-socket-address AF_INET INADDR_LOOPBACK 8000)))
              (connect %dico-socket addr)
              (read-line %dico-socket 'concat)))

          (test-equal "CLIENT"
            "250 ok\r\n"
            (begin
              (display "CLIENT \"GNU Guile\"\r\n" %dico-socket)
              (read-line %dico-socket 'concat)))

          (test-assert "DEFINE"
            (begin
              (display "DEFINE ! hello\r\n" %dico-socket)
              (display "QUIT\r\n" %dico-socket)
              (let ((result (read-string %dico-socket)))
                (and (string-contains result "gcide")
                     (string-contains result "hello")
                     result))))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "dicod" test))

(define %test-dicod
  (system-test
   (name "dicod")
   (description "Connect to the dicod DICT server.")
   (value (run-dicod-test))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 docker)
  #:use-module (gnu tests)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #:use-module (gnu services dbus)
  #:use-module (gnu services networking)
  #:use-module (gnu services docker)
  #:use-module (gnu services desktop)
  #:use-module ((gnu packages base) #:select (glibc))
  #:use-module (gnu packages guile)
  #:use-module (gnu packages docker)
  #:use-module (guix gexp)
  #:use-module (guix grafts)
  #:use-module (guix monads)
  #:use-module (guix packages)
  #:use-module (guix profiles)
  #:use-module (guix scripts pack)
  #:use-module (guix store)
  #:use-module (guix tests)
  #:use-module (guix build-system trivial)
  #:use-module ((guix licenses) #:prefix license:)
  #:export (%test-docker
            %test-docker-system))

(define %docker-os
  (simple-operating-system
   (service dhcp-client-service-type)
   (dbus-service)
   (polkit-service)
   (service elogind-service-type)
   (service docker-service-type)))

(define (run-docker-test docker-tarball)
  "Load DOCKER-TARBALL as Docker image and run it in a Docker container,
inside %DOCKER-OS."
  (define os
    (marionette-operating-system
     %docker-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define vm
    (virtual-machine
     (operating-system os)
     (memory-size 700)
     (disk-image-size (* 1500 (expt 2 20)))
     (port-forwardings '())))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (srfi srfi-11) (srfi srfi-64)
                       (gnu build marionette))

          (define marionette
            (make-marionette (list #$vm)))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "docker")

          (test-assert "service running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (match (start-service 'dockerd)
                  (#f #f)
                  (('service response-parts ...)
                   (match (assq-ref response-parts 'running)
                     ((pid) (number? pid))))))
             marionette))

          (test-eq "fetch version"
            0
            (marionette-eval
             `(begin
                (system* ,(string-append #$docker-cli "/bin/docker")
                         "version"))
             marionette))

          (test-equal "Load docker image and run it"
            '("hello world" "hi!" "JSON!" #o1777)
            (marionette-eval
             `(begin
                (define slurp
                  (lambda args
                    (let* ((port (apply open-pipe* OPEN_READ args))
                           (output (read-line port))
                           (status (close-pipe port)))
                      output)))
                (let* ((raw-line (slurp ,(string-append #$docker-cli
                                                        "/bin/docker")
                                                        "load" "-i"
                                                        ,#$docker-tarball))
                       (repository&tag (string-drop raw-line
                                                    (string-length
                                                     "Loaded image: ")))
                       (response1 (slurp
                                   ,(string-append #$docker-cli "/bin/docker")
                                   "run" "--entrypoint" "bin/Guile"
                                   repository&tag
                                   "/aa.scm"))
                       (response2 (slurp          ;default entry point
                                   ,(string-append #$docker-cli "/bin/docker")
                                   "run" repository&tag
                                   "-c" "(display \"hi!\")"))

                       ;; Check whether (json) is in $GUILE_LOAD_PATH.
                       (response3 (slurp    ;default entry point + environment
                                   ,(string-append #$docker-cli "/bin/docker")
                                   "run" repository&tag
                                   "-c" "(use-modules (json))
  (display (json-string->scm (scm->json-string \"JSON!\")))"))

                       ;; Check whether /tmp exists.
                       (response4 (slurp
                                   ,(string-append #$docker-cli "/bin/docker")
                                   "run" repository&tag "-c"
                                   "(display (stat:perms (lstat \"/tmp\")))")))
                  (list response1 response2 response3
                        (string->number response4))))
             marionette))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "docker-test" test))

(define (build-tarball&run-docker-test)
  (mlet* %store-monad
      ((_ (set-grafting #f))
       (guile (set-guile-for-build (default-guile)))
       (guest-script-package ->
        (package
          (name "guest-script")
          (version "0")
          (source #f)
          (build-system trivial-build-system)
          (arguments `(#:guile ,guile-3.0
                       #:builder
                       (let ((out (assoc-ref %outputs "out")))
                         (mkdir out)
                         (call-with-output-file (string-append out "/a.scm")
                           (lambda (port)
                             (display "(display \"hello world\n\")" port)))
                         #t)))
          (synopsis "Display hello world using Guile")
          (description "This package displays the text \"hello world\" on the
standard output device and then enters a new line.")
          (home-page #f)
          (license license:public-domain)))
       (profile (profile-derivation (packages->manifest
                                     (list guile-3.0 guile-json-3
                                           guest-script-package))
                                    #:hooks '()
                                    #:locales? #f))
       (tarball (docker-image "docker-pack" profile
                              #:symlinks '(("/bin/Guile" -> "bin/guile")
                                           ("aa.scm" -> "a.scm"))
                              #:entry-point "bin/guile"
                              #:localstatedir? #t)))
    (run-docker-test tarball)))

(define %test-docker
  (system-test
   (name "docker")
   (description "Test Docker container of Guix.")
   (value (build-tarball&run-docker-test))))

(define (run-docker-system-test tarball)
  "Load DOCKER-TARBALL as Docker image and run it in a Docker container,
inside %DOCKER-OS."
  (define os
    (marionette-operating-system
     %docker-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define vm
    (virtual-machine
     (operating-system os)
     ;; FIXME: Because we're using the volatile-root setup where the root file
     ;; system is a tmpfs overlaid over a small root file system, 'docker
     ;; load' must be able to store the whole image into memory, hence the
     ;; huge memory requirements.  We should avoid the volatile-root setup
     ;; instead.
     (memory-size 4500)
     (port-forwardings '())))

  (define test
    (with-imported-modules '((gnu build marionette)
                             (guix build utils))
      #~(begin
          (use-modules (srfi srfi-11) (srfi srfi-64)
                       (gnu build marionette)
                       (guix build utils))

          (define marionette
            (make-marionette (list #$vm)))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "docker")

          (test-assert "service running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (match (start-service 'dockerd)
                  (#f #f)
                  (('service response-parts ...)
                   (match (assq-ref response-parts 'running)
                     ((pid) (number? pid))))))
             marionette))

          (test-assert "load system image and run it"
            (marionette-eval
             `(begin
                (define (slurp command . args)
                  ;; Return the output from COMMAND.
                  (let* ((port (apply open-pipe* OPEN_READ command args))
                         (output (read-line port))
                         (status (close-pipe port)))
                    output))

                (define (docker-cli command . args)
                  ;; Run the given Docker COMMAND.
                  (apply invoke #$(file-append docker-cli "/bin/docker")
                         command args))

                (define (wait-for-container-file container file)
                  ;; Wait for FILE to show up in CONTAINER.
                  (docker-cli "exec" container
                              #$(file-append guile-3.0 "/bin/guile")
                              "-c"
                              (object->string
                               `(let loop ((n 15))
                                  (when (zero? n)
                                    (error "file didn't show up" ,file))
                                  (unless (file-exists? ,file)
                                    (sleep 1)
                                    (loop (- n 1)))))))

                (let* ((line (slurp #$(file-append docker-cli "/bin/docker")
                                    "load" "-i" #$tarball))
                       (repository&tag (string-drop line
                                                    (string-length
                                                     "Loaded image: ")))
                       (container (slurp
                                   #$(file-append docker-cli "/bin/docker")
                                   "create" repository&tag)))
                  (docker-cli "start" container)

                  ;; Wait for shepherd to be ready.
                  (wait-for-container-file container
                                           "/var/run/shepherd/socket")

                  (docker-cli "exec" container
                              "/run/current-system/profile/bin/herd"
                              "status")
                  (slurp #$(file-append docker-cli "/bin/docker")
                         "exec" container
                         "/run/current-system/profile/bin/herd"
                         "status" "guix-daemon")))
             marionette))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "docker-system-test" test))

(define %test-docker-system
  (system-test
   (name "docker-system")
   (description "Run a system image as produced by @command{guix system
docker-image} inside Docker.")
   (value (with-monad %store-monad
            (>>= (system-docker-image (operating-system
                                        (inherit (simple-operating-system))
                                        ;; Use locales for a single libc to
                                        ;; reduce space requirements.
                                        (locale-libcs (list glibc)))
                                      #:memory-size 1024)
                 run-docker-system-test)))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Simon South <simon@simonsouth.net>
;;;
;;; 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/>.

;;;
;;; The Transmission Daemon service.
;;;

(define-module (gnu tests file-sharing)
  #:use-module (gnu packages bittorrent)
  #:use-module (gnu services)
  #:use-module (gnu services file-sharing)
  #:use-module (gnu services networking)
  #:use-module (gnu system vm)
  #:use-module (gnu tests)
  #:use-module (guix gexp)
  #:export (%test-transmission-daemon))

(define %transmission-daemon-user "transmission")
(define %transmission-daemon-group "transmission")

(define %transmission-daemon-config-dir "/var/lib/transmission-daemon")
(define %transmission-daemon-watch-dir
  (string-append %transmission-daemon-config-dir "/watch"))
(define %transmission-daemon-incomplete-dir
  (string-append %transmission-daemon-config-dir "/incomplete"))

(define %transmission-daemon-settings-file
  (string-append %transmission-daemon-config-dir "/settings.json"))

(define %transmission-daemon-peer-port 51000) ; default is 51413

(define %transmission-daemon-rpc-port 9999)   ; default is 9091
(define %transmission-daemon-rpc-username "test-username")
(define %transmission-daemon-rpc-password "test-password")

(define %transmission-daemon-test-configuration
  (transmission-daemon-configuration
   (incomplete-dir-enabled? #t)
   (incomplete-dir %transmission-daemon-incomplete-dir)

   (watch-dir-enabled? #t)
   (watch-dir %transmission-daemon-watch-dir)

   (peer-port-random-on-start? #f)
   (peer-port %transmission-daemon-peer-port)

   (rpc-enabled? #t)
   (rpc-port %transmission-daemon-rpc-port)
   (rpc-whitelist-enabled? #f)
   (rpc-authentication-required? #t)
   (rpc-username %transmission-daemon-rpc-username)
   (rpc-password (transmission-password-hash %transmission-daemon-rpc-password
                                             "yEK0q3.X"))))

(define (run-transmission-daemon-test)
  (define os
    (marionette-operating-system
     (simple-operating-system
      (service dhcp-client-service-type)
      (service transmission-daemon-service-type
               %transmission-daemon-test-configuration))
     #:imported-modules '((gnu services herd)
                          (json parser))
     #:requirements '(transmission-daemon)))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette)
                       (srfi srfi-64))

          (define marionette
            (make-marionette
             (list #$(virtual-machine
                      (operating-system os)
                      (port-forwardings
                       `((9091 . ,%transmission-daemon-rpc-port)))))))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "transmission-daemon")

          ;; Make sure the "transmission" user and group have been created.
          (test-assert "\"transmission\" user exists"
            (marionette-eval
             '(begin
                (getpwnam #$%transmission-daemon-user)
                #t)
             marionette))
          (test-assert "\"transmission\" group exists"
            (marionette-eval
             '(begin
                (getgrnam #$%transmission-daemon-group)
                #t)
             marionette))

          ;; Make sure Transmission Daemon's configuration directory has been
          ;; created with the correct ownership and permissions.
          (test-assert "configuration directory exists"
            (marionette-eval
             '(eq? (stat:type (stat #$%transmission-daemon-config-dir))
                   'directory)
             marionette))
          (test-assert "configuration directory has correct ownership"
            (marionette-eval
             '(let ((config-dir (stat #$%transmission-daemon-config-dir))
                    (transmission-user (getpwnam #$%transmission-daemon-user)))
                (and (eqv? (stat:uid config-dir)
                           (passwd:uid transmission-user))
                     (eqv? (stat:gid config-dir)
                           (passwd:gid transmission-user))))
             marionette))
          (test-assert "configuration directory has expected permissions"
            (marionette-eval
             '(eqv? (stat:perms (stat #$%transmission-daemon-config-dir))
                    #o750)
             marionette))

          ;; Make sure the incomplete-downloads and watch directories have been
          ;; created with the correct ownership and permissions.
          (test-assert "incomplete-downloads directory exists"
            (marionette-eval
             '(eq? (stat:type (stat #$%transmission-daemon-incomplete-dir))
                   'directory)
             marionette))
          (test-assert "incomplete-downloads directory has correct ownership"
            (marionette-eval
             '(let ((incomplete-dir
                     (stat #$%transmission-daemon-incomplete-dir))
                    (transmission-user
                     (getpwnam #$%transmission-daemon-user)))
                (and (eqv? (stat:uid incomplete-dir)
                           (passwd:uid transmission-user))
                     (eqv? (stat:gid incomplete-dir)
                           (passwd:gid transmission-user))))
             marionette))
          (test-assert
              "incomplete-downloads directory has expected permissions"
            (marionette-eval
             '(eqv? (stat:perms (stat #$%transmission-daemon-incomplete-dir))
                    #o750)
             marionette))

          (test-assert "watch directory exists"
            (marionette-eval
             '(eq? (stat:type (stat #$%transmission-daemon-watch-dir))
                   'directory)
             marionette))
          (test-assert "watch directory has correct ownership"
            (marionette-eval
             '(let ((watch-dir (stat #$%transmission-daemon-watch-dir))
                    (transmission-user (getpwnam #$%transmission-daemon-user)))
                (and (eqv? (stat:uid watch-dir)
                           (passwd:uid transmission-user))
                     (eqv? (stat:gid watch-dir)
                           (passwd:gid transmission-user))))
             marionette))
          (test-assert "watch directory has expected permissions"
            (marionette-eval
             '(eqv? (stat:perms (stat #$%transmission-daemon-watch-dir))
                    #o770)
             marionette))

          ;; Make sure the settings file has been created and appears valid.
          (test-assert "settings file exists"
            (marionette-eval
             '(file-exists? #$%transmission-daemon-settings-file)
             marionette))
          (test-assert "settings file is valid JSON"
            (marionette-eval
             '(begin
                (use-modules (json parser))
                (with-input-from-file #$%transmission-daemon-settings-file
                  (lambda ()
                    (json->scm)))
                #t)
             marionette))
          (test-assert "settings file contains a non-empty JSON object"
            (marionette-eval
             '(begin
                (use-modules (json parser)
                             (srfi srfi-1))
                (let ((settings (with-input-from-file
                                    #$%transmission-daemon-settings-file
                                  (lambda ()
                                    (json->scm)))))
                  (and (list? settings)
                       (not (null? settings))
                       (every pair? settings))))
             marionette))

          ;; Make sure Transmission Daemon is running.
          (test-assert "transmission-daemon is running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (live-service-running
                 (find (lambda (live-service)
                         (memq 'transmission-daemon
                               (live-service-provision live-service)))
                       (current-services))))
             marionette))

          ;; Make sure the daemon is listening for peer connections.
          (test-assert "transmission-daemon is listening for peers"
            (wait-for-tcp-port #$%transmission-daemon-peer-port marionette))

          ;; Make sure the daemon is listening for RPC-client connections.
          (test-assert "transmission-daemon is listening for RPC clients"
            (wait-for-tcp-port #$%transmission-daemon-rpc-port marionette))

          ;; Make sure the RPC-authentication settings are honored.
          (test-assert "transmission-daemon requires RPC authentication"
            (let ((transmission-remote
                   (string-append #+transmission "/bin/transmission-remote")))
              (with-error-to-port (%make-void-port "w")
                (lambda ()
                  (not (zero? (system* transmission-remote
                                       "--session-info")))))))
          (test-assert "transmission-daemon rejects incorrect RPC credentials"
            (let ((transmission-remote
                   (string-append #+transmission "/bin/transmission-remote"))
                  (wrong-auth-string
                   (string-append #$%transmission-daemon-rpc-username
                                  ":"
                                  "wrong-"
                                  #$%transmission-daemon-rpc-password)))
              (with-error-to-port (%make-void-port "w")
                (lambda ()
                  (not (zero? (system* transmission-remote
                                       "--auth" wrong-auth-string
                                       "--session-info")))))))
          (test-assert "transmission-daemon accepts correct RPC credentials"
            (let ((transmission-remote
                   (string-append #+transmission "/bin/transmission-remote"))
                  (auth-string
                   (string-append #$%transmission-daemon-rpc-username
                                  ":"
                                  #$%transmission-daemon-rpc-password)))
              (with-output-to-port (%make-void-port "w")
                (lambda ()
                  (zero? (system* transmission-remote
                                  "--auth" auth-string
                                  "--session-info"))))))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "transmission-daemon-test" test))

(define %test-transmission-daemon
  (system-test
   (name "transmission-daemon")
   (description "Test a running Transmission Daemon service.")
   (value (run-transmission-daemon-test))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Marius Bakke <marius@gnu.org>.
;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
;;;
;;; 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 ganeti)
  #:use-module (gnu)
  #:use-module (gnu tests)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #:use-module (gnu services ganeti)
  #:use-module (gnu services networking)
  #:use-module (gnu services ssh)
  #:use-module (gnu packages virtualization)
  #:use-module (guix gexp)
  #:use-module (ice-9 format)
  #:export (%test-ganeti-kvm %test-ganeti-lxc))

(define %ganeti-os
  (operating-system
    (host-name "gnt1")
    (timezone "Etc/UTC")
    (locale "en_US.UTF-8")

    (bootloader (bootloader-configuration
                 (bootloader grub-bootloader)
                 (target "/dev/vda")))
    (file-systems (cons (file-system
                          (device (file-system-label "my-root"))
                          (mount-point "/")
                          (type "ext4"))
                        %base-file-systems))
    (firmware '())

    ;; The hosts file must contain a nonlocal IP for host-name.
    ;; In addition, the cluster name must resolve to an IP address that
    ;; is not currently provisioned.
    (hosts-file (plain-file "hosts" (format #f "
127.0.0.1       localhost
::1             localhost
10.0.2.2        gnt1.example.com gnt1
192.168.254.254 ganeti.example.com
")))

    (packages (append (list ganeti-instance-debootstrap ganeti-instance-guix)
                      %base-packages))
    (services
     (append (list (static-networking-service "eth0" "10.0.2.2"
                                              #:netmask "255.255.255.0"
                                              #:gateway "10.0.2.1"
                                              #:name-servers '("10.0.2.1"))

                   (service openssh-service-type
                            (openssh-configuration
                             (permit-root-login 'prohibit-password)))

                   (service ganeti-service-type
                            (ganeti-configuration
                             (file-storage-paths '("/srv/ganeti/file-storage"))
                             (rapi-configuration
                              (ganeti-rapi-configuration
                               ;; Disable TLS so we can test the RAPI without
                               ;; pulling in GnuTLS.
                               (ssl? #f)))
                             (os %default-ganeti-os))))
             %base-services))))

(define* (run-ganeti-test hypervisor #:key
                          (master-netdev "eth0")
                          (hvparams '())
                          (extra-packages '())
                          (rapi-port 5080)
                          (noded-port 1811))
  "Run tests in %GANETI-OS."
  (define os
    (marionette-operating-system
     (operating-system
       (inherit %ganeti-os)
       (packages (append extra-packages
                         (operating-system-packages %ganeti-os))))
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define %forwarded-rapi-port 5080)
  (define %forwarded-noded-port 1811)

  (define vm
    (virtual-machine
     (operating-system os)
     ;; Some of the daemons are fairly memory-hungry.
     (memory-size 512)
     ;; Forward HTTP ports so we can access them from the "outside".
     (port-forwardings `((,%forwarded-rapi-port . ,rapi-port)
                         (,%forwarded-noded-port . ,noded-port)))))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (srfi srfi-11) (srfi srfi-64)
                       (web uri) (web client) (web response)
                       (gnu build marionette))

          (define marionette
            (make-marionette (list #$vm)))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "ganeti")

          ;; Ganeti uses the Shepherd to start/stop daemons, so make sure
          ;; it is ready before we begin.  It takes a while because all
          ;; Ganeti daemons fail to start initially.
          (test-assert "shepherd is ready"
            (wait-for-unix-socket "/var/run/shepherd/socket" marionette))

          (test-eq "gnt-cluster init"
            0
            (marionette-eval
             '(begin
                (setenv
                 "PATH"
                 ;; Init needs to run 'ssh-keygen', 'ip', etc.
                 "/run/current-system/profile/sbin:/run/current-system/profile/bin")
                (system* #$(file-append ganeti "/sbin/gnt-cluster") "init"
                         (string-append "--master-netdev=" #$master-netdev)
                         ;; TODO: Enable more disk backends.
                         "--enabled-disk-templates=file"
                         (string-append "--enabled-hypervisors="
                                        #$hypervisor)
                         (string-append "--hypervisor-parameters="
                                        #$hypervisor ":"
                                        (string-join '#$hvparams "\n"))
                         ;; Set the default NIC mode to 'routed' to avoid having to
                         ;; configure a full bridge to placate 'gnt-cluster verify'.
                         "--nic-parameters=mode=routed,link=eth0"
                         "ganeti.example.com"))
             marionette))

          ;; Disable the watcher while doing daemon tests to prevent interference.
          (test-eq "watcher pause"
            0
            (marionette-eval
             '(begin
                (system* #$(file-append ganeti "/sbin/gnt-cluster")
                         "watcher" "pause" "1h"))
             marionette))

          (test-assert "force-start wconfd"
            ;; Check that the 'force-start' Shepherd action works, used in a
            ;; master-failover scenario.
            (marionette-eval
             '(begin
                (setenv "PATH" "/run/current-system/profile/bin")
                (invoke "herd" "stop" "ganeti-wconfd")
                (invoke "herd" "disable" "ganeti-wconfd")
                (invoke "herd" "force-start" "ganeti-wconfd"))
             marionette))

          ;; Verify that the cluster is healthy.
          (test-eq "gnt-cluster verify 1"
            0
            (marionette-eval
             '(begin
                (system* #$(file-append ganeti "/sbin/gnt-cluster") "verify"))
             marionette))

          ;; Try stopping and starting daemons with daemon-util like
          ;; 'gnt-node add', 'gnt-cluster init', etc.
          (test-eq "daemon-util stop-all"
            0
            (marionette-eval
             '(begin
                (system* #$(file-append ganeti "/lib/ganeti/daemon-util")
                         "stop-all"))
             marionette))

          (test-eq "daemon-util start-all"
            0
            (marionette-eval
             '(begin
                (system* #$(file-append ganeti "/lib/ganeti/daemon-util")
                         "start-all"))
             marionette))

          ;; Check that the cluster is still healthy after the daemon restarts.
          (test-eq "gnt-cluster verify 2"
            0
            (marionette-eval
             '(begin
                (system* #$(file-append ganeti "/sbin/gnt-cluster") "verify"))
             marionette))

          (test-eq "watcher continue"
            0
            (marionette-eval
             '(begin
                (system* #$(file-append ganeti "/sbin/gnt-cluster")
                         "watcher" "continue"))
             marionette))

          ;; Try accessing the RAPI.  This causes an expected failure:
          ;;   https://github.com/ganeti/ganeti/issues/1502
          ;; Run it anyway for easy testing of potential fixes.
          (test-equal "http-get RAPI version"
            '(200 "2")
            (let-values
                (((response text)
                  (http-get #$(simple-format
                               #f "http://localhost:~A/version"
                               %forwarded-rapi-port)
                            #:decode-body? #t)))
              (list (response-code response) text)))

          (test-equal "gnt-os list"
            "debootstrap+default\nguix+default\n"
            (marionette-eval
             '(begin
                (use-modules (ice-9 popen))
                (let* ((port (open-pipe*
                              OPEN_READ
                              #$(file-append ganeti "/sbin/gnt-os")
                              "list" "--no-headers"))
                       (output (get-string-all port)))
                  (close-pipe port)
                  output))
             marionette))

          (test-eq "gnt-cluster destroy"
            0
            (marionette-eval
             '(begin
                (system* #$(file-append ganeti "/sbin/gnt-cluster")
                         "destroy" "--yes-do-it"))
             marionette))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 1)))))

  (gexp->derivation (string-append "ganeti-" hypervisor "-test") test))

(define %test-ganeti-kvm
  (system-test
   (name "ganeti-kvm")
   (description "Provision a Ganeti cluster using the KVM hypervisor.")
   (value (run-ganeti-test "kvm"
                           ;; Set kernel_path to an empty string to prevent
                           ;; 'gnt-cluster verify' from testing for its presence.
                           #:hvparams '("kernel_path=")
                           #:extra-packages (list qemu)))))

(define %test-ganeti-lxc
  (system-test
   (name "ganeti-lxc")
   (description "Provision a Ganeti cluster using LXC as the hypervisor.")
   (value (run-ganeti-test "lxc"
                           #:extra-packages (list lxc)))))