diff options
author | Maxim Cournoyer <maxim.cournoyer@gmail.com> | 2022-01-25 23:36:11 -0500 |
---|---|---|
committer | Maxim Cournoyer <maxim.cournoyer@gmail.com> | 2022-01-25 23:48:37 -0500 |
commit | 0d41fe4855588fb659b8adafe215d5573517a79b (patch) | |
tree | 38b274bd03375f4fa5b7d3a9fb3f64a19786bef2 /gnu/tests | |
parent | 7c57821c68d199ad56a8ed750b36eccc7ef238dd (diff) | |
parent | 1a5302435ff0d2822b823f5a6fe01faa7a85c629 (diff) | |
download | guix-0d41fe4855588fb659b8adafe215d5573517a79b.tar.gz |
Merge branch 'staging' into core-updates.
With "conflicts" resolved in (mostly in favor of master/staging): gnu/packages/admin.scm gnu/packages/gnuzilla.scm gnu/packages/gtk.scm gnu/packages/kerberos.scm gnu/packages/linux.scm guix/lint.scm
Diffstat (limited to 'gnu/tests')
-rw-r--r-- | gnu/tests/docker.scm | 51 | ||||
-rw-r--r-- | gnu/tests/install.scm | 7 | ||||
-rw-r--r-- | gnu/tests/nfs.scm | 181 | ||||
-rw-r--r-- | gnu/tests/reconfigure.scm | 4 | ||||
-rw-r--r-- | gnu/tests/rsync.scm | 40 | ||||
-rw-r--r-- | gnu/tests/telephony.scm | 4 |
6 files changed, 165 insertions, 122 deletions
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm index bc119988b7..6302bd0727 100644 --- a/gnu/tests/docker.scm +++ b/gnu/tests/docker.scm @@ -18,9 +18,11 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu tests docker) + #:use-module (gnu image) #:use-module (gnu tests) #:use-module (gnu system) #:use-module (gnu system file-systems) + #:use-module (gnu system image) #:use-module (gnu system vm) #:use-module (gnu services) #:use-module (gnu services dbus) @@ -35,7 +37,7 @@ #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix profiles) - #:use-module (guix scripts pack) + #:use-module ((guix scripts pack) #:prefix pack:) #:use-module (guix store) #:use-module (guix tests) #:use-module (guix build-system trivial) @@ -56,15 +58,18 @@ inside %DOCKER-OS." (define os (marionette-operating-system - %docker-os + (operating-system-with-gc-roots + %docker-os + (list docker-tarball)) #:imported-modules '((gnu services herd) (guix combinators)))) (define vm (virtual-machine (operating-system os) - (memory-size 700) - (disk-image-size (* 1500 (expt 2 20))) + (volatile? #f) + (memory-size 1024) + (disk-image-size (* 3000 (expt 2 20))) (port-forwardings '()))) (define test @@ -173,11 +178,12 @@ standard output device and then enters a new line.") guest-script-package)) #:hooks '() #:locales? #f)) - (tarball (docker-image "docker-pack" profile - #:symlinks '(("/bin/Guile" -> "bin/guile") - ("aa.scm" -> "a.scm")) - #:entry-point "bin/guile" - #:localstatedir? #t))) + (tarball (pack:docker-image + "docker-pack" profile + #:symlinks '(("/bin/Guile" -> "bin/guile") + ("aa.scm" -> "a.scm")) + #:entry-point "bin/guile" + #:localstatedir? #t))) (run-docker-test tarball))) (define %test-docker @@ -192,19 +198,18 @@ standard output device and then enters a new line.") inside %DOCKER-OS." (define os (marionette-operating-system - %docker-os + (operating-system-with-gc-roots + %docker-os + (list tarball)) #:imported-modules '((gnu services herd) (guix combinators)))) (define vm (virtual-machine (operating-system os) - ;; FIXME: Because we're using the volatile-root setup where the root file - ;; system is a tmpfs overlaid over a small root file system, 'docker - ;; load' must be able to store the whole image into memory, hence the - ;; huge memory requirements. We should avoid the volatile-root setup - ;; instead. - (memory-size 4500) + (volatile? #f) + (disk-image-size (* 5000 (expt 2 20))) + (memory-size 2048) (port-forwardings '()))) (define test @@ -293,10 +298,12 @@ inside %DOCKER-OS." (description "Run a system image as produced by @command{guix system docker-image} inside Docker.") (value (with-monad %store-monad - (>>= (system-docker-image (operating-system - (inherit (simple-operating-system)) - ;; Use locales for a single libc to - ;; reduce space requirements. - (locale-libcs (list glibc))) - #:memory-size 1024) + (>>= (lower-object + (system-image (os->image + (operating-system + (inherit (simple-operating-system)) + ;; Use locales for a single libc to + ;; reduce space requirements. + (locale-libcs (list glibc))) + #:type docker-image-type))) run-docker-system-test))))) diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index 9602efebe7..ae8c6051f1 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -31,7 +31,7 @@ #:use-module (gnu system image) #:use-module (gnu system install) #:use-module (gnu system vm) - #:use-module ((gnu build vm) #:select (qemu-command)) + #:use-module ((gnu build marionette) #:select (qemu-command)) #:use-module (gnu packages admin) #:use-module (gnu packages bootloaders) #:use-module (gnu packages commencement) ;for 'guile-final' @@ -1685,8 +1685,9 @@ build (current-guix) and then store a couple of full system images.") (list (swap-space (target (uuid "11111111-2222-3333-4444-123456789abc")))))) - (services (cons (service dhcp-client-service-type) - (operating-system-user-services %minimal-os-on-vda))))) + (services (cons* (service dhcp-client-service-type) + (service ntp-service-type) + (operating-system-user-services %minimal-os-on-vda))))) (define* (installation-target-desktop-os-for-gui-tests #:key (encrypted? #f)) diff --git a/gnu/tests/nfs.scm b/gnu/tests/nfs.scm index 7b7dd8c360..0d9972e0e9 100644 --- a/gnu/tests/nfs.scm +++ b/gnu/tests/nfs.scm @@ -33,6 +33,7 @@ #:use-module (gnu services base) #:use-module (gnu services nfs) #:use-module (gnu services networking) + #:use-module (gnu packages admin) #:use-module (gnu packages onc-rpc) #:use-module (gnu packages nfs) #:use-module (guix gexp) @@ -40,7 +41,7 @@ #:use-module (guix monads) #:export (%test-nfs %test-nfs-server - %test-nfs-root-fs)) + %test-nfs-full)) (define %base-os (operating-system @@ -259,41 +260,63 @@ directories can be mounted.") (value (run-nfs-server-test)))) -(define (run-nfs-root-fs-test) +(define (run-nfs-full-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)))) + (let ((os (simple-operating-system))) + (marionette-operating-system + (operating-system + (inherit os) + (services + (cons* + (service static-networking-service-type + (list + (static-networking + (addresses (list (network-address + (device "ens5") + (value "10.0.2.15/24"))))))) + (simple-service 'export activation-service-type + #~(begin + (mkdir-p "/export") + (chmod "/export" #o777))) + (service nfs-service-type + (nfs-configuration + (nfsd-port 2049) + (nfs-versions '("4.2")) + (exports '(("/export" + "*(rw,insecure,no_subtree_check,\ +crossmnt,fsid=root,no_root_squash,insecure,async)"))))) + (modify-services (operating-system-user-services os) + (syslog-service-type config + => + (syslog-configuration + (inherit config) + (config-file + (plain-file + "syslog.conf" + "*.* /dev/console\n")))))))) + #: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))) + (simple-operating-system + (service static-networking-service-type + (list + (static-networking + (addresses + (list (network-address + (device "ens5") + (value "10.0.2.16/24"))))))) + (service nfs-service-type + (nfs-configuration + (nfsd-port 2049) + (nfs-versions '("4.2")))) + (simple-service 'export activation-service-type + #~(begin + (mkdir-p "/export") + (chmod "/export" #o777)))) #:requirements '(nscd) #:imported-modules '((gnu services herd) (guix combinators)))) @@ -308,84 +331,56 @@ directories can be mounted.") (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) + (make-marionette + (cons* #$(virtual-machine + (operating-system nfs-root-server-os) + (volatile? #f)) + '("-device" "e1000,netdev=n1,mac=52:54:00:12:34:56" + "-netdev" "socket,id=n1,listen=:1234")) + #:socket-directory "/tmp/server")) ;;; 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)) + (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. - + (mkdir "/tmp/client") (define client-marionette - (make-marionette (list #$(virtual-machine - nfs-root-client-os - ;(port-forwardings '((111 . 111) - ; (2049 . 2049) - ; (20001 . 20001) - ; (20002 . 20002))) - )))) + (make-marionette + (cons* #$(virtual-machine + (operating-system nfs-root-client-os) + (volatile? #f)) + '("-device" "e1000,netdev=n2,mac=52:54:00:12:34:57" + "-netdev" "socket,id=n2,connect=127.0.0.1:1234")) + #:socket-directory "/tmp/client")) + + (test-assert "NFS port is ready" + (wait-for-tcp-port 2049 client-marionette)) (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")) + (and + (system* (string-append #$nfs-utils "/sbin/mount.nfs") + "10.0.2.15:/export" "/export" "-v") + (let ((content (call-with-input-file "/proc/mounts" + get-string-all))) + (call-with-output-file "/export/mounts" + (lambda (port) + (display content port)))))) 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)) + (wait-for-file "/export/mounts" server-marionette)) + (marionette-eval '(begin (current-output-port @@ -395,11 +390,11 @@ directories can be mounted.") (test-end)))) - (gexp->derivation "nfs-root-fs-test" test)) + (gexp->derivation "nfs-full-test" test)) -(define %test-nfs-root-fs +(define %test-nfs-full (system-test - (name "nfs-root-fs") + (name "nfs-full") (description "Test that an NFS server can be started and the exported -directory can be used as root file system.") - (value (run-nfs-root-fs-test)))) +directory can be used by another machine.") + (value (run-nfs-full-test)))) diff --git a/gnu/tests/reconfigure.scm b/gnu/tests/reconfigure.scm index 2fd7c6854d..ec845fe4b0 100644 --- a/gnu/tests/reconfigure.scm +++ b/gnu/tests/reconfigure.scm @@ -189,7 +189,9 @@ bootloader's configuration file." #:imported-modules '((gnu services herd) (guix combinators)))) - (define vm (virtual-machine os)) + (define vm (virtual-machine + (operating-system os) + (volatile? #f))) (define (test script) (with-imported-modules '((gnu build marionette)) diff --git a/gnu/tests/rsync.scm b/gnu/tests/rsync.scm index 91f2b41cec..ea53a157bb 100644 --- a/gnu/tests/rsync.scm +++ b/gnu/tests/rsync.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -104,6 +105,35 @@ PORT." (read-line port)))) marionette)) + (test-equal "Test file not copied to read-only share" + 1 ;see "EXIT VALUES" in rsync(1) + (marionette-eval + '(status:exit-val + (system* "rsync" "/tmp/input" + (string-append "rsync://localhost:" + (number->string #$rsync-port) + "/read-only/input"))) + marionette)) + + (test-equal "Test file correctly received from read-only share" + "\"Hi!\" from the read-only share." + (marionette-eval + '(begin + (use-modules (ice-9 rdelim)) + + (call-with-output-file "/srv/read-only/the-file" + (lambda (port) + (display "\"Hi!\" from the read-only share." port))) + + (zero? + (system* "rsync" + (string-append "rsync://localhost:" + (number->string #$rsync-port) + "/read-only/the-file") + "/tmp/output")) + (call-with-input-file "/tmp/output" read-line)) + marionette)) + (test-end)))) (gexp->derivation "rsync-test" test)) @@ -113,7 +143,15 @@ PORT." (let ((base-os (simple-operating-system (service dhcp-client-service-type) - (service rsync-service-type)))) + (service rsync-service-type + (rsync-configuration + (modules (list (rsync-module + (name "read-only") + (file-name "/srv/read-only")) + (rsync-module + (name "files") + (file-name "/srv/read-write") + (read-only? #f))))))))) (operating-system (inherit base-os) (packages (cons* rsync diff --git a/gnu/tests/telephony.scm b/gnu/tests/telephony.scm index 998bdbccf9..bc464a431a 100644 --- a/gnu/tests/telephony.scm +++ b/gnu/tests/telephony.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gnu.org>. +;;; Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>. ;;; ;;; This file is part of GNU Guix. ;;; @@ -174,7 +174,7 @@ accounts provisioning feature of the service." ;; in the service; use retries. (with-retries 20 1 (not (zero? (status:exit-val - (system* "pgrep" "dring"))))))) + (system* "pgrep" "jamid"))))))) marionette)) (test-assert "service can be restarted" |