[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/01: wip: Use mke2fs to generate disk-images.
|
From: |
guix-commits |
|
Subject: |
01/01: wip: Use mke2fs to generate disk-images. |
|
Date: |
Tue, 21 Apr 2020 14:32:40 -0400 (EDT) |
mothacehe pushed a commit to branch wip-disk-image
in repository guix.
commit 1e6bc9a07aee7b1359c9df67e19c40823c0545ff
Author: Mathieu Othacehe <address@hidden>
AuthorDate: Mon Apr 13 18:54:37 2020 +0200
wip: Use mke2fs to generate disk-images.
---
gnu/build/bootloader.scm | 55 +++++++++-
gnu/build/disk-image.scm | 151 ++++++++++++++++++++++++++
gnu/build/install.scm | 2 +-
gnu/build/vm.scm | 46 +-------
gnu/ci.scm | 14 +--
gnu/image.scm | 67 ++++++++++++
gnu/local.mk | 3 +
gnu/system/examples/bare-bones.tmpl | 4 +-
gnu/system/examples/desktop.tmpl | 17 +--
gnu/system/image.scm | 206 ++++++++++++++++++++++++++++++++++++
gnu/system/vm.scm | 56 ++++++++--
gnu/tests/install.scm | 2 +-
guix/build/store-copy.scm | 1 +
guix/scripts/system.scm | 24 +++--
14 files changed, 563 insertions(+), 85 deletions(-)
diff --git a/gnu/build/bootloader.scm b/gnu/build/bootloader.scm
index 9570d6d..e15e7c0 100644
--- a/gnu/build/bootloader.scm
+++ b/gnu/build/bootloader.scm
@@ -18,8 +18,12 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build bootloader)
+ #:use-module (guix build utils)
+ #:use-module (guix utils)
#:use-module (ice-9 binary-ports)
- #:export (write-file-on-device))
+ #:use-module (ice-9 format)
+ #:export (write-file-on-device
+ install-efi-loader))
;;;
@@ -36,3 +40,52 @@
(seek output offset SEEK_SET)
(put-bytevector output bv))
#:binary #t)))))
+
+
+;;;
+;;; EFI bootloader.
+;;;
+
+(define (install-efi grub grub-config esp)
+ "Write a self-contained GRUB EFI loader to the mounted ESP using
GRUB-CONFIG."
+ (let* ((system %host-type)
+ ;; Hard code the output location to a well-known path recognized by
+ ;; compliant firmware. See "3.5.1.1 Removable Media Boot Behaviour":
+ ;;
http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%202_6.pdf
+ (grub-mkstandalone (string-append grub "/bin/grub-mkstandalone"))
+ (efi-directory (string-append esp "/EFI/BOOT"))
+ ;; Map grub target names to boot file names.
+ (efi-targets (cond ((string-prefix? "x86_64" system)
+ '("x86_64-efi" . "BOOTX64.EFI"))
+ ((string-prefix? "i686" system)
+ '("i386-efi" . "BOOTIA32.EFI"))
+ ((string-prefix? "armhf" system)
+ '("arm-efi" . "BOOTARM.EFI"))
+ ((string-prefix? "aarch64" system)
+ '("arm64-efi" . "BOOTAA64.EFI")))))
+ ;; grub-mkstandalone requires a TMPDIR to prepare the firmware image.
+ (setenv "TMPDIR" esp)
+
+ (mkdir-p efi-directory)
+ (invoke grub-mkstandalone "-O" (car efi-targets)
+ "-o" (string-append efi-directory "/"
+ (cdr efi-targets))
+ ;; Graft the configuration file onto the image.
+ (string-append "boot/grub/grub.cfg=" grub-config))))
+
+(define (install-efi-loader grub-efi esp)
+ ;; Create a tiny configuration file telling the embedded grub
+ ;; where to load the real thing.
+ ;; XXX This is quite fragile, and can prevent the image from booting
+ ;; when there's more than one volume with this label present.
+ ;; Reproducible almost-UUIDs could reduce the risk (not eliminate it).
+ (let ((grub-config "grub.cfg"))
+ (call-with-output-file grub-config
+ (lambda (port)
+ (format port
+ "insmod part_msdos~@
+ search --set=root --label Guix_image~@
+ configfile /boot/grub/grub.cfg~%")
+ (fsync port)))
+ (install-efi grub-efi grub-config esp)
+ (delete-file grub-config)))
diff --git a/gnu/build/disk-image.scm b/gnu/build/disk-image.scm
new file mode 100644
index 0000000..7423a93
--- /dev/null
+++ b/gnu/build/disk-image.scm
@@ -0,0 +1,151 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Mathieu Othacehe <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu build disk-image)
+ #:use-module (guix build store-copy)
+ #:use-module (guix build syscalls)
+ #:use-module (guix build utils)
+ #:use-module (guix store database)
+ #:use-module (gnu build bootloader)
+ #:use-module (gnu build install)
+ #:use-module (gnu build linux-boot)
+ #:use-module (gnu image)
+ #:use-module (ice-9 ftw)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:export (make-partition-image
+ genimage
+ initialize-efi-partition
+ initialize-root-partition))
+
+(define (sexp->partition sexp)
+ (match sexp
+ ((size file-system label)
+ (partition (size size)
+ (file-system file-system)
+ (label label)))))
+
+(define (size-in-kib size)
+ (number->string
+ (inexact->exact (ceiling (/ size 1024)))))
+
+(define (root-size root)
+ (* 1.25 (file-size root)))
+
+(define* (make-ext4-image partition target root
+ #:key (owner 0))
+ (let ((size (partition-size partition))
+ (label (partition-label partition))
+ (options "lazy_itable_init=1,lazy_journal_init=1"))
+ (invoke "mke2fs" "-t" "ext4" "-d" root
+ "-L" label
+ "-E" (format #f "root_owner=~a:~a,~a"
+ owner owner options)
+ target
+ (format #f "~ak"
+ (size-in-kib
+ (if (eq? size 'guess)
+ (root-size root)
+ size))))))
+
+(define* (make-vfat-image partition target root)
+ (let ((size (partition-size partition))
+ (label (partition-label partition)))
+ (invoke "mkdosfs" "-n" label "-C" target "-F" "16" "-S" "1024"
+ (size-in-kib
+ (if (eq? size 'guess)
+ (root-size root)
+ size)))
+ (for-each (lambda (file)
+ (unless (member file '("." ".."))
+ (invoke "mcopy" "-bsp" "-i" target
+ (string-append root "/" file)
+ (string-append "::" file))))
+ (scandir root))))
+
+(define* (make-partition-image partition-sexp target root)
+ (let* ((partition (sexp->partition partition-sexp))
+ (type (partition-file-system partition)))
+ (cond
+ ((string=? type "ext4")
+ (make-ext4-image partition target root))
+ ((string=? type "vfat")
+ (make-vfat-image partition target root))
+ (else
+ (format (current-error-port)
+ "Unsupported partition type~%.")))))
+
+(define* (genimage config target)
+ (mkdir "root")
+ (invoke "genimage" "--config" config
+ "--outputpath" target))
+
+(define* (initialize-efi-partition root
+ #:key
+ bootloader-package
+ #:allow-other-keys)
+ (install-efi-loader bootloader-package root))
+
+(define (register-bootcfg-root target bootcfg)
+ "On file system TARGET, register BOOTCFG as a GC root."
+ (let ((directory (string-append target "/var/guix/gcroots")))
+ (mkdir-p directory)
+ (symlink bootcfg (string-append directory "/bootcfg"))))
+
+(define* (register-closure prefix closure
+ #:key
+ (deduplicate? #t) (reset-timestamps? #t)
+ (schema (sql-schema)))
+ "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
+target store and CLOSURE is the name of a file containing a reference graph as
+produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is
+true, reset timestamps on store files and, if DEDUPLICATE? is true,
+deduplicates files common to CLOSURE and the rest of PREFIX."
+ (let ((items (call-with-input-file closure read-reference-graph)))
+ (register-items items
+ #:prefix prefix
+ #:deduplicate? deduplicate?
+ #:reset-timestamps? reset-timestamps?
+ #:registration-time %epoch
+ #:schema schema)))
+
+(define* (initialize-root-partition root
+ #:key
+ bootcfg
+ bootcfg-location
+ (deduplicate? #t)
+ references-graphs
+ (register-closures? #t)
+ system-directory
+ #:allow-other-keys)
+ (populate-root-file-system system-directory root)
+ (populate-store references-graphs root)
+
+ (when register-closures?
+ (for-each (lambda (closure)
+ (register-closure root
+ closure
+ #:reset-timestamps? #t
+ #:deduplicate? deduplicate?))
+ references-graphs))
+
+ (install-boot-config bootcfg bootcfg-location root)
+
+ ;; Register BOOTCFG as a GC root.
+ (register-bootcfg-root root bootcfg))
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index c0d4d44..c1f6e1f 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -63,7 +63,7 @@ directory TARGET."
(('directory name uid gid)
(let ((dir (string-append target name)))
(mkdir-p dir)
- (chown dir uid gid)))
+ (false-if-exception (chown dir uid gid))))
(('directory name uid gid mode)
(loop `(directory ,name ,uid ,gid))
(chmod (string-append target name) mode))
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 9caa110..4db9b7e 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -27,6 +27,7 @@
#:use-module (guix build store-copy)
#:use-module (guix build syscalls)
#:use-module (guix store database)
+ #:use-module (gnu build bootloader)
#:use-module (gnu build linux-boot)
#:use-module (gnu build install)
#:use-module (gnu system uuid)
@@ -416,33 +417,6 @@ SYSTEM-DIRECTORY is the name of the directory of the
'system' derivation."
(mkdir-p directory)
(symlink bootcfg (string-append directory "/bootcfg"))))
-(define (install-efi grub esp config-file)
- "Write a self-contained GRUB EFI loader to the mounted ESP using
CONFIG-FILE."
- (let* ((system %host-type)
- ;; Hard code the output location to a well-known path recognized by
- ;; compliant firmware. See "3.5.1.1 Removable Media Boot Behaviour":
- ;;
http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%202_6.pdf
- (grub-mkstandalone (string-append grub "/bin/grub-mkstandalone"))
- (efi-directory (string-append esp "/EFI/BOOT"))
- ;; Map grub target names to boot file names.
- (efi-targets (cond ((string-prefix? "x86_64" system)
- '("x86_64-efi" . "BOOTX64.EFI"))
- ((string-prefix? "i686" system)
- '("i386-efi" . "BOOTIA32.EFI"))
- ((string-prefix? "armhf" system)
- '("arm-efi" . "BOOTARM.EFI"))
- ((string-prefix? "aarch64" system)
- '("arm64-efi" . "BOOTAA64.EFI")))))
- ;; grub-mkstandalone requires a TMPDIR to prepare the firmware image.
- (setenv "TMPDIR" esp)
-
- (mkdir-p efi-directory)
- (invoke grub-mkstandalone "-O" (car efi-targets)
- "-o" (string-append efi-directory "/"
- (cdr efi-targets))
- ;; Graft the configuration file onto the image.
- (string-append "boot/grub/grub.cfg=" config-file))))
-
(define* (make-iso9660-image xorriso grub-mkrescue-environment
grub config-file os-drv target
#:key (volume-id "Guix_image") (volume-uuid #f)
@@ -610,30 +584,16 @@ passing it a directory name where it is mounted."
(when esp
;; Mount the ESP somewhere and install GRUB UEFI image.
- (let ((mount-point (string-append target "/boot/efi"))
- (grub-config (string-append target "/tmp/grub-standalone.cfg")))
+ (let ((mount-point (string-append target "/boot/efi")))
(display "mounting EFI system partition...\n")
(mkdir-p mount-point)
(mount (partition-device esp) mount-point
(partition-file-system esp))
- ;; Create a tiny configuration file telling the embedded grub
- ;; where to load the real thing.
- ;; XXX This is quite fragile, and can prevent the image from booting
- ;; when there's more than one volume with this label present.
- ;; Reproducible almost-UUIDs could reduce the risk (not eliminate it).
- (call-with-output-file grub-config
- (lambda (port)
- (format port
- "insmod part_msdos~@
- search --set=root --label Guix_image~@
- configfile /boot/grub/grub.cfg~%")))
-
(display "creating EFI firmware image...")
- (install-efi grub-efi mount-point grub-config)
+ (install-efi-loader grub-efi mount-point)
(display "done.\n")
- (delete-file grub-config)
(umount mount-point)))
;; Register BOOTCFG as a GC root.
diff --git a/gnu/ci.scm b/gnu/ci.scm
index fb2596c..7fd5577 100644
--- a/gnu/ci.scm
+++ b/gnu/ci.scm
@@ -214,7 +214,7 @@ system.")
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
- (system-disk-image
+ (system-disk-image-in-vm
(operating-system (inherit installation-os)
(bootloader (bootloader-configuration
(bootloader u-boot-bootloader)
@@ -225,16 +225,16 @@ system.")
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
- (system-disk-image installation-os
- #:disk-image-size
- (* 1500 MiB)))))
+ (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 installation-os
- #:file-system-type
- "iso9660"))))))
+ (system-disk-image-in-vm installation-os
+ #:file-system-type
+ "iso9660"))))))
'()))
(define channel-build-system
diff --git a/gnu/image.scm b/gnu/image.scm
new file mode 100644
index 0000000..040546e
--- /dev/null
+++ b/gnu/image.scm
@@ -0,0 +1,67 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Mathieu Othacehe <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu image)
+ #:use-module (guix records)
+ #:use-module (ice-9 match)
+ #:export (partition
+ partition?
+ partition-device
+ partition-size
+ partition-file-system
+ partition-label
+ partition-flags
+ partition-initializer
+
+ image
+ image-name
+ image-format
+ image-size
+ image-operating-system
+ image-partitions))
+
+
+;;;
+;;; Partition record.
+;;;
+
+(define-record-type* <partition> partition make-partition
+ partition?
+ (device partition-device (default #f))
+ (size partition-size)
+ (file-system partition-file-system (default "ext4"))
+ (label partition-label (default #f))
+ (uuid partition-uuid (default #f))
+ (flags partition-flags (default '()))
+ (initializer partition-initializer (default #f)))
+
+
+;;;
+;;; Image record.
+;;;
+
+(define-record-type* <image>
+ image make-image
+ image?
+ (format image-format) ;symbol
+ (size image-size ;size in bytes as integer
+ (default 'guess))
+ (operating-system image-operating-system ;<operating-system>
+ (default #f))
+ (partitions image-partitions ;list of <partition>
+ (default '())))
diff --git a/gnu/local.mk b/gnu/local.mk
index ca863a8..39ad5c4 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -58,6 +58,7 @@ GNU_SYSTEM_MODULES = \
%D%/bootloader/u-boot.scm \
%D%/bootloader/depthcharge.scm \
%D%/ci.scm \
+ %D%/image.scm \
%D%/packages.scm \
%D%/packages/abduco.scm \
%D%/packages/abiword.scm \
@@ -598,6 +599,7 @@ GNU_SYSTEM_MODULES = \
%D%/system.scm \
%D%/system/accounts.scm \
%D%/system/file-systems.scm \
+ %D%/system/image.scm \
%D%/system/install.scm \
%D%/system/keyboard.scm \
%D%/system/linux-container.scm \
@@ -618,6 +620,7 @@ GNU_SYSTEM_MODULES = \
%D%/build/activation.scm \
%D%/build/bootloader.scm \
%D%/build/cross-toolchain.scm \
+ %D%/build/disk-image.scm \
%D%/build/file-systems.scm \
%D%/build/install.scm \
%D%/build/linux-boot.scm \
diff --git a/gnu/system/examples/bare-bones.tmpl
b/gnu/system/examples/bare-bones.tmpl
index 4f30a5b..fc35ea8 100644
--- a/gnu/system/examples/bare-bones.tmpl
+++ b/gnu/system/examples/bare-bones.tmpl
@@ -14,10 +14,10 @@
;; target hard disk, and "my-root" is the label of the target
;; root file system.
(bootloader (bootloader-configuration
- (bootloader grub-bootloader)
+ (bootloader grub-efi-bootloader)
(target "/dev/sdX")))
(file-systems (cons (file-system
- (device (file-system-label "my-root"))
+ (device (file-system-label "Guix_image"))
(mount-point "/")
(type "ext4"))
%base-file-systems))
diff --git a/gnu/system/examples/desktop.tmpl b/gnu/system/examples/desktop.tmpl
index 3931bad..de9e1e5 100644
--- a/gnu/system/examples/desktop.tmpl
+++ b/gnu/system/examples/desktop.tmpl
@@ -22,24 +22,11 @@
(target "/boot/efi")
(keyboard-layout keyboard-layout)))
- ;; Specify a mapped device for the encrypted root partition.
- ;; The UUID is that returned by 'cryptsetup luksUUID'.
- (mapped-devices
- (list (mapped-device
- (source (uuid "12345678-1234-1234-1234-123456789abc"))
- (target "my-root")
- (type luks-device-mapping))))
-
(file-systems (append
(list (file-system
- (device (file-system-label "my-root"))
+ (device (file-system-label "Guix_image"))
(mount-point "/")
- (type "ext4")
- (dependencies mapped-devices))
- (file-system
- (device (uuid "1234-ABCD" 'fat))
- (mount-point "/boot/efi")
- (type "vfat")))
+ (type "ext4")))
%base-file-systems))
(users (cons (user-account
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
new file mode 100644
index 0000000..3057c51
--- /dev/null
+++ b/gnu/system/image.scm
@@ -0,0 +1,206 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Mathieu Othacehe <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system image)
+ #:use-module (guix gexp)
+ #:use-module (guix modules)
+ #:use-module (guix records)
+ #:use-module (guix utils)
+ #:use-module ((guix self) #:select (make-config.scm))
+ #:use-module (gnu bootloader)
+ #:use-module (gnu image)
+ #:use-module (gnu system)
+ #:use-module (guix packages)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages disk)
+ #:use-module (gnu packages genimage)
+ #:use-module (gnu packages guile)
+ #:autoload (gnu packages gnupg) (guile-gcrypt)
+ #:use-module (gnu packages linux)
+ #:use-module (gnu packages mtools)
+ #:use-module ((srfi srfi-1) #:select (append-map))
+ #:use-module (ice-9 match)
+ #:export (esp-partition
+ root-partition
+ efi-disk-image
+
+ system-image))
+
+
+;;;
+;;; Images definitions.
+;;;
+
+(define esp-partition
+ (partition
+ (size (* 40 (expt 2 20)))
+ (label "GNU-ESP") ;cosmetic only
+ ;; Use "vfat" here since this property is used
+ ;; when mounting. The actual FAT-ness is based
+ ;; on file system size (16 in this case).
+ (file-system "vfat")
+ (flags '(esp))
+ (initializer (gexp initialize-efi-partition))))
+
+(define root-partition
+ (partition
+ (size 'guess)
+ (label "Guix_image")
+ (file-system "ext4")
+ (flags '(boot))
+ (initializer (gexp initialize-root-partition))))
+
+(define efi-disk-image
+ (image
+ (format 'disk-image)
+ (partitions (list esp-partition root-partition))))
+
+(define not-config?
+ ;; Select (guix …) and (gnu …) modules, except (guix config).
+ (match-lambda
+ (('guix 'config) #f)
+ (('guix rest ...) #t)
+ (('gnu rest ...) #t)
+ (rest #f)))
+
+(define (partition->gexp partition)
+ #~'(#$@(list (partition-size partition))
+ #$(partition-file-system partition)
+ #$(partition-label partition)))
+
+(define gcrypt-sqlite3&co
+ ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
+ (append-map (lambda (package)
+ (cons package
+ (match (package-transitive-propagated-inputs package)
+ (((labels packages) ...)
+ packages))))
+ (list guile-gcrypt guile-sqlite3)))
+
+(define-syntax-rule (with-imported-modules* exp ...)
+ (with-extensions gcrypt-sqlite3&co
+ (with-imported-modules `(,@(source-module-closure
+ '((gnu build vm)
+ (gnu build disk-image)
+ (guix store database))
+ #:select? not-config?)
+ ((guix config) => ,(make-config.scm)))
+ #~(begin
+ (use-modules (gnu build vm)
+ (gnu build disk-image)
+ (guix store database)
+ (guix build utils))
+ exp ...))))
+
+(define (partition-image image partition)
+ (let* ((os (image-operating-system image))
+ (bootloader (bootloader-configuration-bootloader
+ (operating-system-bootloader os)))
+ (bootcfg (operating-system-bootcfg os))
+ (inputs `(("system" ,os)
+ ("bootcfg" ,bootcfg)))
+ (schema (local-file (search-path %load-path
+ "guix/store/schema.sql")))
+ (graph (match inputs
+ (((names . _) ...)
+ names)))
+ (root-builder
+ (with-imported-modules*
+ (let* ((initializer #$(partition-initializer partition)))
+ (sql-schema #$schema)
+ (initializer #$output
+ #:references-graphs '#$graph
+ #:deduplicate? #f
+ #:system-directory #$os
+ #:bootloader-package
+ #$(bootloader-package bootloader)
+ #:bootcfg #$bootcfg
+ #:bootcfg-location
+ #$(bootloader-configuration-file bootloader)))))
+ (image-root
+ (computed-file "partition-image-root" root-builder
+ #:options `(#:references-graphs ,inputs)))
+ (type (partition-file-system partition))
+ (image-builder
+ (with-imported-modules*
+ (let ((inputs '#$(list e2fsprogs ;mke2fs
+ dosfstools ;mkdosfs
+ mtools ;mcopy
+ )))
+ (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+ (make-partition-image #$(partition->gexp partition)
+ #$output
+ #$image-root)))))
+ (computed-file "partition.img" image-builder)))
+
+(define genimage-name "image")
+
+(define (image->genimage-cfg image)
+ (define (format->image-type format)
+ (case format
+ ((disk-image) "hdimage")
+ (else
+ (error
+ (format #f "Unsupported image type ~a~%." format)))))
+
+ (define (partition->dos-type partition)
+ (let ((flags (partition-flags partition)))
+ (cond
+ ((member 'esp flags) "0xEF")
+ (else "0x83"))))
+
+ (define (partition->config partition)
+ (let ((label (partition-label partition))
+ (dos-type (partition->dos-type partition))
+ (image (partition-image image partition)))
+ #~(format #f "~/partition ~a {
+~/~/partition-type = ~a
+~/~/image = \"~a\"
+~/}" #$label #$dos-type #$image)))
+
+ (let* ((format (image-format image))
+ (image-type (format->image-type format))
+ (partitions (image-partitions image))
+ (partitions-config (map partition->config partitions))
+ (builder
+ #~(begin
+ (let ((format (@ (ice-9 format) format)))
+ (call-with-output-file #$output
+ (lambda (port)
+ (format port
+ "\
+image ~a {
+~/~a {}
+~{~a~^~%~}
+}~%" #$genimage-name #$image-type (list #$@partitions-config))))))))
+ (computed-file "genimage.cfg" builder)))
+
+(define* (system-image image)
+ (let* ((builder
+ (with-imported-modules*
+ (let ((inputs '#$(list genimage ;genimage
+ coreutils ;rm
+ findutils ;find
+ )))
+ (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+ (genimage #$(image->genimage-cfg image) #$output))))
+ (image-dir (computed-file "image-dir" builder)))
+ (gexp->derivation "image"
+ #~(symlink
+ (string-append #$image-dir "/" #$genimage-name)
+ #$output))))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 04d84b5..0d2bc91 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -79,6 +79,7 @@
system-qemu-image/shared-store
system-qemu-image/shared-store-script
+ system-disk-image-in-vm
system-disk-image
system-docker-image
@@ -655,13 +656,13 @@ TYPE (one of 'iso9660 or 'dce). Return a UUID object."
4)
type)))
-(define* (system-disk-image os
- #:key
- (name "disk-image")
- (file-system-type "ext4")
- (disk-image-size (* 900 (expt 2 20)))
- (volatile? #t)
- (substitutable? #t))
+(define* (system-disk-image-in-vm os
+ #:key
+ (name "disk-image")
+ (file-system-type "ext4")
+ (disk-image-size (* 900 (expt 2 20)))
+ (volatile? #t)
+ (substitutable? #t))
"Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the
system described by OS. Said image can be copied on a USB stick as is. When
VOLATILE? is true, the root file system is made volatile; this is useful
@@ -754,6 +755,47 @@ substitutable."
("bootcfg" ,bootcfg))
#:substitutable? substitutable?))))
+(define* (system-disk-image os
+ #:key
+ (name "disk-image")
+ (file-system-type "ext4")
+ (disk-image-size 'guess)
+ (volatile? #t)
+ (substitutable? #t))
+ (let* ((bootloader (bootloader-configuration-bootloader
+ (operating-system-bootloader os)))
+ (bootcfg (operating-system-bootcfg os))
+ (inputs `(("system" ,os)
+ ("bootcfg" ,bootcfg)))
+ (builder
+ (with-imported-modules `(,@(source-module-closure
+ '((gnu build disk-image))
+ #:select? not-config?)
+ ((guix config) => ,(make-config.scm)))
+ #~(begin
+ (use-modules (guix build utils)
+ (gnu build disk-image))
+
+ (let* ((inputs '#$(list e2fsprogs)) ;mke2fs
+ (graph '#$(match inputs
+ (((names . _) ...)
+ names)))
+ (disk-image-size '#$disk-image-size))
+ (set-path-environment-variable "PATH" '("bin" "sbin")
+ inputs)
+ (make-disk-image #$output graph
+ #:size disk-image-size
+ #:system-directory #$os
+ #:bootloader-package
+ #$(bootloader-package bootloader)
+ #:bootcfg #$bootcfg
+ #:bootcfg-location
+ #$(bootloader-configuration-file bootloader)
+ #:bootloader-installer
+ #$(bootloader-installer bootloader)))))))
+ (gexp->derivation name builder
+ #:references-graphs inputs)))
+
(define* (system-qemu-image os
#:key
(file-system-type "ext4")
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index 713e031..5913b8d 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -227,7 +227,7 @@ 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
+ (image (system-disk-image-in-vm
(operating-system-with-gc-roots
os (list target))
#:disk-image-size install-size
diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm
index 549aa4f..ad551bc 100644
--- a/guix/build/store-copy.scm
+++ b/guix/build/store-copy.scm
@@ -35,6 +35,7 @@
read-reference-graph
+ file-size
closure-size
populate-store))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 2664c66..2f3c914 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -54,9 +54,11 @@
#:autoload (gnu build linux-modules)
(device-module-aliases matching-modules)
#:use-module (gnu system linux-initrd)
+ #:use-module (gnu image)
#:use-module (gnu system)
#:use-module (gnu bootloader)
#:use-module (gnu system file-systems)
+ #:use-module (gnu system image)
#:use-module (gnu system mapped-devices)
#:use-module (gnu system linux-container)
#:use-module (gnu system uuid)
@@ -692,12 +694,16 @@ checking this by themselves in their 'check' procedure."
(* 70 (expt 2 20)))
#:mappings mappings))
((disk-image)
- (system-disk-image os
- #:name (match file-system-type
- ("iso9660" "image.iso")
- (_ "disk-image"))
- #:disk-image-size image-size
- #:file-system-type file-system-type))
+ (match file-system-type
+ ("iso9660"
+ (system-disk-image-in-vm os
+ #:name "image.iso"
+ #:disk-image-size image-size
+ #:file-system-type file-system-type))
+ (_ (system-image
+ (image
+ (inherit efi-disk-image)
+ (operating-system os))))))
((docker-image)
(system-docker-image os))))
@@ -1226,7 +1232,8 @@ argument list and OPTS is the option alist."
(alist-cons 'argument arg result)
(let ((action (string->symbol arg)))
(case action
- ((build container vm vm-image disk-image reconfigure init
+ ((build container vm vm-image disk-image disk-image-vm
+ reconfigure init
extension-graph shepherd-graph
list-generations describe
delete-generations roll-back
@@ -1259,7 +1266,8 @@ argument list and OPTS is the option alist."
(exit 1))
(case action
- ((build container vm vm-image disk-image docker-image reconfigure)
+ ((build container vm vm-image disk-image disk-image-vm docker-image
+ reconfigure)
(unless (or (= count 1)
(and expr (= count 0)))
(fail)))