summaryrefslogtreecommitdiff
path: root/gnu/build/image.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/build/image.scm')
-rw-r--r--gnu/build/image.scm273
1 files changed, 273 insertions, 0 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)))
+ '()))))
generated by cgit v1.2.3 (git 2.25.4) at 2024-05-11 23:18:44 +0000