code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Gábor Boskovits  <boskovits@gmail.com>
;;; Copyright © 2018, 2019 Oleg Pykhalov <go.wigust@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 packages databases)
  #:use-module (gnu packages monitoring)
  #:use-module (gnu packages php)
  #:use-module (gnu services)
  #:use-module (gnu services monitoring)
  #:use-module (gnu services networking)
  #:use-module (gnu services databases)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services web)
  #:use-module (gnu system vm)
  #:use-module (gnu system)
  #:use-module (gnu tests)
  #:use-module (guix gexp)
  #:export (%test-prometheus-node-exporter
            %test-zabbix))

;;;
;;; 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
   (service dhcp-client-service-type)
   (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))))

;;;
;;; Zabbix
;;;

(define %psql-user-create-zabbix
  "\
sudo -u postgres psql <<< \"create user zabbix password 'zabbix';\"
")

(define %psql-db-zabbix-create-script
  "\
sudo -u postgres psql --no-align <<< \\\\du
")

(define %psql-db-create-zabbix
  "\
sudo -u postgres createdb -O zabbix -E Unicode -T template0 zabbix
")

(define %psql-db-import-zabbix
  #~(format #f "\
cat ~a | sudo -u zabbix psql zabbix;
cat ~a | sudo -u zabbix psql zabbix;
cat ~a | sudo -u zabbix psql zabbix;
"
            (string-append #$zabbix-server:schema
                           "/database/postgresql/schema.sql")
            (string-append #$zabbix-server:schema
                           "/database/postgresql/images.sql")
            (string-append #$zabbix-server:schema
                           "/database/postgresql/data.sql")))

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

  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings '((8080 . 80)))
     (memory-size 1024)))

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

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

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

          (test-begin #$name)

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

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

          ;; Add /run/setuid-programs to $PATH so that the scripts passed to
          ;; 'system' can find 'sudo'.
          (marionette-eval
           '(setenv "PATH"
                    "/run/setuid-programs:/run/current-system/profile/bin")
           marionette)

          (test-eq "postgres create zabbix user"
            0
            (marionette-eval '(begin (system #$%psql-user-create-zabbix))
                             marionette))

          (test-equal "postgres find zabbix user"
            "List of roles
Role name|Attributes|Member of
postgres|Superuser, Create role, Create DB, Replication, Bypass RLS|{}
zabbix||{}
"
            (marionette-eval
             '(begin (let* ((port (open-pipe #$%psql-db-zabbix-create-script
                                             OPEN_READ))
                            (output (read-string port))
                            (status (close-pipe port)))
                       output))
             marionette))

          (test-eq "postgres create zabbix db"
            0
            (marionette-eval '(begin (system #$%psql-db-create-zabbix))
                             marionette))

          (test-eq "postgres import zabbix db"
            0
            (marionette-eval '(begin (system #$%psql-db-import-zabbix))
                             marionette))

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

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

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

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

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

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

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

          ;; Make sure we can access pages that correspond to our Zabbix instance.
          (letrec-syntax ((test-url
                           (syntax-rules ()
                             ((_ path code)
                              (test-equal (string-append "GET " path)
                                code
                                (let-values (((response body)
                                              (http-get (string-append
                                                         "http://localhost:8080"
                                                         path))))
                                  (response-code response))))
                             ((_ path)
                              (test-url path 200)))))
            (test-url "/")
            (test-url "/does-not-exist" 404))

          (test-end)

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

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

(define %zabbix-os
  ;; Return operating system under test.
  (let ((base-os
         (simple-operating-system
          (service dhcp-client-service-type)
          (postgresql-service)
          (service zabbix-front-end-service-type
                   (zabbix-front-end-configuration
                    (db-password "zabbix")))

          (service php-fpm-service-type
                   (php-fpm-configuration
                    (timezone "Europe/Paris")))

          (service zabbix-server-service-type
                   (zabbix-server-configuration
                    (db-password "zabbix")
                    (log-type "console")))

          (service zabbix-agent-service-type))))
    (operating-system
      (inherit base-os)
      (packages (cons* postgresql (operating-system-packages base-os))))))

(define %test-zabbix
  (system-test
   (name "zabbix")
   (description "Connect to a running Zabbix")
   (value (run-zabbix-server-test name %zabbix-os))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Thomas Danckaert <post@thomasdanckaert.be>
;;; Copyright © 2017, 2020 Marius Bakke <marius@gnu.org>
;;; 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
   (service dhcp-client-service-type)
   (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
  (operating-system
    (inherit (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-service))
    ;; Ensure the interface name does not change depending on the driver.
    (kernel-arguments (cons "net.ifnames=0" %default-kernel-arguments))))

(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* #$(file-append openvswitch "/bin/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 '("ens3"))))

(define %dhcpd-os
  (simple-operating-system
   (static-networking-service "ens3" "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
   (service tor-service-type)))

(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
      (service dhcp-client-service-type)
      (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))))

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2020 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>
;;; Copyright © 2019, 2020 Ricardo Wurmus <rekado@elephly.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 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 (gnu packages nfs)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:export (%test-nfs
            %test-nfs-server
            %test-nfs-root-fs))

(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)
               (service dhcp-client-service-type)
               %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))

                ;; Ensure 'rpcinfo' can be found below.
                (setenv "PATH" "/run/current-system/profile/bin")

                (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"))))

(define %nfs-os
  (let ((os (simple-operating-system
             (simple-service 'create-target-directory activation-service-type
                             #~(begin
                                 (mkdir "/remote")
                                 (chmod "/remote" #o777)
                                 #t))
             (service dhcp-client-service-type)
             (service nfs-service-type
                      (nfs-configuration
                       (debug '(nfs nfsd mountd))
                       (exports '(("/export"
                                   ;; crossmnt = This is the pseudo root.
                                   ;; fsid=0 = root file system of the export
                                   "*(ro,insecure,no_subtree_check,crossmnt,fsid=0)"))))))))
    (operating-system
      (inherit os)
      (host-name "nfs-server")
      ;; We need to use a tmpfs here, because the test system's root file
      ;; system cannot be re-exported via NFS.
      (file-systems (cons
                     (file-system
                       (device "none")
                       (mount-point "/export")
                       (type "tmpfs")
                       (create-mount-point? #t))
                     %base-file-systems))
      (services
       ;; Enable debugging output.
       (modify-services (operating-system-user-services os)
         (syslog-service-type config
                              =>
                              (syslog-configuration
                               (inherit config)
                               (config-file
                                (plain-file
                                 "syslog.conf"
                                 "*.* /dev/console\n")))))))))

(define (run-nfs-server-test)
  "Run a test of an OS running a service of NFS-SERVICE-TYPE."
  (define os
    (marionette-operating-system
     %nfs-os
     #:requirements '(nscd)
     #: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))))

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

          (test-begin "nfs-daemon")
          (marionette-eval
           '(begin
              (current-output-port
               (open-file "/dev/console" "w0"))
              (chmod "/export" #o777)
              (with-output-to-file "/export/hello"
                (lambda () (display "hello world")))
              (chmod "/export/hello" #o777))
           marionette)

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

          (test-assert "nscd is listening on its socket"
            (wait-for-unix-socket "/var/run/nscd/socket"
                                  marionette))

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

          ;; Wait for the NFS services to be up and running.
          (test-assert "nfs services are running"
            (and (marionette-eval
                  '(begin
                     (use-modules (gnu services herd))
                     (start-service 'nfs))
                  marionette)
                 (wait-for-file "/var/run/rpc.statd.pid" marionette)))

          (test-assert "nfs share is advertised"
            (marionette-eval
             '(zero? (system* (string-append #$nfs-utils "/sbin/showmount")
                              "-e" "nfs-server"))
             marionette))

          (test-assert "nfs share mounted"
            (marionette-eval
             '(begin
                (and (zero? (system* (string-append #$nfs-utils "/sbin/mount.nfs4")
                                     "nfs-server:/" "/remote" "-v"))
                     (file-exists? "/remote/hello")))
             marionette))
          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "nfs-server-test" test))

(define %test-nfs-server
  (system-test
   (name "nfs-server")
   (description "Test that an NFS server can be started and exported
directories can be mounted.")
   (value (run-nfs-server-test))))

(define (run-nfs-root-fs-test)
  "Run a test of an OS mounting its root file system via NFS."
  (define nfs-root-server-os
    (marionette-operating-system
     (operating-system
       (inherit %nfs-os)
       (services
         (modify-services (operating-system-user-services %nfs-os)
           (nfs-service-type config =>
            (nfs-configuration
             (debug '(nfs nfsd mountd))
             ;;; Note: Adding the following line causes Guix to hang.
             ;(rpcmountd-port 20001)
             ;;; Note: Adding the following line causes Guix to hang.
             ;(rpcstatd-port 20002) ; FIXME: Set broadcast port AND listening port.
             (nfsd-port 2049)
             (nfs-versions '("4.2"))
             (exports '(("/export"
                         "*(rw,insecure,no_subtree_check,crossmnt,fsid=root,no_root_squash,insecure,async)"))))))))
     #:requirements '(nscd)
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define nfs-root-client-os
    (marionette-operating-system
     (operating-system
       (inherit (simple-operating-system (service dhcp-client-service-type)))
       (kernel-arguments '("ip=dhcp"))
       (file-systems (cons
                      (file-system
                        (type "nfs")
                        (mount-point "/")
                        (device ":/export")
                        (options "addr=127.0.0.1,vers=4.2"))
                     %base-file-systems)))
     #:requirements '(nscd)
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

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

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

          (test-begin "start-nfs-boot-test")

          ;;; Start up NFS server host.

          (mkdir "/tmp/server")
          (define server-marionette
            (make-marionette (list #$(virtual-machine
                                      nfs-root-server-os
                                      ;(operating-system nfs-root-server-os)
                                      ;(port-forwardings '( ; (111 . 111)
                                      ;                    (2049 . 2049)
                                      ;                    (20001 . 20001)
                                      ;                    (20002 . 20002)))
))
                             #:socket-directory "/tmp/server"))

          (marionette-eval
           '(begin
              (use-modules (gnu services herd))
              (current-output-port
               (open-file "/dev/console" "w0"))
              ;; FIXME: Instead statfs "/" and "/export" and wait until they
              ;; are different file systems.  But Guile doesn't seem to have
              ;; statfs.
              (sleep 5)
              (chmod "/export" #o777)
              (symlink "/gnu" "/export/gnu")
              (start-service 'nscd)
              (start-service 'networking)
              (start-service 'nfs))
           server-marionette)

          ;;; Wait for the NFS services to be up and running.

          (test-assert "nfs services are running"
           (wait-for-file "/var/run/rpc.statd.pid" server-marionette))

          (test-assert "NFS port is ready"
            (wait-for-tcp-port 2049 server-marionette))

          (test-assert "NFS statd port is ready"
            (wait-for-tcp-port 20002 server-marionette))

          (test-assert "NFS mountd port is ready"
            (wait-for-tcp-port 20001 server-marionette))

          ;;; FIXME: (test-assert "NFS portmapper port is ready"
          ;;; FIXME:  (wait-for-tcp-port 111 server-marionette))

          ;;; Start up NFS client host.

          (define client-marionette
            (make-marionette (list #$(virtual-machine
                                      nfs-root-client-os
                                      ;(port-forwardings '((111 . 111)
                                      ;                    (2049 . 2049)
                                      ;                    (20001 . 20001)
                                      ;                    (20002 . 20002)))
                                                          ))))

          (marionette-eval
           '(begin
              (use-modules (gnu services herd))
              (use-modules (rnrs io ports))

              (current-output-port
               (open-file "/dev/console" "w0"))
              (let ((content (call-with-input-file "/proc/mounts" get-string-all)))
                (call-with-output-file "/mounts.new"
                  (lambda (port)
                    (display content port))))
              (chmod "/mounts.new" #o777)
              (rename-file "/mounts.new" "/mounts"))
           client-marionette)

          (test-assert "nfs-root-client booted")

          ;;; Check whether NFS client host communicated with NFS server host.

          (test-assert "nfs client deposited file"
           (wait-for-file "/export/mounts" server-marionette))
          (marionette-eval
           '(begin
              (current-output-port
               (open-file "/dev/console" "w0"))
              (call-with-input-file "/export/mounts" display))
           server-marionette)

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

  (gexp->derivation "nfs-server-test" test))

(define %test-nfs-root-fs
  (system-test
   (name "nfs-root-fs")
   (description "Test that an NFS server can be started and the exported
directory can be used as root filesystem.")
   (value (run-nfs-root-fs-test))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Oleg Pykhalov <go.wigust@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 package-management)
  #:use-module (gnu packages base)
  #:use-module (gnu packages package-management)
  #:use-module (gnu services)
  #:use-module (gnu services networking)
  #:use-module (gnu services nix)
  #:use-module (gnu system)
  #:use-module (gnu system vm)
  #:use-module (gnu tests)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:export (%test-nix))

;;; Commentary:
;;;
;;; This module provides a test definition for the nix-daemon
;;;
;;; Code:

(define* (run-nix-test name test-os)
  "Run tests in TEST-OS, which has nix-daemon running."
  (define os
    (marionette-operating-system
     test-os
     #:imported-modules '((gnu services herd))))

  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings '((8080 . 80)))
     (memory-size 1024)))

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

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

          (test-assert "Nix daemon running"
            (marionette-eval
             '(begin
                ;; Wait for nix-daemon to be up and running.
                (start-service 'nix-daemon)
                (with-output-to-file "guix-test.nix"
                  (lambda ()
                    (display "\
with import <nix/config.nix>;

derivation {
  system = builtins.currentSystem;
  name = \"guix-test\";
  builder = shell;
  args = [\"-c\" \"mkdir $out\\necho FOO > $out/foo\"];
  PATH = coreutils;
}
")))
                (zero? (system* (string-append #$nix "/bin/nix-build")
                                "--substituters" "" "--debug" "--no-out-link"
                                "guix-test.nix")))
             marionette))

	  (test-end)

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

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

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

(define %test-nix
  (system-test
   (name "nix")
   (description "Connect to a running nix-daemon")
   (value (run-nix-test name %nix-os))))

;;; package-management.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.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 reconfigure)
  #:use-module (gnu bootloader)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system)
  #:use-module (gnu system accounts)
  #:use-module (gnu system shadow)
  #:use-module (gnu system vm)
  #:use-module (gnu tests)
  #:use-module (guix derivations)
  #:use-module (guix gexp)
  #:use-module (guix monads)
  #:use-module (guix scripts system reconfigure)
  #:use-module (guix store)
  #:export (%test-switch-to-system
            %test-upgrade-services
            %test-install-bootloader))

;;; Commentary:
;;;
;;; Test in-place system reconfiguration: advancing the system generation on a
;;; running instance of the Guix System.
;;;
;;; Code:

(define* (run-switch-to-system-test)
  "Run a test of an OS running SWITCH-SYSTEM-PROGRAM, which creates a new
generation of the system profile."
  (define os
    (marionette-operating-system
     (operating-system
       (inherit (simple-operating-system))
       (users (cons (user-account
                     (name "jakob")
                     (group "users")
                     (home-directory "/home/jakob"))
                    %base-user-accounts)))
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define vm (virtual-machine os))

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

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

          ;; Return the names of the generation symlinks on MARIONETTE.
          (define (system-generations marionette)
            (marionette-eval
             '(begin
                (use-modules (ice-9 ftw)
                             (srfi srfi-1))
                (let* ((profile-dir "/var/guix/profiles/")
                       (entries (map first (cddr (file-system-tree profile-dir)))))
                  (remove (lambda (entry)
                            (member entry '("per-user" "system")))
                          entries)))
             marionette))

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

          (test-begin "switch-to-system")

          (let ((generations-prior (system-generations marionette)))
            (test-assert "script successfully evaluated"
              (marionette-eval
               '(primitive-load #$script)
               marionette))

            (test-equal "script created new generation"
              (length (system-generations marionette))
              (1+ (length generations-prior)))

            (test-assert "script activated the new generation"
              (and (eqv? 'symlink
                         (marionette-eval
                          '(stat:type (lstat "/run/current-system"))
                          marionette))
                   (string= #$os
                            (marionette-eval
                             '(readlink "/run/current-system")
                             marionette))))

            (test-assert "script activated user accounts"
              (marionette-eval
               '(string-contains (call-with-input-file "/etc/passwd"
                                   (lambda (port)
                                     (get-string-all port)))
                                 "jakob")
               marionette)))

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

  (gexp->derivation "switch-to-system" (test (switch-system-program os))))

(define* (run-upgrade-services-test)
  "Run a test of an OS running UPGRADE-SERVICES-PROGRAM, which upgrades the
Shepherd (PID 1) by unloading obsolete services and loading new services."
  (define os
    (marionette-operating-system
     (simple-operating-system)
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define vm (virtual-machine os))

  (define dummy-service
    ;; Shepherd service that does nothing, for the sole purpose of ensuring
    ;; that it is properly installed and started by the script.
    (shepherd-service (provision '(dummy))
                      (start #~(const #t))
                      (stop #~(const #t))
                      (respawn? #f)))

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

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

          ;; Return the names of the running services on MARIONETTE.
          (define (running-services marionette)
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (map live-service-canonical-name (current-services)))
             marionette))

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

          (test-begin "upgrade-services")

          (let ((services-prior (running-services marionette)))
            (test-assert "script successfully evaluated"
              (marionette-eval
               '(primitive-load #$enable-dummy)
               marionette))

            (test-assert "script started new service"
              (and (not (memq 'dummy services-prior))
                   (memq 'dummy (running-services marionette))))

            (test-assert "script successfully evaluated"
              (marionette-eval
               '(primitive-load #$disable-dummy)
               marionette))

            (test-assert "script stopped obsolete service"
              (not (memq 'dummy (running-services marionette)))))

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

  (gexp->derivation
   "upgrade-services"
   (let* ((file (shepherd-service-file dummy-service))
          (enable (upgrade-services-program (list file) '(dummy) '() '()))
          (disable (upgrade-services-program '() '() '(dummy) '())))
     (test enable disable))))

(define* (run-install-bootloader-test)
  "Run a test of an OS running INSTALL-BOOTLOADER-PROGRAM, which installs a
bootloader's configuration file."
  (define os
    (marionette-operating-system
     (simple-operating-system)
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define vm (virtual-machine os))

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

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

          ;; Return the system generation paths that have GRUB menu entries.
          (define (generations-in-grub-cfg marionette)
            (let ((grub-cfg (marionette-eval
                             '(begin
                                (call-with-input-file "/boot/grub/grub.cfg"
                                  (lambda (port)
                                    (get-string-all port))))
                             marionette)))
              (map (lambda (parameter)
                     (second (string-split (match:substring parameter) #\=)))
                   (list-matches "system=[^ ]*" grub-cfg))))

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

          (test-begin "install-bootloader")

          (test-assert "no prior menu entry for system generation"
            (not (member #$os (generations-in-grub-cfg marionette))))

          (test-assert "script successfully evaluated"
            (marionette-eval
             '(primitive-load #$script)
             marionette))

          (test-assert "menu entry created for system generation"
            (member #$os (generations-in-grub-cfg marionette)))

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

  (let* ((bootloader ((compose bootloader-configuration-bootloader
                               operating-system-bootloader)
                      os))
         ;; The typical use-case for 'install-bootloader-program' is to read
         ;; the boot parameters for the existing menu entries on the system,
         ;; parse them with 'boot-parameters->menu-entry', and pass the
         ;; results to 'operating-system-bootcfg'. However, to obtain boot
         ;; parameters, we would need to start the marionette, which we should
         ;; ideally avoid doing outside of the 'test' G-Expression. Thus, we
         ;; generate a bootloader configuration for the script as if there
         ;; were no existing menu entries. In the grand scheme of things, this
         ;; matters little -- these tests should not make assertions about the
         ;; behavior of 'operating-system-bootcfg'.
         (bootcfg (operating-system-bootcfg os '()))
         (bootcfg-file (bootloader-configuration-file bootloader)))
    (gexp->derivation
     "install-bootloader"
     ;; Due to the read-only nature of the virtual machines used in the system
     ;; test suite, the bootloader installer script is omitted. 'grub-install'
     ;; would attempt to write directly to the virtual disk if the
     ;; installation script were run.
     (test (install-bootloader-program #f #f bootcfg bootcfg-file #f "/")))))

(define %test-switch-to-system
  (system-test
   (name "switch-to-system")
   (description "Create a new generation of the system profile.")
   (value (run-switch-to-system-test))))

(define %test-upgrade-services
  (system-test
   (name "upgrade-services")
   (description "Upgrade the Shepherd by unloading obsolete services and
loading new services.")
   (value (run-upgrade-services-test))))

(define %test-install-bootloader
  (system-test
   (name "install-bootloader")
   (description "Install a bootloader and its configuration file.")
   (value (run-install-bootloader-test))))


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

                ;; Make sure the 'rsync' command is found.
                (setenv "PATH" "/run/current-system/profile/bin")

                (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
          (service dhcp-client-service-type)
          (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))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 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 singularity)
  #:use-module (gnu tests)
  #:use-module (gnu system)
  #:use-module (gnu system vm)
  #:use-module (gnu system shadow)
  #:use-module (gnu services)
  #:use-module (gnu services docker)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages linux)               ;singularity
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix grafts)
  #:use-module (guix monads)
  #:use-module (guix packages)
  #:use-module (guix profiles)
  #:use-module (guix scripts pack)
  #:export (%test-singularity))

(define %singularity-os
  (simple-operating-system
   (service singularity-service-type)
   (simple-service 'guest-account
                   account-service-type
                   (list (user-account (name "guest") (uid 1000) (group "guest"))
                         (user-group (name "guest") (id 1000))))))

(define (run-singularity-test image)
  "Load IMAGE, a Squashfs image, as a Singularity image and run it inside
%SINGULARITY-OS."
  (define os
    (marionette-operating-system %singularity-os))

  (define singularity-exec
    #~(begin
        (use-modules (ice-9 popen) (rnrs io ports))

        (let* ((pipe (open-pipe* OPEN_READ
                                 #$(file-append singularity
                                                "/bin/singularity")
                                 "exec" #$image "/bin/guile"
                                 "-c" "(display \"hello, world\")"))
               (str  (get-string-all pipe))
               (status (close-pipe pipe)))
          (and (zero? status)
               (string=? str "hello, world")))))

  (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 #$(virtual-machine os))))

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

          (test-begin "singularity")

          (test-assert "singularity exec /bin/guile (as root)"
            (marionette-eval '#$singularity-exec
                             marionette))

          (test-equal "singularity exec /bin/guile (unprivileged)"
            0
            (marionette-eval
             `(begin
                (use-modules (ice-9 match))

                (match (primitive-fork)
                  (0
                   (dynamic-wind
                     (const #f)
                     (lambda ()
                       (setgid 1000)
                       (setuid 1000)
                       (execl #$(program-file "singularity-exec-test"
                                              #~(exit #$singularity-exec))
                              "test"))
                     (lambda ()
                       (primitive-exit 127))))
                  (pid
                   (cdr (waitpid pid)))))
             marionette))

          (test-equal "singularity run"           ;test the entry point
            42
            (marionette-eval
             `(status:exit-val
               (system* #$(file-append singularity "/bin/singularity")
                        "run" #$image "-c" "(exit 42)"))
             marionette))

          ;; FIXME: Singularity 2.x doesn't directly honor
          ;; /.singularity.d/env/*.sh.  Instead, you have to load those files
          ;; manually, which we don't do.  Remove 'test-skip' call once we've
          ;; switch to Singularity 3.x.
          (test-skip 1)
          (test-equal "singularity run, with environment"
            0
            (marionette-eval
             ;; Check whether GUILE_LOAD_PATH is properly set, allowing us to
             ;; find the (json) module.
             `(status:exit-val
               (system* #$(file-append singularity "/bin/singularity")
                        "--debug" "run" #$image "-c" "(use-modules (json))"))
             marionette))

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

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

(define (build-tarball&run-singularity-test)
  (mlet* %store-monad
      ((_        (set-grafting #f))
       (guile    (set-guile-for-build (default-guile)))
       ;; 'singularity exec' insists on having /bin/sh in the image.
       (profile  (profile-derivation (packages->manifest
                                      (list bash-minimal
                                            guile-2.2 guile-json-3))
                                     #:hooks '()
                                     #:locales? #f))
       (tarball  (squashfs-image "singularity-pack" profile
                                 #:entry-point "bin/guile"
                                 #:symlinks '(("/bin" -> "bin")))))
    (run-singularity-test tarball)))

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu tests ssh)
  #:use-module (gnu tests)
  #:use-module (gnu system)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #:use-module (gnu services ssh)
  #:use-module (gnu services networking)
  #:use-module (gnu packages ssh)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:export (%test-openssh
            %test-dropbear))

(define* (run-ssh-test name ssh-service pid-file
                       #:key (sftp? #f) (test-getlogin? #t))
  "Run a test of an OS running SSH-SERVICE, which writes its PID to PID-FILE.
SSH-SERVICE must be configured to listen on port 22 and to allow for root and
empty-password logins.

When SFTP? is true, run an SFTP server test."
  (define os
    (marionette-operating-system
     (simple-operating-system (service dhcp-client-service-type) ssh-service)
     #:imported-modules '((gnu services herd)
                          (guix combinators))))
  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings '((2222 . 22)))))

  (define test
    (with-imported-modules '((gnu build marionette))
      (with-extensions (list guile-ssh)
        #~(begin
            (use-modules (gnu build marionette)
                         (srfi srfi-26)
                         (srfi srfi-64)
                         (ice-9 textual-ports)
                         (ice-9 match)
                         (ssh session)
                         (ssh auth)
                         (ssh channel)
                         (ssh popen)
                         (ssh sftp))

            (define marionette
              ;; Enable TCP forwarding of the guest's port 22.
              (make-marionette (list #$vm)))

            (define (make-session-for-test)
              "Make a session with predefined parameters for a test."
              (make-session #:user "root"
                            #:port 2222
                            #:host "localhost"
                            #:log-verbosity 'protocol))

            (define (call-with-connected-session proc)
              "Call the one-argument procedure PROC with a freshly created and
connected SSH session object, return the result of the procedure call.  The
session is disconnected when the PROC is finished."
              (let ((session (make-session-for-test)))
                (dynamic-wind
                  (lambda ()
                    (let ((result (connect! session)))
                      (unless (equal? result 'ok)
                        (error "Could not connect to a server"
                               session result))))
                  (lambda () (proc session))
                  (lambda () (disconnect! session)))))

            (define (call-with-connected-session/auth proc)
              "Make an authenticated session.  We should be able to connect as
root with an empty password."
              (call-with-connected-session
               (lambda (session)
                 ;; Try the simple authentication methods.  Dropbear requires
                 ;; 'none' when there are no passwords, whereas OpenSSH accepts
                 ;; 'password' with an empty password.
                 (let loop ((methods (list (cut userauth-password! <> "")
                                           (cut userauth-none! <>))))
                   (match methods
                     (()
                      (error "all the authentication methods failed"))
                     ((auth rest ...)
                      (match (pk 'auth (auth session))
                        ('success
                         (proc session))
                        ('denied
                         (loop rest)))))))))

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

            (test-begin "ssh-daemon")

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

            ;; Check sshd's PID file.
            (test-equal "sshd PID"
              (wait-for-file #$pid-file marionette)
              (marionette-eval
               '(begin
                  (use-modules (gnu services herd)
                               (srfi srfi-1))

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

            (test-assert "wait for port 22"
              (wait-for-tcp-port 22 marionette))

            ;; Connect to the guest over SSH.  Make sure we can run a shell
            ;; command there.
            (test-equal "shell command"
              'hello
              (call-with-connected-session/auth
               (lambda (session)
                 ;; FIXME: 'get-server-public-key' segfaults.
                 ;; (get-server-public-key session)
                 (let ((channel (make-channel session)))
                   (channel-open-session channel)
                   (channel-request-exec channel "echo hello > /root/witness")
                   (and (zero? (channel-get-exit-status channel))
                        (wait-for-file "/root/witness" marionette))))))

            ;; Check whether the 'getlogin' procedure returns the right thing.
            (unless #$test-getlogin?
              (test-skip 1))
            (test-equal "getlogin"
              '(0 "root")
              (call-with-connected-session/auth
               (lambda (session)
                 (let* ((pipe   (open-remote-input-pipe
                                 session
                                 "guile -c '(display (getlogin))'"))
                        (output (get-string-all pipe))
                        (status (channel-get-exit-status pipe)))
                   (list status output)))))

            ;; Connect to the guest over SFTP.  Make sure we can write and
            ;; read a file there.
            (unless #$sftp?
              (test-skip 1))
            (test-equal "SFTP file writing and reading"
              'hello
              (call-with-connected-session/auth
               (lambda (session)
                 (let ((sftp-session (make-sftp-session session))
                       (witness "/root/sftp-witness"))
                   (call-with-remote-output-file sftp-session witness
                                                 (cut display "hello" <>))
                   (call-with-remote-input-file sftp-session witness
                                                read)))))

            ;; Connect to the guest over SSH.  Make sure we can run commands
            ;; from the system profile.
            (test-equal "run executables from system profile"
              #t
              (call-with-connected-session/auth
               (lambda (session)
                 (let ((channel (make-channel session)))
                   (channel-open-session channel)
                   (channel-request-exec
                    channel
                    (string-append
                     "mkdir -p /root/.guix-profile/bin && "
                     "touch /root/.guix-profile/bin/path-witness && "
                     "chmod 755 /root/.guix-profile/bin/path-witness"))
                   (zero? (channel-get-exit-status channel))))))

            ;; Connect to the guest over SSH.  Make sure we can run commands
            ;; from the user profile.
            (test-equal "run executable from user profile"
              #t
              (call-with-connected-session/auth
               (lambda (session)
                 (let ((channel (make-channel session)))
                   (channel-open-session channel)
                   (channel-request-exec channel "path-witness")
                   (zero? (channel-get-exit-status channel))))))

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

  (gexp->derivation name test))

(define %test-openssh
  (system-test
   (name "openssh")
   (description "Connect to a running OpenSSH daemon.")
   (value (run-ssh-test name
                        ;; Allow root logins with an empty password to
                        ;; simplify testing.
                        (service openssh-service-type
                                 (openssh-configuration
                                  (permit-root-login #t)
                                  (allow-empty-passwords? #t)))
                        "/var/run/sshd.pid"
                        #:sftp? #t))))

(define %test-dropbear
  (system-test
   (name "dropbear")
   (description "Connect to a running Dropbear SSH daemon.")
   (value (run-ssh-test name
                        (service dropbear-service-type
                                 (dropbear-configuration
                                  (root-login? #t)
                                  (allow-empty-passwords? #t)))
                        "/var/run/dropbear.pid"

                        ;; XXX: Our Dropbear is not built with PAM support.
                        ;; Even when it is, it seems to ignore the PAM
                        ;; 'session' requirements.
                        #:test-getlogin? #f))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Christopher Baines <mail@cbaines.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 version-control)
  #: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 version-control)
  #:use-module (gnu services cgit)
  #:use-module (gnu services ssh)
  #:use-module (gnu services web)
  #:use-module (gnu services networking)
  #:use-module (gnu packages version-control)
  #:use-module (gnu packages ssh)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix modules)
  #:export (%test-cgit
            %test-git-http
            %test-gitolite))

(define README-contents
  "Hello!  This is what goes inside the 'README' file.")

(define %make-git-repository
  ;; Create Git repository in /srv/git/test.
  (with-imported-modules (source-module-closure
                          '((guix build utils)))
    #~(begin
        (use-modules (guix build utils))

        (let ((git (string-append #$git "/bin/git")))
          (mkdir-p "/tmp/test-repo")
          (with-directory-excursion "/tmp/test-repo"
            (call-with-output-file "/tmp/test-repo/README"
              (lambda (port)
                (display #$README-contents port)))
            (invoke git "config" "--global" "user.email" "charlie@example.org")
            (invoke git "config" "--global" "user.name" "A U Thor")
            (invoke git "init")
            (invoke git "add" ".")
            (invoke git "commit" "-m" "That's a commit."))

          (mkdir-p "/srv/git")
          (rename-file "/tmp/test-repo/.git" "/srv/git/test")))))

(define %test-repository-service
  ;; Service that creates /srv/git/test.
  (simple-service 'make-git-repository activation-service-type
                  %make-git-repository))

(define %cgit-configuration-nginx
  (list
   (nginx-server-configuration
    (root cgit)
    (locations
     (list
      (nginx-location-configuration
       (uri "@cgit")
       (body '("fastcgi_param SCRIPT_FILENAME $document_root/lib/cgit/cgit.cgi;"
               "fastcgi_param PATH_INFO $uri;"
               "fastcgi_param QUERY_STRING $args;"
               "fastcgi_param HTTP_HOST $server_name;"
               "fastcgi_pass 127.0.0.1:9000;")))))
    (try-files (list "$uri" "@cgit"))
    (listen '("19418"))
    (ssl-certificate #f)
    (ssl-certificate-key #f))))

(define %cgit-os
  ;; Operating system under test.
  (let ((base-os
         (simple-operating-system
          (service dhcp-client-service-type)
          (service cgit-service-type
                   (cgit-configuration
                    (nginx %cgit-configuration-nginx)))
          %test-repository-service)))
    (operating-system
      (inherit base-os)
      (packages (cons* git
                       (operating-system-packages base-os))))))

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

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

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

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

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

          (test-begin "cgit")

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

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

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

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

          ;; Make sure the configuration file is created.
          (test-assert "configuration file"
            (marionette-eval
             '(file-exists? "/etc/cgitrc")
             marionette))

          ;; Make sure Git test repository is created.
          (test-assert "Git test repository"
            (marionette-eval
             '(file-exists? "/srv/git/test")
             marionette))

          ;; Make sure we can access pages that correspond to our repository.
          (letrec-syntax ((test-url
                           (syntax-rules ()
                             ((_ path code)
                              (test-equal (string-append "GET " path)
                                code
                                (let-values (((response body)
                                              (http-get (string-append
                                                         "http://localhost:8080"
                                                         path))))
                                  (response-code response))))
                             ((_ path)
                              (test-url path 200)))))
            (test-url "/")
            (test-url "/test")
            (test-url "/test/log")
            (test-url "/test/tree")
            (test-url "/test/tree/README")
            (test-url "/test/does-not-exist" 404)
            (test-url "/test/tree/does-not-exist" 404)
            (test-url "/does-not-exist" 404))

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

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

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

;;;
;;; Git server.
;;;

(define %git-nginx-configuration
  (nginx-configuration
   (server-blocks
    (list
     (nginx-server-configuration
      (listen '("19418"))
      (ssl-certificate #f)
      (ssl-certificate-key #f)
      (locations
       (list (git-http-nginx-location-configuration
              (git-http-configuration (export-all? #t)
                                      (uri-path "/git"))))))))))

(define %git-http-os
  (simple-operating-system
   (service dhcp-client-service-type)
   (service fcgiwrap-service-type)
   (service nginx-service-type %git-nginx-configuration)
   %test-repository-service))

(define* (run-git-http-test #:optional (http-port 19418))
  (define os
    (marionette-operating-system
     %git-http-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

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

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

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

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

          (test-begin "git-http")

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

          ;; Make sure Git test repository is created.
          (test-assert "Git test repository"
            (marionette-eval
             '(file-exists? "/srv/git/test")
             marionette))

          ;; Make sure we can clone the repo from the host.
          (test-equal "clone"
            '#$README-contents
            (begin
              (invoke #$(file-append git "/bin/git") "clone" "-v"
                      "http://localhost:8080/git/test" "/tmp/clone")
              (call-with-input-file "/tmp/clone/README"
                get-string-all)))

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

  (gexp->derivation "git-http" test))

(define %test-git-http
  (system-test
   (name "git-http")
   (description "Connect to a running Git HTTP server.")
   (value (run-git-http-test))))

;;;
;;; Gitolite.
;;;

(define %gitolite-test-admin-keypair
  (computed-file
   "gitolite-test-admin-keypair"
   (with-imported-modules (source-module-closure
                           '((guix build utils)))
     #~(begin
         (use-modules (ice-9 match) (srfi srfi-26)
                      (guix build utils))

         (mkdir #$output)
         (invoke #$(file-append openssh "/bin/ssh-keygen")
                 "-f" (string-append #$output "/test-admin")
                 "-t" "rsa"
                 "-q"
                 "-N" "")))))

(define %gitolite-os
  (simple-operating-system
   (service dhcp-client-service-type)
   (service openssh-service-type)
   (service gitolite-service-type
            (gitolite-configuration
             (admin-pubkey
              (file-append %gitolite-test-admin-keypair "/test-admin.pub"))))))

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

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

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

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

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

          (test-begin "gitolite")

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

          (display #$%gitolite-test-admin-keypair)

          (setenv "GIT_SSH_VARIANT" "ssh")
          (setenv "GIT_SSH_COMMAND"
                  (string-join
                   '(#$(file-append openssh "/bin/ssh")
                     "-i" #$(file-append %gitolite-test-admin-keypair
                                         "/test-admin")
                     "-o" "UserKnownHostsFile=/dev/null"
                     "-o" "StrictHostKeyChecking=no")))

          (test-assert "cloning the admin repository"
            (invoke #$(file-append git "/bin/git")
                    "clone" "-v"
                    "ssh://git@localhost:2222/gitolite-admin"
                    "/tmp/clone"))

          (test-assert "admin key exists"
            (file-exists? "/tmp/clone/keydir/test-admin.pub"))

          (with-directory-excursion "/tmp/clone"
            (invoke #$(file-append git "/bin/git")
                    "-c" "user.name=Guix" "-c" "user.email=guix"
                    "commit"
                    "-m" "Test commit"
                    "--allow-empty")

            (test-assert "pushing, and the associated hooks"
              (invoke #$(file-append git "/bin/git") "push")))

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

  (gexp->derivation "gitolite" test))

(define %test-gitolite
  (system-test
   (name "gitolite")
   (description "Clone the Gitolite admin repository.")
   (value (run-gitolite-test))))