[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
03/04: tests: install: Enable the use of multiple disk devices for tests
|
From: |
guix-commits |
|
Subject: |
03/04: tests: install: Enable the use of multiple disk devices for tests. |
|
Date: |
Sat, 19 Mar 2022 11:31:00 -0400 (EDT) |
apteryx pushed a commit to branch master
in repository guix.
commit 252330edd49c361c96bc2bc9c3e68a71110f63ca
Author: Maxim Cournoyer <maxim.cournoyer@gmail.com>
AuthorDate: Fri Mar 11 08:00:36 2022 -0500
tests: install: Enable the use of multiple disk devices for tests.
* gnu/tests/install.scm (run-install)[packages]: Unconditionally add to OS.
[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 | 262 +++++++++++++++++++++++++++-----------------------
1 file changed, 140 insertions(+), 122 deletions(-)
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index d1f8cc1c6d..ac6e553ae4 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -229,10 +229,8 @@ reboot\n")
;; Since the image has no network access, use the
;; current Guix so the store items we need are in
;; the image and add packages provided.
- (inherit (operating-system-add-packages
- (operating-system-with-current-guix
- installation-os)
- packages))
+ (inherit (operating-system-with-current-guix
+ installation-os))
(kernel-arguments '("console=ttyS0")))
#:imported-modules '((gnu services herd)
(gnu installer tests)
@@ -240,12 +238,13 @@ reboot\n")
(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. PACKAGES is a list of packages added to OS.
+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))
@@ -257,12 +256,13 @@ packages defined in installation-os."
;; succeed. Also add guile-final, which is pulled in
;; through provenance.drv and may not always be present.
(target (operating-system-derivation target-os))
- (base-image ->
- (os->image
- (operating-system-with-gc-roots
- os (list target guile-final))
- #:type (lookup-image-type-by-name
- installation-image-type)))
+ (base-image -> (os->image
+ (operating-system-with-gc-roots
+ (operating-system-add-packages
+ os packages)
+ (list target guile-final))
+ #:type (lookup-image-type-by-name
+ installation-image-type)))
(image ->
(system-image
(image
@@ -276,13 +276,18 @@ packages defined in installation-os."
(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 +308,12 @@ packages defined in installation-os."
(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 +347,23 @@ packages defined in installation-os."
(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 of 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 +374,10 @@ above IMAGE, a disk image. The QEMU VM has access to
MEMORY-SIZE MiB of RAM."
'("-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 +387,8 @@ above IMAGE, a disk image. The QEMU VM has access to
MEMORY-SIZE MiB of RAM."
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 +399,13 @@ build (current-guix) and then store a couple of full
system images.")
"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 +475,14 @@ reboot\n")
(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 +533,11 @@ reboot\n")
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 +610,11 @@ reboot\n")
"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 +691,12 @@ reboot\n")
"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 +825,11 @@ to enter the LUKS passphrase."
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 +909,13 @@ reboot\n")
(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 +1011,11 @@ 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-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 +1087,11 @@ reboot\n")
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 +1155,11 @@ reboot\n")
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 +1246,11 @@ 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-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 +1320,11 @@ reboot\n")
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 +1393,11 @@ reboot\n")
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 +1466,11 @@ reboot\n")
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 +1738,22 @@ build (current-guix) and then store a couple of full
system images.")
"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