diff options
Diffstat (limited to 'gnu/tests')
| -rw-r--r-- | gnu/tests/base.scm | 81 | ||||
| -rw-r--r-- | gnu/tests/databases.scm | 3 | ||||
| -rw-r--r-- | gnu/tests/docker.scm | 4 | ||||
| -rw-r--r-- | gnu/tests/gdm.scm | 127 | ||||
| -rw-r--r-- | gnu/tests/lightdm.scm | 7 | ||||
| -rw-r--r-- | gnu/tests/vnc.scm | 203 | ||||
| -rw-r--r-- | gnu/tests/web.scm | 7 |
7 files changed, 407 insertions, 25 deletions
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index 636b127fb8..3e72e193d7 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -1,6 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> +;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2022 Marius Bakke <marius@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -45,10 +47,16 @@ #:use-module (guix monads) #:use-module (guix modules) #:use-module (guix packages) + #:use-module (guix utils) #:use-module ((srfi srfi-1) #:hide (partition)) #:use-module (ice-9 match) #:export (run-basic-test %test-basic-os + %test-linux-libre-5.15 + %test-linux-libre-5.10 + %test-linux-libre-5.4 + %test-linux-libre-4.19 + %test-linux-libre-4.14 %test-halt %test-root-unmount %test-cleanup @@ -423,6 +431,12 @@ info --version") (x (pk 'failure x #f)))) + (test-assert "nscd configuration action" + (marionette-eval '(with-shepherd-action 'nscd ('configuration) + results + (file-exists? (car results))) + marionette)) + (test-equal "nscd invalidate action" '(#t) ;one value, #t (marionette-eval '(with-shepherd-action 'nscd ('invalidate "hosts") @@ -509,32 +523,37 @@ info --version") (file-exists? capture)))) (test-assert "screen text" - (let ((text (marionette-screen-text marionette - #:ocr - #$(file-append ocrad - "/bin/ocrad")))) - ;; Check whether the welcome message and shell prompt are - ;; displayed. Note: OCR confuses "y" and "V" for instance, so - ;; we cannot reliably match the whole text. - (and (string-contains text "This is the GNU") - (string-contains text - (string-append - "root@" - #$(operating-system-host-name os)))))) + (wait-for-screen-text + marionette + (lambda (text) + ;; Check whether the welcome message and shell prompt are + ;; displayed. Note: OCR confuses "y" and "V" for instance, so + ;; we cannot reliably match the whole text. + (and (string-contains text "This is the GNU") + (string-contains text + (string-append + "root@" + #$(operating-system-host-name os))))) + #:ocr #$(file-append ocrad "/bin/ocrad"))) (test-end)))) (gexp->derivation name test)) -(define %test-basic-os +(define* (test-basic-os #:optional (kernel linux-libre)) (system-test - (name "basic") + (name (if (eq? kernel linux-libre) + "basic" + (string-append (package-name kernel) "-" + (version-major+minor (package-version kernel))))) (description "Instrument %SIMPLE-OS, run it in a VM, and run a series of basic -functionality tests.") +functionality tests, using the given KERNEL.") (value (let* ((os (marionette-operating-system - %simple-os + (operating-system + (inherit %simple-os) + (kernel kernel)) #:imported-modules '((gnu services herd) (guix combinators)))) (vm (virtual-machine os))) @@ -542,7 +561,27 @@ functionality tests.") ;; set of services as the OS produced by ;; 'system-qemu-image/shared-store-script'. (run-basic-test (virtualized-operating-system os '()) - #~(list #$vm)))))) + #~(list #$vm) + name))))) + +(define %test-basic-os + (test-basic-os)) + +;; Ensure the LTS kernels are up to snuff, too. +(define %test-linux-libre-5.15 + (test-basic-os linux-libre-5.15)) + +(define %test-linux-libre-5.10 + (test-basic-os linux-libre-5.10)) + +(define %test-linux-libre-5.4 + (test-basic-os linux-libre-5.4)) + +(define %test-linux-libre-4.19 + (test-basic-os linux-libre-4.19)) + +(define %test-linux-libre-4.14 + (test-basic-os linux-libre-4.14)) ;;; @@ -694,7 +733,13 @@ in a loop. See <http://bugs.gnu.org/26931>.") ;; Halt the system. (marionette-eval '(system* "/run/current-system/profile/sbin/halt") - marionette)) + marionette) + + (display "waiting for marionette to complete...") + (force-output) + (false-if-exception (waitpid (marionette-pid marionette))) + (display " done\n") + (force-output)) ;; Remove the sockets used by the marionette above to avoid ;; EADDRINUSE. diff --git a/gnu/tests/databases.scm b/gnu/tests/databases.scm index 296d91d118..2ca13577a1 100644 --- a/gnu/tests/databases.scm +++ b/gnu/tests/databases.scm @@ -430,6 +430,9 @@ data double PRECISION NULL (test-assert "mysql_upgrade completed" (wait-for-file "/var/lib/mysql/mysql_upgrade_info" marionette)) + (test-assert "socket is ready" + (wait-for-unix-socket "/run/mysqld/mysqld.sock" marionette)) + (test-eq "create database" 0 (marionette-eval diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm index 3e780d8a60..4267ff89a8 100644 --- a/gnu/tests/docker.scm +++ b/gnu/tests/docker.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org> -;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019-2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -209,7 +209,7 @@ inside %DOCKER-OS." (virtual-machine (operating-system os) (volatile? #f) - (disk-image-size (* 5000 (expt 2 20))) + (disk-image-size (* 5500 (expt 2 20))) (memory-size 2048) (port-forwardings '()))) diff --git a/gnu/tests/gdm.scm b/gnu/tests/gdm.scm new file mode 100644 index 0000000000..70a86b9065 --- /dev/null +++ b/gnu/tests/gdm.scm @@ -0,0 +1,127 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Bruno Victal <mirai@makinata.eu>. +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu tests gdm) + #:use-module (gnu tests) + #:use-module (gnu packages freedesktop) + #:use-module (gnu services) + #:use-module (gnu services desktop) + #:use-module (gnu services xorg) + #:use-module (gnu system) + #:use-module (gnu system file-systems) + #:use-module (gnu system vm) + #:use-module (guix gexp) + #:use-module (ice-9 format) + #:export (%test-gdm-x11 + %test-gdm-wayland + %test-gdm-wayland-tmpfs)) + +(define* (make-os #:key wayland? tmp-tmpfs?) + (operating-system + (inherit %simple-os) + (services + (modify-services %desktop-services + (gdm-service-type config => (gdm-configuration + (inherit config) + (wayland? wayland?))))) + (file-systems (if tmp-tmpfs? (cons (file-system + (mount-point "/tmp") + (device "none") + (type "tmpfs") + (flags '(no-dev no-suid)) + (check? #f)) + %base-file-systems) + %base-file-systems)))) + +(define* (run-gdm-test #:key wayland? tmp-tmpfs?) + "Run tests in a vm which has gdm running." + (define os + (marionette-operating-system + (make-os #:wayland? wayland? #:tmp-tmpfs? tmp-tmpfs?) + #:imported-modules '((gnu services herd)))) + + (define vm + (virtual-machine + (operating-system os) + (memory-size 1024))) + + (define name (format #f "gdm-~:[x11~;wayland~]~:[~;-tmpfs~]" wayland? tmp-tmpfs?)) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (gnu build marionette) + (ice-9 format) + (srfi srfi-64)) + + (let* ((marionette (make-marionette (list #$vm))) + (expected-session-type #$(if wayland? "wayland" "x11"))) + + (test-runner-current (system-test-runner #$output)) + (test-begin #$name) + + ;; service for gdm is called xorg-server + (test-assert "service is running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'xorg-server)) + marionette)) + + (test-assert "gdm ready" + (wait-for-file "/var/run/gdm/gdm.pid" marionette)) + + (test-equal (string-append "session-type is " expected-session-type) + expected-session-type + (marionette-eval + '(begin + (use-modules (ice-9 popen) + (ice-9 rdelim)) + + (let* ((loginctl #$(file-append elogind "/bin/loginctl")) + (get-session-cmd (string-join `(,loginctl "show-user" "gdm" + "--property Display" "--value"))) + (session (call-with-port (open-input-pipe get-session-cmd) read-line)) + (get-type-cmd (string-join `(,loginctl "show-session" ,session + "--property Type" "--value"))) + (type (call-with-port (open-input-pipe get-type-cmd) read-line))) + type)) + marionette)) + + (test-end))))) + + (gexp->derivation (string-append name "-test") test)) + +(define %test-gdm-x11 + (system-test + (name "gdm-x11") + (description "Basic tests for the GDM service. (X11)") + (value (run-gdm-test)))) + +(define %test-gdm-wayland + (system-test + (name "gdm-wayland") + (description "Basic tests for the GDM service. (Wayland)") + (value (run-gdm-test #:wayland? #t)))) + +(define %test-gdm-wayland-tmpfs + (system-test + ;; See <https://issues.guix.gnu.org/57589>. + (name "gdm-wayland-tmpfs") + (description "Basic tests for the GDM service. (Wayland, /tmp as tmpfs)") + (value (run-gdm-test #:wayland? #t #:tmp-tmpfs? #t)))) diff --git a/gnu/tests/lightdm.scm b/gnu/tests/lightdm.scm index 431b388e7e..57d029a75a 100644 --- a/gnu/tests/lightdm.scm +++ b/gnu/tests/lightdm.scm @@ -34,6 +34,7 @@ #:use-module (gnu services xorg) #:use-module (gnu system) #:use-module (gnu system file-systems) + #:use-module (gnu system keyboard) #:use-module (gnu system shadow) #:use-module (gnu system vm) #:use-module (gnu tests) @@ -56,7 +57,11 @@ (inherit %simple-os) (packages (cons* ocrad ratpoison xterm %base-packages)) (services - (cons* (service lightdm-service-type + (cons* (set-xorg-configuration (xorg-configuration + (keyboard-layout (keyboard-layout "us"))) + lightdm-service-type) + + (service lightdm-service-type (lightdm-configuration (allow-empty-passwords? #t) (debug? #t) diff --git a/gnu/tests/vnc.scm b/gnu/tests/vnc.scm new file mode 100644 index 0000000000..5c4bd43fa3 --- /dev/null +++ b/gnu/tests/vnc.scm @@ -0,0 +1,203 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@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 vnc) + #:use-module (gnu bootloader) + #:use-module (gnu bootloader grub) + #:use-module (gnu packages) + #:use-module (gnu packages ocr) + #:use-module (gnu packages glib) + #:use-module (gnu packages gnome) + #:use-module (gnu packages ratpoison) + #:use-module (gnu packages vnc) + #:use-module (gnu packages xorg) + #:use-module (gnu services) + #:use-module (gnu services dbus) + #:use-module (gnu services desktop) + #:use-module (gnu services networking) + #:use-module (gnu services ssh) + #:use-module (gnu services vnc) + #:use-module (gnu services xorg) + #:use-module (gnu system) + #:use-module (gnu system file-systems) + #:use-module (gnu system shadow) + #:use-module (gnu system vm) + #:use-module (gnu tests) + #:use-module (guix gexp) + #:use-module (guix modules) + #:export (%test-xvnc)) + +(define %xvnc-os + (operating-system + ;; Usual boilerplate. + (host-name "komputilo") + (timezone "Europe/Berlin") + (locale "en_US.UTF-8") + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (targets '("/dev/sdX")))) + (file-systems (cons (file-system + (device (file-system-label "my-root")) + (mount-point "/") + (type "ext4")) + %base-file-systems)) + + (users (cons (user-account + (name "dummy") + (group "users") + (supplementary-groups '("wheel" "netdev" + "audio" "video"))) + %base-user-accounts)) + (packages (cons* dbus ;for dbus-run-session + dconf + `(,glib "bin") + glib + gnome-settings-daemon ;for schemas + ratpoison + tigervnc-client + xterm + %base-packages)) + (services (cons* + (service openssh-service-type (openssh-configuration + (permit-root-login #t) + (allow-empty-passwords? #t))) + (service xvnc-service-type (xvnc-configuration + (display-number 5) + (security-types (list "None")) + (log-level 100) + (localhost? #f) + (xdmcp? #t) + (inetd? #t))) + (modify-services %desktop-services + (gdm-service-type config => (gdm-configuration + (inherit config) + (auto-login? #t) + (auto-suspend? #f) + (default-user "root") + (debug? #t) + (xdmcp? #t)))))))) + +(define (run-xvnc-test) + "Run tests in %XVNC-OS." + + (define os (marionette-operating-system + %xvnc-os + #:imported-modules (source-module-closure + '((gnu services herd))))) + + (define vm (virtual-machine + (operating-system os) + (memory-size 1024))) + + (define test + (with-imported-modules (source-module-closure + '((gnu build marionette) + (guix build utils))) + #~(begin + (use-modules (gnu build marionette) + (guix build utils) + (srfi srfi-26) + (srfi srfi-64)) + + (let ((marionette (make-marionette (list #$vm)))) + + (test-runner-current (system-test-runner #$output)) + (test-begin "xvnc") + + (test-assert "service running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'xvnc)) + marionette)) + + (test-assert "wait for port 5905, IPv4" + (wait-for-tcp-port 5905 marionette)) + + (test-assert "wait for port 5905, IPv6" + (wait-for-tcp-port 5905 marionette + #:address + '(make-socket-address + AF_INET6 (inet-pton AF_INET6 "::1") 5905))) + + (test-assert "gdm auto-suspend is disabled" + ;; More a GDM than a Xvnc test, but since it's a cross-cutting + ;; concern and we have everything set up here, we might as well + ;; check it here. + (marionette-eval + '(begin + ;; Check that DCONF_PROFILE is set... + (invoke "/bin/sh" "-lc" "\ +pgrep gdm | head -n1 | xargs -I{} grep -Fq DCONF_PROFILE /proc/{}/environ") + + ;; ... and that + (invoke "/bin/sh" "-lc" "\ +sudo -E -u gdm env DCONF_PROFILE=/etc/dconf/profile/gdm dbus-run-session \ +gsettings get org.gnome.settings-daemon.plugins.power sleep-inactive-ac-type \ +| grep -Fq nothing")) + marionette)) + + (test-assert "vnc lands on the gdm login screen" + ;; This test runs vncviewer on the local VM and verifies that it + ;; manages to access the GDM login screen (via XDMCP). + (begin + (define (ratpoison-abort) + (marionette-control "sendkey ctrl-g" marionette)) + + (define (ratpoison-help) + (marionette-control "sendkey ctrl-t" marionette) + (marionette-type "?" marionette) + (sleep 1)) ;wait for help screen to appear + + (define (ratpoison-exec command) + (marionette-control "sendkey ctrl-t" marionette) + (marionette-type "!" marionette) + (marionette-type (string-append command "\n") marionette)) + + ;; Wait until the ratpoison help screen can be displayed; this + ;; means the window manager is ready. + (wait-for-screen-text marionette + (cut string-contains <> "key bindings") + #:ocr #$(file-append tesseract-ocr + "/bin/tesseract") + #:pre-action ratpoison-help + #:post-action ratpoison-abort) + + ;; Run vncviewer and expect the GDM login screen (accessed via + ;; XDMCP). This can take a while to appear on slower machines. + (ratpoison-exec "vncviewer localhost:5905") + ;; XXX: tesseract narrowly recognizes "Guix" as "uix" from the + ;; background image; ocrad fares worst. Sadly, 'Username' is + ;; not recognized at all. + (wait-for-screen-text marionette + (cut string-contains <> "uix") + #:ocr #$(file-append tesseract-ocr + "/bin/tesseract") + #:timeout 120))) + + (test-end))))) + + (gexp->derivation "xvnc-test" test)) + +(define %test-xvnc + (system-test + (name "xvnc") + (description "Basic tests for the Xvnc service. One of the tests validate +that XDMCP works with GDM, and is therefore heavy in terms of disk and memory +requirements.") + (value (run-xvnc-test)))) diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm index 7a585e618d..16dc6bea49 100644 --- a/gnu/tests/web.scm +++ b/gnu/tests/web.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2020-2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2020-2021, 2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2019 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr> @@ -419,9 +419,8 @@ HTTP-PORT, along with php-fpm." (define %hpcguix-web-specs ;; Server config gexp. - #~(define site-config - (hpcweb-configuration - (title-prefix "[TEST] HPCGUIX-WEB")))) + #~(hpcweb-configuration + (title-prefix "[TEST] HPCGUIX-WEB"))) (define %hpcguix-web-os (simple-operating-system |