summaryrefslogtreecommitdiff
path: root/gnu/tests
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/tests')
-rw-r--r--gnu/tests/install.scm241
-rw-r--r--gnu/tests/linux-modules.scm103
-rw-r--r--gnu/tests/mail.scm27
-rw-r--r--gnu/tests/networking.scm4
-rw-r--r--gnu/tests/nfs.scm38
-rw-r--r--gnu/tests/rsync.scm4
6 files changed, 294 insertions, 123 deletions
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index 9ecc45cc04..b0b40f2764 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2019 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -31,15 +32,23 @@
#:use-module (gnu packages cryptsetup)
#:use-module (gnu packages linux)
#:use-module (gnu packages ocr)
+ #:use-module (gnu packages openbox)
#:use-module (gnu packages package-management)
+ #:use-module (gnu packages ratpoison)
+ #:use-module (gnu packages suckless)
#:use-module (gnu packages virtualization)
+ #:use-module (gnu packages wm)
+ #:use-module (gnu packages xorg)
+ #:use-module (gnu services desktop)
#:use-module (gnu services networking)
+ #:use-module (gnu services xorg)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix packages)
#:use-module (guix grafts)
#:use-module (guix gexp)
#:use-module (guix utils)
+ #:use-module (srfi srfi-1)
#:export (%test-installed-os
%test-installed-extlinux-os
%test-iso-image-installer
@@ -51,7 +60,8 @@
%test-jfs-root-os
%test-gui-installed-os
- %test-gui-installed-os-encrypted))
+ %test-gui-installed-os-encrypted
+ %test-gui-installed-desktop-os-encrypted))
;;; Commentary:
;;;
@@ -202,6 +212,7 @@ reboot\n")
(gnu installer tests)
(guix combinators))))
(installation-disk-image-file-system-type "ext4")
+ (install-size 'guess)
(target-size (* 2200 MiB)))
"Run SCRIPT (a shell script following the system installation procedure) in
OS to install TARGET-OS. Return a VM image of TARGET-SIZE bytes containing
@@ -219,7 +230,7 @@ packages defined in installation-os."
(image (system-disk-image
(operating-system-with-gc-roots
os (list target))
- #:disk-image-size 'guess
+ #:disk-image-size install-size
#:file-system-type
installation-disk-image-file-system-type)))
(define install
@@ -270,8 +281,12 @@ packages defined in installation-os."
(lambda (port)
(write '#$target-os-source port)))
marionette)
- (exit (marionette-eval '(zero? (system #$script))
- marionette)))
+
+ ;; Run SCRIPT. It typically invokes 'reboot' as a last step and
+ ;; thus normally gets killed with SIGTERM by PID 1.
+ (let ((status (marionette-eval '(system #$script) marionette)))
+ (exit (or (equal? (status:term-sig status) SIGTERM)
+ (equal? (status:exit-val status) 0)))))
(when #$(->bool gui-test)
(wait-for-unix-socket "/var/guix/installer-socket"
@@ -936,73 +951,81 @@ build (current-guix) and then store a couple of full system images.")
(define %root-password "foo")
-(define* (gui-test-program marionette #:key (encrypted? #f))
+(define* (gui-test-program marionette
+ #:key
+ (desktop? #f)
+ (encrypted? #f))
#~(let ()
(define (screenshot file)
(marionette-control (string-append "screendump " file)
#$marionette))
+ (define-syntax-rule (marionette-eval* exp marionette)
+ (or (marionette-eval exp marionette)
+ (throw 'marionette-eval-failure 'exp)))
+
(setvbuf (current-output-port) 'none)
(setvbuf (current-error-port) 'none)
- (marionette-eval '(use-modules (gnu installer tests))
- #$marionette)
+ (marionette-eval* '(use-modules (gnu installer tests))
+ #$marionette)
;; Arrange so that 'converse' prints debugging output to the console.
- (marionette-eval '(let ((console (open-output-file "/dev/console")))
- (setvbuf console 'none)
- (conversation-log-port console))
- #$marionette)
+ (marionette-eval* '(let ((console (open-output-file "/dev/console")))
+ (setvbuf console 'none)
+ (conversation-log-port console))
+ #$marionette)
;; Tell the installer to not wait for the Connman "online" status.
- (marionette-eval '(call-with-output-file "/tmp/installer-assume-online"
- (const #t))
- #$marionette)
+ (marionette-eval* '(call-with-output-file "/tmp/installer-assume-online"
+ (const #t))
+ #$marionette)
;; Run 'guix system init' with '--no-grafts', to cope with the lack of
;; network access.
- (marionette-eval '(call-with-output-file
- "/tmp/installer-system-init-options"
- (lambda (port)
- (write '("--no-grafts" "--no-substitutes")
- port)))
- #$marionette)
+ (marionette-eval* '(call-with-output-file
+ "/tmp/installer-system-init-options"
+ (lambda (port)
+ (write '("--no-grafts" "--no-substitutes")
+ port)))
+ #$marionette)
- (marionette-eval '(define installer-socket
- (open-installer-socket))
- #$marionette)
+ (marionette-eval* '(define installer-socket
+ (open-installer-socket))
+ #$marionette)
(screenshot "installer-start.ppm")
- (marionette-eval '(choose-locale+keyboard installer-socket)
- #$marionette)
+ (marionette-eval* '(choose-locale+keyboard installer-socket)
+ #$marionette)
(screenshot "installer-locale.ppm")
;; Choose the host name that the "basic" test expects.
- (marionette-eval '(enter-host-name+passwords installer-socket
- #:host-name "liberigilo"
- #:root-password
- #$%root-password
- #:users
- '(("alice" "pass1")
- ("bob" "pass2")))
- #$marionette)
+ (marionette-eval* '(enter-host-name+passwords installer-socket
+ #:host-name "liberigilo"
+ #:root-password
+ #$%root-password
+ #:users
+ '(("alice" "pass1")
+ ("bob" "pass2")))
+ #$marionette)
(screenshot "installer-services.ppm")
- (marionette-eval '(choose-services installer-socket
- #:desktop-environments '()
- #:choose-network-service?
- (const #f))
- #$marionette)
+ (marionette-eval* '(choose-services installer-socket
+ #:choose-desktop-environment?
+ (const #$desktop?)
+ #:choose-network-service?
+ (const #f))
+ #$marionette)
(screenshot "installer-partitioning.ppm")
- (marionette-eval '(choose-partitioning installer-socket
- #:encrypted? #$encrypted?
- #:passphrase #$%luks-passphrase)
- #$marionette)
+ (marionette-eval* '(choose-partitioning installer-socket
+ #:encrypted? #$encrypted?
+ #:passphrase #$%luks-passphrase)
+ #$marionette)
(screenshot "installer-run.ppm")
- (marionette-eval '(conclude-installation installer-socket)
- #$marionette)
+ (marionette-eval* '(conclude-installation installer-socket)
+ #$marionette)
(sync)
#t))
@@ -1029,53 +1052,111 @@ build (current-guix) and then store a couple of full system images.")
(gnu installer tests)
(guix combinators))))
-(define* (guided-installation-test name #:key encrypted?)
- (define os
- (operating-system
- (inherit %minimal-os)
- (users (append (list (user-account
- (name "alice")
- (comment "Bob's sister")
- (group "users")
- (supplementary-groups
- '("wheel" "audio" "video")))
- (user-account
- (name "bob")
- (comment "Alice's brother")
- (group "users")
- (supplementary-groups
- '("wheel" "audio" "video"))))
- %base-user-accounts))
- ;; The installer does not create a swap device in guided mode with
- ;; encryption support.
- (swap-devices (if encrypted? '() '("/dev/vdb2")))
- (services (cons (service dhcp-client-service-type)
- (operating-system-user-services %minimal-os)))))
+(define* (installation-target-os-for-gui-tests
+ #:key (encrypted? #f))
+ (operating-system
+ (inherit %minimal-os)
+ (users (append (list (user-account
+ (name "alice")
+ (comment "Bob's sister")
+ (group "users")
+ (supplementary-groups
+ '("wheel" "audio" "video")))
+ (user-account
+ (name "bob")
+ (comment "Alice's brother")
+ (group "users")
+ (supplementary-groups
+ '("wheel" "audio" "video"))))
+ %base-user-accounts))
+ ;; The installer does not create a swap device in guided mode with
+ ;; encryption support.
+ (swap-devices (if encrypted? '() '("/dev/vdb2")))
+ (services (cons (service dhcp-client-service-type)
+ (operating-system-user-services %minimal-os)))))
+
+(define* (installation-target-desktop-os-for-gui-tests
+ #:key (encrypted? #f))
+ (operating-system
+ (inherit (installation-target-os-for-gui-tests
+ #:encrypted? encrypted?))
+ (keyboard-layout (keyboard-layout "us" "altgr-intl"))
+
+ ;; Make sure that all the packages and services that may be used by the
+ ;; graphical installer are available.
+ (packages (append
+ (list openbox awesome i3-wm i3status
+ dmenu st ratpoison xterm)
+ %base-packages))
+ (services
+ (append
+ (list (service gnome-desktop-service-type)
+ (service xfce-desktop-service-type)
+ (service mate-desktop-service-type)
+ (service enlightenment-desktop-service-type)
+ (set-xorg-configuration
+ (xorg-configuration
+ (keyboard-layout keyboard-layout)))
+ (service marionette-service-type
+ (marionette-configuration
+ (imported-modules '((gnu services herd)
+ (guix build utils)
+ (guix combinators))))))
+ %desktop-services))))
+(define* (guided-installation-test name
+ #:key
+ (desktop? #f)
+ (encrypted? #f)
+ target-os
+ (install-size 'guess)
+ (target-size (* 2200 MiB)))
(system-test
(name name)
(description
"Install an OS using the graphical installer and test it.")
(value
- (mlet* %store-monad ((image (run-install os '(this is unused)
- #:script #f
- #:os installation-os-for-gui-tests
- #:gui-test
- (lambda (marionette)
- (gui-test-program
- marionette
- #:encrypted? encrypted?))))
- (command (qemu-command/writable-image image)))
- (run-basic-test os command name
+ (mlet* %store-monad
+ ((image (run-install target-os '(this is unused)
+ #:script #f
+ #:os installation-os-for-gui-tests
+ #:install-size install-size
+ #:target-size target-size
+ #:gui-test
+ (lambda (marionette)
+ (gui-test-program
+ marionette
+ #:desktop? desktop?
+ #:encrypted? encrypted?))))
+ (command (qemu-command/writable-image image)))
+ (run-basic-test target-os command name
#:initialization (and encrypted? enter-luks-passphrase)
#:root-password %root-password)))))
(define %test-gui-installed-os
- (guided-installation-test "gui-installed-os"
- #:encrypted? #f))
+ (guided-installation-test
+ "gui-installed-os"
+ #:target-os (installation-target-os-for-gui-tests)))
(define %test-gui-installed-os-encrypted
- (guided-installation-test "gui-installed-os-encrypted"
- #:encrypted? #t))
+ (guided-installation-test
+ "gui-installed-os-encrypted"
+ #:encrypted? #t
+ #:target-os (installation-target-os-for-gui-tests
+ #:encrypted? #t)))
+
+;; Building a desktop image is very time and space consuming. Install all
+;; desktop environments in a single test to reduce the overhead.
+(define %test-gui-installed-desktop-os-encrypted
+ (guided-installation-test "gui-installed-desktop-os-encrypted"
+ #:desktop? #t
+ #:encrypted? #t
+ #:target-os
+ (installation-target-desktop-os-for-gui-tests
+ #:encrypted? #t)
+ ;; XXX: The disk-image size guess is too low. Use
+ ;; a constant value until this is fixed.
+ #:install-size (* 8000 MiB)
+ #:target-size (* 9000 MiB)))
;;; install.scm ends here
diff --git a/gnu/tests/linux-modules.scm b/gnu/tests/linux-modules.scm
new file mode 100644
index 0000000000..39e11587c6
--- /dev/null
+++ b/gnu/tests/linux-modules.scm
@@ -0,0 +1,103 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
+;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.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 linux-modules)
+ #:use-module (gnu packages linux)
+ #:use-module (gnu system)
+ #:use-module (gnu system vm)
+ #:use-module (gnu tests)
+ #:use-module (guix derivations)
+ #:use-module (guix gexp)
+ #:use-module (guix modules)
+ #:use-module (guix monads)
+ #:use-module (guix store)
+ #:export (%test-loadable-kernel-modules-0
+ %test-loadable-kernel-modules-1
+ %test-loadable-kernel-modules-2))
+
+;;; Commentary:
+;;;
+;;; Test <operating-system> kernel-loadable-modules.
+;;;
+;;; Code:
+
+(define* (module-loader-program os modules)
+ "Return an executable store item that, upon being evaluated, will dry-run
+load MODULES."
+ (program-file
+ "load-kernel-modules.scm"
+ (with-imported-modules (source-module-closure '((guix build utils)))
+ #~(begin
+ (use-modules (guix build utils))
+ (for-each (lambda (module)
+ (invoke (string-append #$kmod "/bin/modprobe") "-n" "--"
+ module))
+ '#$modules)))))
+
+(define* (run-loadable-kernel-modules-test module-packages module-names)
+ "Run a test of an OS having MODULE-PACKAGES, and modprobe MODULE-NAMES."
+ (define os
+ (marionette-operating-system
+ (operating-system
+ (inherit (simple-operating-system))
+ (kernel-loadable-modules module-packages))
+ #:imported-modules '((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)))
+ (mkdir #$output)
+ (chdir #$output)
+ (test-begin "loadable-kernel-modules")
+ (test-assert "script successfully evaluated"
+ (marionette-eval
+ '(primitive-load #$script)
+ marionette))
+ (test-end)
+ (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+ (gexp->derivation "loadable-kernel-modules" (test (module-loader-program os module-names))))
+
+(define %test-loadable-kernel-modules-0
+ (system-test
+ (name "loadable-kernel-modules-0")
+ (description "Tests loadable kernel modules facility of <operating-system>
+with no extra modules.")
+ (value (run-loadable-kernel-modules-test '() '()))))
+
+(define %test-loadable-kernel-modules-1
+ (system-test
+ (name "loadable-kernel-modules-1")
+ (description "Tests loadable kernel modules facility of <operating-system>
+with one extra module.")
+ (value (run-loadable-kernel-modules-test
+ (list ddcci-driver-linux)
+ '("ddcci")))))
+
+(define %test-loadable-kernel-modules-2
+ (system-test
+ (name "loadable-kernel-modules-2")
+ (description "Tests loadable kernel modules facility of <operating-system>
+with two extra modules.")
+ (value (run-loadable-kernel-modules-test
+ (list acpi-call-linux-module ddcci-driver-linux)
+ '("acpi_call" "ddcci")))))
diff --git a/gnu/tests/mail.scm b/gnu/tests/mail.scm
index 298918b3a7..a50fb1dbca 100644
--- a/gnu/tests/mail.scm
+++ b/gnu/tests/mail.scm
@@ -99,8 +99,8 @@ match from any for local action inbound
(test-assert "mbox is empty"
(marionette-eval
- '(and (file-exists? "/var/mail")
- (not (file-exists? "/var/mail/root")))
+ '(and (file-exists? "/var/spool/mail")
+ (not (file-exists? "/var/spool/mail/root")))
marionette))
(test-eq "accept an email"
@@ -140,16 +140,21 @@ match from any for local action inbound
(ice-9 rdelim))
(define (queue-empty?)
- (eof-object?
- (read-line
- (open-input-pipe
- (string-append #$(file-append opensmtpd "/sbin/smtpctl")
- " show queue")))))
+ (let* ((pipe (open-pipe* OPEN_READ
+ #$(file-append opensmtpd
+ "/sbin/smtpctl")
+ "show" "queue"))
+ (line (read-line pipe)))
+ (close-pipe pipe)
+ (eof-object? line)))
- (let wait ()
- (if (queue-empty?)
- (file-exists? "/var/mail/root")
- (begin (sleep 1) (wait)))))
+ (let wait ((n 20))
+ (cond ((queue-empty?)
+ (file-exists? "/var/spool/mail/root"))
+ ((zero? n)
+ (error "root mailbox didn't show up"))
+ (else
+ (sleep 1) (wait (- n 1))))))
marionette))
(test-end)
diff --git a/gnu/tests/networking.scm b/gnu/tests/networking.scm
index d1234442bb..e90b247883 100644
--- a/gnu/tests/networking.scm
+++ b/gnu/tests/networking.scm
@@ -270,11 +270,11 @@ subnet 192.168.1.0 netmask 255.255.255.0 {
(dhcpd-configuration
(config-file minimal-dhcpd-v4-config-file)
(version "4")
- (interfaces '("eth0"))))
+ (interfaces '("ens3"))))
(define %dhcpd-os
(simple-operating-system
- (static-networking-service "eth0" "192.168.1.4"
+ (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"))
diff --git a/gnu/tests/nfs.scm b/gnu/tests/nfs.scm
index 014d049ab5..5e4de2783b 100644
--- a/gnu/tests/nfs.scm
+++ b/gnu/tests/nfs.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; 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>
@@ -101,6 +101,10 @@
(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))
@@ -192,18 +196,6 @@
(define marionette
(make-marionette (list #$(virtual-machine os))))
- (define (wait-for-file file)
- ;; Wait until FILE exists in the guest
- (marionette-eval
- `(let loop ((i 10))
- (cond ((file-exists? ,file)
- #t)
- ((> i 0)
- (sleep 1)
- (loop (- i 1)))
- (else
- (error "File didn't show up: " ,file))))
- marionette))
(mkdir #$output)
(chdir #$output)
@@ -227,22 +219,8 @@
marionette))
(test-assert "nscd is listening on its socket"
- (marionette-eval
- ;; XXX: Work around a race condition in nscd: nscd creates its
- ;; PID file before it is listening on its socket.
- '(let ((sock (socket PF_UNIX SOCK_STREAM 0)))
- (let try ()
- (catch 'system-error
- (lambda ()
- (connect sock AF_UNIX "/var/run/nscd/socket")
- (close-port sock)
- (format #t "nscd is ready~%")
- #t)
- (lambda args
- (format #t "waiting for nscd...~%")
- (usleep 500000)
- (try)))))
- marionette))
+ (wait-for-unix-socket "/var/run/nscd/socket"
+ marionette))
(test-assert "network is up"
(marionette-eval
@@ -258,7 +236,7 @@
(use-modules (gnu services herd))
(start-service 'nfs))
marionette)
- (wait-for-file "/var/run/rpc.statd.pid")))
+ (wait-for-file "/var/run/rpc.statd.pid" marionette)))
(test-assert "nfs share is advertised"
(marionette-eval
diff --git a/gnu/tests/rsync.scm b/gnu/tests/rsync.scm
index 096580022f..24e60d9d9d 100644
--- a/gnu/tests/rsync.scm
+++ b/gnu/tests/rsync.scm
@@ -64,6 +64,10 @@ PORT."
(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))
generated by cgit v1.2.3 (git 2.50.1) at 2025-08-10 17:03:36 +0000