image: Add a new API.

Raw disk-images and ISO9660 images are created in a Qemu virtual machine. This
is quite fragile, very slow, and almost unusable without KVM.

For all these reasons, add support for host image generation. This implies the
use new image generation mechanisms.

- Raw disk images: images of partitions are created using tools such as mke2fs
  and mkdosfs depending on the partition file-system type. The partition
  images are then assembled into a final image using genimage.

- ISO9660 images: the ISO root directory is populated within the store. GNU
  xorriso is then called on that directory, in the exact same way as this is
  done in (gnu build vm) module.

Those mechanisms are built upon the new (gnu image) module.

* gnu/image.scm: New file.
* gnu/system/image.scm: New file.
* gnu/build/image: New file.
* gnu/local.mk: Add them.
* gnu/system/vm.scm (system-disk-image): Rename to system-disk-image-in-vm.
* gnu/ci.scm (qemu-jobs): Adapt to new API.
* gnu/tests/install.scm (run-install): Ditto.
* guix/scripts/system.scm (system-derivation-for-action): Ditto.

2 files changed, 273 insertions, 1 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))