me
/
guix
Archived
1
0
Fork 0
Code

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.
master
Maxim Cournoyer 2022-03-11 08:00:36 -05:00
parent 52d710b917
commit 252330edd4
No known key found for this signature in database
GPG Key ID: 1260E46482E63562
1 changed files with 140 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

262
gnu/tests/install.scm
View File

@ -229,10 +229,8 @@ reboot\n")
;; Since the image has no network access, use the ;; Since the image has no network access, use the
;; current Guix so the store items we need are in ;; current Guix so the store items we need are in
;; the image and add packages provided. ;; the image and add packages provided.
(inherit (operating-system-add-packages (inherit (operating-system-with-current-guix
(operating-system-with-current-guix installation-os))
installation-os)
packages))
(kernel-arguments '("console=ttyS0"))) (kernel-arguments '("console=ttyS0")))
#:imported-modules '((gnu services herd) #:imported-modules '((gnu services herd)
(gnu installer tests) (gnu installer tests)
@ -240,12 +238,13 @@ reboot\n")
(uefi-support? #f) (uefi-support? #f)
(installation-image-type 'efi-raw) (installation-image-type 'efi-raw)
(install-size 'guess) (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 "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 OS to install TARGET-OS. Return the VM disk images of TARGET-SIZE bytes
the installed system. The packages specified in PACKAGES will be appended to containing the installed system. PACKAGES is a list of packages added to OS.
packages defined in installation-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)) (mlet* %store-monad ((_ (set-grafting #f))
(system (current-system)) (system (current-system))
@ -257,12 +256,13 @@ packages defined in installation-os."
;; succeed. Also add guile-final, which is pulled in ;; succeed. Also add guile-final, which is pulled in
;; through provenance.drv and may not always be present. ;; through provenance.drv and may not always be present.
(target (operating-system-derivation target-os)) (target (operating-system-derivation target-os))
(base-image -> (base-image -> (os->image
(os->image (operating-system-with-gc-roots
(operating-system-with-gc-roots (operating-system-add-packages
os (list target guile-final)) os packages)
#:type (lookup-image-type-by-name (list target guile-final))
installation-image-type))) #:type (lookup-image-type-by-name
installation-image-type)))
(image -> (image ->
(system-image (system-image
(image (image
@ -276,13 +276,18 @@ packages defined in installation-os."
(gnu build marionette)) (gnu build marionette))
#~(begin #~(begin
(use-modules (guix build utils) (use-modules (guix build utils)
(gnu build marionette)) (gnu build marionette)
(srfi srfi-1))
(set-path-environment-variable "PATH" '("bin") (set-path-environment-variable "PATH" '("bin")
(list #$qemu-minimal)) (list #$qemu-minimal))
(system* "qemu-img" "create" "-f" "qcow2" (mkdir-p #$output)
#$output #$(number->string target-size)) (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 (define marionette
(make-marionette (make-marionette
@ -303,8 +308,12 @@ packages defined in installation-os."
(error (error
"unsupported installation-image-type:" "unsupported installation-image-type:"
installation-image-type))) installation-image-type)))
"-drive" ,@(append-map
,(string-append "file=" #$output ",if=virtio") (lambda (n)
(list "-drive"
(format #f "file=~a/disk~a.qcow2,if=virtio"
#$output n)))
(iota #$number-of-disks))
,@(if (file-exists? "/dev/kvm") ,@(if (file-exists? "/dev/kvm")
'("-enable-kvm") '("-enable-kvm")
'())))) '()))))
@ -338,16 +347,23 @@ packages defined in installation-os."
(exit #$(and gui-test (exit #$(and gui-test
(gui-test #~marionette))))))) (gui-test #~marionette)))))))
(gexp->derivation "installation" install (mlet %store-monad ((images-dir (gexp->derivation "installation"
#:substitutable? #f))) ;too big 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 "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)) (mlet* %store-monad ((system (current-system))
(uefi-firmware -> (and uefi-support? (uefi-firmware -> (and uefi-support?
(uefi-firmware system)))) (uefi-firmware system))))
(return #~(begin (return #~(begin
(use-modules (srfi srfi-1))
`(,(string-append #$qemu-minimal "/bin/" `(,(string-append #$qemu-minimal "/bin/"
#$(qemu-command system)) #$(qemu-command system))
"-snapshot" ;for the volatile, writable overlay "-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) '("-bios" #$uefi-firmware)
'()) '())
"-no-reboot" "-m" #$(number->string memory-size) "-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 (define %test-installed-os
(system-test (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 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.") build (current-guix) and then store a couple of full system images.")
(value (value
(mlet* %store-monad ((image (run-install %minimal-os %minimal-os-source)) (mlet* %store-monad ((images (run-install %minimal-os %minimal-os-source))
(command (qemu-command* image))) (command (qemu-command* images)))
(run-basic-test %minimal-os command (run-basic-test %minimal-os command
"installed-os"))))) "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 "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.") per %test-installed-os, this test is expensive in terms of CPU and storage.")
(value (value
(mlet* %store-monad ((image (run-install %minimal-extlinux-os (mlet* %store-monad ((images (run-install %minimal-extlinux-os
%minimal-extlinux-os-source %minimal-extlinux-os-source
#:packages #:packages
(list syslinux) (list syslinux)
#:script #:script
%extlinux-gpt-installation-script)) %extlinux-gpt-installation-script))
(command (qemu-command* image))) (command (qemu-command* images)))
(run-basic-test %minimal-extlinux-os command (run-basic-test %minimal-extlinux-os command
"installed-extlinux-os"))))) "installed-extlinux-os")))))
@ -456,14 +475,14 @@ reboot\n")
(description (description
"") "")
(value (value
(mlet* %store-monad ((image (run-install (mlet* %store-monad ((images (run-install
%minimal-os-on-vda %minimal-os-on-vda
%minimal-os-on-vda-source %minimal-os-on-vda-source
#:script #:script
%simple-installation-script-for-/dev/vda %simple-installation-script-for-/dev/vda
#:installation-image-type #:installation-image-type
'uncompressed-iso9660)) 'uncompressed-iso9660))
(command (qemu-command* image))) (command (qemu-command* images)))
(run-basic-test %minimal-os-on-vda command name))))) (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 partition. In particular, home directories must be correctly created (see
<https://bugs.gnu.org/21108>).") <https://bugs.gnu.org/21108>).")
(value (value
(mlet* %store-monad ((image (run-install %separate-home-os (mlet* %store-monad ((images (run-install %separate-home-os
%separate-home-os-source %separate-home-os-source
#:script #:script
%simple-installation-script)) %simple-installation-script))
(command (qemu-command* image))) (command (qemu-command* images)))
(run-basic-test %separate-home-os command "separate-home-os"))))) (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, "Test basic functionality of an OS installed like one would do by hand,
where /gnu lives on a separate partition.") where /gnu lives on a separate partition.")
(value (value
(mlet* %store-monad ((image (run-install %separate-store-os (mlet* %store-monad ((images (run-install %separate-store-os
%separate-store-os-source %separate-store-os-source
#:script #:script
%separate-store-installation-script)) %separate-store-installation-script))
(command (qemu-command* image))) (command (qemu-command* images)))
(run-basic-test %separate-store-os command "separate-store-os"))))) (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 "Test functionality of an OS installed with a RAID root partition managed
by 'mdadm'.") by 'mdadm'.")
(value (value
(mlet* %store-monad ((image (run-install %raid-root-os (mlet* %store-monad ((images (run-install %raid-root-os
%raid-root-os-source %raid-root-os-source
#:script #:script
%raid-root-installation-script %raid-root-installation-script
#:target-size (* 3200 MiB))) #:target-size (* 3200 MiB)))
(command (qemu-command* image))) (command (qemu-command* images)))
(run-basic-test %raid-root-os (run-basic-test %raid-root-os
`(,@command) "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 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.") build (current-guix) and then store a couple of full system images.")
(value (value
(mlet* %store-monad ((image (run-install %encrypted-root-os (mlet* %store-monad ((images (run-install %encrypted-root-os
%encrypted-root-os-source %encrypted-root-os-source
#:script #:script
%encrypted-root-installation-script)) %encrypted-root-installation-script))
(command (qemu-command* image))) (command (qemu-command* images)))
(run-basic-test %encrypted-root-os command "encrypted-root-os" (run-basic-test %encrypted-root-os command "encrypted-root-os"
#:initialization enter-luks-passphrase))))) #:initialization enter-luks-passphrase)))))
@ -890,13 +909,13 @@ reboot\n")
(description (description
"Test functionality of an OS installed with a LVM /home partition") "Test functionality of an OS installed with a LVM /home partition")
(value (value
(mlet* %store-monad ((image (run-install %lvm-separate-home-os (mlet* %store-monad ((images (run-install %lvm-separate-home-os
%lvm-separate-home-os-source %lvm-separate-home-os-source
#:script #:script
%lvm-separate-home-installation-script %lvm-separate-home-installation-script
#:packages (list lvm2-static) #:packages (list lvm2-static)
#:target-size (* 3200 MiB))) #:target-size (* 3200 MiB)))
(command (qemu-command* image))) (command (qemu-command* images)))
(run-basic-test %lvm-separate-home-os (run-basic-test %lvm-separate-home-os
`(,@command) "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.") store a couple of full system images.")
(value (value
(mlet* %store-monad (mlet* %store-monad
((image (run-install %encrypted-root-not-boot-os ((images (run-install %encrypted-root-not-boot-os
%encrypted-root-not-boot-os-source %encrypted-root-not-boot-os-source
#:script #:script
%encrypted-root-not-boot-installation-script)) %encrypted-root-not-boot-installation-script))
(command (qemu-command* image))) (command (qemu-command* images)))
(run-basic-test %encrypted-root-not-boot-os command (run-basic-test %encrypted-root-not-boot-os command
"encrypted-root-not-boot-os" "encrypted-root-not-boot-os"
#:initialization enter-luks-passphrase))))) #: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 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.") build (current-guix) and then store a couple of full system images.")
(value (value
(mlet* %store-monad ((image (run-install %btrfs-root-os (mlet* %store-monad ((images (run-install %btrfs-root-os
%btrfs-root-os-source %btrfs-root-os-source
#:script #:script
%btrfs-root-installation-script)) %btrfs-root-installation-script))
(command (qemu-command* image))) (command (qemu-command* images)))
(run-basic-test %btrfs-root-os command "btrfs-root-os"))))) (run-basic-test %btrfs-root-os command "btrfs-root-os")))))
@ -1136,11 +1155,11 @@ reboot\n")
RAID-0 (stripe) root partition.") RAID-0 (stripe) root partition.")
(value (value
(mlet* %store-monad (mlet* %store-monad
((image (run-install %btrfs-raid-root-os ((images (run-install %btrfs-raid-root-os
%btrfs-raid-root-os-source %btrfs-raid-root-os-source
#:script %btrfs-raid-root-installation-script #:script %btrfs-raid-root-installation-script
#:target-size (* 2800 MiB))) #:target-size (* 2800 MiB)))
(command (qemu-command* image))) (command (qemu-command* images)))
(run-basic-test %btrfs-raid-root-os `(,@command) "btrfs-raid-root-os"))))) (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.") build (current-guix) and then store a couple of full system images.")
(value (value
(mlet* %store-monad (mlet* %store-monad
((image ((images (run-install %btrfs-root-on-subvolume-os
(run-install %btrfs-root-on-subvolume-os %btrfs-root-on-subvolume-os-source
%btrfs-root-on-subvolume-os-source #:script
#:script %btrfs-root-on-subvolume-installation-script))
%btrfs-root-on-subvolume-installation-script)) (command (qemu-command* images)))
(command (qemu-command* image)))
(run-basic-test %btrfs-root-on-subvolume-os command (run-basic-test %btrfs-root-on-subvolume-os command
"btrfs-root-on-subvolume-os"))))) "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 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.") build (current-guix) and then store a couple of full system images.")
(value (value
(mlet* %store-monad ((image (run-install %jfs-root-os (mlet* %store-monad ((images (run-install %jfs-root-os
%jfs-root-os-source %jfs-root-os-source
#:script #:script
%jfs-root-installation-script)) %jfs-root-installation-script))
(command (qemu-command* image))) (command (qemu-command* images)))
(run-basic-test %jfs-root-os command "jfs-root-os"))))) (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 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.") build (current-guix) and then store a couple of full system images.")
(value (value
(mlet* %store-monad ((image (run-install %f2fs-root-os (mlet* %store-monad ((images (run-install %f2fs-root-os
%f2fs-root-os-source %f2fs-root-os-source
#:script #:script
%f2fs-root-installation-script)) %f2fs-root-installation-script))
(command (qemu-command* image))) (command (qemu-command* images)))
(run-basic-test %f2fs-root-os command "f2fs-root-os"))))) (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 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.") build (current-guix) and then store a couple of full system images.")
(value (value
(mlet* %store-monad ((image (run-install %xfs-root-os (mlet* %store-monad ((images (run-install %xfs-root-os
%xfs-root-os-source %xfs-root-os-source
#:script #:script
%xfs-root-installation-script)) %xfs-root-installation-script))
(command (qemu-command* image))) (command (qemu-command* images)))
(run-basic-test %xfs-root-os command "xfs-root-os"))))) (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.") "Install an OS using the graphical installer and test it.")
(value (value
(mlet* %store-monad (mlet* %store-monad
((image (run-install target-os '(this is unused) ((images (run-install target-os '(this is unused)
#:script #f #:script #f
#:os installation-os-for-gui-tests #:os installation-os-for-gui-tests
#:uefi-support? uefi-support? #:uefi-support? uefi-support?
#:install-size install-size #:install-size install-size
#:target-size target-size #:target-size target-size
#:installation-image-type #:installation-image-type
'uncompressed-iso9660 'uncompressed-iso9660
#:gui-test #:gui-test
(lambda (marionette) (lambda (marionette)
(gui-test-program (gui-test-program
marionette marionette
#:desktop? desktop? #:desktop? desktop?
#:encrypted? encrypted? #:encrypted? encrypted?
#:uefi-support? uefi-support?)))) #:uefi-support? uefi-support?))))
(command (qemu-command* image (command (qemu-command* images
#:uefi-support? uefi-support? #:uefi-support? uefi-support?
#:memory-size 512))) #:memory-size 512)))
(run-basic-test target-os command name (run-basic-test target-os command name