Package: guix-patches;
Reported by: Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
Date: Sun, 13 Mar 2022 05:42:02 UTC
Severity: normal
Tags: patch
Done: Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
Bug is archived. No further changes may be made.
Message #14 received at 54368 <at> debbugs.gnu.org (full text, mbox):
From: Maxim Cournoyer <maxim.cournoyer <at> gmail.com> To: 54368 <at> debbugs.gnu.org Cc: Maxim Cournoyer <maxim.cournoyer <at> gmail.com> Subject: [PATCH 3/4] tests: install: Enable the use of multiple disk devices for tests. Date: Sun, 13 Mar 2022 00:43:54 -0500
* gnu/tests/install.scm (run-install)[NUMBER-OF-DISKS]: Add argument, update
doc and adjust. The returned gexp output is now a list of images rather than
the image itself.
* gnu/tests/install.scm (qemu-command*): Rename IMAGE argument to IMAGES, to
account for the above change. Adjust doc. Generate a QEMU '-drive' argument
for each disk image.
(%test-installed-os): Rename the IMAGE variable to IMAGES.
(%test-installed-extlinux-os): Likewise.
(%test-iso-image-installer): Likewise.
(%test-separate-home-os): Likewise.
(%test-separate-store-os): Likewise.
(%test-raid-root-os): Likewise.
(%test-encrypted-root-os): Likewise.
(%test-lvm-separate-home-os): Likewise.
(%test-encrypted-root-not-boot-os): Likewise.
(%test-btrfs-root-os): Likewise.
(%test-btrfs-raid-root-os): Likewise.
(%test-btrfs-root-on-subvolume-os): Likewise.
(%test-jfs-root-os): Likewise.
(%test-f2fs-root-os): Likewise.
(%test-xfs-root-os): Likewise.
(guided-installation-test): Likewise.
---
gnu/tests/install.scm | 244 +++++++++++++++++++++++-------------------
1 file changed, 132 insertions(+), 112 deletions(-)
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index d1f8cc1c6d..59e76c86e7 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -240,12 +240,14 @@ (define* (run-install target-os target-os-source
(uefi-support? #f)
(installation-image-type 'efi-raw)
(install-size 'guess)
- (target-size (* 2200 MiB)))
+ (target-size (* 2200 MiB))
+ (number-of-disks 1))
"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
-the installed system. The packages specified in PACKAGES will be appended to
-packages defined in installation-os."
-
+OS to install TARGET-OS. Return the VM disk images of TARGET-SIZE bytes
+containing the installed system. Unless providing OS, the PACKAGES will be
+added to the packages defined in INSTALLATION-OS (from (gnu system install)).
+NUMBER-OF-DISKS can be used to specify a number of disks different than one,
+such as for RAID systems."
(mlet* %store-monad ((_ (set-grafting #f))
(system (current-system))
@@ -276,13 +278,18 @@ (define install
(gnu build marionette))
#~(begin
(use-modules (guix build utils)
- (gnu build marionette))
+ (gnu build marionette)
+ (srfi srfi-1))
(set-path-environment-variable "PATH" '("bin")
(list #$qemu-minimal))
- (system* "qemu-img" "create" "-f" "qcow2"
- #$output #$(number->string target-size))
+ (mkdir-p #$output)
+ (for-each (lambda (n)
+ (system* "qemu-img" "create" "-f" "qcow2"
+ (format #f "~a/disk~a.qcow2" #$output n)
+ #$(number->string target-size)))
+ (iota #$number-of-disks))
(define marionette
(make-marionette
@@ -303,8 +310,12 @@ (define marionette
(error
"unsupported installation-image-type:"
installation-image-type)))
- "-drive"
- ,(string-append "file=" #$output ",if=virtio")
+ ,@(append-map
+ (lambda (n)
+ (list "-drive"
+ (format #f "file=~a/disk~a.qcow2,if=virtio"
+ #$output n)))
+ (iota #$number-of-disks))
,@(if (file-exists? "/dev/kvm")
'("-enable-kvm")
'()))))
@@ -338,16 +349,23 @@ (define marionette
(exit #$(and gui-test
(gui-test #~marionette)))))))
- (gexp->derivation "installation" install
- #:substitutable? #f))) ;too big
+ (mlet %store-monad ((images-dir (gexp->derivation "installation"
+ install
+ #:substitutable? #f))) ;too big
+ (return (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+ (find-files #$images-dir)))))))
-(define* (qemu-command* image #:key (uefi-support? #f) (memory-size 256))
+(define* (qemu-command* images #:key (uefi-support? #f) (memory-size 256))
"Return as a monadic value the command to run QEMU with a writable overlay
-above IMAGE, a disk image. The QEMU VM has access to MEMORY-SIZE MiB of RAM."
+on top of IMAGES, a list disk images. The QEMU VM has access to MEMORY-SIZE
+MiB of RAM."
(mlet* %store-monad ((system (current-system))
(uefi-firmware -> (and uefi-support?
(uefi-firmware system))))
(return #~(begin
+ (use-modules (srfi srfi-1))
`(,(string-append #$qemu-minimal "/bin/"
#$(qemu-command system))
"-snapshot" ;for the volatile, writable overlay
@@ -358,7 +376,10 @@ (define* (qemu-command* image #:key (uefi-support? #f) (memory-size 256))
'("-bios" #$uefi-firmware)
'())
"-no-reboot" "-m" #$(number->string memory-size)
- "-drive" (format #f "file=~a,if=virtio" #$image))))))
+ ,@(append-map (lambda (image)
+ (list "-drive" (format #f "file=~a,if=virtio"
+ image)))
+ #$images))))))
(define %test-installed-os
(system-test
@@ -368,8 +389,8 @@ (define %test-installed-os
This test is expensive in terms of CPU and storage usage since we need to
build (current-guix) and then store a couple of full system images.")
(value
- (mlet* %store-monad ((image (run-install %minimal-os %minimal-os-source))
- (command (qemu-command* image)))
+ (mlet* %store-monad ((images (run-install %minimal-os %minimal-os-source))
+ (command (qemu-command* images)))
(run-basic-test %minimal-os command
"installed-os")))))
@@ -380,13 +401,13 @@ (define %test-installed-extlinux-os
"Test basic functionality of an OS booted with an extlinux bootloader. As
per %test-installed-os, this test is expensive in terms of CPU and storage.")
(value
- (mlet* %store-monad ((image (run-install %minimal-extlinux-os
- %minimal-extlinux-os-source
- #:packages
- (list syslinux)
- #:script
- %extlinux-gpt-installation-script))
- (command (qemu-command* image)))
+ (mlet* %store-monad ((images (run-install %minimal-extlinux-os
+ %minimal-extlinux-os-source
+ #:packages
+ (list syslinux)
+ #:script
+ %extlinux-gpt-installation-script))
+ (command (qemu-command* images)))
(run-basic-test %minimal-extlinux-os command
"installed-extlinux-os")))))
@@ -456,14 +477,14 @@ (define %test-iso-image-installer
(description
"")
(value
- (mlet* %store-monad ((image (run-install
- %minimal-os-on-vda
- %minimal-os-on-vda-source
- #:script
- %simple-installation-script-for-/dev/vda
- #:installation-image-type
- 'uncompressed-iso9660))
- (command (qemu-command* image)))
+ (mlet* %store-monad ((images (run-install
+ %minimal-os-on-vda
+ %minimal-os-on-vda-source
+ #:script
+ %simple-installation-script-for-/dev/vda
+ #:installation-image-type
+ 'uncompressed-iso9660))
+ (command (qemu-command* images)))
(run-basic-test %minimal-os-on-vda command name)))))
@@ -514,11 +535,11 @@ (define %test-separate-home-os
partition. In particular, home directories must be correctly created (see
<https://bugs.gnu.org/21108>).")
(value
- (mlet* %store-monad ((image (run-install %separate-home-os
- %separate-home-os-source
- #:script
- %simple-installation-script))
- (command (qemu-command* image)))
+ (mlet* %store-monad ((images (run-install %separate-home-os
+ %separate-home-os-source
+ #:script
+ %simple-installation-script))
+ (command (qemu-command* images)))
(run-basic-test %separate-home-os command "separate-home-os")))))
@@ -591,11 +612,11 @@ (define %test-separate-store-os
"Test basic functionality of an OS installed like one would do by hand,
where /gnu lives on a separate partition.")
(value
- (mlet* %store-monad ((image (run-install %separate-store-os
- %separate-store-os-source
- #:script
- %separate-store-installation-script))
- (command (qemu-command* image)))
+ (mlet* %store-monad ((images (run-install %separate-store-os
+ %separate-store-os-source
+ #:script
+ %separate-store-installation-script))
+ (command (qemu-command* images)))
(run-basic-test %separate-store-os command "separate-store-os")))))
@@ -672,12 +693,12 @@ (define %test-raid-root-os
"Test functionality of an OS installed with a RAID root partition managed
by 'mdadm'.")
(value
- (mlet* %store-monad ((image (run-install %raid-root-os
- %raid-root-os-source
- #:script
- %raid-root-installation-script
- #:target-size (* 3200 MiB)))
- (command (qemu-command* image)))
+ (mlet* %store-monad ((images (run-install %raid-root-os
+ %raid-root-os-source
+ #:script
+ %raid-root-installation-script
+ #:target-size (* 3200 MiB)))
+ (command (qemu-command* images)))
(run-basic-test %raid-root-os
`(,@command) "raid-root-os")))))
@@ -806,11 +827,11 @@ (define %test-encrypted-root-os
This test is expensive in terms of CPU and storage usage since we need to
build (current-guix) and then store a couple of full system images.")
(value
- (mlet* %store-monad ((image (run-install %encrypted-root-os
- %encrypted-root-os-source
- #:script
- %encrypted-root-installation-script))
- (command (qemu-command* image)))
+ (mlet* %store-monad ((images (run-install %encrypted-root-os
+ %encrypted-root-os-source
+ #:script
+ %encrypted-root-installation-script))
+ (command (qemu-command* images)))
(run-basic-test %encrypted-root-os command "encrypted-root-os"
#:initialization enter-luks-passphrase)))))
@@ -890,13 +911,13 @@ (define %test-lvm-separate-home-os
(description
"Test functionality of an OS installed with a LVM /home partition")
(value
- (mlet* %store-monad ((image (run-install %lvm-separate-home-os
- %lvm-separate-home-os-source
- #:script
- %lvm-separate-home-installation-script
- #:packages (list lvm2-static)
- #:target-size (* 3200 MiB)))
- (command (qemu-command* image)))
+ (mlet* %store-monad ((images (run-install %lvm-separate-home-os
+ %lvm-separate-home-os-source
+ #:script
+ %lvm-separate-home-installation-script
+ #:packages (list lvm2-static)
+ #:target-size (* 3200 MiB)))
+ (command (qemu-command* images)))
(run-basic-test %lvm-separate-home-os
`(,@command) "lvm-separate-home-os")))))
@@ -992,11 +1013,11 @@ (define %test-encrypted-root-not-boot-os
store a couple of full system images.")
(value
(mlet* %store-monad
- ((image (run-install %encrypted-root-not-boot-os
- %encrypted-root-not-boot-os-source
- #:script
- %encrypted-root-not-boot-installation-script))
- (command (qemu-command* image)))
+ ((images (run-install %encrypted-root-not-boot-os
+ %encrypted-root-not-boot-os-source
+ #:script
+ %encrypted-root-not-boot-installation-script))
+ (command (qemu-command* images)))
(run-basic-test %encrypted-root-not-boot-os command
"encrypted-root-not-boot-os"
#:initialization enter-luks-passphrase)))))
@@ -1068,11 +1089,11 @@ (define %test-btrfs-root-os
This test is expensive in terms of CPU and storage usage since we need to
build (current-guix) and then store a couple of full system images.")
(value
- (mlet* %store-monad ((image (run-install %btrfs-root-os
- %btrfs-root-os-source
- #:script
- %btrfs-root-installation-script))
- (command (qemu-command* image)))
+ (mlet* %store-monad ((images (run-install %btrfs-root-os
+ %btrfs-root-os-source
+ #:script
+ %btrfs-root-installation-script))
+ (command (qemu-command* images)))
(run-basic-test %btrfs-root-os command "btrfs-root-os")))))
@@ -1136,11 +1157,11 @@ (define %test-btrfs-raid-root-os
RAID-0 (stripe) root partition.")
(value
(mlet* %store-monad
- ((image (run-install %btrfs-raid-root-os
- %btrfs-raid-root-os-source
- #:script %btrfs-raid-root-installation-script
- #:target-size (* 2800 MiB)))
- (command (qemu-command* image)))
+ ((images (run-install %btrfs-raid-root-os
+ %btrfs-raid-root-os-source
+ #:script %btrfs-raid-root-installation-script
+ #:target-size (* 2800 MiB)))
+ (command (qemu-command* images)))
(run-basic-test %btrfs-raid-root-os `(,@command) "btrfs-raid-root-os")))))
@@ -1227,12 +1248,11 @@ (define %test-btrfs-root-on-subvolume-os
build (current-guix) and then store a couple of full system images.")
(value
(mlet* %store-monad
- ((image
- (run-install %btrfs-root-on-subvolume-os
- %btrfs-root-on-subvolume-os-source
- #:script
- %btrfs-root-on-subvolume-installation-script))
- (command (qemu-command* image)))
+ ((images (run-install %btrfs-root-on-subvolume-os
+ %btrfs-root-on-subvolume-os-source
+ #:script
+ %btrfs-root-on-subvolume-installation-script))
+ (command (qemu-command* images)))
(run-basic-test %btrfs-root-on-subvolume-os command
"btrfs-root-on-subvolume-os")))))
@@ -1302,11 +1322,11 @@ (define %test-jfs-root-os
This test is expensive in terms of CPU and storage usage since we need to
build (current-guix) and then store a couple of full system images.")
(value
- (mlet* %store-monad ((image (run-install %jfs-root-os
- %jfs-root-os-source
- #:script
- %jfs-root-installation-script))
- (command (qemu-command* image)))
+ (mlet* %store-monad ((images (run-install %jfs-root-os
+ %jfs-root-os-source
+ #:script
+ %jfs-root-installation-script))
+ (command (qemu-command* images)))
(run-basic-test %jfs-root-os command "jfs-root-os")))))
@@ -1375,11 +1395,11 @@ (define %test-f2fs-root-os
This test is expensive in terms of CPU and storage usage since we need to
build (current-guix) and then store a couple of full system images.")
(value
- (mlet* %store-monad ((image (run-install %f2fs-root-os
- %f2fs-root-os-source
- #:script
- %f2fs-root-installation-script))
- (command (qemu-command* image)))
+ (mlet* %store-monad ((images (run-install %f2fs-root-os
+ %f2fs-root-os-source
+ #:script
+ %f2fs-root-installation-script))
+ (command (qemu-command* images)))
(run-basic-test %f2fs-root-os command "f2fs-root-os")))))
@@ -1448,11 +1468,11 @@ (define %test-xfs-root-os
This test is expensive in terms of CPU and storage usage since we need to
build (current-guix) and then store a couple of full system images.")
(value
- (mlet* %store-monad ((image (run-install %xfs-root-os
- %xfs-root-os-source
- #:script
- %xfs-root-installation-script))
- (command (qemu-command* image)))
+ (mlet* %store-monad ((images (run-install %xfs-root-os
+ %xfs-root-os-source
+ #:script
+ %xfs-root-installation-script))
+ (command (qemu-command* images)))
(run-basic-test %xfs-root-os command "xfs-root-os")))))
@@ -1720,22 +1740,22 @@ (define* (guided-installation-test name
"Install an OS using the graphical installer and test it.")
(value
(mlet* %store-monad
- ((image (run-install target-os '(this is unused)
- #:script #f
- #:os installation-os-for-gui-tests
- #:uefi-support? uefi-support?
- #:install-size install-size
- #:target-size target-size
- #:installation-image-type
- 'uncompressed-iso9660
- #:gui-test
- (lambda (marionette)
- (gui-test-program
- marionette
- #:desktop? desktop?
- #:encrypted? encrypted?
- #:uefi-support? uefi-support?))))
- (command (qemu-command* image
+ ((images (run-install target-os '(this is unused)
+ #:script #f
+ #:os installation-os-for-gui-tests
+ #:uefi-support? uefi-support?
+ #:install-size install-size
+ #:target-size target-size
+ #:installation-image-type
+ 'uncompressed-iso9660
+ #:gui-test
+ (lambda (marionette)
+ (gui-test-program
+ marionette
+ #:desktop? desktop?
+ #:encrypted? encrypted?
+ #:uefi-support? uefi-support?))))
+ (command (qemu-command* images
#:uefi-support? uefi-support?
#:memory-size 512)))
(run-basic-test target-os command name
--
2.34.0
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.