01/04: system: vm: Non-volatile 'run-vm.sh' creates a CoW image.

[guix-commits]

civodul pushed a commit to branch version-1.4.0
in repository guix.

commit f59aa79ca342ef311a20dafc782adea6eed29b1a
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue Dec 6 15:06:35 2022 +0100

    system: vm: Non-volatile 'run-vm.sh' creates a CoW image.
    
    Previously, copying the image would consume a lot of space and was
    I/O-intensive, to the point that the marionette connection timeout of
    20s could be reached when running tests like "docker-system".
    
    * gnu/system/vm.scm (common-qemu-options): Pass 'format=' for each
    '-drive' option.
    (system-qemu-image/shared-store-script)[copy-image]: New variable.
    [builder]: Use it when VOLATILE? is false.
---
 gnu/system/vm.scm | 27 ++++++++++++++++++---------
 1 file changed, 18 insertions(+), 9 deletions(-)

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index c2f7efa966..b7bccd72a4 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic 
Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Christine Lemmer-Webber <cwebber@dustycloud.org>
 ;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -234,8 +234,8 @@ with '-virtfs' options for the host file systems listed in 
SHARED-FS."
 
      #$@(map virtfs-option shared-fs)
      #$@(if rw-image?
-            #~((format #f "-drive file=~a,if=virtio" #$image))
-            #~((format #f "-drive 
file=~a,if=virtio,cache=writeback,werror=report,readonly=on"
+            #~((format #f "-drive file=~a,format=qcow2,if=virtio" #$image))
+            #~((format #f "-drive 
file=~a,format=raw,if=virtio,cache=writeback,werror=report,readonly=on"
                        #$image)))))
 
 (define* (system-qemu-image/shared-store-script os
@@ -303,17 +303,26 @@ useful when FULL-BOOT?  is true."
               "-m " (number->string #$memory-size)
               #$@options))
 
+    (define copy-image
+      ;; Script that "copies" BASE-IMAGE to /tmp.  Make a copy-on-write image,
+      ;; which is much cheaper than actually copying it.
+      (program-file "copy-image"
+                    (with-imported-modules '((guix build utils))
+                      #~(begin
+                          (use-modules (guix build utils))
+                          (unless (file-exists? #$rw-image)
+                            (invoke #+(file-append qemu "/bin/qemu-img")
+                                    "create" "-b" #$base-image
+                                    "-F" "raw" "-f" "qcow2" #$rw-image))))))
+
     (define builder
       #~(call-with-output-file #$output
           (lambda (port)
             (format port "#!~a~%"
                     #+(file-append bash "/bin/sh"))
-            (when (not #$volatile?)
-              (format port "~a~%"
-                      #$(program-file "copy-image"
-                                      #~(unless (file-exists? #$rw-image)
-                                          (copy-file #$base-image #$rw-image)
-                                          (chmod #$rw-image #o640)))))
+            #$@(if volatile?
+                   #~()
+                   #~((format port "~a~%" #+copy-image)))
             (format port "exec ~a \"$@\"~%"
                     (string-join #$qemu-exec " "))
             (chmod port #o555))))