me
/
guix
Archived
1
0
Fork 0
Code

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.
master
Mathieu Othacehe 2020-05-23 19:10:28 +02:00
parent b7b45372e7
commit e3f0155c41
No known key found for this signature in database
GPG Key ID: 8354763531769CA6
4 changed files with 30 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
gnu/ci.scm
View File

@ -219,19 +219,21 @@ system.")
(run-with-store store (run-with-store store
(mbegin %store-monad (mbegin %store-monad
(set-guile-for-build (default-guile)) (set-guile-for-build (default-guile))
(system-image (lower-object
(image (system-image
(inherit efi-disk-image) (image
(size (* 1500 MiB)) (inherit efi-disk-image)
(operating-system installation-os)))))) (size (* 1500 MiB))
(operating-system installation-os)))))))
(->job 'iso9660-image (->job 'iso9660-image
(run-with-store store (run-with-store store
(mbegin %store-monad (mbegin %store-monad
(set-guile-for-build (default-guile)) (set-guile-for-build (default-guile))
(system-image (lower-object
(image (system-image
(inherit iso9660-image) (image
(operating-system installation-os))))))) (inherit iso9660-image)
(operating-system installation-os))))))))
'())) '()))
(define channel-build-system (define channel-build-system

40
gnu/system/image.scm
View File

@ -492,7 +492,7 @@ it can be used for bootloading."
(type root-file-system-type)) (type root-file-system-type))
file-systems-to-keep))))) 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 "Return the derivation of IMAGE. It can be a raw disk-image or an ISO9660
image, depending on IMAGE format." image, depending on IMAGE format."
(define substitutable? (image-substitutable? image)) (define substitutable? (image-substitutable? image))
@ -525,38 +525,10 @@ image, depending on IMAGE format."
"Find and return an image that could match the given FILE-SYSTEM-TYPE. This "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> is useful to adapt to interfaces written before the addition of the <image>
record." record."
;; XXX: Add support for system and target here, or in the caller. (mbegin %store-monad
(match file-system-type (return
("iso9660" iso9660-image) (match file-system-type
(_ efi-disk-image))) ("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))))))
;;; image.scm ends here ;;; image.scm ends here

8
gnu/tests/install.scm
View File

@ -228,18 +228,18 @@ packages defined in installation-os."
(mlet* %store-monad ((_ (set-grafting #f)) (mlet* %store-monad ((_ (set-grafting #f))
(system (current-system)) (system (current-system))
(target (operating-system-derivation target-os)) (target (operating-system-derivation target-os))
(base-image (find-image
installation-disk-image-file-system-type))
;; Since the installation system has no network access, ;; Since the installation system has no network access,
;; we cheat a little bit by adding TARGET to its GC ;; we cheat a little bit by adding TARGET to its GC
;; roots. This way, we know 'guix system init' will ;; roots. This way, we know 'guix system init' will
;; succeed. Also add guile-final, which is pulled in ;; succeed. Also add guile-final, which is pulled in
;; through provenance.drv and may not always be present. ;; through provenance.drv and may not always be present.
(image (image ->
(system-image (system-image
(image (image
(inherit (inherit base-image)
(find-image
installation-disk-image-file-system-type))
(size install-size) (size install-size)
(operating-system (operating-system
(operating-system-with-gc-roots (operating-system-with-gc-roots

16
guix/scripts/system.scm
View File

@ -670,7 +670,7 @@ checking this by themselves in their 'check' procedure."
;;; Action. ;;; Action.
;;; ;;;
(define* (system-derivation-for-action os action (define* (system-derivation-for-action os base-image action
#:key image-size file-system-type #:key image-size file-system-type
full-boot? container-shared-network? full-boot? container-shared-network?
mappings) mappings)
@ -694,11 +694,12 @@ checking this by themselves in their 'check' procedure."
(* 70 (expt 2 20))) (* 70 (expt 2 20)))
#:mappings mappings)) #:mappings mappings))
((disk-image) ((disk-image)
(system-image (lower-object
(image (system-image
(inherit (find-image file-system-type)) (image
(size image-size) (inherit base-image)
(operating-system os)))) (size image-size)
(operating-system os)))))
((docker-image) ((docker-image)
(system-docker-image os #:shared-network? container-shared-network?)))) (system-docker-image os #:shared-network? container-shared-network?))))
@ -800,7 +801,8 @@ static checks."
(check-initrd-modules os))) (check-initrd-modules os)))
(mlet* %store-monad (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 #:file-system-type file-system-type
#:image-size image-size #:image-size image-size
#:full-boot? full-boot? #:full-boot? full-boot?