Toggle diff (458 lines)
diff --git a/gnu/build/image.scm b/gnu/build/image.scm
new file mode 100644
index 0000000000..7c47bda344
--- /dev/null
+++ b/gnu/build/image.scm
@@ -0,0 +1,275 @@
+;;; 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 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 (root-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 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 owner options)
+ target
+ (format #f "~ak"
+ (size-in-kib
+ (if (eq? size 'guess)
+ (root-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)
+ (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)
+ "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* (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 (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)
+ "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)
+
+ ;; Register BOOTCFG as a GC root.
+ (register-bootcfg-root root bootcfg)))
+
+(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/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..e250741c98
--- /dev/null
+++ b/gnu/image.scm
@@ -0,0 +1,77 @@
+;;; 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)
+ #:use-module (ice-9 match)
+ #: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 9f212434a9..408063a36e 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -61,6 +61,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 \
@@ -602,6 +603,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 \
@@ -622,6 +624,7 @@ GNU_SYSTEM_MODULES = \
%D%/build/activation.scm \
%D%/build/bootloader.scm \
%D%