mirror of git://git.savannah.gnu.org/guix.git
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.
This commit is contained in:
Mathieu Othacehe
parent
b7b45372e7
commit
e3f0155c41
20
gnu/ci.scm
20
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
|
||||
|
|
|
|||
|
|
@ -492,7 +492,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))
|
||||
|
|
@ -525,38 +525,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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
|
|||
Loading…
Reference in New Issue