[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/04: tests: install: Streamline 'qemu-command/writable-image'.
|
From: |
guix-commits |
|
Subject: |
02/04: tests: install: Streamline 'qemu-command/writable-image'. |
|
Date: |
Fri, 18 Mar 2022 05:26:37 -0400 (EDT) |
mothacehe pushed a commit to branch wip-btrfs-raid-tests
in repository guix.
commit e741580869aee37eeb26e2e7c29a82d03e73f4eb
Author: Maxim Cournoyer <maxim.cournoyer@gmail.com>
AuthorDate: Sun Mar 13 00:43:53 2022 -0500
tests: install: Streamline 'qemu-command/writable-image'.
* gnu/tests/install.scm (qemu-command/writable-image): Replace the use of a
writable backing file by the use of the '-snapshot' option, and rename to...
(qemu-command*): ... this, adjusting all calls.
Signed-off-by: Mathieu Othacehe <othacehe@gnu.org>
---
gnu/tests/install.scm | 61 ++++++++++++++++++++-------------------------------
1 file changed, 24 insertions(+), 37 deletions(-)
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index ae8c6051f1..d1f8cc1c6d 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -341,29 +341,16 @@ packages defined in installation-os."
(gexp->derivation "installation" install
#:substitutable? #f))) ;too big
-(define* (qemu-command/writable-image image
- #:key
- (uefi-support? #f)
- (memory-size 256))
- "Return as a monadic value the command to run QEMU on a writable copy of
-IMAGE, a disk image. The QEMU VM has access to MEMORY-SIZE MiB of RAM."
+(define* (qemu-command* image #: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."
(mlet* %store-monad ((system (current-system))
(uefi-firmware -> (and uefi-support?
(uefi-firmware system))))
- (return #~(let ((image #$image))
- ;; First we need a writable copy of the image.
- (format #t "creating writable image from '~a'...~%" image)
- (unless (zero? (system* #+(file-append qemu-minimal
- "/bin/qemu-img")
- "create" "-f" "qcow2" "-F" "qcow2"
- "-o"
- (string-append "backing_file=" image)
- "disk.img"))
- (error "failed to create writable QEMU image" image))
-
- (chmod "disk.img" #o644)
+ (return #~(begin
`(,(string-append #$qemu-minimal "/bin/"
#$(qemu-command system))
+ "-snapshot" ;for the volatile, writable overlay
,@(if (file-exists? "/dev/kvm")
'("-enable-kvm")
'())
@@ -371,7 +358,7 @@ 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" "file=disk.img,if=virtio")))))
+ "-drive" (format #f "file=~a,if=virtio" #$image))))))
(define %test-installed-os
(system-test
@@ -382,7 +369,7 @@ 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/writable-image image)))
+ (command (qemu-command* image)))
(run-basic-test %minimal-os command
"installed-os")))))
@@ -399,7 +386,7 @@ per %test-installed-os, this test is expensive in terms of
CPU and storage.")
(list syslinux)
#:script
%extlinux-gpt-installation-script))
- (command (qemu-command/writable-image image)))
+ (command (qemu-command* image)))
(run-basic-test %minimal-extlinux-os command
"installed-extlinux-os")))))
@@ -476,7 +463,7 @@ reboot\n")
%simple-installation-script-for-/dev/vda
#:installation-image-type
'uncompressed-iso9660))
- (command (qemu-command/writable-image image)))
+ (command (qemu-command* image)))
(run-basic-test %minimal-os-on-vda command name)))))
@@ -531,7 +518,7 @@ partition. In particular, home directories must be
correctly created (see
%separate-home-os-source
#:script
%simple-installation-script))
- (command (qemu-command/writable-image image)))
+ (command (qemu-command* image)))
(run-basic-test %separate-home-os command "separate-home-os")))))
@@ -608,7 +595,7 @@ where /gnu lives on a separate partition.")
%separate-store-os-source
#:script
%separate-store-installation-script))
- (command (qemu-command/writable-image image)))
+ (command (qemu-command* image)))
(run-basic-test %separate-store-os command "separate-store-os")))))
@@ -690,7 +677,7 @@ by 'mdadm'.")
#:script
%raid-root-installation-script
#:target-size (* 3200 MiB)))
- (command (qemu-command/writable-image image)))
+ (command (qemu-command* image)))
(run-basic-test %raid-root-os
`(,@command) "raid-root-os")))))
@@ -823,7 +810,7 @@ build (current-guix) and then store a couple of full system
images.")
%encrypted-root-os-source
#:script
%encrypted-root-installation-script))
- (command (qemu-command/writable-image image)))
+ (command (qemu-command* image)))
(run-basic-test %encrypted-root-os command "encrypted-root-os"
#:initialization enter-luks-passphrase)))))
@@ -909,7 +896,7 @@ reboot\n")
%lvm-separate-home-installation-script
#:packages (list lvm2-static)
#:target-size (* 3200 MiB)))
- (command (qemu-command/writable-image image)))
+ (command (qemu-command* image)))
(run-basic-test %lvm-separate-home-os
`(,@command) "lvm-separate-home-os")))))
@@ -1009,7 +996,7 @@ store a couple of full system images.")
%encrypted-root-not-boot-os-source
#:script
%encrypted-root-not-boot-installation-script))
- (command (qemu-command/writable-image image)))
+ (command (qemu-command* image)))
(run-basic-test %encrypted-root-not-boot-os command
"encrypted-root-not-boot-os"
#:initialization enter-luks-passphrase)))))
@@ -1085,7 +1072,7 @@ build (current-guix) and then store a couple of full
system images.")
%btrfs-root-os-source
#:script
%btrfs-root-installation-script))
- (command (qemu-command/writable-image image)))
+ (command (qemu-command* image)))
(run-basic-test %btrfs-root-os command "btrfs-root-os")))))
@@ -1153,7 +1140,7 @@ RAID-0 (stripe) root partition.")
%btrfs-raid-root-os-source
#:script %btrfs-raid-root-installation-script
#:target-size (* 2800 MiB)))
- (command (qemu-command/writable-image image)))
+ (command (qemu-command* image)))
(run-basic-test %btrfs-raid-root-os `(,@command)
"btrfs-raid-root-os")))))
@@ -1245,7 +1232,7 @@ build (current-guix) and then store a couple of full
system images.")
%btrfs-root-on-subvolume-os-source
#:script
%btrfs-root-on-subvolume-installation-script))
- (command (qemu-command/writable-image image)))
+ (command (qemu-command* image)))
(run-basic-test %btrfs-root-on-subvolume-os command
"btrfs-root-on-subvolume-os")))))
@@ -1319,7 +1306,7 @@ build (current-guix) and then store a couple of full
system images.")
%jfs-root-os-source
#:script
%jfs-root-installation-script))
- (command (qemu-command/writable-image image)))
+ (command (qemu-command* image)))
(run-basic-test %jfs-root-os command "jfs-root-os")))))
@@ -1392,7 +1379,7 @@ build (current-guix) and then store a couple of full
system images.")
%f2fs-root-os-source
#:script
%f2fs-root-installation-script))
- (command (qemu-command/writable-image image)))
+ (command (qemu-command* image)))
(run-basic-test %f2fs-root-os command "f2fs-root-os")))))
@@ -1465,7 +1452,7 @@ build (current-guix) and then store a couple of full
system images.")
%xfs-root-os-source
#:script
%xfs-root-installation-script))
- (command (qemu-command/writable-image image)))
+ (command (qemu-command* image)))
(run-basic-test %xfs-root-os command "xfs-root-os")))))
@@ -1748,9 +1735,9 @@ build (current-guix) and then store a couple of full
system images.")
#:desktop? desktop?
#:encrypted? encrypted?
#:uefi-support? uefi-support?))))
- (command (qemu-command/writable-image image
- #:uefi-support? uefi-support?
- #:memory-size 512)))
+ (command (qemu-command* image
+ #:uefi-support? uefi-support?
+ #:memory-size 512)))
(run-basic-test target-os command name
#:initialization (and encrypted? enter-luks-passphrase)
#:root-password %root-password