From: Mathieu Othacehe <othacehe@gnu.org>
To: 45979@debbugs.gnu.org
Subject: [bug#45979] system: vm: Introduce system-qemu-image/script.
Date: Tue, 19 Jan 2021 14:16:42 +0100 [thread overview]
Message-ID: <87a6t5xe11.fsf@gnu.org> (raw)
[-- Attachment #1: Type: text/plain, Size: 187 bytes --]
Hello,
Here's a patch turning system-qemu-image/shared-store-script into
system-qemu-image/script so that it can be used for system test
requiring a read-write store.
Thanks,
Mathieu
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-system-vm-Introduce-system-qemu-image-script.patch --]
[-- Type: text/x-diff, Size: 11785 bytes --]
From 3f1aff7d391453adbbe4a693ae20f4e0f2d5fcf6 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@gnu.org>
Date: Tue, 19 Jan 2021 13:57:52 +0100
Subject: [PATCH] system: vm: Introduce system-qemu-image/script.
Some system tests may require to run a virtual machine with a freestanding
store, that can be written to. This is not possible when using the host store
as a read-only mount. Add a "shared-store?" field to the <virtual-machine>
record, so that it can be lowered to a virtual machine running a freestanding
Guix System image.
* gnu/system/vm.scm (system-qemu-image/shared-store-script): Rename to ...
(system-qemu-image/script): ... this new procedure. Add a "shared-store?"
argument and honor it.
(<virtual-machine>)[shared-store?]: New field.
(virtual-machine-compiler): Honor it.
* guix/scripts/system.scm (system-derivation-for-action): Adapt accordingly.
* gnu/tests/base.scm (%test-basic-os): Adapt comment.
---
gnu/system/vm.scm | 112 ++++++++++++++++++++++++----------------
gnu/tests/base.scm | 2 +-
guix/scripts/system.scm | 14 ++---
3 files changed, 75 insertions(+), 53 deletions(-)
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 1afae6b4ed..945b9d1378 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -52,8 +52,10 @@
#:use-module (gnu packages linux)
#:use-module (gnu packages admin)
+ #:use-module (gnu image)
#:use-module (gnu bootloader)
#:use-module (gnu bootloader grub)
+ #:use-module (gnu system image)
#:use-module (gnu system shadow)
#:use-module (gnu system pam)
#:use-module (gnu system linux-container)
@@ -65,7 +67,7 @@
#:use-module (gnu services base)
#:use-module (gnu system uuid)
- #:use-module (srfi srfi-1)
+ #:use-module ((srfi srfi-1) #:hide (partition))
#:use-module (srfi srfi-26)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
@@ -76,7 +78,7 @@
system-qemu-image
system-qemu-image/shared-store
- system-qemu-image/shared-store-script
+ system-qemu-image/script
system-docker-image
virtual-machine
@@ -772,22 +774,25 @@ with '-virtfs' options for the host file systems listed in SHARED-FS."
(format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly"
#$image)))
-(define* (system-qemu-image/shared-store-script os
- #:key
- (system (%current-system))
- (target (%current-target-system))
- (qemu qemu)
- (graphic? #t)
- (memory-size 256)
- (mappings '())
- full-boot?
- (disk-image-size
- (* (if full-boot? 500 70)
- (expt 2 20)))
- (options '()))
+(define* (system-qemu-image/script os
+ #:key
+ (system (%current-system))
+ (target (%current-target-system))
+ (qemu qemu)
+ (graphic? #t)
+ (shared-store? #t)
+ (memory-size 256)
+ (mappings '())
+ (full-boot?
+ (not shared-store?))
+ (disk-image-size
+ (* (if full-boot? 500 70)
+ (expt 2 20)))
+ (options '()))
"Return a derivation that builds a script to run a virtual machine image of
-OS that shares its store with the host. The virtual machine runs with
-MEMORY-SIZE MiB of memory.
+OS that shares its store with the host or uses a freestanding Guix System
+image is SHARED-STORE? is false. The virtual machine runs with MEMORY-SIZE
+MiB of memory.
MAPPINGS is a list of <file-system-mapping> specifying mapping of host file
systems into the guest.
@@ -796,13 +801,22 @@ When FULL-BOOT? is true, the returned script runs everything starting from the
bootloader; otherwise it directly starts the operating system kernel. The
DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image;
it is mostly useful when FULL-BOOT? is true."
- (mlet* %store-monad ((os -> (virtualized-operating-system os mappings full-boot?))
- (image (system-qemu-image/shared-store
- os
- #:system system
- #:target target
- #:full-boot? full-boot?
- #:disk-image-size disk-image-size)))
+ (mlet* %store-monad
+ ((os -> (virtualized-operating-system os mappings full-boot?))
+ (image (if shared-store?
+ (system-qemu-image/shared-store
+ os
+ #:system system
+ #:target target
+ #:full-boot? full-boot?
+ #:disk-image-size disk-image-size)
+ (lower-object
+ (system-image
+ (image
+ (inherit (os->image os #:type qcow2-image-type))
+ (size disk-image-size)))
+ system
+ #:target target))))
(define kernel-arguments
#~(list #$@(if graphic? #~() #~("console=ttyS0"))
#+@(operating-system-kernel-arguments os "/dev/vda1")))
@@ -818,7 +832,9 @@ it is mostly useful when FULL-BOOT? is true."
(string-join #$kernel-arguments " "))))
#$@(common-qemu-options image
(map file-system-mapping-source
- (cons %store-mapping mappings)))
+ (if shared-store?
+ (cons %store-mapping mappings)
+ mappings)))
"-m " (number->string #$memory-size)
#$@options))
@@ -845,6 +861,8 @@ it is mostly useful when FULL-BOOT? is true."
(default qemu))
(graphic? virtual-machine-graphic? ;Boolean
(default #f))
+ (shared-store? virtual-machine-shared-store? ;Boolean
+ (default #t))
(memory-size virtual-machine-memory-size ;integer (MiB)
(default 256))
(disk-image-size virtual-machine-disk-image-size ;integer (bytes)
@@ -876,29 +894,33 @@ FORWARDINGS is a list of host-port/guest-port pairs."
(define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
system target)
(match vm
- (($ <virtual-machine> os qemu graphic? memory-size disk-image-size ())
- (system-qemu-image/shared-store-script os
- #:system system
- #:target target
- #:qemu qemu
- #:graphic? graphic?
- #:memory-size memory-size
- #:disk-image-size
- disk-image-size))
- (($ <virtual-machine> os qemu graphic? memory-size disk-image-size
- forwardings)
+ (($ <virtual-machine> os qemu graphic? shared-store? memory-size
+ disk-image-size ())
+ (system-qemu-image/script os
+ #:system system
+ #:target target
+
+ #:qemu qemu
+ #:graphic? graphic?
+ #:shared-store? shared-store?
+ #:memory-size memory-size
+ #:disk-image-size
+ disk-image-size))
+ (($ <virtual-machine> os qemu graphic? shared-store? memory-size
+ disk-image-size forwardings)
(let ((options
`("-nic" ,(string-append
"user,model=virtio-net-pci,"
(port-forwardings->qemu-options forwardings)))))
- (system-qemu-image/shared-store-script os
- #:system system
- #:target target
- #:qemu qemu
- #:graphic? graphic?
- #:memory-size memory-size
- #:disk-image-size
- disk-image-size
- #:options options)))))
+ (system-qemu-image/script os
+ #:system system
+ #:target target
+ #:qemu qemu
+ #:graphic? graphic?
+ #:shared-store? shared-store?
+ #:memory-size memory-size
+ #:disk-image-size
+ disk-image-size
+ #:options options)))))
;;; vm.scm ends here
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index e5f9b87b1d..16163bc1f3 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -524,7 +524,7 @@ functionality tests.")
(vm (virtual-machine os)))
;; XXX: Add call to 'virtualized-operating-system' to get the exact same
;; set of services as the OS produced by
- ;; 'system-qemu-image/shared-store-script'.
+ ;; 'system-qemu-image/script'.
(run-basic-test (virtualized-operating-system os '())
#~(list #$vm))))))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index eb7137b7a9..f805db7a72 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -698,13 +698,13 @@ checking this by themselves in their 'check' procedure."
((vm-image)
(system-qemu-image os #:disk-image-size image-size))
((vm)
- (system-qemu-image/shared-store-script os
- #:full-boot? full-boot?
- #:disk-image-size
- (if full-boot?
- image-size
- (* 70 (expt 2 20)))
- #:mappings mappings))
+ (system-qemu-image/script os
+ #:full-boot? full-boot?
+ #:disk-image-size
+ (if full-boot?
+ image-size
+ (* 70 (expt 2 20)))
+ #:mappings mappings))
((disk-image)
(let* ((base-image (os->image os #:type image-type))
(base-target (image-target base-image)))
--
2.29.2
next reply other threads:[~2021-01-19 13:17 UTC|newest]
Thread overview: 3+ messages / expand[flat|nested] mbox.gz Atom feed top
2021-01-19 13:16 Mathieu Othacehe [this message]
2021-01-19 15:13 ` [bug#45979] system: vm: Introduce system-qemu-image/script Mathieu Othacehe
2021-03-26 9:55 ` bug#45979: " Mathieu Othacehe
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87a6t5xe11.fsf@gnu.org \
--to=othacehe@gnu.org \
--cc=45979@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).