mirror of
https://git.savannah.gnu.org/git/guix.git
synced 2026-05-27 19:41:50 +02:00
Merge branch 'master' into core-updates
This commit is contained in:
@@ -18,8 +18,12 @@
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (gnu build bootloader)
|
||||
#:use-module (guix build utils)
|
||||
#:use-module (guix utils)
|
||||
#:use-module (ice-9 binary-ports)
|
||||
#:export (write-file-on-device))
|
||||
#:use-module (ice-9 format)
|
||||
#:export (write-file-on-device
|
||||
install-efi-loader))
|
||||
|
||||
|
||||
;;;
|
||||
@@ -36,3 +40,53 @@
|
||||
(seek output offset SEEK_SET)
|
||||
(put-bytevector output bv))
|
||||
#:binary #t)))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; EFI bootloader.
|
||||
;;;
|
||||
|
||||
(define (install-efi grub grub-config esp)
|
||||
"Write a self-contained GRUB EFI loader to the mounted ESP using GRUB-CONFIG."
|
||||
(let* ((system %host-type)
|
||||
;; Hard code the output location to a well-known path recognized by
|
||||
;; compliant firmware. See "3.5.1.1 Removable Media Boot Behaviour":
|
||||
;; http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%202_6.pdf
|
||||
(grub-mkstandalone (string-append grub "/bin/grub-mkstandalone"))
|
||||
(efi-directory (string-append esp "/EFI/BOOT"))
|
||||
;; Map grub target names to boot file names.
|
||||
(efi-targets (cond ((string-prefix? "x86_64" system)
|
||||
'("x86_64-efi" . "BOOTX64.EFI"))
|
||||
((string-prefix? "i686" system)
|
||||
'("i386-efi" . "BOOTIA32.EFI"))
|
||||
((string-prefix? "armhf" system)
|
||||
'("arm-efi" . "BOOTARM.EFI"))
|
||||
((string-prefix? "aarch64" system)
|
||||
'("arm64-efi" . "BOOTAA64.EFI")))))
|
||||
;; grub-mkstandalone requires a TMPDIR to prepare the firmware image.
|
||||
(setenv "TMPDIR" esp)
|
||||
|
||||
(mkdir-p efi-directory)
|
||||
(invoke grub-mkstandalone "-O" (car efi-targets)
|
||||
"-o" (string-append efi-directory "/"
|
||||
(cdr efi-targets))
|
||||
;; Graft the configuration file onto the image.
|
||||
(string-append "boot/grub/grub.cfg=" grub-config))))
|
||||
|
||||
(define (install-efi-loader grub-efi esp)
|
||||
"Install in ESP directory the given GRUB-EFI bootloader. Configure it to
|
||||
load the Grub bootloader located in the 'Guix_image' root partition."
|
||||
(let ((grub-config "grub.cfg"))
|
||||
(call-with-output-file grub-config
|
||||
(lambda (port)
|
||||
;; Create a tiny configuration file telling the embedded grub where to
|
||||
;; load the real thing. XXX This is quite fragile, and can prevent
|
||||
;; the image from booting when there's more than one volume with this
|
||||
;; label present. Reproducible almost-UUIDs could reduce the risk
|
||||
;; (not eliminate it).
|
||||
(format port
|
||||
"insmod part_msdos~@
|
||||
search --set=root --label Guix_image~@
|
||||
configfile /boot/grub/grub.cfg~%")))
|
||||
(install-efi grub-efi grub-config esp)
|
||||
(delete-file grub-config)))
|
||||
|
||||
@@ -98,6 +98,47 @@ takes a bytevector and returns #t when it's a valid superblock."
|
||||
(define null-terminated-latin1->string
|
||||
(cut latin1->string <> zero?))
|
||||
|
||||
(define (bytevector-utf16-length bv)
|
||||
"Given a bytevector BV containing a NUL-terminated UTF16-encoded string,
|
||||
determine where the NUL terminator is and return its index. If there's no
|
||||
NUL terminator, return the size of the bytevector."
|
||||
(let ((length (bytevector-length bv)))
|
||||
(let loop ((index 0))
|
||||
(if (< index length)
|
||||
(if (zero? (bytevector-u16-ref bv index 'little))
|
||||
index
|
||||
(loop (+ index 2)))
|
||||
length))))
|
||||
|
||||
(define* (bytevector->u16-list bv endianness #:optional (index 0))
|
||||
(if (< index (bytevector-length bv))
|
||||
(cons (bytevector-u16-ref bv index endianness)
|
||||
(bytevector->u16-list bv endianness (+ index 2)))
|
||||
'()))
|
||||
|
||||
;; The initrd doesn't have iconv data, so do the conversion ourselves.
|
||||
(define (utf16->string bv endianness)
|
||||
(list->string
|
||||
(map integer->char
|
||||
(reverse
|
||||
(let loop ((remainder (bytevector->u16-list bv endianness))
|
||||
(result '()))
|
||||
(match remainder
|
||||
(() result)
|
||||
((a) (cons a result))
|
||||
((a b x ...)
|
||||
(if (and (>= a #xD800) (< a #xDC00) ; high surrogate
|
||||
(>= b #xDC00) (< b #xE000)) ; low surrogate
|
||||
(loop x (cons (+ #x10000
|
||||
(* #x400 (- a #xD800))
|
||||
(- b #xDC00))
|
||||
result))
|
||||
(loop (cons b x) (cons a result))))))))))
|
||||
|
||||
(define (null-terminated-utf16->string bv endianness)
|
||||
(utf16->string (sub-bytevector bv 0 (bytevector-utf16-length bv))
|
||||
endianness))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Ext2 file systems.
|
||||
@@ -377,7 +418,9 @@ if DEVICE does not contain an F2FS file system."
|
||||
(define (f2fs-superblock-volume-name sblock)
|
||||
"Return the volume name of SBLOCK as a string of at most 512 characters, or
|
||||
#f if SBLOCK has no volume name."
|
||||
(utf16->string (sub-bytevector sblock (- (+ #x470 12) #x400) 512) %f2fs-endianness))
|
||||
(null-terminated-utf16->string
|
||||
(sub-bytevector sblock (- (+ #x470 12) #x400) 512)
|
||||
%f2fs-endianness))
|
||||
|
||||
(define (check-f2fs-file-system device)
|
||||
"Return the health of a F2FS file system on DEVICE."
|
||||
|
||||
@@ -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)))
|
||||
'()))))
|
||||
+14
-7
@@ -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))
|
||||
|
||||
@@ -51,9 +50,14 @@ that the fonts, background images, etc. referred to by BOOTCFG are not GC'd."
|
||||
(copy-file bootcfg pivot)
|
||||
(rename-file pivot target)))
|
||||
|
||||
(define (evaluate-populate-directive directive target)
|
||||
(define* (evaluate-populate-directive directive target
|
||||
#:key
|
||||
(default-gid 0)
|
||||
(default-uid 0))
|
||||
"Evaluate DIRECTIVE, an sexp describing a file or directory to create under
|
||||
directory TARGET."
|
||||
directory TARGET. DEFAULT-UID and DEFAULT-GID are the default UID and GID in
|
||||
the context of the caller. If the directive matches those defaults then,
|
||||
'chown' won't be run."
|
||||
(let loop ((directive directive))
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
@@ -63,7 +67,12 @@ directory TARGET."
|
||||
(('directory name uid gid)
|
||||
(let ((dir (string-append target name)))
|
||||
(mkdir-p dir)
|
||||
(chown dir uid gid)))
|
||||
;; If called from a context without "root" permissions, "chown"
|
||||
;; to root will fail. In that case, do not try to run "chown"
|
||||
;; and assume that the file will be chowned elsewhere (when
|
||||
;; interned in the store for instance).
|
||||
(or (and (= uid default-uid) (= gid default-gid))
|
||||
(chown dir uid gid))))
|
||||
(('directory name uid gid mode)
|
||||
(loop `(directory ,name ,uid ,gid))
|
||||
(chmod (string-append target name) mode))
|
||||
@@ -98,9 +107,7 @@ directory TARGET."
|
||||
(define (directives store)
|
||||
"Return a list of directives to populate the root file system that will host
|
||||
STORE."
|
||||
`(;; Note: the store's GID is fixed precisely so we can set it here rather
|
||||
;; than at activation time.
|
||||
(directory ,store 0 30000 #o1775)
|
||||
`((directory ,store 0 0 #o1775)
|
||||
|
||||
(directory "/etc")
|
||||
(directory "/var/log") ; for shepherd
|
||||
|
||||
+4
-171
@@ -27,6 +27,7 @@
|
||||
#:use-module (guix build store-copy)
|
||||
#:use-module (guix build syscalls)
|
||||
#:use-module (guix store database)
|
||||
#:use-module (gnu build bootloader)
|
||||
#:use-module (gnu build linux-boot)
|
||||
#:use-module (gnu build install)
|
||||
#:use-module (gnu system uuid)
|
||||
@@ -57,8 +58,7 @@
|
||||
estimated-partition-size
|
||||
root-partition-initializer
|
||||
initialize-partition-table
|
||||
initialize-hard-disk
|
||||
make-iso9660-image))
|
||||
initialize-hard-disk))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
@@ -439,159 +439,6 @@ system that is passed to 'populate-root-file-system'."
|
||||
(mkdir-p directory)
|
||||
(symlink bootcfg (string-append directory "/bootcfg"))))
|
||||
|
||||
(define (install-efi grub esp config-file)
|
||||
"Write a self-contained GRUB EFI loader to the mounted ESP using CONFIG-FILE."
|
||||
(let* ((system %host-type)
|
||||
;; Hard code the output location to a well-known path recognized by
|
||||
;; compliant firmware. See "3.5.1.1 Removable Media Boot Behaviour":
|
||||
;; http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%202_6.pdf
|
||||
(grub-mkstandalone (string-append grub "/bin/grub-mkstandalone"))
|
||||
(efi-directory (string-append esp "/EFI/BOOT"))
|
||||
;; Map grub target names to boot file names.
|
||||
(efi-targets (cond ((string-prefix? "x86_64" system)
|
||||
'("x86_64-efi" . "BOOTX64.EFI"))
|
||||
((string-prefix? "i686" system)
|
||||
'("i386-efi" . "BOOTIA32.EFI"))
|
||||
((string-prefix? "armhf" system)
|
||||
'("arm-efi" . "BOOTARM.EFI"))
|
||||
((string-prefix? "aarch64" system)
|
||||
'("arm64-efi" . "BOOTAA64.EFI")))))
|
||||
;; grub-mkstandalone requires a TMPDIR to prepare the firmware image.
|
||||
(setenv "TMPDIR" esp)
|
||||
|
||||
(mkdir-p efi-directory)
|
||||
(invoke grub-mkstandalone "-O" (car efi-targets)
|
||||
"-o" (string-append efi-directory "/"
|
||||
(cdr efi-targets))
|
||||
;; Graft the configuration file onto the image.
|
||||
(string-append "boot/grub/grub.cfg=" config-file))))
|
||||
|
||||
(define* (make-iso9660-image xorriso grub-mkrescue-environment
|
||||
grub config-file os-drv target
|
||||
#:key (volume-id "Guix_image") (volume-uuid #f)
|
||||
register-closures? (closures '()))
|
||||
"Given a GRUB package, creates an iso image as TARGET, using CONFIG-FILE 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 xorriso "/bin/grub-mkrescue-sed.sh"))
|
||||
|
||||
(define target-store
|
||||
(string-append "/tmp/root" (%store-directory)))
|
||||
|
||||
(define items
|
||||
;; The store items to add to the image.
|
||||
(delete-duplicates
|
||||
(append-map (lambda (closure)
|
||||
(map store-info-item
|
||||
(call-with-input-file (string-append "/xchg/" closure)
|
||||
read-reference-graph)))
|
||||
closures)))
|
||||
|
||||
(populate-root-file-system os-drv "/tmp/root")
|
||||
(mount (%store-directory) target-store "" MS_BIND)
|
||||
|
||||
(when register-closures?
|
||||
(display "registering closures...\n")
|
||||
(for-each (lambda (closure)
|
||||
(register-closure
|
||||
"/tmp/root"
|
||||
(string-append "/xchg/" closure)
|
||||
|
||||
;; TARGET-STORE is a read-only bind-mount so we shouldn't try
|
||||
;; to modify it.
|
||||
#:deduplicate? #f
|
||||
#:reset-timestamps? #f))
|
||||
closures)
|
||||
(register-bootcfg-root "/tmp/root" config-file))
|
||||
|
||||
;; '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)
|
||||
|
||||
(let ((pipe
|
||||
(apply open-pipe* OPEN_WRITE
|
||||
grub-mkrescue
|
||||
(string-append "--xorriso=" grub-mkrescue-sed.sh)
|
||||
"-o" target
|
||||
(string-append "boot/grub/grub.cfg=" config-file)
|
||||
"etc=/tmp/root/etc"
|
||||
"var=/tmp/root/var"
|
||||
"run=/tmp/root/run"
|
||||
;; /mnt is used as part of the installation
|
||||
;; process, as the mount point for the target
|
||||
;; file system, so create it.
|
||||
"mnt=/tmp/root/mnt"
|
||||
"-path-list" "-"
|
||||
"--"
|
||||
|
||||
;; Set all timestamps to 1.
|
||||
"-volume_date" "all_file_dates" "=1"
|
||||
|
||||
;; ‘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)))
|
||||
`()))))
|
||||
;; Pass lines like 'gnu/store/…-x=/gnu/store/…-x' corresponding to the
|
||||
;; '-path-list -' option.
|
||||
(for-each (lambda (item)
|
||||
(format pipe "~a=~a~%"
|
||||
(string-drop item 1) item))
|
||||
items)
|
||||
(unless (zero? (close-pipe pipe))
|
||||
(error "oh, my! grub-mkrescue failed" grub-mkrescue))))
|
||||
|
||||
(define* (initialize-hard-disk device
|
||||
#:key
|
||||
bootloader-package
|
||||
@@ -633,30 +480,16 @@ passing it a directory name where it is mounted."
|
||||
|
||||
(when esp
|
||||
;; Mount the ESP somewhere and install GRUB UEFI image.
|
||||
(let ((mount-point (string-append target "/boot/efi"))
|
||||
(grub-config (string-append target "/tmp/grub-standalone.cfg")))
|
||||
(let ((mount-point (string-append target "/boot/efi")))
|
||||
(display "mounting EFI system partition...\n")
|
||||
(mkdir-p mount-point)
|
||||
(mount (partition-device esp) mount-point
|
||||
(partition-file-system esp))
|
||||
|
||||
;; Create a tiny configuration file telling the embedded grub
|
||||
;; where to load the real thing.
|
||||
;; XXX This is quite fragile, and can prevent the image from booting
|
||||
;; when there's more than one volume with this label present.
|
||||
;; Reproducible almost-UUIDs could reduce the risk (not eliminate it).
|
||||
(call-with-output-file grub-config
|
||||
(lambda (port)
|
||||
(format port
|
||||
"insmod part_msdos~@
|
||||
search --set=root --label Guix_image~@
|
||||
configfile /boot/grub/grub.cfg~%")))
|
||||
|
||||
(display "creating EFI firmware image...")
|
||||
(install-efi grub-efi mount-point grub-config)
|
||||
(install-efi-loader grub-efi mount-point)
|
||||
(display "done.\n")
|
||||
|
||||
(delete-file grub-config)
|
||||
(umount mount-point)))
|
||||
|
||||
;; Register BOOTCFG as a GC root.
|
||||
|
||||
Reference in New Issue
Block a user