;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Christine Lemmer-Webber <cwebber@dustycloud.org>
;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2020, 2022 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2022 Pavel Shlyak <p.shlyak@pantherx.org>
;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; 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 (guix utils)
#: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
convert-disk-image
genimage
initialize-efi-partition
initialize-efi32-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 file-system-options label uuid flags)
(partition (size size)
(file-system file-system)
(file-system-options file-system-options)
(label label)
(uuid uuid)
(flags flags)))))
(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, evaluate and return its size. As this doesn't
take the partition metadata size into account, take a 25% margin. As this in
turn doesn't take any constant overhead into account, force a 1-MiB minimum."
(max (ash 1 20)
(* 1.25 (file-size root))))
(define* (make-btrfs-image partition target root)
"Handle the creation of BTRFS partition images. See
'make-partition-image'."
(let ((size (partition-size partition))
(fs-options (partition-file-system-options partition))
(label (partition-label partition))
(uuid (partition-uuid partition)))
(apply invoke
`("fakeroot" "mkfs.btrfs" "-r" ,root
"-L" ,label
,@(if uuid
`("-U" ,(uuid->string uuid))
'())
"--shrink"
,@fs-options
,target))))
(define* (make-ext-image partition target root
#:key
(owner-uid 0)
(owner-gid 0))
"Handle the creation of EXT2/3/4 partition images. See
'make-partition-image'."
(let ((size (partition-size partition))
(fs (partition-file-system partition))
(fs-options (partition-file-system-options partition))
(label (partition-label partition))
(uuid (partition-uuid partition))
(journal-options "lazy_itable_init=1,lazy_journal_init=1"))
(apply invoke
`("fakeroot" "mke2fs" "-t" ,fs "-d" ,root
"-L" ,label
,@(if uuid
`("-U" ,(uuid->string uuid))
'())
"-E" ,(format #f "root_owner=~a:~a,~a"
owner-uid owner-gid journal-options)
,@fs-options
,target
,(format #f "~ak"
(size-in-kib
(if (eq? size 'guess)
(estimate-partition-size root)
size)))))))
(define* (make-vfat-image partition target root fs-bits)
"Handle the creation of VFAT partition images. See 'make-partition-image'."
(let ((size (partition-size partition))
(label (partition-label partition))
(flags (partition-flags partition))
(fs-options (partition-file-system-options partition)))
(apply invoke "fakeroot" "mkdosfs" "-n" label "-C" target
"-F" (number->string fs-bits)
(size-in-kib
(if (eq? size 'guess)
(estimate-partition-size root)
size))
;; u-boot in particular needs the formatted block
;; size and the physical block size to be equal.
;; TODO: What about 4k blocks?
(if (and (member 'esp flags)
(not (member "-S" fs-options)))
(append (list "-S" "512") fs-options)
fs-options))
(for-each (lambda (file)
(unless (member file '("." ".."))
(invoke "mcopy" "-bsp" "-i" target
(string-append root "/" file)
(string-append "::" file))))
(scandir root))))
(define* (make-unformatted-image partition target)
"Make an unformatted partition of a certain size."
(let ((size (partition-size partition)))
;; Create the file and then truncate it to the desired size.
(with-output-to-file target
(lambda _ (display "")))
(truncate-file target size)))
(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=? "btrfs" type)
(make-btrfs-image partition target root))
((string-prefix? "ext" type)
(make-ext-image partition target root))
((or (string=? type "vfat") (string=? type "fat16"))
(make-vfat-image partition target root 16))
((string=? type "fat32")
(make-vfat-image partition target root 32))
((string=? type "unformatted")
(make-unformatted-image partition target))
(else
(raise (condition
(&message
(message "unsupported partition type"))))))))
(define (convert-disk-image image format output)
"Convert IMAGE to OUTPUT according to the given FORMAT."
(case format
((compressed-qcow2)
(invoke "qemu-img" "convert" "-c" "-f" "raw"
"-O" "qcow2" image output))
(else
(copy-file image output))))
(define* (genimage config)
"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))
(define* (register-closure prefix closure
#:key
(schema (sql-schema))
(wal-mode? #t))
"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. Pass WAL-MODE? to call-with-database."
(let ((items (call-with-input-file closure read-reference-graph)))
(parameterize ((sql-schema schema))
(with-database (store-database-file #:prefix prefix) db
#:wal-mode? wal-mode?
(register-items db items
#:prefix prefix
#:registration-time %epoch)))))
(define* (initialize-efi-partition root
#:key
grub-efi
#:allow-other-keys)
"Install in ROOT directory, an EFI loader using GRUB-EFI."
(install-efi-loader grub-efi root))
(define* (initialize-efi32-partition root
#:key
grub-efi32
#:allow-other-keys)
"Install in ROOT directory, an EFI 32bit loader using GRUB-EFI32."
(install-efi-loader grub-efi32 root
#:targets (cond ((target-x86?)
'("i386-efi" . "BOOTIA32.EFI"))
((target-arm?)
'("arm-efi" . "BOOTARM.EFI")))))
(define* (initialize-root-partition root
#:key
bootcfg
bootcfg-location
bootloader-package
bootloader-installer
(copy-closures? #t)
(deduplicate? #t)
references-graphs
(register-closures? #t)
system-directory
make-device-nodes
(wal-mode? #t)
#:allow-other-keys)
"Initialize the given ROOT directory. Use BOOTCFG and BOOTCFG-LOCATION to
install the bootloader configuration.
If COPY-CLOSURES? is true, copy all of REFERENCES-GRAPHS to the partition. 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. Pass WAL-MODE? to
register-closure."
(define root-store
(string-append root (%store-directory)))
(define tmp-store ".tmp-store")
(populate-root-file-system system-directory root)
(when copy-closures?
(populate-store references-graphs root
#:deduplicate? deduplicate?))
;; Populate /dev.
(when make-device-nodes
(make-device-nodes root))
(when register-closures?
(unless copy-closures?
;; XXX: 'register-closure' wants to palpate the things it registers, so
;; create a symlink to the store.
(rename-file root-store tmp-store)
(symlink (%store-directory) root-store))
(for-each (lambda (closure)
(register-closure root closure
#:wal-mode? wal-mode?))
references-graphs)
(unless copy-closures?
(delete-file root-store)
(rename-file tmp-store root-store)))
;; There's no point installing a bootloader if we do not populate the store.
(when copy-closures?
(when bootloader-installer
(display "installing bootloader...\n")
(bootloader-installer bootloader-package #f root))
(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)))
'()))))
