08/10: image: Do not use VM to create disk-images.

[guix-commits]

mothacehe pushed a commit to branch wip-hurd-vm
in repository guix.

commit 40d0e6aa631ab56d4054cfe8ba357414c4ca2fba
Author: Mathieu Othacehe <address@hidden>
AuthorDate: Sat May 23 19:10:28 2020 +0200

    image: Do not use VM to create disk-images.
    
    Now that installing Grub on raw disk-images is supported, we do not need to
    rely on (gnu system vm) module.
    
    * gnu/system/image.scm (make-system-image): Rename to ...
    (system-image): ... this, and remove the compatibility wrapper.
    (find-image): Turn to a monadic procedure. This will become useful when
    introducing Hurd support, to be able to detect the target system.
    * gnu/ci.scm (qemu-jobs): Use lower-object now that system-image returns a
    file-like object.
    * gnu/tests/install.scm (run-install): Ditto.
    * guix/scripts/system.scm (system-derivation-for-action): Add a 'base-image'
    argument,
    (perform-action): adapt accordingly.
---
 gnu/ci.scm              | 20 +++++++++++---------
 gnu/system/image.scm    | 40 ++++++----------------------------------
 gnu/tests/install.scm   |  8 ++++----
 guix/scripts/system.scm | 16 +++++++++-------
 4 files changed, 30 insertions(+), 54 deletions(-)

diff --git a/gnu/ci.scm b/gnu/ci.scm
index b61181b..fa67168 100644
--- a/gnu/ci.scm
+++ b/gnu/ci.scm
@@ -219,19 +219,21 @@ system.")
                    (run-with-store store
                      (mbegin %store-monad
                        (set-guile-for-build (default-guile))
-                       (system-image
-                        (image
-                         (inherit efi-disk-image)
-                         (size (* 1500 MiB))
-                         (operating-system installation-os))))))
+                       (lower-object
+                        (system-image
+                         (image
+                          (inherit efi-disk-image)
+                          (size (* 1500 MiB))
+                          (operating-system installation-os)))))))
             (->job 'iso9660-image
                    (run-with-store store
                      (mbegin %store-monad
                        (set-guile-for-build (default-guile))
-                       (system-image
-                        (image
-                         (inherit iso9660-image)
-                         (operating-system installation-os)))))))
+                       (lower-object
+                        (system-image
+                         (image
+                          (inherit iso9660-image)
+                          (operating-system installation-os))))))))
       '()))
 
 (define channel-build-system
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index 8bebf23..d121ef0 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -487,7 +487,7 @@ it can be used for bootloading."
                             (type root-file-system-type))
                           file-systems-to-keep)))))
 
-(define* (make-system-image image)
+(define* (system-image image)
   "Return the derivation of IMAGE.  It can be a raw disk-image or an ISO9660
 image, depending on IMAGE format."
   (define substitutable? (image-substitutable? image))
@@ -520,38 +520,10 @@ image, depending on IMAGE format."
   "Find and return an image that could match the given FILE-SYSTEM-TYPE.  This
 is useful to adapt to interfaces written before the addition of the <image>
 record."
-  ;; XXX: Add support for system and target here, or in the caller.
-  (match file-system-type
-    ("iso9660" iso9660-image)
-    (_ efi-disk-image)))
-
-(define (system-image image)
-  "Wrap 'make-system-image' call, so that it is used only if the given IMAGE
-is supported.  Otherwise, fallback to image creation in a VM.  This is
-temporary and should be removed once 'make-system-image' is able to deal with
-all types of images."
-  (define substitutable? (image-substitutable? image))
-  (define volatile-root? (image-volatile-root? image))
-
-  (let* ((image-os (image-operating-system image))
-         (image-root-filesystem-type (image->root-file-system image))
-         (bootloader (bootloader-configuration-bootloader
-                      (operating-system-bootloader image-os)))
-         (bootloader-name (bootloader-name bootloader))
-         (size (image-size image))
-         (format (image-format image)))
-    (mbegin %store-monad
-      (if (and (or (eq? bootloader-name 'grub)
-                   (eq? bootloader-name 'extlinux))
-               (eq? format 'disk-image))
-          ;; Fallback to image creation in a VM when it is not yet supported
-          ;; by this module.
-          (system-disk-image-in-vm image-os
-                                   #:disk-image-size size
-                                   #:file-system-type 
image-root-filesystem-type
-                                   #:volatile? volatile-root?
-                                   #:substitutable? substitutable?)
-          (lower-object
-           (make-system-image image))))))
+  (mbegin %store-monad
+    (return
+     (match file-system-type
+       ("iso9660" iso9660-image)
+       (_ efi-disk-image)))))
 
 ;;; image.scm ends here
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index cea26c8..6bd8c7d 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -228,18 +228,18 @@ packages defined in installation-os."
   (mlet* %store-monad ((_      (set-grafting #f))
                        (system (current-system))
                        (target (operating-system-derivation target-os))
+                       (base-image (find-image
+                                    installation-disk-image-file-system-type))
 
                        ;; Since the installation system has no network access,
                        ;; we cheat a little bit by adding TARGET to its GC
                        ;; roots.  This way, we know 'guix system init' will
                        ;; succeed.  Also add guile-final, which is pulled in
                        ;; through provenance.drv and may not always be present.
-                       (image
+                       (image ->
                         (system-image
                          (image
-                          (inherit
-                           (find-image
-                            installation-disk-image-file-system-type))
+                          (inherit base-image)
                           (size install-size)
                           (operating-system
                             (operating-system-with-gc-roots
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 3efd113..3d7aa77 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -670,7 +670,7 @@ checking this by themselves in their 'check' procedure."
 ;;; Action.
 ;;;
 
-(define* (system-derivation-for-action os action
+(define* (system-derivation-for-action os base-image action
                                        #:key image-size file-system-type
                                        full-boot? container-shared-network?
                                        mappings)
@@ -694,11 +694,12 @@ checking this by themselves in their 'check' procedure."
                                                 (* 70 (expt 2 20)))
                                             #:mappings mappings))
     ((disk-image)
-     (system-image
-      (image
-       (inherit (find-image file-system-type))
-       (size image-size)
-       (operating-system os))))
+     (lower-object
+      (system-image
+       (image
+        (inherit base-image)
+        (size image-size)
+        (operating-system os)))))
     ((docker-image)
      (system-docker-image os #:shared-network? container-shared-network?))))
 
@@ -800,7 +801,8 @@ static checks."
       (check-initrd-modules os)))
 
   (mlet* %store-monad
-      ((sys       (system-derivation-for-action os action
+      ((image     (find-image file-system-type))
+       (sys       (system-derivation-for-action os image action
                                                 #:file-system-type 
file-system-type
                                                 #:image-size image-size
                                                 #:full-boot? full-boot?