Subject: system: vm: Introduce system-qemu-image/script.

From: Mathieu Othacehe <[email-masked]>
Date: Tue, 19 Jan 2021 14:16:42 +0100

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
>From 3f1aff7d391453adbbe4a693ae20f4e0f2d5fcf6 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <[email-masked]>
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