diff mbox series

[bug#41560,8/8] image: Do not use VM to create disk-images.

Message ID 20200527072420.26140-8-othacehe@gnu.org
State Accepted
Headers show
Series image: Add MBR based boot support. | expand

Checks

Context Check Description
cbaines/comparison success View comparision
cbaines/git branch success View Git branch
cbaines/applying patch success View Laminar job

Commit Message

Mathieu Othacehe May 27, 2020, 7:24 a.m. UTC
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(-)

Comments

Ludovic Courtès May 28, 2020, 9:47 p.m. UTC | #1
Mathieu Othacehe <m.othacehe@gmail.com> skribis:

> 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.

Yay!  \o/

Thank you,
Ludo’.
Mathieu Othacehe May 29, 2020, 7:27 a.m. UTC | #2
Just pushed the serie, taking your remarks into account.

Thanks again for reviewing!

Mathieu

> Mathieu Othacehe <m.othacehe@gmail.com> skribis:
>
>> 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.
>
> Yay!  \o/
>
> Thank you,
> Ludo’.
Janneke Nieuwenhuizen May 29, 2020, 8:45 a.m. UTC | #3
Mathieu Othacehe writes:

> Just pushed the serie, taking your remarks into account.
>
> Thanks again for reviewing!

\o/
diff mbox series

Patch

diff --git a/gnu/ci.scm b/gnu/ci.scm
index b61181be51..fa67168e22 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 97124a4699..8bb8412f16 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -488,7 +488,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))
@@ -521,38 +521,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 cea26c8ef3..6bd8c7d3d2 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 3efd113ac8..3d7aa77cb7 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?