diff options
Diffstat (limited to 'gnu')
| -rw-r--r-- | gnu/build/image.scm | 273 | ||||
| -rw-r--r-- | gnu/build/install.scm | 1 | ||||
| -rw-r--r-- | gnu/ci.scm | 45 | ||||
| -rw-r--r-- | gnu/image.scm | 76 | ||||
| -rw-r--r-- | gnu/local.mk | 3 | ||||
| -rw-r--r-- | gnu/system/image.scm | 532 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 17 | ||||
| -rw-r--r-- | gnu/tests/install.scm | 22 |
8 files changed, 925 insertions, 44 deletions
diff --git a/gnu/build/image.scm b/gnu/build/image.scm new file mode 100644 index 0000000000..fe8e11aa1b --- /dev/null +++ b/gnu/build/image.scm @@ -0,0 +1,273 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org> +;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name> +;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> +;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com> +;;; +;;; 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 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 (gnu system uuid) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:export (make-partition-image + genimage + initialize-efi-partition + initialize-root-partition + + make-iso9660-image)) + +(define (sexp->partition sexp) + "Take SEXP, a tuple as returned by 'partition->gexp', and turn it into a +<partition> record." + (match sexp + ((size file-system label uuid) + (partition (size size) + (file-system file-system) + (label label) + (uuid uuid))))) + +(define (size-in-kib size) + "Convert SIZE expressed in bytes, to kilobytes and return it as a string." + (number->string + (inexact->exact (ceiling (/ size 1024))))) + +(define (estimate-partition-size root) + "Given the ROOT directory, evalute and return its size. As this doesn't +take the partition metadata size into account, take a 25% margin." + (* 1.25 (file-size root))) + +(define* (make-ext4-image partition target root + #:key + (owner-uid 0) + (owner-gid 0)) + "Handle the creation of EXT4 partition images. See 'make-partition-image'." + (let ((size (partition-size partition)) + (label (partition-label partition)) + (uuid (partition-uuid partition)) + (options "lazy_itable_init=1,lazy_journal_init=1")) + (invoke "mke2fs" "-t" "ext4" "-d" root + "-L" label "-U" (uuid->string uuid) + "-E" (format #f "root_owner=~a:~a,~a" + owner-uid owner-gid options) + target + (format #f "~ak" + (size-in-kib + (if (eq? size 'guess) + (estimate-partition-size root) + size)))))) + +(define* (make-vfat-image partition target root) + "Handle the creation of VFAT partition images. See 'make-partition-image'." + (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) + (estimate-partition-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) + "Create and return the image of PARTITION-SEXP as TARGET. Use the given +ROOT directory to populate the image." + (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) + "Use genimage to generate in TARGET directory, the image described in the +given CONFIG file." + ;; genimage needs a 'root' directory. + (mkdir "root") + (invoke "genimage" "--config" config + "--outputpath" target)) + +(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-efi-partition root + #:key + bootloader-package + #:allow-other-keys) + "Install in ROOT directory, an EFI loader using BOOTLOADER-PACKAGE." + (install-efi-loader bootloader-package root)) + +(define* (initialize-root-partition root + #:key + bootcfg + bootcfg-location + (deduplicate? #t) + references-graphs + (register-closures? #t) + system-directory + #:allow-other-keys) + "Initialize the given ROOT directory. Use BOOTCFG and BOOTCFG-LOCATION to +install the bootloader configuration. + +If REGISTER-CLOSURES? is true, register REFERENCES-GRAPHS in the store. If +DEDUPLICATE? is true, then also deduplicate files common to CLOSURES and the +rest of the store when registering the closures. SYSTEM-DIRECTORY is the name +of the directory of the 'system' derivation." + (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)) + + (when bootcfg + (install-boot-config bootcfg bootcfg-location root))) + +(define* (make-iso9660-image xorriso grub-mkrescue-environment + grub bootcfg system-directory root target + #:key (volume-id "Guix_image") (volume-uuid #f) + register-closures? (references-graphs '()) + (compression? #t)) + "Given a GRUB package, creates an iso image as TARGET, using BOOTCFG as +GRUB configuration and OS-DRV as the stuff in it." + (define grub-mkrescue + (string-append grub "/bin/grub-mkrescue")) + + (define grub-mkrescue-sed.sh + (string-append (getcwd) "/" "grub-mkrescue-sed.sh")) + + ;; Use a modified version of grub-mkrescue-sed.sh, see below. + (copy-file (string-append xorriso + "/bin/grub-mkrescue-sed.sh") + grub-mkrescue-sed.sh) + + ;; Force grub-mkrescue-sed.sh to use the build directory instead of /tmp + ;; that is read-only inside the build container. + (substitute* grub-mkrescue-sed.sh + (("/tmp/") (string-append (getcwd) "/")) + (("MKRESCUE_SED_XORRISO_ARGS \\$x") + (format #f "MKRESCUE_SED_XORRISO_ARGS $(echo $x | sed \"s|/tmp|~a|\")" + (getcwd)))) + + ;; 'grub-mkrescue' calls out to mtools programs to create 'efi.img', a FAT + ;; file system image, and mtools honors SOURCE_DATE_EPOCH for the mtime of + ;; those files. The epoch for FAT is Jan. 1st 1980, not 1970, so choose + ;; that. + (setenv "SOURCE_DATE_EPOCH" + (number->string + (time-second + (date->time-utc (make-date 0 0 0 0 1 1 1980 0))))) + + ;; Our patched 'grub-mkrescue' honors this environment variable and passes + ;; it to 'mformat', which makes it the serial number of 'efi.img'. This + ;; allows for deterministic builds. + (setenv "GRUB_FAT_SERIAL_NUMBER" + (number->string (if volume-uuid + + ;; On 32-bit systems the 2nd argument must be + ;; lower than 2^32. + (string-hash (iso9660-uuid->string volume-uuid) + (- (expt 2 32) 1)) + + #x77777777) + 16)) + + (setenv "MKRESCUE_SED_MODE" "original") + (setenv "MKRESCUE_SED_XORRISO" (string-append xorriso "/bin/xorriso")) + (setenv "MKRESCUE_SED_IN_EFI_NO_PT" "yes") + + (for-each (match-lambda + ((name . value) (setenv name value))) + grub-mkrescue-environment) + + (apply invoke grub-mkrescue + (string-append "--xorriso=" grub-mkrescue-sed.sh) + "-o" target + (string-append "boot/grub/grub.cfg=" bootcfg) + root + "--" + ;; Set all timestamps to 1. + "-volume_date" "all_file_dates" "=1" + + `(,@(if compression? + '(;; ‘zisofs’ compression reduces the total image size by + ;; ~60%. + "-zisofs" "level=9:block_size=128k" ; highest compression + ;; It's transparent to our Linux-Libre kernel but not to + ;; GRUB. Don't compress the kernel, initrd, and other + ;; files read by grub.cfg, as well as common + ;; already-compressed file names. + "-find" "/" "-type" "f" + ;; XXX Even after "--" above, and despite documentation + ;; claiming otherwise, "-or" is stolen by grub-mkrescue + ;; which then chokes on it (as ‘-o …’) and dies. Don't use + ;; "-or". + "-not" "-wholename" "/boot/*" + "-not" "-wholename" "/System/*" + "-not" "-name" "unicode.pf2" + "-not" "-name" "bzImage" + "-not" "-name" "*.gz" ; initrd & all man pages + "-not" "-name" "*.png" ; includes grub-image.png + "-exec" "set_filter" "--zisofs" + "--") + '()) + "-volid" ,(string-upcase volume-id) + ,@(if volume-uuid + `("-volume_date" "uuid" + ,(string-filter (lambda (value) + (not (char=? #\- value))) + (iso9660-uuid->string + volume-uuid))) + '())))) diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 59a118e905..b18654f1cc 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -25,7 +25,6 @@ #:export (install-boot-config evaluate-populate-directive populate-root-file-system - register-closure install-database-and-gc-roots populate-single-profile-directory)) diff --git a/gnu/ci.scm b/gnu/ci.scm index fb2596c809..0430cf594b 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 - (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 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")))))) + (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/image.scm b/gnu/image.scm new file mode 100644 index 0000000000..b05fc69dc5 --- /dev/null +++ b/gnu/image.scm @@ -0,0 +1,76 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com> +;;; +;;; 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) + #:export (partition + partition? + partition-device + partition-size + partition-file-system + partition-label + partition-uuid + partition-flags + partition-initializer + + image + image-name + image-format + image-size + image-operating-system + image-partitions + image-compression? + image-volatile-root? + image-substitutable?)) + + +;;; +;;; 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 '())) + (compression? image-compression? ;boolean + (default #t)) + (volatile-root? image-volatile-root? ;boolean + (default #t)) + (substitutable? image-substitutable? ;boolean + (default #t))) diff --git a/gnu/local.mk b/gnu/local.mk index daf6bd0306..4e0521baa5 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -62,6 +62,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 \ @@ -606,6 +607,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 \ @@ -626,6 +628,7 @@ GNU_SYSTEM_MODULES = \ %D%/build/activation.scm \ %D%/build/bootloader.scm \ %D%/build/cross-toolchain.scm \ + %D%/build/image.scm \ %D%/build/file-systems.scm \ %D%/build/install.scm \ %D%/build/linux-boot.scm \ diff --git a/gnu/system/image.scm b/gnu/system/image.scm new file mode 100644 index 0000000000..571b7af5f3 --- /dev/null +++ b/gnu/system/image.scm @@ -0,0 +1,532 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com> +;;; +;;; 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 monads) + #:use-module (guix records) + #:use-module (guix store) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module ((guix self) #:select (make-config.scm)) + #:use-module (gnu bootloader) + #:use-module (gnu bootloader grub) + #:use-module (gnu image) + #:use-module (gnu services) + #:use-module (gnu services base) + #: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) + #:use-module (gnu packages cdrom) + #:use-module (gnu packages disk) + #:use-module (gnu packages gawk) + #: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) #:prefix srfi-1:) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 match) + #:export (esp-partition + root-partition + + efi-disk-image + iso9660-image + + find-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 iso9660-image + (image + (format 'iso9660) + (partitions + (list (partition + (size 'guess) + (label "GUIX_IMAGE") + (flags '(boot))))) + ;; XXX: Temporarily disable compression to speed-up the tests. + (compression? #f))) + + +;; +;; Helpers. +;; + +(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) + "Turn PARTITION, a <partition> object, into a list-valued gexp suitable for +'make-partition-image'." + #~'(#$@(list (partition-size partition)) + #$(partition-file-system partition) + #$(partition-label partition) + #$(and=> (partition-uuid partition) + uuid-bytevector))) + +(define gcrypt-sqlite3&co + ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs. + (srfi-1: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* gexp* ...) + (with-extensions gcrypt-sqlite3&co + (with-imported-modules `(,@(source-module-closure + '((gnu build vm) + (gnu build image) + (guix store database)) + #:select? not-config?) + ((guix config) => ,(make-config.scm))) + #~(begin + (use-modules (gnu build vm) + (gnu build image) + (guix store database) + (guix build utils)) + gexp* ...)))) + + +;; +;; Disk image. +;; + +(define* (system-disk-image image + #:key + (name "disk-image") + bootcfg + bootloader + register-closures? + (inputs '())) + "Return as a file-like object, the disk-image described by IMAGE. Said +image can be copied on a USB stick as is. BOOTLOADER is the bootloader that +will be installed and configured according to BOOTCFG parameter. + +Raw images of the IMAGE partitions are first created. Then, genimage is used +to assemble the partition images into a disk-image without resorting to a +virtual machine. + +INPUTS is a list of inputs (as for packages). When REGISTER-CLOSURES? is +true, register INPUTS in the store database of the image so that Guix can be +used in the image." + + (define genimage-name "image") + + (define (image->genimage-cfg image) + ;; Return as a file-like object, the genimage configuration file + ;; describing the given IMAGE. + (define (format->image-type format) + ;; Return the genimage format corresponding to FORMAT. For now, only + ;; the hdimage format (raw disk-image) is supported. + (case format + ((disk-image) "hdimage") + (else + (raise (condition + (&message + (message + (format #f (G_ "Unsupported image type ~a~%.") format)))))))) + + (define (partition->dos-type partition) + ;; Return the MBR partition type corresponding to the given PARTITION. + ;; See: https://en.wikipedia.org/wiki/Partition_type. + (let ((flags (partition-flags partition))) + (cond + ((member 'esp flags) "0xEF") + (else "0x83")))) + + (define (partition-image partition) + ;; Return as a file-like object, an image of the given PARTITION. A + ;; directory, filled by calling the PARTITION initializer procedure, is + ;; first created within the store. Then, an image of this directory is + ;; created using tools such as 'mke2fs' or 'mkdosfs', depending on the + ;; partition file-system type. + (let* ((os (image-operating-system image)) + (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) + + ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be + ;; decoded. + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) + (setlocale LC_ALL "en_US.utf8") + + (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 dosfstools mtools))) + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + (make-partition-image #$(partition->gexp partition) + #$output + #$image-root))))) + (computed-file "partition.img" image-builder))) + + (define (partition->config partition) + ;; Return the genimage partition configuration for PARTITION. + (let ((label (partition-label partition)) + (dos-type (partition->dos-type partition)) + (image (partition-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))) + + (let* ((substitutable? (image-substitutable? image)) + (builder + (with-imported-modules* + (let ((inputs '#$(list genimage coreutils findutils))) + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + (genimage #$(image->genimage-cfg image) #$output)))) + (image-dir (computed-file "image-dir" builder))) + (computed-file name + #~(symlink + (string-append #$image-dir "/" #$genimage-name) + #$output) + #:options `(#:substitutable? ,substitutable?)))) + + +;; +;; ISO9660 image. +;; + +(define (has-guix-service-type? os) + "Return true if OS contains a service of the type GUIX-SERVICE-TYPE." + (not (not (srfi-1:find (lambda (service) + (eq? (service-kind service) guix-service-type)) + (operating-system-services os))))) + +(define* (system-iso9660-image image + #:key + (name "iso9660-image") + bootcfg + bootloader + register-closures? + (inputs '()) + (grub-mkrescue-environment '())) + "Return as a file-like object a bootable, stand-alone iso9660 image. + +INPUTS is a list of inputs (as for packages). When REGISTER-CLOSURES? is +true, register INPUTS in the store database of the image so that Guix can be +used in the image. " + (define root-label + (match (image-partitions image) + ((partition) + (partition-label partition)))) + + (define root-uuid + (match (image-partitions image) + ((partition) + (uuid-bytevector (partition-uuid partition))))) + + (let* ((os (image-operating-system image)) + (bootloader (bootloader-package bootloader)) + (compression? (image-compression? image)) + (substitutable? (image-substitutable? image)) + (schema (local-file (search-path %load-path + "guix/store/schema.sql"))) + (graph (match inputs + (((names . _) ...) + names))) + (root-builder + (with-imported-modules* + (sql-schema #$schema) + + ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded. + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) + (setlocale LC_ALL "en_US.utf8") + + (initialize-root-partition #$output + #:references-graphs '#$graph + #:deduplicate? #f + #:system-directory #$os))) + (image-root + (computed-file "image-root" root-builder + #:options `(#:references-graphs ,inputs))) + (builder + (with-imported-modules* + (let* ((inputs '#$(list parted e2fsprogs dosfstools xorriso + sed grep coreutils findutils gawk))) + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + (make-iso9660-image #$xorriso + '#$grub-mkrescue-environment + #$bootloader + #$bootcfg + #$os + #$image-root + #$output + #:references-graphs '#$graph + #:register-closures? #$register-closures? + #:compression? #$compression? + #:volume-id #$root-label + #:volume-uuid #$root-uuid))))) + (computed-file name builder + #:options `(#:references-graphs ,inputs + #:substitutable? ,substitutable?)))) + + +;; +;; Image creation. +;; + +(define (root-partition? partition) + "Return true if PARTITION is the root partition, false otherwise." + (member 'boot (partition-flags partition))) + +(define (find-root-partition image) + "Return the root partition of the given IMAGE." + (srfi-1:find root-partition? (image-partitions image))) + +(define (image->root-file-system image) + "Return the IMAGE root partition file-system type." + (let ((format (image-format image))) + (if (eq? format 'iso9660) + "iso9660" + (partition-file-system (find-root-partition image))))) + +(define (root-size image) + "Return the root partition size of IMAGE." + (let* ((image-size (image-size image)) + (root-partition (find-root-partition image)) + (root-size (partition-size root-partition))) + (cond + ((and (eq? root-size 'guess) image-size) + image-size) + (else root-size)))) + +(define* (image-with-os base-image os) + "Return an image based on BASE-IMAGE but with the operating-system field set +to OS. Also set the UUID and the size of the root partition." + (define root-file-system + (srfi-1:find + (lambda (fs) + (string=? (file-system-mount-point fs) "/")) + (operating-system-file-systems os))) + + (let*-values (((partitions) (image-partitions base-image)) + ((root-partition other-partitions) + (srfi-1:partition root-partition? partitions))) + (image + (inherit base-image) + (operating-system os) + (partitions + (cons (partition + (inherit (car root-partition)) + (uuid (file-system-device root-file-system)) + (size (root-size base-image))) + other-partitions))))) + +(define (operating-system-for-image image) + "Return an operating-system based on the one specified in IMAGE, but +suitable for image creation. Assign an UUID to the root file-system, so that +it can be used for bootloading." + (define volatile-root? (image-volatile-root? image)) + + (define (root-uuid os) + ;; UUID of the root file system, computed in a deterministic fashion. + ;; This is what we use to locate the root file system so it has to be + ;; different from the user's own file system UUIDs. + (let ((type (if (eq? (image-format image) 'iso9660) + 'iso9660 + 'dce))) + (operating-system-uuid os type))) + + (let* ((root-file-system-type (image->root-file-system image)) + (base-os (image-operating-system image)) + (file-systems-to-keep + (srfi-1:remove + (lambda (fs) + (string=? (file-system-mount-point fs) "/")) + (operating-system-file-systems base-os))) + (format (image-format image)) + (os + (operating-system + (inherit base-os) + (initrd (lambda (file-systems . rest) + (apply (operating-system-initrd base-os) + file-systems + #:volatile-root? volatile-root? + rest))) + (bootloader (if (eq? format 'iso9660) + (bootloader-configuration + (inherit + (operating-system-bootloader base-os)) + (bootloader grub-mkrescue-bootloader)) + (operating-system-bootloader base-os))) + (file-systems (cons (file-system + (mount-point "/") + (device "/dev/placeholder") + (type root-file-system-type)) + file-systems-to-keep)))) + (uuid (root-uuid os))) + (operating-system + (inherit os) + (file-systems (cons (file-system + (mount-point "/") + (device uuid) + (type root-file-system-type)) + file-systems-to-keep))))) + +(define* (make-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)) + + (let* ((os (operating-system-for-image image)) + (image* (image-with-os image os)) + (register-closures? (has-guix-service-type? os)) + (bootcfg (operating-system-bootcfg os)) + (bootloader (bootloader-configuration-bootloader + (operating-system-bootloader os)))) + (case (image-format image) + ((disk-image) + (system-disk-image image* + #:bootcfg bootcfg + #:bootloader bootloader + #:register-closures? register-closures? + #:inputs `(("system" ,os) + ("bootcfg" ,bootcfg)))) + ((iso9660) + (system-iso9660-image image* + #:bootcfg bootcfg + #:bootloader bootloader + #:register-closures? register-closures? + #:inputs `(("system" ,os) + ("bootcfg" ,bootcfg)) + #:grub-mkrescue-environment + '(("MKRESCUE_SED_MODE" . "mbr_hfs"))))))) + +(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: 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)))))) + +;;; image.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 2fdf954883..37840ce355 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -77,7 +77,7 @@ system-qemu-image/shared-store system-qemu-image/shared-store-script - system-disk-image + system-disk-image-in-vm system-docker-image virtual-machine @@ -604,14 +604,13 @@ system." ;;; VM and disk images. ;;; - -(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 diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index 23f60c68bf..2e5913953e 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -22,9 +22,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)) @@ -229,14 +231,18 @@ 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 - (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)) + (size install-size) + (operating-system + (operating-system-with-gc-roots + os (list target))) + ;; Don't provide substitutes; too big. + (substitutable? #f))))) (define install (with-imported-modules '((guix build utils) (gnu build marionette)) |