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" "/dev/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
   (dhcp-client-service)
   (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))))

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; 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 install)
  #:use-module (gnu)
  #:use-module (gnu bootloader extlinux)
  #:use-module (gnu tests)
  #:use-module (gnu tests base)
  #:use-module (gnu system)
  #:use-module (gnu system install)
  #:use-module (gnu system vm)
  #:use-module ((gnu build vm) #:select (qemu-command))
  #:use-module (gnu packages bootloaders)
  #:use-module (gnu packages ocr)
  #:use-module (gnu packages package-management)
  #:use-module (gnu packages virtualization)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix packages)
  #:use-module (guix grafts)
  #:use-module (guix gexp)
  #:use-module (guix utils)
  #:export (%test-installed-os
            %test-installed-extlinux-os
            %test-iso-image-installer
            %test-separate-store-os
            %test-separate-home-os
            %test-raid-root-os
            %test-encrypted-os
            %test-btrfs-root-os))

;;; Commentary:
;;;
;;; Test the installation of GuixSD using the documented approach at the
;;; command line.
;;;
;;; Code:

(define-os-with-source (%minimal-os %minimal-os-source)
  ;; The OS we want to install.
  (use-modules (gnu) (gnu tests) (srfi srfi-1))

  (operating-system
    (host-name "liberigilo")
    (timezone "Europe/Paris")
    (locale "en_US.UTF-8")

    (bootloader (bootloader-configuration
                 (bootloader grub-bootloader)
                 (target "/dev/vdb")))
    (kernel-arguments '("console=ttyS0"))
    (file-systems (cons (file-system
                          (device (file-system-label "my-root"))
                          (mount-point "/")
                          (type "ext4"))
                        %base-file-systems))
    (users (cons (user-account
                  (name "alice")
                  (comment "Bob's sister")
                  (group "users")
                  (supplementary-groups '("wheel" "audio" "video"))
                  (home-directory "/home/alice"))
                 %base-user-accounts))
    (services (cons (service marionette-service-type
                             (marionette-configuration
                              (imported-modules '((gnu services herd)
                                                  (guix combinators)))))
                    %base-services))))

(define (operating-system-add-packages os packages)
  "Append PACKAGES to OS packages list."
  (operating-system
    (inherit os)
    (packages (append packages (operating-system-packages os)))))

(define-os-with-source (%minimal-extlinux-os
                        %minimal-extlinux-os-source)
  (use-modules (gnu) (gnu tests) (gnu bootloader extlinux)
               (srfi srfi-1))

  (operating-system
    (host-name "liberigilo")
    (timezone "Europe/Paris")
    (locale "en_US.UTF-8")

    (bootloader (bootloader-configuration
                 (bootloader extlinux-bootloader-gpt)
                 (target "/dev/vdb")))
    (kernel-arguments '("console=ttyS0"))
    (file-systems (cons (file-system
                          (device (file-system-label "my-root"))
                          (mount-point "/")
                          (type "ext4"))
                        %base-file-systems))
    (services (cons (service marionette-service-type
                             (marionette-configuration
                              (imported-modules '((gnu services herd)
                                                  (guix combinators)))))
                    %base-services))))

(define (operating-system-with-current-guix os)
  "Return a variant of OS that uses the current Guix."
  (operating-system
    (inherit os)
    (services (modify-services (operating-system-user-services os)
                (guix-service-type config =>
                                   (guix-configuration
                                    (inherit config)
                                    (guix (current-guix))))))))

(define (operating-system-with-gc-roots os roots)
  "Return a variant of OS where ROOTS are registered as GC roots."
  (operating-system
    (inherit os)

    ;; We use this procedure for the installation OS, which already defines GC
    ;; roots.  Add ROOTS to those.
    (services (cons (simple-service 'extra-root
                                    gc-root-service-type roots)
                    (operating-system-user-services os)))))

(define MiB (expt 2 20))

(define %simple-installation-script
  ;; Shell script of a simple installation.
  "\
. /etc/profile
set -e -x
guix --version

export GUIX_BUILD_OPTIONS=--no-grafts
guix build isc-dhcp
parted --script /dev/vdb mklabel gpt \\
  mkpart primary ext2 1M 3M \\
  mkpart primary ext2 3M 1G \\
  set 1 boot on \\
  set 1 bios_grub on
mkfs.ext4 -L my-root /dev/vdb2
mount /dev/vdb2 /mnt
df -h /mnt
herd start cow-store /mnt
mkdir /mnt/etc
cp /etc/target-config.scm /mnt/etc/config.scm
guix system init /mnt/etc/config.scm /mnt --no-substitutes
sync
reboot\n")

(define %extlinux-gpt-installation-script
  ;; Shell script of a simple installation.
  ;; As syslinux 6.0.3 does not handle 64bits ext4 partitions,
  ;; we make sure to pass -O '^64bit' to mkfs.
  "\
. /etc/profile
set -e -x
guix --version

export GUIX_BUILD_OPTIONS=--no-grafts
guix build isc-dhcp
parted --script /dev/vdb mklabel gpt \\
  mkpart ext2 1M 1G \\
  set 1 legacy_boot on
mkfs.ext4 -L my-root -O '^64bit' /dev/vdb1
mount /dev/vdb1 /mnt
df -h /mnt
herd start cow-store /mnt
mkdir /mnt/etc
cp /etc/target-config.scm /mnt/etc/config.scm
guix system init /mnt/etc/config.scm /mnt --no-substitutes
sync
reboot\n")

(define* (run-install target-os target-os-source
                      #:key
                      (script %simple-installation-script)
                      (packages '())
                      (os (marionette-operating-system
                           (operating-system
                             ;; Since the image has no network access, use the
                             ;; current Guix so the store items we need are in
                             ;; the image and add packages provided.
                             (inherit (operating-system-add-packages
                                       (operating-system-with-current-guix
                                        installation-os)
                                       packages))
                             (kernel-arguments '("console=ttyS0")))
                           #:imported-modules '((gnu services herd)
                                                (guix combinators))))
                      (installation-disk-image-file-system-type "ext4")
                      (target-size (* 2200 MiB)))
  "Run SCRIPT (a shell script following the GuixSD installation procedure) in
OS to install TARGET-OS.  Return a VM image of TARGET-SIZE bytes containing
the installed system.  The packages specified in PACKAGES will be appended to
packages defined in installation-os."

  (mlet* %store-monad ((_      (set-grafting #f))
                       (system (current-system))
                       (target (operating-system-derivation target-os))

                       ;; Since the installation system has no network access,
                       ;; we cheat a little bit by adding TARGET to its GC
                       ;; roots.  This way, we know 'guix system init' will
                       ;; succeed.
                       (image  (system-disk-image
                                (operating-system-with-gc-roots
                                 os (list target))
                                #:disk-image-size 'guess
                                #:file-system-type
                                installation-disk-image-file-system-type)))
    (define install
      (with-imported-modules '((guix build utils)
                               (gnu build marionette))
        #~(begin
            (use-modules (guix build utils)
                         (gnu build marionette))

            (set-path-environment-variable "PATH" '("bin")
                                           (list #$qemu-minimal))

            (system* "qemu-img" "create" "-f" "qcow2"
                     #$output #$(number->string target-size))

            (define marionette
              (make-marionette
               `(,(which #$(qemu-command system))
                 "-no-reboot"
                 "-m" "800"
                 #$@(cond
                     ((string=? "ext4" installation-disk-image-file-system-type)
                      #~("-drive"
                         ,(string-append "file=" #$image
                                         ",if=virtio,readonly")))
                     ((string=? "iso9660" installation-disk-image-file-system-type)
                      #~("-cdrom" #$image))
                     (else
                      (error
                       "unsupported installation-disk-image-file-system-type:"
                       installation-disk-image-file-system-type)))
                 "-drive"
                 ,(string-append "file=" #$output ",if=virtio")
                 ,@(if (file-exists? "/dev/kvm")
                       '("-enable-kvm")
                       '()))))

            (pk 'uname (marionette-eval '(uname) marionette))

            ;; Wait for tty1.
            (marionette-eval '(begin
                                (use-modules (gnu services herd))
                                (start 'term-tty1))
                             marionette)

            (marionette-eval '(call-with-output-file "/etc/target-config.scm"
                                (lambda (port)
                                  (write '#$target-os-source port)))
                             marionette)

            (exit (marionette-eval '(zero? (system #$script))
                                   marionette)))))

    (gexp->derivation "installation" install)))

(define* (qemu-command/writable-image image #:key (memory-size 256))
  "Return as a monadic value the command to run QEMU on a writable copy of
IMAGE, a disk image.  The QEMU VM is has access to MEMORY-SIZE MiB of RAM."
  (mlet %store-monad ((system (current-system)))
    (return #~(let ((image #$image))
                ;; First we need a writable copy of the image.
                (format #t "creating writable image from '~a'...~%" image)
                (unless (zero? (system* #+(file-append qemu-minimal
                                                       "/bin/qemu-img")
                                        "create" "-f" "qcow2"
                                        "-o"
                                        (string-append "backing_file=" image)
                                        "disk.img"))
                  (error "failed to create writable QEMU image" image))

                (chmod "disk.img" #o644)
                `(,(string-append #$qemu-minimal "/bin/"
                                  #$(qemu-command system))
                  ,@(if (file-exists? "/dev/kvm")
                        '("-enable-kvm")
                        '())
                  "-no-reboot" "-m" #$(number->string memory-size)
                  "-drive" "file=disk.img,if=virtio")))))

(define %test-installed-os
  (system-test
   (name "installed-os")
   (description
    "Test basic functionality of an OS installed like one would do by hand.
This test is expensive in terms of CPU and storage usage since we need to
build (current-guix) and then store a couple of full system images.")
   (value
    (mlet* %store-monad ((image   (run-install %minimal-os %minimal-os-source))
                         (command (qemu-command/writable-image image)))
      (run-basic-test %minimal-os command
                      "installed-os")))))

(define %test-installed-extlinux-os
  (system-test
   (name "installed-extlinux-os")
   (description
    "Test basic functionality of an OS booted with an extlinux bootloader.  As
per %test-installed-os, this test is expensive in terms of CPU and storage.")
   (value
    (mlet* %store-monad ((image (run-install %minimal-extlinux-os
                                             %minimal-extlinux-os-source
                                             #:packages
                                             (list syslinux)
                                             #:script
                                             %extlinux-gpt-installation-script))
                         (command (qemu-command/writable-image image)))
      (run-basic-test %minimal-extlinux-os command
                      "installed-extlinux-os")))))

;;;
;;; Installation through an ISO image.
;;;

(define-os-with-source (%minimal-os-on-vda %minimal-os-on-vda-source)
  ;; The OS we want to install.
  (use-modules (gnu) (gnu tests) (srfi srfi-1))

  (operating-system
    (host-name "liberigilo")
    (timezone "Europe/Paris")
    (locale "en_US.UTF-8")

    (bootloader (bootloader-configuration
                 (bootloader grub-bootloader)
                 (target "/dev/vda")))
    (kernel-arguments '("console=ttyS0"))
    (file-systems (cons (file-system
                          (device (file-system-label "my-root"))
                          (mount-point "/")
                          (type "ext4"))
                        %base-file-systems))
    (users (cons (user-account
                  (name "alice")
                  (comment "Bob's sister")
                  (group "users")
                  (supplementary-groups '("wheel" "audio" "video"))
                  (home-directory "/home/alice"))
                 %base-user-accounts))
    (services (cons (service marionette-service-type
                             (marionette-configuration
                              (imported-modules '((gnu services herd)
                                                  (guix combinators)))))
                    %base-services))))

(define %simple-installation-script-for-/dev/vda
  ;; Shell script of a simple installation.
  "\
. /etc/profile
set -e -x
guix --version

export GUIX_BUILD_OPTIONS=--no-grafts
guix build isc-dhcp
parted --script /dev/vda mklabel gpt \\
  mkpart primary ext2 1M 3M \\
  mkpart primary ext2 3M 1G \\
  set 1 boot on \\
  set 1 bios_grub on
mkfs.ext4 -L my-root /dev/vda2
mount /dev/vda2 /mnt
df -h /mnt
herd start cow-store /mnt
mkdir /mnt/etc
cp /etc/target-config.scm /mnt/etc/config.scm
guix system init /mnt/etc/config.scm /mnt --no-substitutes
sync
reboot\n")

(define %test-iso-image-installer
  (system-test
   (name "iso-image-installer")
   (description
    "")
   (value
    (mlet* %store-monad ((image   (run-install
                                   %minimal-os-on-vda
                                   %minimal-os-on-vda-source
                                   #:script
                                   %simple-installation-script-for-/dev/vda
                                   #:installation-disk-image-file-system-type
                                   "iso9660"))
                         (command (qemu-command/writable-image image)))
      (run-basic-test %minimal-os-on-vda command name)))))

;;;
;;; Separate /home.
;;;

(define-os-with-source (%separate-home-os %separate-home-os-source)
  ;; The OS we want to install.
  (use-modules (gnu) (gnu tests) (srfi srfi-1))

  (operating-system
    (host-name "liberigilo")
    (timezone "Europe/Paris")
    (locale "en_US.utf8")

    (bootloader (bootloader-configuration
                 (bootloader grub-bootloader)
                 (target "/dev/vdb")))
    (kernel-arguments '("console=ttyS0"))
    (file-systems (cons* (file-system
                           (device (file-system-label "my-root"))
                           (mount-point "/")
                           (type "ext4"))
                         (file-system
                           (device "none")
                           (type "tmpfs")
                           (mount-point "/home")
                           (type "tmpfs"))
                         %base-file-systems))
    (users (cons* (user-account
                   (name "alice")
                   (group "users")
                   (home-directory "/home/alice"))
                  (user-account
                   (name "charlie")
                   (group "users")
                   (home-directory "/home/charlie"))
                  %base-user-accounts))
    (services (cons (service marionette-service-type
                             (marionette-configuration
                              (imported-modules '((gnu services herd)
                                                  (guix combinators)))))
                    %base-services))))

(define %test-separate-home-os
  (system-test
   (name "separate-home-os")
   (description
    "Test basic functionality of an installed OS with a separate /home
partition.  In particular, home directories must be correctly created (see
<https://bugs.gnu.org/21108>).")
   (value
    (mlet* %store-monad ((image   (run-install %separate-home-os
                                               %separate-home-os-source
                                               #:script
                                               %simple-installation-script))
                         (command (qemu-command/writable-image image)))
      (run-basic-test %separate-home-os command "separate-home-os")))))

;;;
;;; Separate /gnu/store partition.
;;;

(define-os-with-source (%separate-store-os %separate-store-os-source)
  ;; The OS we want to install.
  (use-modules (gnu) (gnu tests) (srfi srfi-1))

  (operating-system
    (host-name "liberigilo")
    (timezone "Europe/Paris")
    (locale "en_US.UTF-8")

    (bootloader (bootloader-configuration
                 (bootloader grub-bootloader)
                 (target "/dev/vdb")))
    (kernel-arguments '("console=ttyS0"))
    (file-systems (cons* (file-system
                           (device (file-system-label "root-fs"))
                           (mount-point "/")
                           (type "ext4"))
                         (file-system
                           (device (file-system-label "store-fs"))
                           (mount-point "/gnu")
                           (type "ext4"))
                         %base-file-systems))
    (users %base-user-accounts)
    (services (cons (service marionette-service-type
                             (marionette-configuration
                              (imported-modules '((gnu services herd)
                                                  (guix combinators)))))
                    %base-services))))

(define %separate-store-installation-script
  ;; Installation with a separate /gnu partition.
  "\
. /etc/profile
set -e -x
guix --version

export GUIX_BUILD_OPTIONS=--no-grafts
guix build isc-dhcp
parted --script /dev/vdb mklabel gpt \\
  mkpart primary ext2 1M 3M \\
  mkpart primary ext2 3M 100M \\
  mkpart primary ext2 100M 1G \\
  set 1 boot on \\
  set 1 bios_grub on
mkfs.ext4 -L root-fs /dev/vdb2
mkfs.ext4 -L store-fs /dev/vdb3
mount /dev/vdb2 /mnt
mkdir /mnt/gnu
mount /dev/vdb3 /mnt/gnu
df -h /mnt
herd start cow-store /mnt
mkdir /mnt/etc
cp /etc/target-config.scm /mnt/etc/config.scm
guix system init /mnt/etc/config.scm /mnt --no-substitutes
sync
reboot\n")

(define %test-separate-store-os
  (system-test
   (name "separate-store-os")
   (description
    "Test basic functionality of an OS installed like one would do by hand,
where /gnu lives on a separate partition.")
   (value
    (mlet* %store-monad ((image   (run-install %separate-store-os
                                               %separate-store-os-source
                                               #:script
                                               %separate-store-installation-script))
                         (command (qemu-command/writable-image image)))
      (run-basic-test %separate-store-os command "separate-store-os")))))

;;;
;;; RAID root device.
;;;

(define-os-with-source (%raid-root-os %raid-root-os-source)
  ;; An OS whose root partition is a RAID partition.
  (use-modules (gnu) (gnu tests))

  (operating-system
    (host-name "raidified")
    (timezone "Europe/Paris")
    (locale "en_US.utf8")

    (bootloader (bootloader-configuration
                 (bootloader grub-bootloader)
                 (target "/dev/vdb")))
    (kernel-arguments '("console=ttyS0"))

    ;; Add a kernel module for RAID-0 (aka. "stripe").
    (initrd-modules (cons "raid0" %base-initrd-modules))

    (mapped-devices (list (mapped-device
                           (source (list "/dev/vda2" "/dev/vda3"))
                           (target "/dev/md0")
                           (type raid-device-mapping))))
    (file-systems (cons (file-system
                          (device (file-system-label "root-fs"))
                          (mount-point "/")
                          (type "ext4")
                          (dependencies mapped-devices))
                        %base-file-systems))
    (users %base-user-accounts)
    (services (cons (service marionette-service-type
                             (marionette-configuration
                              (imported-modules '((gnu services herd)
                                                  (guix combinators)))))
                    %base-services))))

(define %raid-root-installation-script
  ;; Installation with a separate /gnu partition.  See
  ;; <https://raid.wiki.kernel.org/index.php/RAID_setup> for more on RAID and
  ;; mdadm.
  "\
. /etc/profile
set -e -x
guix --version

export GUIX_BUILD_OPTIONS=--no-grafts
parted --script /dev/vdb mklabel gpt \\
  mkpart primary ext2 1M 3M \\
  mkpart primary ext2 3M 600M \\
  mkpart primary ext2 600M 1200M \\
  set 1 boot on \\
  set 1 bios_grub on
mdadm --create /dev/md0 --verbose --level=stripe --raid-devices=2 \\
  /dev/vdb2 /dev/vdb3
mkfs.ext4 -L root-fs /dev/md0
mount /dev/md0 /mnt
df -h /mnt
herd start cow-store /mnt
mkdir /mnt/etc
cp /etc/target-config.scm /mnt/etc/config.scm
guix system init /mnt/etc/config.scm /mnt --no-substitutes
sync
reboot\n")

(define %test-raid-root-os
  (system-test
   (name "raid-root-os")
   (description
    "Test functionality of an OS installed with a RAID root partition managed
by 'mdadm'.")
   (value
    (mlet* %store-monad ((image   (run-install %raid-root-os
                                               %raid-root-os-source
                                               #:script
                                               %raid-root-installation-script
                                               #:target-size (* 1300 MiB)))
                         (command (qemu-command/writable-image image)))
      (run-basic-test %raid-root-os
                      `(,@command) "raid-root-os")))))

;;;
;;; LUKS-encrypted root file system.
;;;

(define-os-with-source (%encrypted-root-os %encrypted-root-os-source)
  ;; The OS we want to install.
  (use-modules (gnu) (gnu tests) (srfi srfi-1))

  (operating-system
    (host-name "liberigilo")
    (timezone "Europe/Paris")
    (locale "en_US.UTF-8")

    (bootloader (bootloader-configuration
                 (bootloader grub-bootloader)
                 (target "/dev/vdb")))

    ;; Note: Do not pass "console=ttyS0" so we can use our passphrase prompt
    ;; detection logic in 'enter-luks-passphrase'.

    (mapped-devices (list (mapped-device
                           (source (uuid "12345678-1234-1234-1234-123456789abc"))
                           (target "the-root-device")
                           (type luks-device-mapping))))
    (file-systems (cons (file-system
                          (device "/dev/mapper/the-root-device")
                          (mount-point "/")
                          (type "ext4"))
                        %base-file-systems))
    (users (cons (user-account
                  (name "charlie")
                  (group "users")
                  (home-directory "/home/charlie")
                  (supplementary-groups '("wheel" "audio" "video")))
                 %base-user-accounts))
    (services (cons (service marionette-service-type
                             (marionette-configuration
                              (imported-modules '((gnu services herd)
                                                  (guix combinators)))))
                    %base-services))))

(define %encrypted-root-installation-script
  ;; Shell script of a simple installation.
  "\
. /etc/profile
set -e -x
guix --version

export GUIX_BUILD_OPTIONS=--no-grafts
ls -l /run/current-system/gc-roots
parted --script /dev/vdb mklabel gpt \\
  mkpart primary ext2 1M 3M \\
  mkpart primary ext2 3M 1G \\
  set 1 boot on \\
  set 1 bios_grub on
echo -n thepassphrase | \\
  cryptsetup luksFormat --uuid=12345678-1234-1234-1234-123456789abc -q /dev/vdb2 -
echo -n thepassphrase | \\
  cryptsetup open --type luks --key-file - /dev/vdb2 the-root-device
mkfs.ext4 -L my-root /dev/mapper/the-root-device
mount LABEL=my-root /mnt
herd start cow-store /mnt
mkdir /mnt/etc
cp /etc/target-config.scm /mnt/etc/config.scm
guix system build /mnt/etc/config.scm
guix system init /mnt/etc/config.scm /mnt --no-substitutes
sync
reboot\n")

(define (enter-luks-passphrase marionette)
  "Return a gexp to be inserted in the basic system test running on MARIONETTE
to enter the LUKS passphrase."
  (let ((ocrad (file-append ocrad "/bin/ocrad")))
    #~(begin
        (define (passphrase-prompt? text)
          (string-contains (pk 'screen-text text) "Enter pass"))

        (define (bios-boot-screen? text)
          ;; Return true if TEXT corresponds to the boot screen, before GRUB's
          ;; menu.
          (string-prefix? "SeaBIOS" text))

        (test-assert "enter LUKS passphrase for GRUB"
          (begin
            ;; At this point we have no choice but to use OCR to determine
            ;; when the passphrase should be entered.
            (wait-for-screen-text #$marionette passphrase-prompt?
                                  #:ocrad #$ocrad)
            (marionette-type "thepassphrase\n" #$marionette)

            ;; Now wait until we leave the boot screen.  This is necessary so
            ;; we can then be sure we match the "Enter passphrase" prompt from
            ;; 'cryptsetup', in the initrd.
            (wait-for-screen-text #$marionette (negate bios-boot-screen?)
                                  #:ocrad #$ocrad
                                  #:timeout 20)))

        (test-assert "enter LUKS passphrase for the initrd"
          (begin
            ;; XXX: Here we use OCR as well but we could instead use QEMU
            ;; '-serial stdio' and run it in an input pipe,
            (wait-for-screen-text #$marionette passphrase-prompt?
                                  #:ocrad #$ocrad
                                  #:timeout 60)
            (marionette-type "thepassphrase\n" #$marionette)

            ;; Take a screenshot for debugging purposes.
            (marionette-control (string-append "screendump " #$output
                                               "/post-initrd-passphrase.ppm")
                                #$marionette))))))

(define %test-encrypted-os
  (system-test
   (name "encrypted-root-os")
   (description
    "Test basic functionality of an OS installed like one would do by hand.
This test is expensive in terms of CPU and storage usage since we need to
build (current-guix) and then store a couple of full system images.")
   (value
    (mlet* %store-monad ((image   (run-install %encrypted-root-os
                                               %encrypted-root-os-source
                                               #:script
                                               %encrypted-root-installation-script))
                         (command (qemu-command/writable-image image)))
      (run-basic-test %encrypted-root-os command "encrypted-root-os"
                      #:initialization enter-luks-passphrase)))))

;;;
;;; Btrfs root file system.
;;;

(define-os-with-source (%btrfs-root-os %btrfs-root-os-source)
  ;; The OS we want to install.
  (use-modules (gnu) (gnu tests) (srfi srfi-1))

  (operating-system
    (host-name "liberigilo")
    (timezone "Europe/Paris")
    (locale "en_US.UTF-8")

    (bootloader (bootloader-configuration
                 (bootloader grub-bootloader)
                 (target "/dev/vdb")))
    (kernel-arguments '("console=ttyS0"))
    (file-systems (cons (file-system
                          (device (file-system-label "my-root"))
                          (mount-point "/")
                          (type "btrfs"))
                        %base-file-systems))
    (users (cons (user-account
                  (name "charlie")
                  (group "users")
                  (home-directory "/home/charlie")
                  (supplementary-groups '("wheel" "audio" "video")))
                 %base-user-accounts))
    (services (cons (service marionette-service-type
                             (marionette-configuration
                              (imported-modules '((gnu services herd)
                                                  (guix combinators)))))
                    %base-services))))

(define %btrfs-root-installation-script
  ;; Shell script of a simple installation.
  "\
. /etc/profile
set -e -x
guix --version

export GUIX_BUILD_OPTIONS=--no-grafts
ls -l /run/current-system/gc-roots
parted --script /dev/vdb mklabel gpt \\
  mkpart primary ext2 1M 3M \\
  mkpart primary ext2 3M 2G \\
  set 1 boot on \\
  set 1 bios_grub on
mkfs.btrfs -L my-root /dev/vdb2
mount /dev/vdb2 /mnt
btrfs subvolume create /mnt/home
herd start cow-store /mnt
mkdir /mnt/etc
cp /etc/target-config.scm /mnt/etc/config.scm
guix system build /mnt/etc/config.scm
guix system init /mnt/etc/config.scm /mnt --no-substitutes
sync
reboot\n")

(define %test-btrfs-root-os
  (system-test
   (name "btrfs-root-os")
   (description
    "Test basic functionality of an OS installed like one would do by hand.
This test is expensive in terms of CPU and storage usage since we need to
build (current-guix) and then store a couple of full system images.")
   (value
    (mlet* %store-monad ((image   (run-install %btrfs-root-os
                                               %btrfs-root-os-source
                                               #:script
                                               %btrfs-root-installation-script))
                         (command (qemu-command/writable-image image)))
      (run-basic-test %btrfs-root-os command "btrfs-root-os")))))

;;; install.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Sou Bunnbu <iyzsong@member.fsf.org>
;;; Copyright © 2017 Carlo Zancanaro <carlo@zancanaro.id.au>
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; 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 mail)
  #:use-module (gnu tests)
  #:use-module (gnu system)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #:use-module (gnu services mail)
  #:use-module (gnu services networking)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (ice-9 ftw)
  #:export (%test-opensmtpd
            %test-exim
            %test-dovecot))

(define %opensmtpd-os
  (simple-operating-system
   (dhcp-client-service)
   (service opensmtpd-service-type
            (opensmtpd-configuration
             (config-file
              (plain-file "smtpd.conf" "
listen on 0.0.0.0
accept from any for local deliver to mbox
"))))))

(define (run-opensmtpd-test)
  "Return a test of an OS running OpenSMTPD service."
  (define vm
    (virtual-machine
     (operating-system (marionette-operating-system
                        %opensmtpd-os
                        #:imported-modules '((gnu services herd))))
     (port-forwardings '((1025 . 25)))))

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

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

          (define (read-reply-code port)
            "Read a SMTP reply from PORT and return its reply code."
            (let* ((line      (read-line port))
                   (mo        (string-match "([0-9]+)([ -]).*" line))
                   (code      (string->number (match:substring mo 1)))
                   (finished? (string= " " (match:substring mo 2))))
              (if finished?
                  code
                  (read-reply-code port))))

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

          (test-begin "opensmptd")

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

          (test-assert "mbox is empty"
            (marionette-eval
             '(and (file-exists? "/var/mail")
                   (not (file-exists? "/var/mail/root")))
             marionette))

          (test-eq "accept an email"
            #t
            (let* ((smtp (socket AF_INET SOCK_STREAM 0))
                   (addr (make-socket-address AF_INET INADDR_LOOPBACK 1025)))
              (connect smtp addr)
              ;; Be greeted.
              (read-reply-code smtp)              ;220
              ;; Greet the server.
              (write-line "EHLO somehost" smtp)
              (read-reply-code smtp)              ;250
              ;; Set sender email.
              (write-line "MAIL FROM: <someone>" smtp)
              (read-reply-code smtp)              ;250
              ;; Set recipient email.
              (write-line "RCPT TO: <root>" smtp)
              (read-reply-code smtp)              ;250
              ;; Send message.
              (write-line "DATA" smtp)
              (read-reply-code smtp)              ;354
              (write-line "Subject: Hello" smtp)
              (newline smtp)
              (write-line "Nice to meet you!" smtp)
              (write-line "." smtp)
              (read-reply-code smtp)              ;250
              ;; Say goodbye.
              (write-line "QUIT" smtp)
              (read-reply-code smtp)              ;221
              (close smtp)
              #t))

          (test-assert "mail arrived"
            (marionette-eval
             '(begin
                (use-modules (ice-9 popen)
                             (ice-9 rdelim))

                (define (queue-empty?)
                  (eof-object?
                   (read-line
                    (open-input-pipe "smtpctl show queue"))))

                (let wait ()
                  (if (queue-empty?)
                      (file-exists? "/var/mail/root")
                      (begin (sleep 1) (wait)))))
             marionette))

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

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

(define %test-opensmtpd
  (system-test
   (name "opensmtpd")
   (description "Send an email to a running OpenSMTPD server.")
   (value (run-opensmtpd-test))))

(define %exim-os
  (simple-operating-system
   (dhcp-client-service)
   (service mail-aliases-service-type '())
   (service exim-service-type
            (exim-configuration
             (config-file
              (plain-file "exim.conf" "
primary_hostname = komputilo
domainlist local_domains = @
domainlist relay_to_domains =
hostlist   relay_from_hosts = localhost

never_users =

acl_smtp_rcpt = acl_check_rcpt
acl_smtp_data = acl_check_data

begin acl

acl_check_rcpt:
  accept
acl_check_data:
  accept
"))))))

(define (run-exim-test)
  "Return a test of an OS running an Exim service."
  (define vm
    (virtual-machine
     (operating-system (marionette-operating-system
                        %exim-os
                        #:imported-modules '((gnu services herd))))
     (port-forwardings '((1025 . 25)))))

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

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

          (define (read-reply-code port)
            "Read a SMTP reply from PORT and return its reply code."
            (let* ((line      (read-line port))
                   (mo        (string-match "([0-9]+)([ -]).*" line))
                   (code      (string->number (match:substring mo 1)))
                   (finished? (string= " " (match:substring mo 2))))
              (if finished?
                  code
                  (read-reply-code port))))

          (define smtp (socket AF_INET SOCK_STREAM 0))
          (define addr (make-socket-address AF_INET INADDR_LOOPBACK 1025))

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

          (test-begin "exim")

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

          (sleep 1) ;; give the service time to start talking

          (connect smtp addr)
          ;; Be greeted.
          (test-eq "greeting received"
            220 (read-reply-code smtp))
          ;; Greet the server.
          (write-line "EHLO somehost" smtp)
          (test-eq "greeting successful"
            250 (read-reply-code smtp))
          ;; Set sender email.
          (write-line "MAIL FROM: test@example.com" smtp)
          (test-eq "sender set"
            250 (read-reply-code smtp))           ;250
          ;; Set recipient email.
          (write-line "RCPT TO: root@komputilo" smtp)
          (test-eq "recipient set"
            250 (read-reply-code smtp))           ;250
          ;; Send message.
          (write-line "DATA" smtp)
          (test-eq "data begun"
            354 (read-reply-code smtp))           ;354
          (write-line "Subject: Hello" smtp)
          (newline smtp)
          (write-line "Nice to meet you!" smtp)
          (write-line "." smtp)
          (test-eq "message sent"
            250 (read-reply-code smtp))           ;250
          ;; Say goodbye.
          (write-line "QUIT" smtp)
          (test-eq "quit successful"
            221 (read-reply-code smtp))           ;221
          (close smtp)

          (test-eq "the email is received"
            1
            (marionette-eval
             '(begin
                (use-modules (ice-9 ftw))
                (length (scandir "/var/spool/exim/msglog"
                                 (lambda (x) (not (string-prefix? "." x))))))
             marionette))

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

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

(define %test-exim
  (system-test
   (name "exim")
   (description "Send an email to a running an Exim server.")
   (value (run-exim-test))))

(define %dovecot-os
  (simple-operating-system
   (dhcp-client-service)
   (dovecot-service #:config
                    (dovecot-configuration
                     (disable-plaintext-auth? #f)
                     (ssl? "no")
                     (auth-mechanisms '("anonymous"))
                     (auth-anonymous-username "alice")
                     (mail-location
                      (string-append "maildir:~/Maildir"
                                     ":INBOX=~/Maildir/INBOX"
                                     ":LAYOUT=fs"))))))

(define (run-dovecot-test)
  "Return a test of an OS running Dovecot service."
  (define vm
    (virtual-machine
     (operating-system (marionette-operating-system
                        %dovecot-os
                        #:imported-modules '((gnu services herd))))
     (port-forwardings '((8143 . 143)))))

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

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

          (define* (message-length message #:key (encoding "iso-8859-1"))
            (bytevector-length (string->bytevector message encoding)))

          (define message "From: test@example.com\n\
Subject: Hello Nice to meet you!")

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

          (test-begin "dovecot")

          ;; Wait for dovecot to be up and running.
          (test-assert "dovecot running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'dovecot))
             marionette))

          ;; Check Dovecot service's PID.
          (test-assert "service process id"
            (let ((pid
                   (number->string (wait-for-file "/var/run/dovecot/master.pid"
                                                  marionette))))
              (marionette-eval `(file-exists? (string-append "/proc/" ,pid))
                               marionette)))

          (test-assert "accept an email"
            (let ((imap (socket AF_INET SOCK_STREAM 0))
                  (addr (make-socket-address AF_INET INADDR_LOOPBACK 8143)))
              (connect imap addr)
              ;; Be greeted.
              (read-line imap) ;OK
              ;; Authenticate
              (write-line "a AUTHENTICATE ANONYMOUS" imap)
              (read-line imap) ;+
              (write-line "c2lyaGM=" imap)
              (read-line imap) ;OK
              ;; Create a TESTBOX mailbox
              (write-line "a CREATE TESTBOX" imap)
              (read-line imap) ;OK
              ;; Append a message to a TESTBOX mailbox
              (write-line (format #f "a APPEND TESTBOX {~a}"
                                  (number->string (message-length message)))
                          imap)
              (read-line imap) ;+
              (write-line message imap)
              (read-line imap) ;OK
              ;; Logout
              (write-line "a LOGOUT" imap)
              (close imap)
              #t))

          (test-equal "mail arrived"
            message
            (marionette-eval
             '(begin
                (use-modules (ice-9 ftw)
                             (ice-9 match))
                (let ((TESTBOX/new "/home/alice/Maildir/TESTBOX/new/"))
                  (match (scandir TESTBOX/new)
                    (("." ".." message-file)
                     (call-with-input-file
                         (string-append TESTBOX/new message-file)
                       get-string-all)))))
             marionette))

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

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

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


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

(define (run-xmpp-test name xmpp-service pid-file create-account)
  "Run a test of an OS running XMPP-SERVICE, which writes its PID to PID-FILE."
  (define os
    (marionette-operating-system
     (simple-operating-system (dhcp-client-service)
                              xmpp-service)
     #:imported-modules '((gnu services herd))))

  (define port 15222)

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

  (define username "alice")
  (define server "localhost")
  (define jid (string-append username "@" server))
  (define password "correct horse battery staple")
  (define message "hello world")
  (define witness "/tmp/freetalk-witness")

  (define script.ft
    (scheme-file
     "script.ft"
     #~(begin
         (define (handle-received-message time from nickname message)
           (define (touch file-name)
             (call-with-output-file file-name (const #t)))
           (when (equal? message #$message)
             (touch #$witness)))
         (add-hook! ft-message-receive-hook handle-received-message)

         (ft-set-jid! #$jid)
         (ft-set-password! #$password)
         (ft-set-server! #$server)
         (ft-set-port! #$port)
         (ft-set-sslconn! #f)
         (ft-connect-blocking)
         (ft-send-message #$jid #$message)

         (ft-set-daemon)
         (ft-main-loop))))

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

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

          (define (host-wait-for-file file)
            ;; Wait until FILE exists in the host.
            (let loop ((i 60))
              (cond ((file-exists? file)
                     #t)
                    ((> i 0)
                     (begin
                       (sleep 1))
                     (loop (- i 1)))
                    (else
                     (error "file didn't show up" file)))))

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

          (test-begin "xmpp")

          ;; Wait for XMPP service to be up and running.
          (test-assert "service running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'xmpp-daemon))
             marionette))

          ;; Check XMPP service's PID.
          (test-assert "service process id"
            (let ((pid (number->string (wait-for-file #$pid-file
                                                      marionette))))
              (marionette-eval `(file-exists? (string-append "/proc/" ,pid))
                               marionette)))

          ;; Alice sends an XMPP message to herself, with Freetalk.
          (test-assert "client-to-server communication"
            (let ((freetalk-bin (string-append #$freetalk "/bin/freetalk")))
              (marionette-eval '(system* #$create-account #$jid #$password)
                               marionette)
              ;; Freetalk requires write access to $HOME.
              (setenv "HOME" "/tmp")
              (system* freetalk-bin "-s" #$script.ft)
              (host-wait-for-file #$witness)))

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

  (gexp->derivation name test))

(define %create-prosody-account
  (program-file
   "create-account"
   #~(begin
       (use-modules (ice-9 match))
       (match (command-line)
         ((command jid password)
          (let ((password-input (format #f "\"~a~%~a\"" password password))
                (prosodyctl #$(file-append prosody "/bin/prosodyctl")))
            (system (string-join
                     `("echo" ,password-input "|" ,prosodyctl "adduser" ,jid)
                     " "))))))))

(define %test-prosody
  (let* ((config (prosody-configuration
                  (disable-sasl-mechanisms '())
                  (virtualhosts
                   (list
                    (virtualhost-configuration
                     (domain "localhost")))))))
    (system-test
     (name "prosody")
     (description "Connect to a running Prosody daemon.")
     (value (run-xmpp-test name
                           (service prosody-service-type config)
                           (prosody-configuration-pidfile config)
                           %create-prosody-account)))))

;;;
;;; BitlBee.
;;;

(define (run-bitlbee-test)
  (define os
    (marionette-operating-system
     (simple-operating-system (dhcp-client-service)
                              (service bitlbee-service-type
                                       (bitlbee-configuration
                                        (interface "0.0.0.0"))))
     #:imported-modules (source-module-closure
                         '((gnu services herd)))))

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

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

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

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

          (test-begin "bitlbee")

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

          (test-equal "valid PID"
            #$(file-append bitlbee "/sbin/bitlbee")
            (marionette-eval
             '(begin
                (use-modules (srfi srfi-1)
                             (gnu services herd))

                (let ((bitlbee
                       (find (lambda (service)
                               (equal? '(bitlbee)
                                       (live-service-provision service)))
                             (current-services))))
                  (and (pk 'bitlbee-service bitlbee)
                       (let ((pid (live-service-running bitlbee)))
                         (readlink (string-append "/proc/"
                                                  (number->string pid)
                                                  "/exe"))))))
             marionette))

          (test-assert "connect"
            (let* ((address (make-socket-address AF_INET INADDR_LOOPBACK
                                                 6667))
                   (sock    (socket AF_INET SOCK_STREAM 0)))
              (connect sock address)
              ;; See <https://tools.ietf.org/html/rfc1459>.
              (->bool (string-contains (pk 'message (read-line sock))
                                       "BitlBee"))))

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

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

(define %test-bitlbee
  (system-test
   (name "bitlbee")
   (description "Connect to a BitlBee IRC server.")
   (value (run-bitlbee-test))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Gábor Boskovits  <boskovits@gmail.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 monitoring)
  #:use-module (gnu services)
  #:use-module (gnu services monitoring)
  #:use-module (gnu services networking)
  #:use-module (gnu system vm)
  #:use-module (gnu tests)
  #:use-module (guix gexp)
  #:export (%test-prometheus-node-exporter))

;;;
;;; Prometheus Node Exporter
;;;

(define* (run-prometheus-node-exporter-server-test name test-os)
  "Run tests in %PROMETHEUS-NODE-EXPORTER-OS, which has prometheus-node-exporter running."
  (define os
    (marionette-operating-system
     test-os
     #:imported-modules '((gnu services herd))))

  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings '((8080 . 9100)))))

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

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

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

          (test-begin #$name)

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

          (test-equal "http-get"
            200
            (begin
              (wait-for-tcp-port 9100 marionette)
              (let-values (((response text)
                            (http-get "http://localhost:8080")))
                (response-code response))))

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

  (gexp->derivation (string-append name "-test") test))

(define %prometheus-node-exporter-os
  (simple-operating-system
   (dhcp-client-service)
   (service prometheus-node-exporter-service-type
            (prometheus-node-exporter-configuration))))

(define %test-prometheus-node-exporter
  (system-test
   (name "prometheus-node-exporter")
   (description "Connect to a running prometheus-node-exporter server.")
   (value (run-prometheus-node-exporter-server-test
           name %prometheus-node-exporter-os))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Thomas Danckaert <post@thomasdanckaert.be>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.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/>.

(define-module (gnu tests networking)
  #:use-module (gnu tests)
  #:use-module (gnu system)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services networking)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages networking)
  #:use-module (gnu services shepherd)
  #:use-module (ice-9 match)
  #:export (%test-inetd %test-openvswitch %test-dhcpd %test-tor %test-iptables))

(define %inetd-os
  ;; Operating system with 2 inetd services.
  (simple-operating-system
   (dhcp-client-service)
   (service inetd-service-type
            (inetd-configuration
             (entries (list
                       (inetd-entry
                        (name "echo")
                        (socket-type 'stream)
                        (protocol "tcp")
                        (wait? #f)
                        (user "root"))
                       (inetd-entry
                        (name "dict")
                        (socket-type 'stream)
                        (protocol "tcp")
                        (wait? #f)
                        (user "root")
                        (program (file-append bash
                                              "/bin/bash"))
                        (arguments
                         (list "bash" (plain-file "my-dict.sh" "\
while read line
do
    if [[ $line =~ ^DEFINE\\ (.*)$ ]]
    then
        case ${BASH_REMATCH[1]} in
            Guix)
                echo GNU Guix is a package management tool for the GNU system.
                ;;
            G-expression)
                echo Like an S-expression but with a G.
                ;;
            *)
                echo NO DEFINITION FOUND
                ;;
        esac
    else
        echo ERROR
    fi
done" ))))))))))

(define* (run-inetd-test)
  "Run tests in %INETD-OS, where the inetd service provides an echo service on
port 7, and a dict service on port 2628."
  (define os
    (marionette-operating-system %inetd-os))

  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings `((8007 . 7)
                         (8628 . 2628)))))

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

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

          (test-begin "inetd")

          ;; Make sure the PID file is created.
          (test-assert "PID file"
            (marionette-eval
             '(file-exists? "/var/run/inetd.pid")
             marionette))

          ;; Test the echo service.
          (test-equal "echo response"
            "Hello, Guix!"
            (let ((echo (socket PF_INET SOCK_STREAM 0))
                  (addr (make-socket-address AF_INET INADDR_LOOPBACK 8007)))
              (connect echo addr)
              (display "Hello, Guix!\n" echo)
              (let ((response (read-line echo)))
                (close echo)
                response)))

          ;; Test the dict service
          (test-equal "dict response"
            "GNU Guix is a package management tool for the GNU system."
            (let ((dict (socket PF_INET SOCK_STREAM 0))
                  (addr (make-socket-address AF_INET INADDR_LOOPBACK 8628)))
              (connect dict addr)
              (display "DEFINE Guix\n" dict)
              (let ((response (read-line dict)))
                (close dict)
                response)))

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

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

(define %test-inetd
  (system-test
   (name "inetd")
   (description "Connect to a host with an INETD server.")
   (value (run-inetd-test))))

;;;
;;; Open vSwitch
;;;

(define setup-openvswitch
  #~(let ((ovs-vsctl (lambda (str)
                       (zero? (apply system*
                                     #$(file-append openvswitch "/bin/ovs-vsctl")
                                     (string-tokenize str)))))
          (add-native-port (lambda (if)
                             (string-append "--may-exist add-port br0 " if
                                            " vlan_mode=native-untagged"
                                            " -- set Interface " if
                                            " type=internal"))))
      (and (ovs-vsctl "--may-exist add-br br0")
           ;; Connect eth0 as an "untagged" port (no VLANs).
           (ovs-vsctl "--may-exist add-port br0 eth0 vlan_mode=native-untagged")
           (ovs-vsctl (add-native-port "ovs0")))))

(define openvswitch-configuration-service
  (simple-service 'openvswitch-configuration shepherd-root-service-type
                  (list (shepherd-service
                         (provision '(openvswitch-configuration))
                         (requirement '(vswitchd))
                         (start #~(lambda ()
                                    #$setup-openvswitch))
                         (respawn? #f)))))

(define %openvswitch-os
  (simple-operating-system
   (static-networking-service "ovs0" "10.1.1.1"
                              #:netmask "255.255.255.252"
                              #:requirement '(openvswitch-configuration))
   (service openvswitch-service-type
            (openvswitch-configuration
             (package openvswitch)))
   openvswitch-configuration-service))

(define (run-openvswitch-test)
  (define os
    (marionette-operating-system %openvswitch-os
                                 #:imported-modules '((gnu services herd))))

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

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

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

          (test-begin "openvswitch")

          ;; Make sure the bridge is created.
          (test-assert "br0 exists"
            (marionette-eval
             '(zero? (system* "ovs-vsctl" "br-exists" "br0"))
             marionette))

          ;; Make sure eth0 is connected to the bridge.
          (test-equal "eth0 is connected to br0"
            "br0"
            (marionette-eval
             '(begin
                (use-modules (ice-9 popen) (ice-9 rdelim))
                (let* ((port (open-pipe*
                              OPEN_READ
                              (string-append #$openvswitch "/bin/ovs-vsctl")
                              "port-to-br" "eth0"))
                       (output (read-line port)))
                  (close-pipe port)
                  output))
             marionette))

          ;; Make sure the virtual interface got a static IP.
          (test-assert "networking has started on ovs0"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd)
                             (srfi srfi-1))
                (live-service-running
                 (find (lambda (live)
                         (memq 'networking-ovs0
                               (live-service-provision live)))
                       (current-services))))
             marionette))

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

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

(define %test-openvswitch
  (system-test
   (name "openvswitch")
   (description "Test a running OpenvSwitch configuration.")
   (value (run-openvswitch-test))))

;;;
;;; DHCP Daemon
;;;

(define minimal-dhcpd-v4-config-file
  (plain-file "dhcpd.conf"
              "\
default-lease-time 600;
max-lease-time 7200;

subnet 192.168.1.0 netmask 255.255.255.0 {
 range 192.168.1.100 192.168.1.200;
 option routers 192.168.1.1;
 option domain-name-servers 192.168.1.2, 192.168.1.3;
 option domain-name \"dummy.domain.name.abc123xyz\";
}
"))

(define dhcpd-v4-configuration
  (dhcpd-configuration
   (config-file minimal-dhcpd-v4-config-file)
   (version "4")
   (interfaces '("eth0"))))

(define %dhcpd-os
  (simple-operating-system
   (static-networking-service "eth0" "192.168.1.4"
                              #:netmask "255.255.255.0"
                              #:gateway "192.168.1.1"
                              #:name-servers '("192.168.1.2" "192.168.1.3"))
   (service dhcpd-service-type dhcpd-v4-configuration)))

(define (run-dhcpd-test)
  (define os
    (marionette-operating-system %dhcpd-os
                                 #:imported-modules '((gnu services herd))))

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

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

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

          (test-begin "dhcpd")

          (test-assert "pid file exists"
            (marionette-eval
             '(file-exists?
               #$(dhcpd-configuration-pid-file dhcpd-v4-configuration))
             marionette))

          (test-assert "lease file exists"
            (marionette-eval
             '(file-exists?
               #$(dhcpd-configuration-lease-file dhcpd-v4-configuration))
             marionette))

          (test-assert "run directory exists"
            (marionette-eval
             '(file-exists?
               #$(dhcpd-configuration-run-directory dhcpd-v4-configuration))
             marionette))

          (test-assert "dhcpd is alive"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd)
                             (srfi srfi-1))
                (live-service-running
                 (find (lambda (live)
                         (memq 'dhcpv4-daemon
                               (live-service-provision live)))
                       (current-services))))
             marionette))

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

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

(define %test-dhcpd
  (system-test
   (name "dhcpd")
   (description "Test a running DHCP daemon configuration.")
   (value (run-dhcpd-test))))

;;;
;;; Services related to Tor
;;;

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

(define %tor-os/unix-socks-socket
  (simple-operating-system
   (service tor-service-type
            (tor-configuration
             (socks-socket-type 'unix)))))

(define (run-tor-test)
  (define os
    (marionette-operating-system %tor-os
                                 #:imported-modules '((gnu services herd))
                                 #:requirements '(tor)))

  (define os/unix-socks-socket
    (marionette-operating-system %tor-os/unix-socks-socket
                                 #:imported-modules '((gnu services herd))
                                 #:requirements '(tor)))

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

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

          (define (tor-is-alive? marionette)
            (marionette-eval
             '(begin
                (use-modules (gnu services herd)
                             (srfi srfi-1))
                (live-service-running
                 (find (lambda (live)
                         (memq 'tor
                               (live-service-provision live)))
                       (current-services))))
             marionette))

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

          (test-begin "tor")

          ;; Test the usual Tor service.

          (test-assert "tor is alive"
            (tor-is-alive? marionette))

          (test-assert "tor is listening"
            (let ((default-port 9050))
              (wait-for-tcp-port default-port marionette)))

          ;; Don't run two VMs at once.
          (marionette-control "quit" marionette)

          ;; Test the Tor service using a SOCKS socket.

          (let* ((socket-directory "/tmp/more-sockets")
                 (_ (mkdir socket-directory))
                 (marionette/unix-socks-socket
                  (make-marionette
                   (list #$(virtual-machine os/unix-socks-socket))
                   ;; We can't use the same socket directory as the first
                   ;; marionette.
                   #:socket-directory socket-directory)))
            (test-assert "tor is alive, even when using a SOCKS socket"
              (tor-is-alive? marionette/unix-socks-socket))

            (test-assert "tor is listening, even when using a SOCKS socket"
              (wait-for-unix-socket "/var/run/tor/socks-sock"
                                    marionette/unix-socks-socket)))

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

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

(define %test-tor
  (system-test
   (name "tor")
   (description "Test a running Tor daemon configuration.")
   (value (run-tor-test))))

(define* (run-iptables-test)
  "Run tests of 'iptables-service-type'."
  (define iptables-rules
    "*filter
:INPUT ACCEPT
:FORWARD ACCEPT
:OUTPUT ACCEPT
-A INPUT -p tcp -m tcp --dport 7 -j REJECT --reject-with icmp-port-unreachable
COMMIT
")

  (define ip6tables-rules
    "*filter
:INPUT ACCEPT
:FORWARD ACCEPT
:OUTPUT ACCEPT
-A INPUT -p tcp -m tcp --dport 7 -j REJECT --reject-with icmp6-port-unreachable
COMMIT
")

  (define inetd-echo-port 7)

  (define os
    (marionette-operating-system
     (simple-operating-system
      (dhcp-client-service)
      (service inetd-service-type
               (inetd-configuration
                (entries (list
                          (inetd-entry
                           (name "echo")
                           (socket-type 'stream)
                           (protocol "tcp")
                           (wait? #f)
                           (user "root"))))))
      (service iptables-service-type
               (iptables-configuration
                (ipv4-rules (plain-file "iptables.rules" iptables-rules))
                (ipv6-rules (plain-file "ip6tables.rules" ip6tables-rules)))))
     #:imported-modules '((gnu services herd))
     #:requirements '(inetd iptables)))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (srfi srfi-64)
                       (gnu build marionette))
          (define marionette
            (make-marionette (list #$(virtual-machine os))))

          (define (dump-iptables iptables-save marionette)
            (marionette-eval
             `(begin
                (use-modules (ice-9 popen)
                             (ice-9 rdelim)
                             (ice-9 regex))
                (call-with-output-string
                  (lambda (out)
                    (call-with-port
                     (open-pipe* OPEN_READ ,iptables-save)
                     (lambda (in)
                       (let loop ((line (read-line in)))
                         ;; iptables-save does not output rules in the exact
                         ;; same format we loaded using iptables-restore. It
                         ;; adds comments, packet counters, etc. We remove
                         ;; these additions.
                         (unless (eof-object? line)
                           (cond
                            ;; Remove comments
                            ((string-match "^#" line) #t)
                            ;; Remove packet counters
                            ((string-match "^:([A-Z]*) ([A-Z]*) .*" line)
                             => (lambda (match-record)
                                  (format out ":~a ~a~%"
                                          (match:substring match-record 1)
                                          (match:substring match-record 2))))
                            ;; Pass other lines without modification
                            (else (display line out)
                                  (newline out)))
                           (loop (read-line in)))))))))
             marionette))

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

          (test-begin "iptables")

          (test-equal "iptables-save dumps the same rules that were loaded"
            (dump-iptables #$(file-append iptables "/sbin/iptables-save")
                           marionette)
            #$iptables-rules)

          (test-equal "ip6tables-save dumps the same rules that were loaded"
            (dump-iptables #$(file-append iptables "/sbin/ip6tables-save")
                           marionette)
            #$ip6tables-rules)

          (test-error "iptables firewall blocks access to inetd echo service"
                      'misc-error
                      (wait-for-tcp-port inetd-echo-port marionette #:timeout 5))

          ;; TODO: This test freezes up at the login prompt without any
          ;; relevant messages on the console. Perhaps it is waiting for some
          ;; timeout. Find and fix this issue.
          ;; (test-assert "inetd echo service is accessible after iptables firewall is stopped"
          ;;   (begin
          ;;     (marionette-eval
          ;;      '(begin
          ;;         (use-modules (gnu services herd))
          ;;         (stop-service 'iptables))
          ;;      marionette)
          ;;     (wait-for-tcp-port inetd-echo-port marionette #:timeout 5)))

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

  (gexp->derivation "iptables" test))

(define %test-iptables
  (system-test
   (name "iptables")
   (description "Test a running iptables daemon.")
   (value (run-iptables-test))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 John Darrington <jmd@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; 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 nfs)
  #:use-module (gnu tests)
  #:use-module (gnu bootloader)
  #:use-module (gnu bootloader grub)
  #: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 base)
  #:use-module (gnu services nfs)
  #:use-module (gnu services networking)
  #:use-module (gnu packages onc-rpc)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:export (%test-nfs))

(define %base-os
  (operating-system
    (host-name "olitupmok")
    (timezone "Europe/Berlin")
    (locale "en_US.UTF-8")

    (bootloader (bootloader-configuration
                 (bootloader grub-bootloader)
                 (target "/dev/sdX")))
    (file-systems %base-file-systems)
    (users %base-user-accounts)
    (packages (cons*
               rpcbind
               %base-packages))
    (services (cons*
               (service rpcbind-service-type
                        (rpcbind-configuration))
               (dhcp-client-service)
               %base-services))))

(define (run-nfs-test name socket)
  "Run a test of an OS running RPC-SERVICE, which should create SOCKET."
  (define os
    (marionette-operating-system
     %base-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))

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

          (define (wait-for-socket file)
            ;; Wait until SOCKET  exists in the guest
            (marionette-eval
             `(let loop ((i 10))
                (cond ((and (file-exists? ,file)
                            (eq? 'socket (stat:type (stat ,file))))
                       #t)
                      ((> i 0)
                       (sleep 1)
                       (loop (- i 1)))
                      (else
                       (error "Socket didn't show up: " ,file))))
             marionette))

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

          (test-begin "rpc-daemon")

          ;; Wait for the rpcbind daemon to be up and running.
          (test-assert "RPC service running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'rpcbind-daemon))
             marionette))

          ;; Check the socket file and that the service is still running.
          (test-assert "RPC socket exists"
            (and
             (wait-for-socket #$socket)
             (marionette-eval
              '(begin
                 (use-modules (gnu services herd)
                              (srfi srfi-1))

                 (live-service-running
                  (find (lambda (live)
                          (memq 'rpcbind-daemon
                                (live-service-provision live)))
                        (current-services))))
              marionette)))

          (test-assert "Probe RPC daemon"
            (marionette-eval
             '(zero? (system* "rpcinfo" "-p"))
             marionette))

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

  (gexp->derivation name test))

(define %test-nfs
  (system-test
   (name "nfs")
   (description "Test some things related to NFS.")
   (value (run-nfs-test name "/var/run/rpcbind.sock"))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
;;; 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 rsync)
  #:use-module (gnu packages rsync)
  #: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 rsync)
  #:use-module (gnu services networking)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:export (%test-rsync))

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

  (define vm
    (virtual-machine
     (operating-system os)
     (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 "rsync")

          ;; Wait for rsync to be up and running.
          (test-assert "service running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'rsync))
             marionette))

          ;; Make sure the PID file is created.
          (test-assert "PID file"
            (marionette-eval
             '(file-exists? "/var/run/rsyncd/rsyncd.pid")
             marionette))

          (test-assert "Test file copied to share"
            (marionette-eval
             '(begin
                (call-with-output-file "/tmp/input"
                  (lambda (port)
                    (display "test-file-contents\n" port)))
                (zero?
                 (system* "rsync" "/tmp/input"
                          (string-append "rsync://localhost:"
                                         (number->string #$rsync-port)
                                         "/files/input"))))
             marionette))

          (test-equal "Test file correctly received from share"
            "test-file-contents"
            (marionette-eval
             '(begin
                (use-modules (ice-9 rdelim))
                (zero?
                 (system* "rsync"
                          (string-append "rsync://localhost:"
                                         (number->string #$rsync-port)
                                         "/files/input")
                          "/tmp/output"))
                (call-with-input-file "/tmp/output"
                  (lambda (port)
                    (read-line port))))
             marionette))

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

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

(define* %rsync-os
  ;; Return operating system under test.
  (let ((base-os
         (simple-operating-system
          (dhcp-client-service)
          (service rsync-service-type))))
    (operating-system
      (inherit base-os)
      (packages (cons* rsync
                       (operating-system-packages base-os))))))

(define %test-rsync
  (system-test
   (name "rsync")
   (description "Connect to a running RSYNC server.")
   (value (run-rsync-test %rsync-os))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.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/>.

(define-module (gnu tests security-token)
  #:use-module (gnu tests)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #:use-module (gnu services security-token)
  #:use-module (guix gexp)
  #:export (%test-pcscd))

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

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

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (srfi srfi-64)
                       (gnu build marionette))
          (define marionette
            (make-marionette (list #$(virtual-machine os))))

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

          (test-begin "pcscd")

          (test-assert "pcscd is alive"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (live-service-running
                 (find (lambda (live)
                         (memq 'pcscd (live-service-provision live)))
                       (current-services))))
             marionette))

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

  (gexp->derivation "pcscd" test))

(define %test-pcscd
  (system-test
   (name "pcscd")
   (description "Test a running pcscd daemon.")
   (value (run-pcscd-test))))