[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/02: Use the new image interface.
|
From: |
guix-commits |
|
Subject: |
01/02: Use the new image interface. |
|
Date: |
Mon, 27 Apr 2020 10:09:25 -0400 (EDT) |
mothacehe pushed a commit to branch wip-disk-image
in repository guix.
commit cb95adefedc2eb256dffc67d0da50f40d9f16852
Author: Mathieu Othacehe <address@hidden>
AuthorDate: Mon Apr 27 16:00:34 2020 +0200
Use the new image interface.
---
gnu/ci.scm | 45 +++++++++++++++++++--------------------------
gnu/system/image.scm | 37 +++++++++++++++++++++++++++++++++++--
gnu/tests/install.scm | 20 ++++++++++++--------
guix/scripts/system.scm | 13 +++++--------
4 files changed, 71 insertions(+), 44 deletions(-)
diff --git a/gnu/ci.scm b/gnu/ci.scm
index 7fd5577..0430cf5 100644
--- a/gnu/ci.scm
+++ b/gnu/ci.scm
@@ -38,6 +38,7 @@
#:select (lookup-compressor self-contained-tarball))
#:use-module (gnu bootloader)
#:use-module (gnu bootloader u-boot)
+ #:use-module (gnu image)
#:use-module (gnu packages)
#:use-module (gnu packages gcc)
#:use-module (gnu packages base)
@@ -49,6 +50,7 @@
#:use-module (gnu packages make-bootstrap)
#:use-module (gnu packages package-management)
#:use-module (gnu system)
+ #:use-module (gnu system image)
#:use-module (gnu system vm)
#:use-module (gnu system install)
#:use-module (gnu tests)
@@ -209,32 +211,23 @@ system.")
(expt 2 20))
(if (member system %guixsd-supported-systems)
- (if (member system %u-boot-systems)
- (list (->job 'flash-image
- (run-with-store store
- (mbegin %store-monad
- (set-guile-for-build (default-guile))
- (system-disk-image-in-vm
- (operating-system (inherit installation-os)
- (bootloader (bootloader-configuration
- (bootloader u-boot-bootloader)
- (target #f))))
- #:disk-image-size
- (* 1500 MiB))))))
- (list (->job 'usb-image
- (run-with-store store
- (mbegin %store-monad
- (set-guile-for-build (default-guile))
- (system-disk-image-in-vm installation-os
- #:disk-image-size
- (* 1500 MiB)))))
- (->job 'iso9660-image
- (run-with-store store
- (mbegin %store-monad
- (set-guile-for-build (default-guile))
- (system-disk-image-in-vm installation-os
- #:file-system-type
- "iso9660"))))))
+ (list (->job 'usb-image
+ (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))))))
+ (->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)))))))
'()))
(define channel-build-system
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index 2978e77..b8544b2 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -30,6 +30,7 @@
#:use-module (gnu system)
#:use-module (gnu system file-systems)
#:use-module (gnu system uuid)
+ #:use-module (gnu system vm)
#:use-module (guix packages)
#:use-module (gnu packages base)
#:use-module (gnu packages bootloaders)
@@ -52,7 +53,8 @@
efi-disk-image
iso9660-image
- system-image))
+ system-image
+ find-image))
;;;
@@ -371,7 +373,7 @@ image ~a {
(size root-size))
other-partitions)))))
-(define* (system-image image)
+(define* (make-system-image image)
(let* ((image-os (image-operating-system image))
(format (image-format image))
(file-systems-to-keep
@@ -434,3 +436,34 @@ image ~a {
#:grub-mkrescue-environment
'(("MKRESCUE_SED_MODE" . "mbr_hfs"))
#:substitutable? substitutable?)))))
+
+(define (find-image file-system-type)
+ "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: Proposing an EFI image for an ARM system wouldn't probably make
+ ;; sense. 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)
+ (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))
+ (substitutable? (image-substitutable? image))
+ (volatile? (image-volatile-root? image))
+ (format (image-format image)))
+ (if (and (eq? bootloader-name 'grub)
+ (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 image-size
+ #:file-system-type image-root-filesystem-type
+ #:volatile? volatile?
+ #:substitutable? substitutable?)
+ (make-system-image image))))
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index 5913b8d..e81e7e3 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -21,9 +21,11 @@
(define-module (gnu tests install)
#:use-module (gnu)
#:use-module (gnu bootloader extlinux)
+ #:use-module (gnu image)
#:use-module (gnu tests)
#:use-module (gnu tests base)
#:use-module (gnu system)
+ #:use-module (gnu system image)
#:use-module (gnu system install)
#:use-module (gnu system vm)
#:use-module ((gnu build vm) #:select (qemu-command))
@@ -49,6 +51,7 @@
#:use-module (guix gexp)
#:use-module (guix utils)
#:use-module (srfi srfi-1)
+ #:use-module (ice-9 match)
#:export (%test-installed-os
%test-installed-extlinux-os
%test-iso-image-installer
@@ -227,14 +230,15 @@ packages defined in installation-os."
;; we cheat a little bit by adding TARGET to its GC
;; roots. This way, we know 'guix system init' will
;; succeed.
- (image (system-disk-image-in-vm
- (operating-system-with-gc-roots
- os (list target))
- #:disk-image-size install-size
- #:file-system-type
- installation-disk-image-file-system-type
- ;; Don't provide substitutes; too big.
- #:substitutable? #f)))
+ (image
+ (system-image
+ (image
+ (inherit
+ (find-image
+ installation-disk-image-file-system-type))
+ (operating-system
+ (operating-system-with-gc-roots
+ os (list target)))))))
(define install
(with-imported-modules '((guix build utils)
(gnu build marionette))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 1c0bf64..60a1189 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -694,14 +694,11 @@ checking this by themselves in their 'check' procedure."
(* 70 (expt 2 20)))
#:mappings mappings))
((disk-image)
- (let ((image-base (match file-system-type
- ("iso9660" iso9660-image)
- (_ efi-disk-image))))
- (system-image
- (image
- (inherit image-base)
- (size image-size)
- (operating-system os)))))
+ (system-image
+ (image
+ (inherit (find-image file-system-type))
+ (size image-size)
+ (operating-system os))))
((docker-image)
(system-docker-image os))))