@@ -7,6 +7,7 @@
;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
;;; Copyright © 2022 Reza Alizadeh Majd <r.majd@pantherx.org>
;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz>
+;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -24,45 +25,52 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu bootloader)
+ #:autoload (gnu build file-systems)
+ (read-partition-label read-partition-uuid
+ find-partition-by-label find-partition-by-uuid)
+ #:use-module (gnu packages linux)
#:use-module (gnu system file-systems)
#:use-module (gnu system uuid)
- #:use-module (guix discovery)
- #:use-module (guix gexp)
- #:use-module (guix profiles)
- #:use-module (guix records)
+ #:autoload (guix build syscalls)
+ (mounts mount-source mount-point mount-type)
#:use-module (guix deprecation)
#:use-module (guix diagnostics)
+ #:use-module (guix gexp)
#:use-module (guix i18n)
#:use-module (guix modules)
+ #:use-module (guix profiles)
+ #:use-module (guix records)
+ #:use-module (guix utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 match)
- #:export (menu-entry
+ #:use-module (ice-9 receive)
+ #:export (<menu-entry>
+ menu-entry
menu-entry?
menu-entry-label
menu-entry-device
+ menu-entry-device-mount-point
+ menu-entry-device-subvol
menu-entry-linux
menu-entry-linux-arguments
menu-entry-initrd
- menu-entry-device-mount-point
menu-entry-multiboot-kernel
menu-entry-multiboot-arguments
menu-entry-multiboot-modules
menu-entry-chain-loader
+ normalize-file
menu-entry->sexp
sexp->menu-entry
bootloader
bootloader?
bootloader-name
- bootloader-package
+ bootloader-default-targets
bootloader-installer
- bootloader-disk-image-installer
- bootloader-configuration-file
- bootloader-configuration-file-generator
<bootloader-target>
bootloader-target
@@ -84,13 +92,15 @@ (define-module (gnu bootloader)
:path :devpath :device :fs :label :uuid
with-targets
+ <bootloader-configuration>
bootloader-configuration
bootloader-configuration?
bootloader-configuration-bootloader
- bootloader-configuration-target ;deprecated
bootloader-configuration-targets
bootloader-configuration-menu-entries
bootloader-configuration-default-entry
+ bootloader-configuration-efi-removable?
+ bootloader-configuration-32bit?
bootloader-configuration-timeout
bootloader-configuration-keyboard-layout
bootloader-configuration-theme
@@ -101,10 +111,11 @@ (define-module (gnu bootloader)
bootloader-configuration-device-tree-support?
bootloader-configuration-extra-initrd
- %bootloaders
- lookup-bootloader-by-name
+ bootloader-configuration->gexp
+ bootloader-configurations->gexp
- efi-bootloader-chain))
+ efi-arch
+ install-efi))
;;;
@@ -119,6 +130,8 @@ (define-record-type* <menu-entry>
(default #f))
(device-mount-point menu-entry-device-mount-point
(default #f))
+ (device-subvol menu-entry-device-subvol
+ (default #f))
(linux menu-entry-linux
(default #f))
(linux-arguments menu-entry-linux-arguments
@@ -135,6 +148,18 @@ (define-record-type* <menu-entry>
(chain-loader menu-entry-chain-loader
(default #f))) ; string, path of efi file
+(define (normalize-file entry val)
+ "Normalize a file VAL stored in a menu entry into one suitable for a
+bootloader. Realizes device-mount-point and device-subvol."
+ (match-record entry <menu-entry> (device-mount-point device-subvol)
+ #~(let* ((rel (lambda (s) (substring s (if (string-prefix? "/" s) 1 0))))
+ (file (rel #$val))
+ (subvol (and=> #$device-subvol rel))
+ (mount (and=> #$device-mount-point rel)))
+ (string-append (if subvol (string-append "/" subvol "/") "/")
+ (if (and mount (string-prefix? mount file))
+ (substring file (string-length mount)) file)))))
+
(define (report-menu-entry-error menu-entry)
(raise
(condition
@@ -162,7 +187,7 @@ (define (menu-entry->sexp entry)
`(label ,(file-system-label->string label)))
(_ device)))
(match entry
- (($ <menu-entry> label device mount-point
+ (($ <menu-entry> label device mount-point subvol
(? identity linux) linux-arguments (? identity initrd)
#f () () #f)
`(menu-entry (version 0)
@@ -171,8 +196,9 @@ (define (menu-entry->sexp entry)
(device-mount-point ,mount-point)
(linux ,linux)
(linux-arguments ,linux-arguments)
- (initrd ,initrd)))
- (($ <menu-entry> label device mount-point #f () #f
+ (initrd ,initrd)
+ (device-subvol ,subvol)))
+ (($ <menu-entry> label device mount-point subvol #f () #f
(? identity multiboot-kernel) multiboot-arguments
multiboot-modules #f)
`(menu-entry (version 0)
@@ -181,19 +207,23 @@ (define (menu-entry->sexp entry)
(device-mount-point ,mount-point)
(multiboot-kernel ,multiboot-kernel)
(multiboot-arguments ,multiboot-arguments)
- (multiboot-modules ,multiboot-modules)))
- (($ <menu-entry> label device mount-point #f () #f #f () ()
+ (multiboot-modules ,multiboot-modules)
+ (device-subvol ,subvol)))
+ (($ <menu-entry> label device mount-point subvol #f () #f #f () ()
(? identity chain-loader))
`(menu-entry (version 0)
(label ,label)
(device ,(device->sexp device))
(device-mount-point ,mount-point)
- (chain-loader ,chain-loader)))
+ (chain-loader ,chain-loader)
+ (device-subvol ,subvol)))
(_ (report-menu-entry-error entry))))
(define (sexp->menu-entry sexp)
"Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
record."
+ ;; XXX: rely on shadowing to support the match ors below
+ (define subvol #f)
(define (sexp->device device-sexp)
(match device-sexp
(('uuid type uuid-string)
@@ -206,35 +236,41 @@ (define (sexp->menu-entry sexp)
('label label) ('device device)
('device-mount-point mount-point)
('linux linux) ('linux-arguments linux-arguments)
- ('initrd initrd) _ ...)
+ ('initrd initrd)
+ (or ('device-subvol subvol _ ...) (_ ...)))
(menu-entry
(label label)
(device (sexp->device device))
(device-mount-point mount-point)
+ (device-subvol subvol)
(linux linux)
(linux-arguments linux-arguments)
(initrd initrd)))
(('menu-entry ('version 0)
('label label) ('device device)
- ('device-mount-point mount-point)
+ ('device-mount-point mount-point) ('device-subvol subvol)
('multiboot-kernel multiboot-kernel)
('multiboot-arguments multiboot-arguments)
- ('multiboot-modules multiboot-modules) _ ...)
+ ('multiboot-modules multiboot-modules)
+ (or ('device-subvol subvol _ ...) (_ ...)))
(menu-entry
(label label)
(device (sexp->device device))
(device-mount-point mount-point)
+ (device-subvol subvol)
(multiboot-kernel multiboot-kernel)
(multiboot-arguments multiboot-arguments)
(multiboot-modules multiboot-modules)))
(('menu-entry ('version 0)
('label label) ('device device)
- ('device-mount-point mount-point)
- ('chain-loader chain-loader) _ ...)
+ ('device-mount-point mount-point) ('device-subvol subvol)
+ ('chain-loader chain-loader)
+ (or ('device-subvol subvol _ ...) (_ ...)))
(menu-entry
(label label)
(device (sexp->device device))
(device-mount-point mount-point)
+ (device-subvol subvol)
(chain-loader chain-loader)))))
@@ -247,15 +283,10 @@ (define (sexp->menu-entry sexp)
;; has to be described by this record.
(define-record-type* <bootloader>
- bootloader make-bootloader
- bootloader?
- (name bootloader-name)
- (package bootloader-package)
- (installer bootloader-installer)
- (disk-image-installer bootloader-disk-image-installer
- (default #f))
- (configuration-file bootloader-configuration-file)
- (configuration-file-generator bootloader-configuration-file-generator))
+ bootloader make-bootloader bootloader?
+ (name bootloader-name)
+ (default-targets bootloader-default-targets (default '()))
+ (installer bootloader-installer))
;;;
@@ -450,28 +481,48 @@ (define-syntax with-targets
;; The <bootloader-configuration> record contains bootloader independant
;; configuration used to fill bootloader configuration file.
-(define-with-syntax-properties (warn-target-field-deprecation
- (value properties))
- (when value
- (warning (source-properties->location properties)
- (G_ "the 'target' field is deprecated, please use 'targets' \
-instead~%")))
- value)
+(define-with-syntax-properties (warn-update-targets (value properties))
+ (let ((loc (source-properties->location properties)))
+ (define update
+ (match-lambda
+ ((? bootloader-target? target) (cons #f target))
+ ((? string? s) (cons #t (if (string-prefix? "/dev" s)
+ (bootloader-target
+ (type 'disk)
+ (device s))
+ (bootloader-target
+ (type 'esp)
+ (offset 'root)
+ (path s)))))
+ (x (error loc (G_ "invalid target '~a'~%") x))))
+
+ (let* ((updated (map update (if (list? value) value (list value))))
+ (targets (map cdr updated))
+ (types (map bootloader-target-type targets)))
+ ;; XXX: should this be an error?
+ (when (any car updated)
+ (warning loc (G_ "the 'targets' field should now contain \
+<bootloader-target> records. inferring a best guess (this might break!)...~%")))
+ (when (not (eqv? (length types) (length (delete-duplicates types))))
+ (error loc (G_ "the 'targets' field may not contain duplicates~%")))
+ targets)))
(define-record-type* <bootloader-configuration>
bootloader-configuration make-bootloader-configuration
bootloader-configuration?
(bootloader
- bootloader-configuration-bootloader) ;<bootloader>
- (targets %bootloader-configuration-targets
- (default #f)) ;list of strings
- (target %bootloader-configuration-target ;deprecated
- (default #f)
- (sanitize warn-target-field-deprecation))
+ bootloader-configuration-bootloader) ;<bootloader>
+ (targets bootloader-configuration-targets
+ (default '()) ;list of strings
+ (sanitize warn-update-targets))
(menu-entries bootloader-configuration-menu-entries
(default '())) ;list of <menu-entry>
(default-entry bootloader-configuration-default-entry
(default 0)) ;integer
+ (efi-removable? bootloader-configuration-efi-removable?
+ (default #f)) ;bool
+ (32bit? bootloader-configuration-32bit?
+ (default #f)) ;bool
(timeout bootloader-configuration-timeout
(default 5)) ;seconds as integer
(keyboard-layout bootloader-configuration-keyboard-layout
@@ -479,9 +530,9 @@ (define-record-type* <bootloader-configuration>
(theme bootloader-configuration-theme
(default #f)) ;bootloader-specific theme
(terminal-outputs bootloader-configuration-terminal-outputs
- (default '(gfxterm))) ;list of symbols
+ (default #f)) ;list of symbols | #f (default outs)
(terminal-inputs bootloader-configuration-terminal-inputs
- (default '())) ;list of symbols
+ (default #f)) ;list of symbols | #f (default ins)
(serial-unit bootloader-configuration-serial-unit
(default #f)) ;integer | #f
(serial-speed bootloader-configuration-serial-speed
@@ -491,164 +542,129 @@ (define-record-type* <bootloader-configuration>
(extra-initrd bootloader-configuration-extra-initrd
(default #f))) ;string | #f
-(define-deprecated (bootloader-configuration-target config)
- bootloader-configuration-targets
- (%bootloader-configuration-target config))
+
+;;;
+;;; Bootloader installation paths.
+;;;
-(define (bootloader-configuration-targets config)
- (or (%bootloader-configuration-targets config)
- ;; TODO: Remove after the deprecated 'target' field is removed.
- (list (%bootloader-configuration-target config))
- ;; XXX: At least the GRUB installer (see (gnu bootloader grub)) has this
- ;; peculiar behavior of installing fonts and GRUB modules when DEVICE is #f,
- ;; hence the default value of '(#f) rather than '().
- (list #f)))
+;; highest -> lowest priority
+(define (target-overrides . layers)
+ (let* ((types (fold append '()
+ (map (cute map bootloader-target-type <>) layers)))
+ (pred (lambda (type layer found)
+ (or found (get-target-of-type type layer))))
+ (find (lambda (type) (fold (cute pred type <> <>) #f layers))))
+ (filter ->bool (map find (delete-duplicates types)))))
+
+(define (normalize targets)
+ "Augments user-supplied targets with filesystem information at runtime,
+allowing users to specify a lot less information. Relatively minimal to prevent
+errors. Puts targets into a normal form, where all paths are fully specified up
+to a device offset."
+ (let* ((mass (lambda (m) `((,(mount-source m) . ,m) (,(mount-point m) . ,m))))
+ (amounts (delay (apply append (map mass (mounts)))))
+ (accessible=> (lambda (d f) (and d (access? d R_OK) (f d))))
+ (assoc-mnt (lambda (f) (lambda (v)
+ (and=> (assoc-ref (force amounts) v) f)))))
+
+ (define (scrape target)
+ (match-record target <bootloader-target>
+ (expected? path offset device label uuid file-system)
+ (if expected? target
+ (bootloader-target
+ (inherit target)
+ (device (or device (false-if-exception
+ (or (and=> uuid find-partition-by-uuid)
+ (and=> label find-partition-by-label)))
+ (and path ((assoc-mnt mount-source)
+ (unfold-pathcat target targets)))))
+ (label (or label (accessible=> device read-partition-label)))
+ (uuid (or uuid (accessible=> device read-partition-uuid)))
+ (file-system (or file-system (and=> device (assoc-mnt mount-type))))
+ (offset (and path offset))
+ (path (or path (and=> device (assoc-mnt mount-point))))))))
+
+ (define (arborify target targets)
+ (let* ((up (lambda (t) (and t (parent-of t targets))))
+ (proto (unfold target-base? identity up (up target) list))
+ (chain (reverse (cons target proto))))
+ (bootloader-target
+ (inherit target)
+ (offset (and=> (car chain) bootloader-target-type))
+ (path (reduce pathcat #f (map bootloader-target-path (cdr chain)))))))
+
+ (let ((mid (map scrape targets))) (map (cut arborify <> mid) mid))))
+
+(define* (bootloader-configuration->gexp bootloader-config args #:key
+ (root-offset "/") (overrides '()))
+ "Returns a gexp to install BOOTLOADER-CONFIG to its targets, passing ARGS
+to each installer alongside the additional #:bootloader-config keyword
+arguments. Target OVERRIDES are applied and all path targets have ROOT-OFFSET
+applied. The following keyword arguments are expected in ARGS:
+@enumerate
+@item current-boot-alternative
+@item old-boot-alternatives
+@item locale (from bootmeta)
+@item store-directory-prefix (from bootmeta)
+@item store-crypto-devices (from bootmeta)
+@end enumerate"
+ (let* ((bootloader (bootloader-configuration-bootloader bootloader-config))
+ (installer (bootloader-installer bootloader))
+ (auto-targets (list (bootloader-target
+ (type 'root)
+ (path root-offset)
+ (offset #f))))
+ (targets (target-overrides
+ overrides
+ (bootloader-configuration-targets bootloader-config)
+ auto-targets
+ (bootloader-default-targets bootloader)))
+ (conf (bootloader-configuration
+ (inherit bootloader-config)
+ (targets (normalize targets)))))
+ (apply installer #:bootloader-config conf args)))
+
+(define (bootloader-configurations->gexp bootloader-configs . rest)
+ (apply gbegin (filter-map (cut apply bootloader-configuration->gexp <> rest)
+ bootloader-configs)))
;;;
-;;; Bootloaders.
+;;; EFI shit
;;;
-(define (bootloader-modules)
- "Return the list of bootloader modules."
- ;; don't provide #:warn to prevent mutual imports
- (all-modules (map (lambda (entry)
- `(,entry . "gnu/bootloader"))
- %load-path)))
-
-(define %bootloaders
- ;; The list of publically-known bootloaders.
- (delay (fold-module-public-variables (lambda (obj result)
- (if (bootloader? obj)
- (cons obj result)
- result))
- '()
- (bootloader-modules))))
-
-(define (lookup-bootloader-by-name name)
- "Return the bootloader called NAME."
- (or (find (lambda (bootloader)
- (eq? name (bootloader-name bootloader)))
- (force %bootloaders))
- (leave (G_ "~a: no such bootloader~%") name)))
-
-(define (efi-bootloader-profile packages files hooks)
- "Creates a profile from the lists of PACKAGES and FILES from the store.
-This profile is meant to be used by the bootloader-installer.
-
-FILES is a list of file or directory names from the store, which will be
-symlinked into the profile. If a directory name ends with '/', then the
-directory content instead of the directory itself will be symlinked into the
-profile.
-
-FILES may contain file like objects produced by procedures like plain-file,
-local-file, etc., or package contents produced with file-append.
-
-HOOKS lists additional hook functions to modify the profile."
- (define* (efi-bootloader-profile-hook manifest #:optional system)
- (define build
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules ((guix build utils)
- #:select (mkdir-p strip-store-file-name))
- ((ice-9 ftw)
- #:select (scandir))
- ((srfi srfi-1)
- #:select (append-map every remove))
- ((srfi srfi-26)
- #:select (cut)))
- (define (symlink-to file directory transform)
- "Creates a symlink to FILE named (TRANSFORM FILE) in DIRECTORY."
- (symlink file (string-append directory "/" (transform file))))
- (define (directory-content directory)
- "Creates a list of absolute path names inside DIRECTORY."
- (map (lambda (name)
- (string-append directory name))
- (or (scandir directory (lambda (name)
- (not (member name '("." "..")))))
- '())))
- (define name-ends-with-/? (cut string-suffix? "/" <>))
- (define (name-is-store-entry? name)
- "Return #t if NAME is a direct store entry and nothing inside."
- (not (string-index (strip-store-file-name name) #\/)))
- (let* ((files '#$files)
- (directories (filter name-ends-with-/? files))
- (names-from-directories
- (append-map (lambda (directory)
- (directory-content directory))
- directories))
- (names (append names-from-directories
- (remove name-ends-with-/? files))))
- (mkdir-p #$output)
- (if (every file-exists? names)
- (begin
- (for-each (lambda (name)
- (symlink-to name #$output
- (if (name-is-store-entry? name)
- strip-store-file-name
- basename)))
- names)
- #t)
- #f)))))
-
- (gexp->derivation "efi-bootloader-profile"
- build
- #:system system
- #:local-build? #t
- #:substitutable? #f
- #:properties
- `((type . profile-hook)
- (hook . efi-bootloader-profile-hook))))
-
- (profile (content (packages->manifest packages))
- (name "efi-bootloader-profile")
- (hooks (cons efi-bootloader-profile-hook hooks))
- (locales? #f)
- (allow-collisions? #f)
- (relative-symlinks? #f)))
-
-(define* (efi-bootloader-chain final-bootloader
- #:key
- (packages '())
- (files '())
- (hooks '())
- installer
- disk-image-installer)
- "Define a chain of bootloaders with the FINAL-BOOTLOADER, optional PACKAGES,
-and optional directories and files from the store given in the list of FILES.
-
-The package of the FINAL-BOOTLOADER and all PACKAGES and FILES will be placed
-in an efi-bootloader-profile, which will be passed to the INSTALLER.
-
-FILES may contain file-like objects produced by procedures like plain-file,
-local-file, etc., or package contents produced with file-append.
-
-If a directory name in FILES ends with '/', then the directory content instead
-of the directory itself will be symlinked into the efi-bootloader-profile.
-
-The procedures in the HOOKS list can be used to further modify the bootloader
-profile. It is possible to pass a single function instead of a list.
-
-If the INSTALLER argument is used, then this gexp procedure will be called to
-install the efi-bootloader-profile. Otherwise the installer of the
-FINAL-BOOTLOADER will be called.
-
-If the DISK-IMAGE-INSTALLER is used, then this gexp procedure will be called
-to install the efi-bootloader-profile into a disk image. Otherwise the
-disk-image-installer of the FINAL-BOOTLOADER will be called."
- (bootloader
- (inherit final-bootloader)
- (name "efi-bootloader-chain")
- (package
- (efi-bootloader-profile (cons (bootloader-package final-bootloader)
- packages)
- files
- (if (list? hooks)
- hooks
- (list hooks))))
- (installer
- (or installer
- (bootloader-installer final-bootloader)))
- (disk-image-installer
- (or disk-image-installer
- (bootloader-disk-image-installer final-bootloader)))))
+(define* (efi-arch #:key (target (or (%current-target-system) (%current-system)))
+ (32? #f))
+ "Returns the UEFI architecture name for the current target, in lowercase."
+ (cond ((target-x86-32? target) "ia32")
+ ((target-x86-64? target) (if 32? "ia32" "x64"))
+ ((target-arm32? target) "arm")
+ ((target-aarch64? target) (if 32? "arm" "aa64"))
+ ((target-riscv64? target) (if 32? "riscv32" "riscv64"))
+ (else (raise (formatted-message (G_ "no UEFI standard arch for ~a!")
+ target)))))
+
+(define (install-efi bootloader-config plan)
+ "Returns a gexp installing PLAN to the ESP, as denoted by the 'vendir target.
+PLAN is a gexp of a list of '(BUILDER DEST-BASENAME . LABEL) triples, that
+should be in boot order. If the user selects a removable bootloader, only the
+first entry in PLAN is used."
+ (match-record bootloader-config <bootloader-configuration>
+ (targets efi-removable? 32bit?)
+ (if efi-removable?
+ ;; 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
+ (with-targets targets
+ (('esp => (path :path))
+ #~(let ((boot #$(string-append path "/EFI/BOOT"))
+ (arch #$(string-upcase (efi-arch #:32? 32bit?)))
+ (builder (car (car #$plan))))
+ (mkdir-p boot)
+ ;; only realize first planspec
+ (builder (string-append boot "/BOOT" arch ".EFI")))))
+ ;; normal install when not doing a removable config
+ (with-targets targets
+ (('vendir => (vendir :path) (loader :devpath) (disk :device))
+ #~(install-efi #+(file-append efibootmgr "/sbin/efibootmgr")
+ #$vendir #$loader #$disk #$plan))))))
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Timothy Sample <samplet@ngyro.com>
+;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -17,92 +18,86 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu bootloader depthcharge)
- #:use-module (gnu bootloader extlinux)
#:use-module (gnu bootloader)
#:use-module (gnu packages bootloaders)
+ #:use-module (gnu system boot)
#:use-module (guix gexp)
+ #:use-module (guix deprecation)
+ #:use-module (guix diagnostics)
+ #:use-module (guix i18n)
+ #:use-module (guix records)
#:use-module (guix utils)
- #:use-module (ice-9 match)
- #:export (depthcharge-bootloader))
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-35)
+ #:export (depthcharge-veyron-speedy-bootloader
+ depthcharge-bootloader))
-(define (signed-kernel kernel kernel-arguments initrd)
- (define builder
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils)
- (ice-9 binary-ports)
- (rnrs bytevectors))
- (set-path-environment-variable "PATH" '("bin") (list #$dtc))
+(define* (install-depthcharge arch dtb
+ #:key bootloader-config current-boot-alternative
+ #:allow-other-keys)
+ (when (not (null? (bootloader-configuration-menu-entries bootloader-config)))
+ (raise (formatted-message
+ (G_ "extra menu-entries are not supported for depthcharge!"))))
+ (with-targets (bootloader-configuration-targets bootloader-config)
+ ;; use 'part instead of 'disk, cause we write an image directly into a
+ ;; partition instead of the extra-partition disk space
+ (('part => (disk :device))
+ (match-record (boot-alternative->menu-entry current-boot-alternative)
+ <menu-entry> (linux linux-arguments initrd)
+ #~(begin
+ (use-modules (ice-9 binary-ports) (rnrs bytevectors))
+ (set-path-environment-variable "PATH" '("bin") (list #$dtc))
- ;; TODO: These files have to be writable, so we copy them.
- ;; This can probably be fixed by using a ".its" file, just
- ;; be careful not to break initrd loading.
- (copy-file #$kernel "zImage")
- (chmod "zImage" #o755)
- (copy-file (string-append (dirname #$kernel) "/lib/dtbs/"
- "rk3288-veyron-speedy.dtb")
- "rk3288-veyron-speedy.dtb")
- (chmod "rk3288-veyron-speedy.dtb" #o644)
- (copy-file #$initrd "initrd")
- (chmod "initrd" #o644)
+ ;; TODO: These files have to be writable, so we copy them.
+ ;; This can probably be fixed by using a ".its" file, just
+ ;; be careful not to break initrd loading.
+ (copy-file #$linux "zImage")
+ (chmod "zImage" #o755)
+ (copy-file (string-append (dirname #$linux) "/lib/dtbs/" #$dtb)
+ "dtb")
+ (chmod "dtb" #o644)
+ (copy-file #$initrd "initrd")
+ (chmod "initrd" #o644)
- (invoke (string-append #$u-boot-tools "/bin/mkimage")
- "-D" "-I dts -O dtb -p 2048"
- "-f" "auto"
- "-A" "arm"
- "-O" "linux"
- "-T" "kernel"
- "-C" "None"
- "-d" "zImage"
- "-a" "0"
- "-b" "rk3288-veyron-speedy.dtb"
- "-i" "initrd"
- "image.itb")
- (call-with-output-file "bootloader.bin"
- (lambda (port)
- (put-bytevector port (make-bytevector 512 0))))
- (with-output-to-file "kernel-arguments"
- (lambda ()
- (display (string-join (list #$@kernel-arguments)))))
- (invoke (string-append #$vboot-utils "/bin/vbutil_kernel")
- "--pack" #$output
- "--version" "1"
- "--vmlinuz" "image.itb"
- "--arch" "arm"
- "--keyblock" (string-append #$vboot-utils
- "/share/vboot-utils/devkeys/"
- "kernel.keyblock")
- "--signprivate" (string-append #$vboot-utils
- "/share/vboot-utils/devkeys/"
- "kernel_data_key.vbprivk")
- "--config" "kernel-arguments"
- "--bootloader" "bootloader.bin"))))
- (computed-file "vmlinux.kpart" builder))
+ (invoke #+(file-append u-boot-tools "/bin/mkimage")
+ "-D" "-I dts -O dtb -p 2048"
+ "-f" "auto" ; format
+ "-A" #$arch ; architecture
+ "-O" "linux" ; os
+ "-T" "kernel" ; image type
+ "-C" "None" ; compression
+ "-d" "zImage" ; image data
+ "-a" "0" ; load address (hex)
+ "-b" "dtb" ; dtb for device
+ "-i" "initrd" ; initrd
+ "image.itb")
+ (call-with-output-file "bootloader.bin"
+ (lambda (port)
+ (put-bytevector port (make-bytevector 512 0))))
+ (call-with-output-file "kernel-arguments"
+ (lambda (port)
+ (display (string-join (list #$@linux-arguments)) port)))
+ (invoke #+(file-append vboot-utils "/bin/vbutil_kernel")
+ "--version" "1"
+ "--vmlinuz" "image.itb"
+ "--arch" #$arch
+ "--keyblock"
+ #$(file-append vboot-utils
+ "/share/vboot-utils/devkeys/kernel.keyblock")
+ "--signprivate"
+ #$(file-append vboot-utils
+ "/share/vboot-utils/devkeys/kernel_data_key.vbprivk")
+ "--config" "kernel-arguments"
+ "--pack" "vmlinux.kpart")
+ (write-file-on-device "vmlinux.kpart"
+ (stat:size (stat "vmlinux.kpart"))
+ #$disk 0))))))
-(define* (depthcharge-configuration-file config entries
- #:key
- (system (%current-system))
- (old-entries '())
- #:allow-other-keys)
- (match entries
- ((entry)
- (let ((kernel (menu-entry-linux entry))
- (kernel-arguments (menu-entry-linux-arguments entry))
- (initrd (menu-entry-initrd entry)))
- ;; XXX: Make this a symlink.
- (signed-kernel kernel kernel-arguments initrd)))
- (_ (error "Too many bootloader menu entries!"))))
-
-(define install-depthcharge
- #~(lambda (bootloader device mount-point)
- (let ((kpart (string-append mount-point
- "/boot/depthcharge/vmlinux.kpart")))
- (write-file-on-device kpart (stat:size (stat kpart)) device 0))))
-
-(define depthcharge-bootloader
+(define depthcharge-veyron-speedy-bootloader
(bootloader
(name 'depthcharge)
- (package #f)
- (installer install-depthcharge)
- (configuration-file "/boot/depthcharge/vmlinux.kpart")
- (configuration-file-generator depthcharge-configuration-file)))
+ (installer (cute install-depthcharge "arm" "rk3288-veyron-speedy.dtb"
+ <...>))))
+
+(define-deprecated/alias depthcharge-bootloader
+ depthcharge-veyron-speedy-bootloader)
@@ -2,6 +2,7 @@
;;; Copyright © 2017 David Craven <david@craven.ch>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2022 Reza Alizadeh Majd <r.majd@pantherx.org>
+;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -21,112 +22,102 @@
(define-module (gnu bootloader extlinux)
#:use-module (gnu bootloader)
#:use-module (gnu packages bootloaders)
+ #:use-module (gnu system boot)
#:use-module (guix gexp)
+ #:use-module (guix deprecation)
+ #:use-module (guix records)
#:use-module (guix utils)
- #:export (extlinux-bootloader
+ #:export (install-extlinux-config ; for u-boot
+ extlinux-bootloader
+ extlinux-gpt-bootloader
extlinux-bootloader-gpt))
-(define* (extlinux-configuration-file config entries
- #:key
- (system (%current-system))
- (old-entries '())
- #:allow-other-keys)
- "Return the U-Boot configuration file corresponding to CONFIG, a
-<u-boot-configuration> object, and where the store is available at STORE-FS, a
-<file-system> object. OLD-ENTRIES is taken to be a list of menu entries
-corresponding to old generations of the system."
-
- (define all-entries
- (append entries (bootloader-configuration-menu-entries config)))
-
- (define with-fdtdir?
- (bootloader-configuration-device-tree-support? config))
+
+;;;
+;;; Config procedures.
+;;;
- (define (menu-entry->gexp entry)
- (let ((label (menu-entry-label entry))
- (kernel (menu-entry-linux entry))
- (kernel-arguments (menu-entry-linux-arguments entry))
- (initrd (menu-entry-initrd entry)))
- #~(format port "LABEL ~a
+(define* (install-extlinux-config #:key bootloader-config
+ current-boot-alternative
+ old-boot-alternatives
+ #:allow-other-keys)
+ "Installer for the extlinux configuration file, meant to be shared by all
+bootloaders that use the format to specify boot options."
+ (match-record bootloader-config <bootloader-configuration>
+ (targets menu-entries device-tree-support? timeout)
+ (define (menu-entry->gexp entry)
+ (match-record entry <menu-entry> (label linux linux-arguments initrd)
+ (let* ((normkern (normalize-file entry linux))
+ (fdt #~(string-append "FDTDIR" (dirname #$normkern) "/lib/dtbs")))
+ #~(format port "LABEL ~a
MENU LABEL ~a
KERNEL ~a
~a
INITRD ~a
APPEND ~a
-~%"
- #$label #$label
- #$kernel
- (if #$with-fdtdir?
- (string-append "FDTDIR " (dirname #$kernel) "/lib/dtbs")
- "")
- #$initrd
- (string-join (list #$@kernel-arguments)))))
-
- (define builder
- #~(call-with-output-file #$output
- (lambda (port)
- (let ((timeout #$(bootloader-configuration-timeout config)))
- (format port "# This file was generated from your Guix configuration. Any changes
+~%" #$label #$label #$normkern
+ #$(if device-tree-support? fdt "")
+ #$(normalize-file entry initrd)
+ (string-join (list #$@linux-arguments))))))
+
+ (let ((ents (cons (boot-alternative->menu-entry current-boot-alternative)
+ (append menu-entries
+ (map boot-alternative->menu-entry old-boot-alternatives)))))
+ (with-targets targets
+ (('extlinux => (path :path))
+ #~(begin (mkdir-p #$path)
+ (call-with-output-file #$path
+ (lambda (port)
+ (format port "\
+# This file was generated from your Guix configuration. Any changes
# will be lost upon reconfiguration.
UI menu.c32
MENU TITLE GNU Guix Boot Options
PROMPT ~a
-TIMEOUT ~a~%"
- (if (> timeout 0) 1 0)
- ;; timeout is expressed in 1/10s of seconds.
- (* 10 timeout))
- #$@(map menu-entry->gexp all-entries)
-
- #$@(if (pair? old-entries)
- #~((format port "~%")
- #$@(map menu-entry->gexp old-entries)
- (format port "~%"))
- #~())))))
-
- (computed-file "extlinux.conf" builder
- #:options '(#:local-build? #t
- #:substitutable? #f)))
-
+TIMEOUT ~a~%" ;; timeout is expressed in tenths of a second
+ #$(if (> timeout 0) 1 0) #$(* 10 timeout))
+ #$@(map menu-entry->gexp ents)))))))))
-
;;;
-;;; Install procedures.
+;;; Install procedure.
;;;
(define (install-extlinux mbr)
- #~(lambda (bootloader device mount-point)
- (let ((extlinux (string-append bootloader "/sbin/extlinux"))
- (install-dir (string-append mount-point "/boot/extlinux"))
- (syslinux-dir (string-append bootloader "/share/syslinux")))
- (for-each (lambda (file)
- (install-file file install-dir))
- (find-files syslinux-dir "\\.c32$"))
- (invoke/quiet extlinux "--install" install-dir)
- (write-file-on-device (string-append syslinux-dir "/" #$mbr)
- 440 device 0))))
-
-(define install-extlinux-mbr
- (install-extlinux "mbr.bin"))
+ (lambda* (#:key bootloader-config #:allow-other-keys . args)
+ (with-targets (bootloader-configuration-targets bootloader-config)
+ (('extlinux => (path :path))
+ #~(begin
+ #$(apply install-extlinux-config args)
+ (copy-recursively #$(file-append syslinux "/share/syslinux") #$path)
+ (invoke/quiet #+(file-append syslinux "/sbin/extlinux")
+ "--install" #$path)))
+ (('disk => (disk :device))
+ #~(write-file-on-device #$(file-append syslinux "/share/syslinux/" mbr)
+ 440 #$disk 0)))))
-(define install-extlinux-gpt
- (install-extlinux "gptmbr.bin"))
-
;;;
;;; Bootloader definitions.
;;;
(define extlinux-bootloader
(bootloader
- (name 'extlinux)
- (package syslinux)
- (installer install-extlinux-mbr)
- (configuration-file "/boot/extlinux/extlinux.conf")
- (configuration-file-generator extlinux-configuration-file)))
-
-(define extlinux-bootloader-gpt
+ (name 'extlinux)
+ (default-targets (list (bootloader-target
+ (type 'install)
+ (offset 'root)
+ (path "boot"))
+ (bootloader-target
+ (type 'extlinux)
+ (offset 'install)
+ (path "extlinux"))))
+ (installer (install-extlinux "mbr.bin"))))
+
+(define extlinux-gpt-bootloader
(bootloader
- (inherit extlinux-bootloader)
- (installer install-extlinux-gpt)))
+ (inherit extlinux-bootloader)
+ (installer (install-extlinux "gptmbr.bin"))))
+
+(define-deprecated/alias extlinux-bootloader-gpt extlinux-gpt-bootloader)
@@ -10,6 +10,7 @@
;;; Copyright © 2022 Karl Hallsby <karl@hallsby.com>
;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz>
+;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -27,24 +28,26 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu bootloader grub)
- #:use-module (guix build union)
- #:use-module (guix records)
- #:use-module (guix store)
- #:use-module (guix utils)
- #:use-module (guix gexp)
#:use-module (gnu artwork)
#:use-module (gnu bootloader)
- #:use-module (gnu system uuid)
- #:use-module (gnu system file-systems)
- #:use-module (gnu system keyboard)
- #:use-module (gnu system locale)
#:use-module (gnu packages bootloaders)
#:autoload (gnu packages gtk) (guile-cairo guile-rsvg)
#:autoload (gnu packages xorg) (xkeyboard-config)
+ #:use-module (gnu system boot)
+ #:use-module (gnu system file-systems)
+ #:use-module (gnu system keyboard)
+ #:use-module (gnu system locale)
+ #:use-module (gnu system uuid)
+ #:use-module (guix deprecation)
+ #:use-module (guix diagnostics)
+ #:use-module (guix gexp)
+ #:use-module (guix i18n)
+ #:use-module (guix records)
+ #:use-module (guix utils)
#:use-module (ice-9 match)
- #:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-2)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-35)
#:export (grub-theme
grub-theme?
grub-theme-image
@@ -53,54 +56,109 @@ (define-module (gnu bootloader grub)
grub-theme-color-highlight
grub-theme-gfxmode
- install-grub-efi-removable
- make-grub-efi-netboot-installer
-
+ grub.dir ; for (gnu build image) iso9660 images
grub-bootloader
+ grub-minimal-bootloader
grub-efi-bootloader
+ ;; deprecated
grub-efi-removable-bootloader
grub-efi32-bootloader
grub-efi-netboot-bootloader
- grub-efi-netboot-removable-bootloader
- grub-mkrescue-bootloader
- grub-minimal-bootloader
+ grub-efi-netboot-removable-bootloader))
- grub-configuration))
-
-;;; Commentary:
+
;;;
-;;; Configuration of GNU GRUB.
+;;; General utils.
;;;
-;;; Code:
-(define* (normalize-file file mount-point store-directory-prefix)
- "Strip MOUNT-POINT and prepend STORE-DIRECTORY-PREFIX, if any, to FILE, a
-G-expression or other lowerable object denoting a file name."
+;; in-gexp procedure to sanitize a value to be inserted into a GRUB script
+(define (sanitize str)
+ "Sanitize a value for use in a GRUB script."
+ #~(let* ((glycerin (lambda (l r) (if (pair? l) (append l r) (cons l r))))
+ (isopropyl (lambda (c) (case c ((#\\ #\$ #\") '(#\\ ,c)) (else c)))))
+ (use-modules (srfi srfi-1))
+ (list->string (fold-right glycerin '()
+ (map isopropyl (string->list #$str))))))
- (define (strip-mount-point mount-point file)
- (if mount-point
- (if (string=? mount-point "/")
- file
- #~(let ((file #$file))
- (if (string-prefix? #$mount-point file)
- (substring #$file #$(string-length mount-point))
- file)))
- file))
- (define (prepend-store-directory-prefix store-directory-prefix file)
- (if store-directory-prefix
- #~(string-append #$store-directory-prefix #$file)
- file))
- (prepend-store-directory-prefix store-directory-prefix
- (strip-mount-point mount-point file)))
+(define (grub-format type 32?)
+ (string-append
+ (cond ((string-prefix? "pc" type) "i386")
+ ((target-x86-32?) "i386")
+ ((target-x86-64?) (if 32? "i386" "x86_64"))
+ ((target-arm32?) "arm")
+ ((target-aarch64?) (if 32? "arm" "arm64"))
+ ((target-powerpc?) "powerpc")
+ ((target-riscv64?) "riscv64")
+ (else (raise (formatted-message (G_ "unrecognized target arch '~a'!")
+ (or (%current-target-system) (%current-system))))))
+ "-" type))
+(define* (search/target type targets var #:optional (port #f))
+ "Returns a gexp of a GRUB search command for target TYPE, storing the result
+in VAR. Optionally outputs to the gexp PORT instead of returning a string."
+ (define (form name val)
+ #~(format #$port "search.~a \"~a\" ~a~%" #$name #$val #$var))
+ (with-targets targets
+ ((type => (path :devpath) (device :device) (fs :fs)
+ (label :label) (uuid :uuid))
+ (cond ((member fs '("tftp" "nfs")) #~(format #$port "set ~a=tftp~%" #$var))
+ (uuid (form "fs_uuid" (uuid->string uuid)))
+ (label (form "fs_label" label))
+ (else (form "file" (sanitize path)))))))
+
+
+
+(define* (search/menu-entry device file var #:optional (port #f))
+ "Return the GRUB 'search' command to look for DEVICE, which contains FILE,
+a gexp. The result is a gexp that can be inserted in the grub.cfg-generation
+code to set the variable VAR. This procedure is able to handle DEVICEs
+unmounted at evaltime."
+ (match device
+ ;; Preferably refer to DEVICE by its UUID or label. This is more
+ ;; efficient and less ambiguous, see <http://bugs.gnu.org/22281>.
+ ((? uuid? idfk) ; calling idfk uuid here errors for some reason
+ #~(format #$port "search.fs_uuid ~a ~a~%" #$(uuid->string device) #$var))
+ ((? file-system-label? label)
+ #~(format #$port "search.fs_label \"~a\" ~a~%"
+ #$(sanitize (file-system-label->string label)) #$var))
+ ((? (lambda (device)
+ (and (string? device) (string-contains device ":/"))) nfs-uri)
+ ;; If the device is an NFS share, then we assume that the expected
+ ;; file on that device (e.g. the GRUB background image or the kernel)
+ ;; has to be loaded over the network. Otherwise we would need an
+ ;; additional device information for some local disk to look for that
+ ;; file, which we do not have.
+ ;;
+ ;; TFTP is preferred to HTTP because it is used more widely and
+ ;; specified in standards more widely--especially BOOTP/DHCPv4
+ ;; defines a TFTP server for DHCP option 66, but not HTTP.
+ ;;
+ ;; Note: DHCPv6 specifies option 59 to contain a boot-file-url,
+ ;; which can contain a HTTP or TFTP URL.
+ ;;
+ ;; Note: It is assumed that the file paths are of a similar
+ ;; setup on both the TFTP server and the NFS server (it is
+ ;; not possible to search for files on TFTP).
+ ;;
+ ;; TODO: Allow HTTP.
+ #~(format #$port "set ~a=tftp~%" #$var))
+ ((or #f (? string?))
+ #~(format #$port "search.file \"~a\" ~a~%" #$(sanitize file) #$var))))
+
+
+
+
+;;;
+;;; Theming.
+;;;
+
(define-record-type* <grub-theme>
;; Default theme contributed by Felipe López.
- grub-theme make-grub-theme
- grub-theme?
+ grub-theme make-grub-theme grub-theme?
(image grub-theme-image
(default (file-append %artwork-repository
"/grub/GuixSD-fully-black-4-3.svg")))
@@ -113,128 +171,274 @@ (define-record-type* <grub-theme>
(gfxmode grub-theme-gfxmode
(default '("auto")))) ;list of string
+(define (grub-theme-png theme)
+ "Return the GRUB background image defined in THEME. If the suffix of the
+image file is \".svg\", then it is converted into a PNG file with the
+resolution provided in CONFIG. Returns #f if no file is provided."
+ (match-record theme <grub-theme> (image resolution)
+ (match resolution
+ (((? number? width) . (? number? height))
+ (computed-file "grub-image.png"
+ (with-imported-modules '((gnu build svg) (guix build utils))
+ (with-extensions (list guile-rsvg guile-cairo)
+ #~(begin (use-modules (gnu build svg) (guix build utils))
+ (if (png-file? #$image) (copy-file #$image #$output)
+ (svg->png #$image #$output
+ #:width #$width
+ #:height #$height)))))))
+ (_ image))))
+
+
+
;;;
-;;; Background image & themes.
+;;; Core config.
+;;; GRUB architecture works by having a bootstage load up a core.img, which then
+;;; sets the root and prefix variables, allowing grub to load its main config
+;;; and modules, and then enter normal mode. On i386-pc systems a boot.img is
+;;; flashed which loads the core.img from the MBR gap, but on efi systems the
+;;; core.img is just a PE executable, able to be booted directly. We set up a
+;;; minimal core.img capable of finding the user-configured 'install target to
+;;; load its config from there.
;;;
-(define (bootloader-theme config)
- "Return user defined theme in CONFIG if defined or a default theme
-otherwise."
- (or (bootloader-configuration-theme config) (grub-theme)))
-
-(define* (image->png image #:key width height)
- "Build a PNG of HEIGHT x WIDTH from IMAGE if its file suffix is \".svg\".
-Otherwise the picture in IMAGE is just copied."
- (computed-file "grub-image.png"
- (with-imported-modules '((gnu build svg))
- (with-extensions (list guile-rsvg guile-cairo)
- #~(if (string-suffix? ".svg" #+image)
- (begin
- (use-modules (gnu build svg))
- (svg->png #+image #$output
- #:width #$width
- #:height #$height))
- (copy-file #+image #$output))))))
-
-(define* (grub-background-image config)
- "Return the GRUB background image defined in CONFIG or #f if none was found.
-If the suffix of the image file is \".svg\", then it is converted into a PNG
-file with the resolution provided in CONFIG."
- (let* ((theme (bootloader-theme config))
- (image (grub-theme-image theme)))
- (and image
- (match (grub-theme-resolution theme)
- (((? number? width) . (? number? height))
- (image->png image #:width width #:height height))
- (_ #f)))))
-
-(define (grub-locale-directory grub)
- "Generate a directory with the locales from GRUB."
- (define builder
- #~(begin
- (use-modules (ice-9 ftw))
- (let ((locale (string-append #$grub "/share/locale"))
- (out #$output))
- (mkdir out)
- (chdir out)
- (for-each (lambda (lang)
- (let ((file (string-append locale "/" lang
- "/LC_MESSAGES/grub.mo"))
- (dest (string-append lang ".mo")))
- (when (file-exists? file)
- (copy-file file dest))))
- (scandir locale)))))
- (computed-file "grub-locales" builder))
-
-(define* (eye-candy config store-device store-mount-point
- #:key store-directory-prefix port)
- "Return a gexp that writes to PORT (a port-valued gexp) the 'grub.cfg' part
-concerned with graphics mode, background images, colors, and all that.
-STORE-DEVICE designates the device holding the store, and STORE-MOUNT-POINT is
-its mount point; these are used to determine where the background image and
-fonts must be searched for. STORE-DIRECTORY-PREFIX is a directory prefix to
-prepend to any store file name."
- (define (setup-gfxterm config)
- (if (memq 'gfxterm (bootloader-configuration-terminal-outputs config))
- #~(format #f "
+(define (core.cfg targets store-crypto-devices)
+ "Returns a filelike object for a core configuration file good enough to
+decrypt STORE-CRYPTO-DEVICES and boot to normal."
+ (define (crypto-device->cryptomount dev)
+ (and (uuid? dev) ; ignore non-uuids - warning given by os
+ #~(format port "cryptomount -u ~a~%"
+ ;; cryptomount only accepts UUID without the hyphen.
+ #$(string-delete #\- (uuid->string dev)))))
+
+ (and=>
+ (with-targets targets
+ (('install => (path :devpath))
+ #~(call-with-output-file #$output
+ (lambda (port)
+ #$@(filter ->bool
+ (map crypto-device->cryptomount store-crypto-devices))
+ #$(search/target 'install targets "root" #~port)
+ (format port "set \"prefix=($root)~a\"~%" #$(sanitize path))))))
+ (cut computed-file "core.cfg" <>)))
+
+
+
+;; TODO: do we need LVM support here?
+(define* (core.img grub format #:key bootloader-config store-crypto-devices
+ #:allow-other-keys)
+ "The core image for GRUB, built for FORMAT."
+ (let* ((targets (bootloader-configuration-targets bootloader-config))
+ (bios? (string-prefix? format "pc"))
+ (efi? (string=? format "efi"))
+ (32? (bootloader-configuration-32bit? bootloader-config))
+ (cfg (core.cfg targets store-crypto-devices)))
+ (and cfg
+ (and=>
+ (with-targets targets
+ (('install => (fs :fs))
+ (let ((tftp? (or (string=? fs "tftp") (string=? fs "nfs"))))
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils) (ice-9 textual-ports)
+ (srfi srfi-1))
+ (apply invoke #$(file-append grub "/bin/grub-mkimage")
+ "--output" #$output
+ "--config" #$cfg
+ "--prefix" "none" ; we override this in cfg
+ ;; bios pxe uses pxeboot instead of diskboot - diff format
+ "--format" #$(string-append (grub-format format 32?)
+ (if (and bios? tftp?) "-pxe" ""))
+ "--compression" "auto"
+ ;; modules
+ "minicmd"
+ (append
+ ;; disk drivers
+ '#$(if bios? '("biosdisk") '())
+ ;; partmaps (TODO: detect which to use?)
+ '#$(if tftp? '() '("part_msdos" "part_gpt"))
+ ;; file systems
+ '#$(cond ((member fs '("ext2" "ext3" "ext4")) '("ext2"))
+ ((member fs "vfat" "fat32") "fat")
+ ((and tftp? efi?) "efinet")
+ ((and tftp? bios?) "pxe")
+ (else (list fs)))
+ ;; store crypto devs
+ '#$(if (any uuid? store-crypto-devices)
+ '("luks" "luks2" "cryptomount") '())
+ ;; search module that cfg uses
+ (call-with-input-file #$cfg
+ (lambda (port)
+ (let* ((str (get-string-all port))
+ (use (lambda (s) (string-contains str s))))
+ (cond ((use "search.fs_uuid") '("search_fs_uuid"))
+ ((use "search.fs_label") '("search_label"))
+ ((use "search.file") '("search_fs_file"))
+ (else '()))))))))))))
+ (cut computed-file "core.img" <>
+ #:options '(#:local-build? #t #:substitutable? #f))))))
+
+
+
+
+;;;
+;;; Main config.
+;;; This is what does the heavy lifting after core.img finds it.
+;;;
+
+(define (menu-entry->gexp store extra-initrd port)
+ (lambda (entry)
+ (match-record entry <menu-entry>
+ (label device linux linux-arguments initrd
+ multiboot-kernel multiboot-arguments multiboot-modules chain-loader)
+ (let ((norm (compose sanitize (cut normalize-file entry <>))))
+ #~(begin
+ (format #$port "menuentry ~s {~% " #$label)
+ #$(search/menu-entry
+ device (or linux multiboot-kernel chain-loader) "boot" port)
+ #$@(cond
+ (linux
+ (list #~(format #$port " linux \"($boot)~a\" ~a~%"
+ #$(norm linux)
+ ;; grub passes rest of the line _verbatim_
+ (string-join (list #$@linux-arguments)))
+ #~(format #$port " initrd ~a \"($boot)~a\"~%"
+ (if #$extra-initrd (string-append "($boot)\""
+ (norm #$extra-initrd) "\"")
+ "")
+ #$(norm initrd))))
+ ;; previously, this provided a (wrong) root= argument. just
+ ;; don't bother anymore. better less info than wrong info
+ (multiboot-kernel
+ (cons #~(format #$port " multiboot \"($boot)~a\" ~a~%"
+ #$(norm multiboot-kernel)
+ (string-join (list #$@multiboot-arguments)))
+ (map (lambda (mod) #~(format port " module \"($boot)~a\"~%"
+ #$(norm mod)))
+ multiboot-modules)))
+ (chain-loader
+ (list #~(format #$port " chainloader \"~a\"~%"
+ #$(norm chain-loader)))))
+ (format #$port "}~%"))))))
+
+
+
+(define* (grub.cfg #:key bootloader-config
+ current-boot-alternative
+ old-boot-alternatives
+ locale
+ store-directory-prefix
+ #:allow-other-keys)
+ "Returns a valid grub config given installer inputs. Expects locales, keymap,
+and theme image at LOCALES-TARG, KEYMAP-TARG, and IMAGE-TARG, respectively."
+ (match-record bootloader-config <bootloader-configuration>
+ ;; can't match keyboard-layout here cause it's bound to its struct
+ (targets menu-entries default-entry timeout extra-initrd
+ theme terminal-outputs terminal-inputs serial-unit serial-speed)
+ (let* ((entry->gexp (menu-entry->gexp store-directory-prefix
+ extra-initrd #~port))
+ (terms->str (compose string-join (cut map symbol->string <>)))
+ (colors->str (lambda (c) (format #f "~a/~a" (assoc-ref c 'fg)
+ (assoc-ref c 'bg))))
+ (outputs (or terminal-outputs '(gfxterm))) ; set default outs
+ (inputs (or terminal-inputs '())) ; set default ins
+ (theme (or theme (grub-theme))))
+ (and=>
+ (with-targets targets
+ (('install => (install :devpath))
+ #~(call-with-output-file #$output
+ (lambda (port)
+ ;; preamble
+ (format port "\
+# This file was generated from your Guix configuration. Any changes
+# will be lost upon reconfiguration~%")
+ #$@(filter ->bool
+ (list
+ ;; menu settings
+ (and default-entry
+ #~(format port "set default=~a~%" #$default-entry))
+ (and timeout
+ #~(format port "set timeout=~a~%" #$timeout))
+ ;; gfxterm setup
+ (and (memq 'gfxterm outputs)
+ #~(format port "\
if loadfont unicode; then
set gfxmode=~a
insmod all_video
insmod gfxterm
-fi~%"
- #$(string-join
- (grub-theme-gfxmode (bootloader-theme config))
- ";"))
- ""))
-
- (define (theme-colors type)
- (let* ((theme (bootloader-theme config))
- (colors (type theme)))
- (string-append (symbol->string (assoc-ref colors 'fg)) "/"
- (symbol->string (assoc-ref colors 'bg)))))
-
- (define image
- (normalize-file (grub-background-image config)
- store-mount-point
- store-directory-prefix))
-
- (and image
- #~(format #$port "
-# Set 'root' to the partition that contains /gnu/store.
-~a
-
-~a
-~a
-
+fi~%" #$(string-join (grub-theme-gfxmode theme) ";")))
+ ;; io
+ (and (or serial-unit serial-speed)
+ #~(format port "serial --unit=~a --speed=~a~%"
+ ;; documented defaults are unit 0 at 9600 baud.
+ #$(number->string (or serial-unit 0))
+ #$(number->string (or serial-speed 9600))))
+ (and (pair? outputs)
+ #~(format port "terminal_output ~a~%"
+ #$(terms->str outputs)))
+ (and (pair? inputs)
+ #~(format port "terminal_input ~a~%"
+ #$(terms->str inputs)))
+ ;; locale
+ (and locale
+ #~(format port "\
+set \"locale_dir=($root)~a/locales\"
+set lang=~a~%" #$(sanitize install)
+ #$(locale-definition-source
+ (locale-name->definition locale))))
+ ;; keyboard layout
+ (and (bootloader-configuration-keyboard-layout
+ bootloader-config)
+ #~(format port "\
+insmod keylayouts
+keymap \"($root)~a/keymap~%\"" #$(sanitize install)))
+ ;; theme
+ (match-record theme <grub-theme>
+ (image color-normal color-highlight)
+ (and image
+ #~(format port "\
insmod png
-if background_image ~a; then
+if background_image \"($root)~a/image.png\"; then
set color_normal=~a
set color_highlight=~a
else
set menu_color_normal=cyan/blue
- set menu_color_highlight=white/blue
-fi~%"
- #$(grub-root-search store-device image)
- #$(setup-gfxterm config)
- #$(grub-setup-io config)
+ set menu_color_highlight=whiute/blue
+fi~%" #$(sanitize install)
+ #$(colors->str color-normal)
+ #$(colors->str color-highlight))))))
+ ;; menu entries
+ #$(entry->gexp
+ (boot-alternative->menu-entry current-boot-alternative))
+ #$@(map entry->gexp menu-entries)
+ #$@(if (pair? old-boot-alternatives)
+ (append (list #~(format port "submenu ~s {~%"
+ "GNU system, old configurations..."))
+ (map (compose entry->gexp
+ boot-alternative->menu-entry)
+ old-boot-alternatives)
+ (list #~(format port "}~%"))) '())
+ (format port "
+if [ \"${grub_platform}\" == efi ]; then
+ menuentry \"Firmware setup\" {
+ fwsetup
+ }
+fi~%")))))
+ (cut computed-file "grub.cfg" <>
+ ;; Since this file is rather unique, there's no point in trying to
+ ;; substitute it.
+ #:options '(#:local-build? #t #:substitutable? #f))))))
- #$image
- #$(theme-colors grub-theme-color-normal)
- #$(theme-colors grub-theme-color-highlight))))
-
-;;;
-;;; Configuration file.
-;;;
-(define* (keyboard-layout-file layout
- #:key
- (grub grub))
+(define (keyboard-layout-file layout grub)
"Process the X keyboard layout description LAYOUT, a <keyboard-layout> record,
and return a file in the format for GRUB keymaps. LAYOUT must be present in
the 'share/X11/xkb/symbols/' directory of 'xkeyboard-config'."
- (define builder
+ (computed-file
+ (string-append "grub-keymap."
+ (string-map (match-lambda (#\, #\-) (chr chr))
+ (keyboard-layout-name layout)))
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils))
@@ -243,670 +447,175 @@ (define* (keyboard-layout-file layout
;; (from the 'console-setup' package).
(invoke #+(file-append grub "/bin/grub-mklayout")
"-i" #+(keyboard-layout->console-keymap layout)
- "-o" #$output))))
-
- (computed-file (string-append "grub-keymap."
- (string-map (match-lambda
- (#\, #\-)
- (chr chr))
- (keyboard-layout-name layout)))
- builder))
-
-(define (grub-setup-io config)
- "Return GRUB commands to configure the input / output interfaces. The result
-is a string that can be inserted in grub.cfg."
- (let* ((symbols->string (lambda (list)
- (string-join (map symbol->string list) " ")))
- (outputs (bootloader-configuration-terminal-outputs config))
- (inputs (bootloader-configuration-terminal-inputs config))
- (unit (bootloader-configuration-serial-unit config))
- (speed (bootloader-configuration-serial-speed config))
-
- ;; Respectively, GRUB_TERMINAL_OUTPUT and GRUB_TERMINAL_INPUT,
- ;; as documented in GRUB manual section "Simple Configuration
- ;; Handling".
- (valid-outputs '(console serial serial_0 serial_1 serial_2 serial_3
- gfxterm vga_text mda_text morse spkmodem))
- (valid-inputs '(console serial serial_0 serial_1 serial_2 serial_3
- at_keyboard usb_keyboard))
-
- (io (string-append
- ;; UNIT and SPEED are arguments to the same GRUB command
- ;; ("serial"), so we process them together.
- (if (or unit speed)
- (string-append
- "serial"
- (if unit
- ;; COM ports 1 through 4
- (if (and (exact-integer? unit) (<= unit 3) (>= unit 0))
- (string-append " --unit=" (number->string unit))
- #f)
- "")
- (if speed
- (if (exact-integer? speed)
- (string-append " --speed=" (number->string speed))
- #f)
- "")
- "\n")
- "")
- (if (null? inputs)
- ""
- (string-append
- "terminal_input "
- (symbols->string
- (map
- (lambda (input)
- (if (memq input valid-inputs) input #f)) inputs))
- "\n"))
- "terminal_output "
- (symbols->string
- (map
- (lambda (output)
- (if (memq output valid-outputs) output #f)) outputs)))))
- (format #f "~a" io)))
-
-(define (grub-root-search device file)
- "Return the GRUB 'search' command to look for DEVICE, which contains FILE,
-a gexp. The result is a gexp that can be inserted in the grub.cfg-generation
-code."
- ;; Usually FILE is a file name gexp like "/gnu/store/…-linux/vmlinuz", but
- ;; it can also be something like "(hd0,msdos1)/vmlinuz" in the case of
- ;; custom menu entries. In the latter case, don't emit a 'search' command.
- (if (and (string? file) (not (string-prefix? "/" file)))
- ""
- (match device
- ;; Preferably refer to DEVICE by its UUID or label. This is more
- ;; efficient and less ambiguous, see <http://bugs.gnu.org/22281>.
- ((? uuid? uuid)
- (format #f "search --fs-uuid --set ~a"
- (uuid->string device)))
- ((? file-system-label? label)
- (format #f "search --label --set ~a"
- (file-system-label->string label)))
- ((? (lambda (device)
- (and (string? device) (string-contains device ":/"))) nfs-uri)
- ;; If the device is an NFS share, then we assume that the expected
- ;; file on that device (e.g. the GRUB background image or the kernel)
- ;; has to be loaded over the network. Otherwise we would need an
- ;; additional device information for some local disk to look for that
- ;; file, which we do not have.
- ;;
- ;; We explicitly set "root=(tftp)" here even though if grub.cfg
- ;; had been loaded via TFTP, Grub would have set "root=(tftp)"
- ;; automatically anyway. The reason is if you have a system that
- ;; used to be on NFS but now is local, root would be set to local
- ;; disk. If you then selected an older system generation that is
- ;; supposed to boot from network in the Grub boot menu, Grub still
- ;; wouldn't load those files from network otherwise.
- ;;
- ;; TFTP is preferred to HTTP because it is used more widely and
- ;; specified in standards more widely--especially BOOTP/DHCPv4
- ;; defines a TFTP server for DHCP option 66, but not HTTP.
- ;;
- ;; Note: DHCPv6 specifies option 59 to contain a boot-file-url,
- ;; which can contain a HTTP or TFTP URL.
- ;;
- ;; Note: It is assumed that the file paths are of a similar
- ;; setup on both the TFTP server and the NFS server (it is
- ;; not possible to search for files on TFTP).
- ;;
- ;; TODO: Allow HTTP.
- "set root=(tftp)")
- ((or #f (? string?))
- #~(format #f "search --file --set ~a" #$file)))))
-
-(define* (make-grub-configuration grub config entries
- #:key
- (locale #f)
- (system (%current-system))
- (old-entries '())
- (store-crypto-devices '())
- store-directory-prefix)
- "Return the GRUB configuration file corresponding to CONFIG, a
-<bootloader-configuration> object, and where the store is available at
-STORE-FS, a <file-system> object. OLD-ENTRIES is taken to be a list of menu
-entries corresponding to old generations of the system.
-STORE-CRYPTO-DEVICES contain the UUIDs of the encrypted units that must
-be unlocked to access the store contents.
-STORE-DIRECTORY-PREFIX may be used to specify a store prefix, as is required
-when booting a root file system on a Btrfs subvolume."
- (define all-entries
- (append entries (bootloader-configuration-menu-entries config)))
- (define (menu-entry->gexp entry)
- (let ((label (menu-entry-label entry))
- (linux (menu-entry-linux entry))
- (device (menu-entry-device entry))
- (device-mount-point (menu-entry-device-mount-point entry))
- (multiboot-kernel (menu-entry-multiboot-kernel entry))
- (chain-loader (menu-entry-chain-loader entry)))
- (cond
- (linux
- (let ((arguments (menu-entry-linux-arguments entry))
- (linux (normalize-file linux
- device-mount-point
- store-directory-prefix))
- (initrd (normalize-file (menu-entry-initrd entry)
- device-mount-point
- store-directory-prefix))
- (extra-initrd (bootloader-configuration-extra-initrd config)))
- ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
- ;; Use the right file names for LINUX and INITRD in case
- ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
- ;; separate partition.
-
- ;; When STORE-DIRECTORY-PREFIX is defined, prepend it the linux and
- ;; initrd paths, to allow booting from a Btrfs subvolume.
- #~(format port "menuentry ~s {
- ~a
- linux ~a ~a
- initrd ~a ~a
-}~%"
- #$label
- #$(grub-root-search device linux)
- #$linux (string-join (list #$@arguments))
- (or #$extra-initrd "")
- #$initrd)))
- (multiboot-kernel
- (let* ((kernel (menu-entry-multiboot-kernel entry))
- (arguments (menu-entry-multiboot-arguments entry))
- ;; Choose between device names as understood by Mach's built-in
- ;; IDE driver ("hdX") and those understood by rumpdisk ("wdX"
- ;; in the "noide" case).
- (disk (if (member "noide" arguments) "w" "h"))
- (modules (menu-entry-multiboot-modules entry))
- (root-index 1)) ; XXX EFI will need root-index 2
- #~(format port "
-menuentry ~s {
- multiboot ~a root=part:~a:device:~ad0~a~a
-}~%"
- #$label
- #$kernel
- #$root-index
- #$disk
- (string-join (list #$@arguments) " " 'prefix)
- (string-join (map string-join '#$modules)
- "\n module " 'prefix))))
- (chain-loader
- #~(format port "
-menuentry ~s {
- ~a
- chainloader ~a
-}~%"
- #$label
- #$(grub-root-search device chain-loader)
- #$chain-loader)))))
-
- (define (crypto-devices)
- (define (crypto-device->cryptomount dev)
- (if (uuid? dev)
- #~(format port "cryptomount -u ~a~%"
- ;; cryptomount only accepts UUID without the hypen.
- #$(string-delete #\- (uuid->string dev)))
- ;; Other type of devices aren't implemented.
- #~()))
- (let ((devices (map crypto-device->cryptomount store-crypto-devices))
- (modules #~(format port "insmod luks~%insmod luks2~%")))
- (if (null? devices)
- devices
- (cons modules devices))))
-
- (define (sugar)
- (let* ((entry (first all-entries))
- (device (menu-entry-device entry))
- (mount-point (menu-entry-device-mount-point entry)))
- (eye-candy config
- device
- mount-point
- #:store-directory-prefix store-directory-prefix
- #:port #~port)))
-
- (define locale-config
- (let* ((entry (first all-entries))
- (device (menu-entry-device entry))
- (mount-point (menu-entry-device-mount-point entry)))
- #~(let ((locale #$(and locale
- (locale-definition-source
- (locale-name->definition locale))))
- (locales #$(and locale
- (normalize-file (grub-locale-directory grub)
- mount-point
- store-directory-prefix))))
- (when locale
- (format port "\
-# Localization configuration.
-~asearch --file --set ~a/en@quot.mo
-set locale_dir=~a
-set lang=~a~%"
- ;; Skip the search if there is an image, as it has already
- ;; been performed by eye-candy and traversing the store is
- ;; an expensive operation.
- #$(if (grub-theme-image (bootloader-theme config))
- "# "
- "")
- locales
- locales
- locale)))))
-
- (define keyboard-layout-config
- (let* ((layout (bootloader-configuration-keyboard-layout config))
- (keymap* (and layout
- (keyboard-layout-file layout #:grub grub)))
- (entry (first all-entries))
- (device (menu-entry-device entry))
- (mount-point (menu-entry-device-mount-point entry))
- (keymap (and keymap*
- (normalize-file keymap* mount-point
- store-directory-prefix))))
- #~(when #$keymap
- (format port "\
-insmod keylayouts
-keymap ~a~%" #$keymap))))
-
- (define builder
- #~(call-with-output-file #$output
- (lambda (port)
- (format port
- "# This file was generated from your Guix configuration. Any changes
-# will be lost upon reconfiguration.
-")
- #$@(crypto-devices)
- #$(sugar)
- #$locale-config
- #$keyboard-layout-config
- (format port "
-set default=~a
-set timeout=~a~%"
- #$(bootloader-configuration-default-entry config)
- #$(bootloader-configuration-timeout config))
- #$@(map menu-entry->gexp all-entries)
-
- #$@(if (pair? old-entries)
- #~((format port "
-submenu \"GNU system, old configurations...\" {~%")
- #$@(map menu-entry->gexp old-entries)
- (format port "}~%"))
- #~())
- (format port "
-if [ \"${grub_platform}\" == efi ]; then
- menuentry \"Firmware setup\" {
- fwsetup
- }
-fi~%"))))
+ "-o" #$output)))))
+
+
+
+(define* (grub.dir grub #:key bootloader-config locale
+ #:allow-other-keys . args)
+ "Everything what should go in GRUB's prefix, including fonts, modules,
+locales, keymap, theme image, and grub.cfg."
+ (match-record bootloader-config <bootloader-configuration>
+ ;; can't match for keyboard-layout: identifier bound in this scope
+ (targets theme)
+ (let* ((theme (or theme (grub-theme)))
+ (keyboard-layout (bootloader-configuration-keyboard-layout
+ bootloader-config))
+ (lang (and=> locale (compose locale-definition-source
+ locale-name->definition)))
+ (lc-mesg (and=> lang (cut file-append grub "/share/locale" <>
+ "/LC_MESSAGES/grub.mo"))))
+ (computed-file "grub.dir"
+ (with-imported-modules '((guix build utils))
+ #~(begin (use-modules (guix build utils))
+ (mkdir-p #$output)
+ (chdir #$output)
+ ;; grub files
+ (copy-recursively #$(file-append grub "/lib/grub/") #$output
+ #:copy-file symlink)
+ (mkdir "fonts")
+ (symlink #$(file-append grub "/share/grub/unicode.pf2")
+ "fonts/unicode.pf2")
+ ;; config file
+ (symlink #$(apply grub.cfg args) "grub.cfg")
+ ;; locales
+ (when (and=> #$lc-mesg file-exists?)
+ (mkdir "locales")
+ (symlink #$lc-mesg (string-append "locales/" #$lang ".mo")))
+ ;; keymap
+ #$@(filter ->bool
+ (list
+ (and keyboard-layout
+ #~(symlink #$(keyboard-layout-file keyboard-layout grub)
+ "keymap"))
+ ;; image
+ (and (grub-theme-image theme)
+ #~(copy-file #$(grub-theme-png theme) "image.png"))))))
+ #:options '(#:local-build? #t #:substitutable? #f)))))
- ;; Since this file is rather unique, there's no point in trying to
- ;; substitute it.
- (computed-file "grub.cfg" builder
- #:options '(#:local-build? #t
- #:substitutable? #f)))
-(define (grub-configuration-file config . args)
- (let* ((bootloader (bootloader-configuration-bootloader config))
- (grub (bootloader-package bootloader)))
- (apply make-grub-configuration grub config args)))
-
-(define (grub-efi-configuration-file . args)
- (apply make-grub-configuration grub-efi args))
-
-(define grub-cfg "/boot/grub/grub.cfg")
-
;;;
-;;; Install procedures.
+;;; Installers.
;;;
-(define install-grub
- #~(lambda (bootloader device mount-point)
- (let ((grub (string-append bootloader "/sbin/grub-install"))
- (install-dir (string-append mount-point "/boot")))
- ;; Install GRUB on DEVICE which is mounted at MOUNT-POINT. If DEVICE
- ;; is #f, then we populate the disk-image rooted at MOUNT-POINT.
- (if device
- (begin
- ;; Tell 'grub-install' that there might be a LUKS-encrypted
- ;; /boot or root partition.
- (setenv "GRUB_ENABLE_CRYPTODISK" "y")
-
- ;; Hide potentially confusing messages from the user, such as
- ;; "Installing for i386-pc platform."
- (invoke/quiet grub "--no-floppy" "--target=i386-pc"
- "--boot-directory" install-dir
- device))
- ;; When creating a disk-image, only install a font and GRUB modules.
- (let* ((fonts (string-append install-dir "/grub/fonts")))
- (mkdir-p fonts)
- (copy-file (string-append bootloader "/share/grub/unicode.pf2")
- (string-append fonts "/unicode.pf2"))
- (copy-recursively (string-append bootloader "/lib/")
- install-dir))))))
-
-(define install-grub-disk-image
- #~(lambda (bootloader root-index image)
- ;; Install GRUB on the given IMAGE. The root partition index is
- ;; ROOT-INDEX.
- (let ((grub-mkimage
- (string-append bootloader "/bin/grub-mkimage"))
- (modules '("biosdisk" "part_msdos" "fat" "ext2"))
- (grub-bios-setup
- (string-append bootloader "/sbin/grub-bios-setup"))
- (root-device (format #f "hd0,msdos~a" root-index))
- (boot-img (string-append bootloader "/lib/grub/i386-pc/boot.img"))
- (device-map "device.map"))
-
- ;; Create a minimal, standalone GRUB image that will be written
- ;; directly in the MBR-GAP (space between the end of the MBR and the
- ;; first partition).
- (apply invoke grub-mkimage
- "-O" "i386-pc"
- "-o" "core.img"
- "-p" (format #f "(~a)/boot/grub" root-device)
- modules)
-
- ;; Create a device mapping file.
- (call-with-output-file device-map
- (lambda (port)
- (format port "(hd0) ~a~%" image)))
-
- ;; Copy the default boot.img, that will be written on the MBR sector
- ;; by GRUB-BIOS-SETUP.
- (copy-file boot-img "boot.img")
-
- ;; Install both the "boot.img" and the "core.img" files on the given
- ;; IMAGE. On boot, the MBR sector will execute the minimal GRUB
- ;; written in the MBR-GAP. GRUB configuration and missing modules will
- ;; be read from ROOT-DEVICE.
- (invoke grub-bios-setup
- "-m" device-map
- "-r" root-device
- "-d" "."
- image))))
-
-(define install-grub-efi
- #~(lambda (bootloader efi-dir mount-point)
- ;; There is nothing useful to do when called in the context of a disk
- ;; image generation.
- (when efi-dir
- ;; Install GRUB onto the EFI partition mounted at EFI-DIR, for the
- ;; system whose root is mounted at MOUNT-POINT.
- (let ((grub-install (string-append bootloader "/sbin/grub-install"))
- (install-dir (string-append mount-point "/boot"))
- ;; When installing Guix, it's common to mount EFI-DIR below
- ;; MOUNT-POINT rather than /boot/efi on the live image.
- (target-esp (if (file-exists? (string-append mount-point efi-dir))
- (string-append mount-point efi-dir)
- efi-dir)))
- ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or
- ;; root partition.
- (setenv "GRUB_ENABLE_CRYPTODISK" "y")
- (invoke/quiet grub-install "--boot-directory" install-dir
- "--bootloader-id=Guix"
- "--efi-directory" target-esp)))))
-
-(define install-grub-efi-removable
- #~(lambda (bootloader efi-dir mount-point)
- ;; NOTE: mount-point is /mnt in guix system init /etc/config.scm /mnt/point
- ;; NOTE: efi-dir comes from target list of booloader configuration
- ;; There is nothing useful to do when called in the context of a disk
- ;; image generation.
- (when efi-dir
- ;; Install GRUB onto the EFI partition mounted at EFI-DIR, for the
- ;; system whose root is mounted at MOUNT-POINT.
- (let ((grub-install (string-append bootloader "/sbin/grub-install"))
- (install-dir (string-append mount-point "/boot"))
- ;; When installing Guix, it's common to mount EFI-DIR below
- ;; MOUNT-POINT rather than /boot/efi on the live image.
- (target-esp (if (file-exists? (string-append mount-point efi-dir))
- (string-append mount-point efi-dir)
- efi-dir)))
- ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or
- ;; root partition.
- (setenv "GRUB_ENABLE_CRYPTODISK" "y")
- (invoke/quiet grub-install "--boot-directory" install-dir
- "--removable"
- ;; "--no-nvram"
- "--bootloader-id=Guix"
- "--efi-directory" target-esp)))))
-
-(define install-grub-efi32
- #~(lambda (bootloader efi-dir mount-point)
- ;; There is nothing useful to do when called in the context of a disk
- ;; image generation.
- (when efi-dir
- ;; Install GRUB onto the EFI partition mounted at EFI-DIR, for the
- ;; system whose root is mounted at MOUNT-POINT.
- (let ((grub-install (string-append bootloader "/sbin/grub-install"))
- (install-dir (string-append mount-point "/boot"))
- ;; When installing Guix, it's common to mount EFI-DIR below
- ;; MOUNT-POINT rather than /boot/efi on the live image.
- (target-esp (if (file-exists? (string-append mount-point efi-dir))
- (string-append mount-point efi-dir)
- efi-dir)))
- ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or
- ;; root partition.
- (setenv "GRUB_ENABLE_CRYPTODISK" "y")
- (invoke/quiet grub-install "--boot-directory" install-dir
- "--bootloader-id=Guix"
- (cond ((target-x86?) "--target=i386-efi")
- ((target-arm?) "--target=arm-efi"))
- "--efi-directory" target-esp)))))
-
-(define* (make-grub-efi-netboot-installer grub-efi grub-cfg subdir)
- "Make a bootloader-installer for a grub-efi-netboot bootloader, which expects
-its files in SUBDIR and its configuration file in GRUB-CFG.
-
-As a grub-efi-netboot package is already pre-installed by 'grub-mknetdir', the
-installer basically copies all files from the bootloader-package (or profile)
-into the bootloader-target directory.
-
-Additionally for network booting over TFTP, two relative symlinks to the store
-and to the GRUB-CFG file are necessary. Due to this a TFTP root directory must
-not be located on a FAT file-system.
-
-If the bootloader-target does not support symlinks, then it is assumed to be a
-kind of EFI System Partition (ESP). In this case an intermediate configuration
-file is created with the help of GRUB-EFI to load the GRUB-CFG.
-
-The installer is usable for any efi-bootloader-chain, which prepares the
-bootloader-profile in a way ready for copying.
-
-The installer does not manipulate the system's 'UEFI Boot Manager'.
-
-The returned installer accepts the BOOTLOADER, TARGET and MOUNT-POINT
-arguments. Its job is to copy the BOOTLOADER, which must be a pre-installed
-grub-efi-netboot package with a SUBDIR like efi/boot or efi/Guix, below the
-directory TARGET for the system whose root is mounted at MOUNT-POINT.
-
-MOUNT-POINT is the last argument in 'guix system init /etc/config.scm mnt/point'
-or '/' for other 'guix system' commands.
-
-Where TARGET comes from the targets argument given to the
-bootloader-configuration in:
-
-(operating-system
- (bootloader (bootloader-configuration
- (targets '(\"/boot/efi\"))
- …))
- …)
-
-TARGET is required to be an absolute directory name, usually mounted via NFS,
-and finally needs to be provided by a TFTP server as
-the TFTP root directory.
-
-Usually the installer will be used to prepare network booting over TFTP. Then
-GRUB will load tftp://server/SUBDIR/grub.cfg and this file will instruct it to
-load more files from the store like tftp://server/gnu/store/…-linux…/Image.
-
-To make this possible two symlinks are created. The first symlink points
-relatively form MOUNT-POINT/TARGET/SUBDIR/grub.cfg to
-MOUNT-POINT/boot/grub/grub.cfg, and the second symlink points relatively from
-MOUNT-POINT/TARGET/%store-prefix to MOUNT-POINT/%store-prefix.
-
-It is important to note that these symlinks need to be relative, as the absolute
-paths on the TFTP server side are unknown.
-
-It is also important to note that both symlinks will point outside the TFTP root
-directory and that the TARGET/%store-prefix symlink makes the whole store
-accessible via TFTP. Possibly the TFTP server must be configured to allow
-accesses outside its TFTP root directory. This all may need to be considered
-for security aspects. It is advised to disable any TFTP write access!
-
-The installer can also be used to prepare booting from local storage, if the
-underlying file-system, like FAT on an EFI System Partition (ESP), does not
-support symlinks. In this case the MOUNT-POINT/TARGET/SUBDIR/grub.cfg will be
-created with the help of GRUB-EFI to load the /boot/grub/grub.cfg file. A
-symlink to the store is not needed in this case."
- (with-imported-modules '((guix build union))
- #~(lambda (bootloader target mount-point)
- ;; In context of a disk image creation TARGET will be #f and an
- ;; installer is expected to do necessary installations on MOUNT-POINT,
- ;; which will become the root file system. If TARGET is #f, this
- ;; installer has nothing to do, as it only cares about the EFI System
- ;; Partition (ESP).
- (when target
- (use-modules ((guix build union) #:select (symlink-relative))
- (ice-9 popen)
- (ice-9 rdelim))
- (let* ((mount-point/target (string-append mount-point target "/"))
- ;; When installing Guix, it is common to mount TARGET below
- ;; MOUNT-POINT rather than the root directory.
- (bootloader-target (if (file-exists? mount-point/target)
- mount-point/target
- target))
- (store (string-append mount-point (%store-prefix)))
- (store-link (string-append bootloader-target (%store-prefix)))
- (grub-cfg (string-append mount-point #$grub-cfg))
- (grub-cfg-link (string-append bootloader-target
- #$subdir "/"
- (basename grub-cfg))))
- ;; Copy the bootloader into the bootloader-target directory.
- ;; Should we beforehand recursively delete any existing file?
- (copy-recursively bootloader bootloader-target
- #:follow-symlinks? #t
- #:log (%make-void-port "w"))
- ;; For TFTP we need to install additional relative symlinks.
- ;; If we install on an EFI System Partition (ESP) or some other FAT
- ;; file-system, then symlinks cannot be created and are not needed.
- ;; Therefore we ignore exceptions when trying.
- ;; Prepare the symlink to the grub.cfg.
- (mkdir-p (dirname grub-cfg-link))
- (false-if-exception (delete-file grub-cfg-link))
- (if (unspecified?
- (false-if-exception (symlink-relative grub-cfg grub-cfg-link)))
- ;; Symlinks are supported.
- (begin
- ;; Prepare the symlink to the store.
- (mkdir-p (dirname store-link))
- (false-if-exception (delete-file store-link))
- (symlink-relative store store-link))
- ;; Creating symlinks does not seem to be supported. Probably
- ;; an ESP is used. Add a script to search and load the actual
- ;; grub.cfg.
- (let* ((probe #$(file-append grub-efi "/sbin/grub-probe"))
- (port (open-pipe* OPEN_READ probe "--target=fs_uuid"
- grub-cfg))
- (search-root
- (match (read-line port)
- ((? eof-object?)
- ;; There is no UUID available. As a fallback search
- ;; everywhere for the grub.cfg.
- (string-append "search --file --set " #$grub-cfg))
- (fs-uuid
- ;; The UUID to load the grub.cfg from is known.
- (string-append "search --fs-uuid --set " fs-uuid))))
- (load-grub-cfg (string-append "configfile " #$grub-cfg)))
- (close-pipe port)
- (with-output-to-file grub-cfg-link
- (lambda ()
- (display (string-join (list search-root
- load-grub-cfg)
- "\n")))))))))))
+(define* (install-grub.dir grub #:key bootloader-config
+ #:allow-other-keys . args)
+ (with-targets (bootloader-configuration-targets bootloader-config)
+ (('install => (path :path))
+ #~(copy-recursively #$(apply grub.dir grub args) #$path
+ #:log (%make-void-port "w")
+ #:follow-symlinks? #t
+ #:copy-file atomic-copy))))
+
+(define (install-grub-bios grub)
+ "Returns an installer for the bios-bootable grub package GRUB."
+ (lambda* (#:key bootloader-config #:allow-other-keys . args)
+ (gbegin (apply install-grub.dir grub args)
+ (with-targets (bootloader-configuration-targets bootloader-config)
+ (('disk => (device :device))
+ #~(invoke #$(file-append grub "/sbin/grub-bios-setup") "-v" "-v"
+ "--directory" "/" ; can't be blank
+ "--device-map" "" ; no dev map - need to specify
+ "--boot-image"
+ #$(file-append grub "/lib/grub/i386-pc/boot.img")
+ "--core-image" #$(apply core.img grub "pc" args)
+ "--root-device" #$(string-append "hostdisk/" device)
+ #$device))))))
+
+(define* (install-grub-efi #:key bootloader-config #:allow-other-keys . args)
+ "Installs grub into the system's uefi bootloader, taking into account
+user-specified requirements for a 32-bit or fallback bootloader."
+ (let* ((32? (bootloader-configuration-32bit? bootloader-config))
+ (grub (if 32? grub-efi32 grub-efi))
+ (core (apply core.img grub "efi" args))
+ (copy #~(lambda (dest) (copy-file #$core dest))))
+ (gbegin (apply install-grub.dir grub args)
+ (install-efi bootloader-config #~`((,#$copy "grub.efi" . "GNU GRUB"))))))
+
-
+
;;;
-;;; Bootloader definitions.
+;;; Bootloaders.
;;;
-;;; For all these grub-bootloader variables the path to /boot/grub/grub.cfg
-;;; is fixed. Inheriting and overwriting the field 'configuration-file' will
-;;; break 'guix system delete-generations', 'guix system switch-generation',
-;;; and 'guix system roll-back'.
+
+(define %grub-default-targets
+ (list (bootloader-target
+ (type 'install)
+ (offset 'root)
+ (path "boot"))))
(define grub-bootloader
(bootloader
- (name 'grub)
- (package grub)
- (installer install-grub)
- (disk-image-installer install-grub-disk-image)
- (configuration-file grub-cfg)
- (configuration-file-generator grub-configuration-file)))
+ (name 'grub)
+ (default-targets %grub-default-targets)
+ (installer (install-grub-bios grub))))
(define grub-minimal-bootloader
(bootloader
- (inherit grub-bootloader)
- (package grub-minimal)))
+ (name 'grub)
+ (default-targets %grub-default-targets)
+ (installer (install-grub-bios grub-minimal))))
(define grub-efi-bootloader
(bootloader
- (name 'grub-efi)
- (package grub-efi)
- (installer install-grub-efi)
- (disk-image-installer #f)
- (configuration-file grub-cfg)
- (configuration-file-generator grub-configuration-file)))
-
-(define grub-efi-removable-bootloader
- (bootloader
- (inherit grub-efi-bootloader)
- (name 'grub-efi-removable-bootloader)
- (installer install-grub-efi-removable)))
+ (name 'grub-efi)
+ (default-targets (cons (bootloader-target
+ (type 'vendir)
+ (offset 'esp)
+ (path "EFI/Guix"))
+ %grub-default-targets))
+ (installer install-grub-efi)))
-(define grub-efi32-bootloader
- (bootloader
- (inherit grub-efi-bootloader)
- (installer install-grub-efi32)
- (name 'grub-efi32)
- (package grub-efi32)))
-(define (make-grub-efi-netboot-bootloader name subdir)
- (bootloader
- (name name)
- (package (make-grub-efi-netboot (symbol->string name) subdir))
- (installer (make-grub-efi-netboot-installer grub-efi grub-cfg subdir))
- (disk-image-installer #f)
- (configuration-file grub-cfg)
- (configuration-file-generator grub-efi-configuration-file)))
-
-(define grub-efi-netboot-bootloader
- (make-grub-efi-netboot-bootloader 'grub-efi-netboot-bootloader
- "efi/Guix"))
-
-(define grub-efi-netboot-removable-bootloader
- (make-grub-efi-netboot-bootloader 'grub-efi-netboot-removable-bootloader
- "efi/boot"))
-
-(define grub-mkrescue-bootloader
- (bootloader
- (inherit grub-efi-bootloader)
- (package grub-hybrid)))
;;;
-;;; Compatibility macros.
+;;; deprecated shit!
+;;; use the bootloader-config flags instead! or, in the case of netboot, set
+;;; your 'install (or parent thereof) target fs to be "tftp" or "nfs"
;;;
-(define-syntax grub-configuration
- (syntax-rules (grub)
- ((_ (grub package) fields ...)
- (if (eq? package grub)
- (bootloader-configuration
- (bootloader grub-bootloader)
- fields ...)
- (bootloader-configuration
- (bootloader grub-efi-bootloader)
- fields ...)))
- ((_ fields ...)
- (bootloader-configuration
- (bootloader grub-bootloader)
- fields ...))))
-
-;;; grub.scm ends here
+(define (deprecated-installer installer removable? 32?)
+ (lambda args (apply installer
+ (substitute-keyword-arguments args
+ ((#:bootloader-config conf) (bootloader-configuration
+ (inherit conf)
+ (efi-removable? removable?)
+ (32bit? 32?)))))))
+
+(define-deprecated grub-efi-removable-bootloader grub-efi-bootloader
+ (bootloader
+ (inherit grub-efi-bootloader)
+ (installer (deprecated-installer install-grub-efi #t #f))))
+
+(define-deprecated grub-efi32-bootloader grub-efi-bootloader
+ (bootloader
+ (inherit grub-efi-bootloader)
+ (installer (deprecated-installer install-grub-efi #f #t))))
+
+(define %netboot-targets
+ (list (bootloader-target
+ (type 'install)
+ (offset 'root)
+ (path "boot")
+ (file-system "tftp"))
+ (bootloader-target
+ (type 'vendir)
+ (offset 'esp)
+ (path "EFI/Guix"))))
+
+(define-deprecated grub-efi-netboot-bootloader
+ grub-efi-bootloader
+ (bootloader
+ (inherit grub-efi-bootloader)
+ (default-targets %netboot-targets)))
+
+(define-deprecated grub-efi-netboot-removable-bootloader
+ grub-efi-bootloader
+ (bootloader
+ (inherit grub-efi-bootloader)
+ (default-targets %netboot-targets)
+ (installer (deprecated-installer install-grub-efi #t #f))))
@@ -7,6 +7,7 @@
;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2023 Herman Rimm <herman_rimm@protonmail.com>
;;; Copyright © 2024 Zheng Junjie <873216071@qq.com>
+;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -24,12 +25,11 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu bootloader u-boot)
- #:use-module (gnu bootloader extlinux)
#:use-module (gnu bootloader)
+ #:use-module (gnu bootloader extlinux)
#:use-module (gnu packages bootloaders)
#:use-module (guix gexp)
- #:export (u-boot-bootloader
- u-boot-a20-olinuxino-lime-bootloader
+ #:export (u-boot-a20-olinuxino-lime-bootloader
u-boot-a20-olinuxino-lime2-bootloader
u-boot-a20-olinuxino-micro-bootloader
u-boot-bananapi-m2-ultra-bootloader
@@ -53,301 +53,172 @@ (define-module (gnu bootloader u-boot)
u-boot-ts7970-q-2g-1000mhz-c-bootloader
u-boot-wandboard-bootloader))
-(define install-u-boot
- #~(lambda (bootloader root-index image)
- (if bootloader
- (error "Failed to install U-Boot"))))
+(define (make-install-u-boot firmware installers)
+ (lambda* (#:key bootloader-config #:allow-other-keys . args)
+ (with-targets (bootloader-configuration-targets bootloader-config)
+ ('extlinux (apply install-extlinux-config args))
+ (('install => (path :path)) #~(let ((path #$path) #$firmware)))
+ (('disk => (disk :device)) #~(let ((disk #$disk)) #f #$@installers)))))
+
+(define-syntax-rule (define-u-bootloader def-name package firmware
+ (file size doffset) ...)
+ "Defines a u-boot installer DEF-NAME, using u-boot PACKAGE. Installs each
+given FILE of SIZE (or #f to autodetect) to the targetted disk at OFFSET.
+FIRMWARE is ran on the u-boot firmware directory for installation of supporting
+files, with the variable path set to the dir path."
+ (define def-name
+ (bootloader
+ (name 'u-boot)
+ (default-targets (list (bootloader-target
+ (type 'install)
+ (offset 'root)
+ (path "boot"))
+ (bootloader-target
+ (type 'extlinux)
+ (offset 'install)
+ (path "extlinux"))))
+ (installer (make-install-u-boot firmware
+ (list #~(let ((fw #$(file-append package "/libexec/" file)))
+ (write-file-on-device fw
+ #$(or size #~(stat:size (stat fw)))
+ disk #$doffset)) ...))))))
+
+
+;;;
+;;; Bootloader definitions.
+;;;
-(define install-beaglebone-black-u-boot
+(define-u-bootloader u-boot-beaglebone-black-bootloader
+ u-boot-am335x-boneblack #f
;; http://wiki.beyondlogic.org/index.php?title=BeagleBoneBlack_Upgrading_uBoot
;; This first stage bootloader called MLO (U-Boot SPL) is expected at
;; 0x20000 by BBB ROM code. The second stage bootloader will be loaded by
;; the MLO and is expected at 0x60000. Write both first stage ("MLO") and
- ;; second stage ("u-boot.img") images, read in BOOTLOADER directory, to the
- ;; specified DEVICE.
- #~(lambda (bootloader root-index image)
- (let ((mlo (string-append bootloader "/libexec/MLO"))
- (u-boot (string-append bootloader "/libexec/u-boot.img")))
- (write-file-on-device mlo (* 256 512)
- image (* 256 512))
- (write-file-on-device u-boot (* 1024 512)
- image (* 768 512)))))
-
-(define install-allwinner-u-boot
- #~(lambda (bootloader root-index image)
- (let ((u-boot (string-append bootloader
- "/libexec/u-boot-sunxi-with-spl.bin")))
- (write-file-on-device u-boot (stat:size (stat u-boot))
- image (* 8 1024)))))
-
-(define install-allwinner64-u-boot
- #~(lambda (bootloader root-index image)
- (let ((spl (string-append bootloader "/libexec/u-boot-sunxi-with-spl.bin"))
- (u-boot (string-append bootloader "/libexec/u-boot-sunxi-with-spl.fit.itb")))
- (write-file-on-device spl (stat:size (stat spl))
- image (* 8 1024))
- (write-file-on-device u-boot (stat:size (stat u-boot))
- image (* 40 1024)))))
-
-(define install-imx-u-boot
- #~(lambda (bootloader root-index image)
- (let ((spl (string-append bootloader "/libexec/SPL"))
- (u-boot (string-append bootloader "/libexec/u-boot.img")))
- (write-file-on-device spl (stat:size (stat spl))
- image (* 1 1024))
- (write-file-on-device u-boot (stat:size (stat u-boot))
- image (* 69 1024)))))
-
-(define install-orangepi-r1-plus-lts-rk3328-u-boot
- #~(lambda (bootloader root-index image)
- (let ((idb (string-append bootloader "/libexec/idbloader.img"))
- (u-boot (string-append bootloader "/libexec/u-boot.itb")))
- (write-file-on-device idb (stat:size (stat idb))
- image (* 64 512))
- (write-file-on-device u-boot (stat:size (stat u-boot))
- image (* 16384 512)))))
-
-(define install-puma-rk3399-u-boot
- #~(lambda (bootloader root-index image)
- (let ((spl (string-append bootloader "/libexec/idbloader.img"))
- (u-boot (string-append bootloader "/libexec/u-boot.itb")))
- (write-file-on-device spl (stat:size (stat spl))
- image (* 64 512))
- (write-file-on-device u-boot (stat:size (stat u-boot))
- image (* 512 512)))))
-
-(define install-firefly-rk3399-u-boot
- #~(lambda (bootloader root-index image)
- (let ((idb (string-append bootloader "/libexec/idbloader.img"))
- (u-boot (string-append bootloader "/libexec/u-boot.itb")))
- (write-file-on-device idb (stat:size (stat idb))
- image (* 64 512))
- (write-file-on-device u-boot (stat:size (stat u-boot))
- image (* 16384 512)))))
-
-(define install-rock64-rk3328-u-boot
- #~(lambda (bootloader root-index image)
- (let ((idb (string-append bootloader "/libexec/idbloader.img"))
- (u-boot (string-append bootloader "/libexec/u-boot.itb")))
- (write-file-on-device idb (stat:size (stat idb))
- image (* 64 512))
- (write-file-on-device u-boot (stat:size (stat u-boot))
- image (* 16384 512)))))
-
-(define install-rockpro64-rk3399-u-boot
- #~(lambda (bootloader root-index image)
- (let ((idb (string-append bootloader "/libexec/idbloader.img"))
- (u-boot (string-append bootloader "/libexec/u-boot.itb")))
- (write-file-on-device idb (stat:size (stat idb))
- image (* 64 512))
- (write-file-on-device u-boot (stat:size (stat u-boot))
- image (* 16384 512)))))
-
-(define install-pinebook-pro-rk3399-u-boot install-rockpro64-rk3399-u-boot)
-
-(define install-u-boot-ts7970-q-2g-1000mhz-c-u-boot
- #~(lambda (bootloader device mount-point)
- (let ((u-boot.imx (string-append bootloader "/libexec/u-boot.imx"))
- (install-dir (string-append mount-point "/boot")))
- (install-file u-boot.imx install-dir))))
-
-(define install-sifive-unmatched-u-boot
- #~(lambda (bootloader root-index image)
- (let ((spl (string-append bootloader "/libexec/spl/u-boot-spl.bin"))
- (u-boot (string-append bootloader "/libexec/u-boot.itb")))
- (write-file-on-device spl (stat:size (stat spl))
- image (* 34 512))
- (write-file-on-device u-boot (stat:size (stat u-boot))
- image (* 2082 512)))))
-
-(define install-starfive-visionfive2-u-boot
- #~(lambda (bootloader root-index image)
- (let ((spl (string-append
- bootloader "/libexec/spl/u-boot-spl.bin.normal.out"))
- (u-boot (string-append bootloader "/libexec/u-boot.itb")))
- (write-file-on-device spl (stat:size (stat spl))
- image (* 34 512))
- (write-file-on-device u-boot (stat:size (stat u-boot))
- image (* 2082 512)))))
-
-(define install-starfive-visionfive2-uEnv.txt
- #~(lambda (bootloader device mount-point)
- (mkdir-p (string-append mount-point "/boot"))
- (call-with-output-file (string-append mount-point "/boot/uEnv.txt")
+ ;; second stage ("u-boot.img") images to the target.
+ ("MLO" (* 256 512) (* 256 512))
+ ("u-boot.img" (* 1024 512) (* 768 512)))
+
+(define-u-bootloader u-boot-sifive-unmatched-bootloader
+ u-boot-sifive-unmatched #f
+ ("spl/u-boot-spl.bin" #f (* 34 512))
+ ("u-boot.itb" #f (* 2082 512)))
+
+(define-u-bootloader u-boot-starfive-visionfive2-bootloader
+ u-boot-starfive-visionfive2
+ #~(begin (mkdir-p path)
+ (call-with-output-file (string-append path "/uEnv.txt")
(lambda (port)
(format port
- ;; if board SPI use vender's u-boot, will find
- ;; ""starfive/starfive_visionfive2.dtb"", We cannot guarantee
- ;; that users will update this u-boot, so set it.
- "fdtfile=starfive/jh7110-starfive-visionfive-2-v1.3b.dtb~%")))))
+ ;; if board SPI use vender's u-boot, will find
+ ;; ""starfive/starfive_visionfive2.dtb"", We cannot guarantee
+ ;; that users will update this u-boot, so set it.
+ "fdtfile=starfive/jh7110-starfive-visionfive-2-v1.3b.dtb~%"))))
+ ("spl/u-boot-spl.bin.normal.out" #f (* 34 512))
+ ("u-boot.itb" #f (* 2082 512)))
+
+
+;;;
+;;; Allwinner bootloader definitions.
+;;;
+(define-syntax-rule (define-u-bootloader-allwinner def-name package)
+ (define-u-bootloader def-name package #f
+ ("u-boot-sunxi-with-spl.bin" #f (* 8 1024))))
+
-(define install-qemu-riscv64-u-boot
- #~(lambda (bootloader device mount-point)
- (let ((u-boot.bin (string-append bootloader "/libexec/u-boot.bin"))
- (install-dir (string-append mount-point "/boot")))
- (install-file u-boot.bin install-dir))))
+(define-u-bootloader-allwinner u-boot-nintendo-nes-classic-edition-bootloader
+ u-boot-nintendo-nes-classic-edition)
+
+(define-u-bootloader-allwinner u-boot-a20-olinuxino-lime-bootloader
+ u-boot-a20-olinuxino-lime)
+
+(define-u-bootloader-allwinner u-boot-a20-olinuxino-lime2-bootloader
+ u-boot-a20-olinuxino-lime2)
+
+(define-u-bootloader-allwinner u-boot-a20-olinuxino-micro-bootloader
+ u-boot-a20-olinuxino-micro)
+
+(define-u-bootloader-allwinner u-boot-bananapi-m2-ultra-bootloader
+ u-boot-bananapi-m2-ultra)
+
+(define-u-bootloader-allwinner u-boot-cubietruck-bootloader u-boot-cubietruck)
+
+(define-u-bootloader-allwinner u-boot-pine64-lts-bootloader u-boot-pine64-lts)
+;;;
+;;; Allwinner64 bootloader definitions.
+;;;
+(define-syntax-rule (define-u-bootloader-allwinner64 def-name package)
+ (define-u-bootloader def-name package #f
+ ("u-boot-sunxi-with-spl.bin" #f (* 8 1024))
+ ("u-boot-sunxi-with-spl.fit.itb" #f (* 40 1024))))
+
+
+(define-u-bootloader-allwinner64 u-boot-pine64-plus-bootloader
+ u-boot-pine64-plus)
+
+(define-u-bootloader-allwinner64 u-boot-pinebook-bootloader u-boot-pinebook)
+
;;;
-;;; Bootloader definitions.
+;;; IMX bootloader definitions.
;;;
+(define-syntax-rule (define-u-bootloader-imx def-name package)
+ (define-u-bootloader def-name package #f
+ ("SPL" #f (* 8 1024))
+ ("u-boot.img" #f (* 40 1024))))
-(define u-boot-bootloader
- (bootloader
- (inherit extlinux-bootloader)
- (name 'u-boot)
- (package #f)
- (installer #f)
- (disk-image-installer install-u-boot)))
-
-(define u-boot-beaglebone-black-bootloader
- (bootloader
- (inherit u-boot-bootloader)
- (package u-boot-am335x-boneblack)
- (disk-image-installer install-beaglebone-black-u-boot)))
-
-(define u-boot-allwinner-bootloader
- (bootloader
- (inherit u-boot-bootloader)
- (disk-image-installer install-allwinner-u-boot)))
-
-(define u-boot-allwinner64-bootloader
- (bootloader
- (inherit u-boot-bootloader)
- (disk-image-installer install-allwinner64-u-boot)))
-
-(define u-boot-imx-bootloader
- (bootloader
- (inherit u-boot-bootloader)
- (disk-image-installer install-imx-u-boot)))
-
-(define u-boot-nintendo-nes-classic-edition-bootloader
- (bootloader
- (inherit u-boot-allwinner-bootloader)
- (package u-boot-nintendo-nes-classic-edition)))
-
-(define u-boot-a20-olinuxino-lime-bootloader
- (bootloader
- (inherit u-boot-allwinner-bootloader)
- (package u-boot-a20-olinuxino-lime)))
-
-(define u-boot-a20-olinuxino-lime2-bootloader
- (bootloader
- (inherit u-boot-allwinner-bootloader)
- (package u-boot-a20-olinuxino-lime2)))
-
-(define u-boot-a20-olinuxino-micro-bootloader
- (bootloader
- (inherit u-boot-allwinner-bootloader)
- (package u-boot-a20-olinuxino-micro)))
-
-(define u-boot-bananapi-m2-ultra-bootloader
- (bootloader
- (inherit u-boot-allwinner-bootloader)
- (package u-boot-bananapi-m2-ultra)))
-
-(define u-boot-cubietruck-bootloader
- (bootloader
- (inherit u-boot-allwinner-bootloader)
- (package u-boot-cubietruck)))
-
-(define u-boot-firefly-rk3399-bootloader
- ;; SD and eMMC use the same format
- (bootloader
- (inherit u-boot-bootloader)
- (package u-boot-firefly-rk3399)
- (disk-image-installer install-firefly-rk3399-u-boot)))
-
-(define u-boot-mx6cuboxi-bootloader
- (bootloader
- (inherit u-boot-imx-bootloader)
- (package u-boot-mx6cuboxi)))
-
-(define u-boot-wandboard-bootloader
- (bootloader
- (inherit u-boot-imx-bootloader)
- (package u-boot-wandboard)))
-
-(define u-boot-novena-bootloader
- (bootloader
- (inherit u-boot-imx-bootloader)
- (package u-boot-novena)))
-
-(define u-boot-orangepi-r1-plus-lts-rk3328-bootloader
- (bootloader
- (inherit u-boot-bootloader)
- (package u-boot-orangepi-r1-plus-lts-rk3328)
- (disk-image-installer install-orangepi-r1-plus-lts-rk3328-u-boot)))
-
-(define u-boot-pine64-plus-bootloader
- (bootloader
- (inherit u-boot-allwinner64-bootloader)
- (package u-boot-pine64-plus)))
-
-(define u-boot-pine64-lts-bootloader
- (bootloader
- (inherit u-boot-allwinner-bootloader)
- (package u-boot-pine64-lts)))
-
-(define u-boot-pinebook-bootloader
- (bootloader
- (inherit u-boot-allwinner64-bootloader)
- (package u-boot-pinebook)))
-
-(define u-boot-puma-rk3399-bootloader
- (bootloader
- (inherit u-boot-bootloader)
- (package u-boot-puma-rk3399)
- (disk-image-installer install-puma-rk3399-u-boot)))
-
-(define u-boot-rock64-rk3328-bootloader
- ;; SD and eMMC use the same format
- (bootloader
- (inherit u-boot-bootloader)
- (package u-boot-rock64-rk3328)
- (disk-image-installer install-rock64-rk3328-u-boot)))
-(define u-boot-rockpro64-rk3399-bootloader
- ;; SD and eMMC use the same format
- (bootloader
- (inherit u-boot-bootloader)
- (package u-boot-rockpro64-rk3399)
- (disk-image-installer install-rockpro64-rk3399-u-boot)))
+(define-u-bootloader-imx u-boot-mx6cuboxi-bootloader u-boot-mx6cuboxi)
+
+(define-u-bootloader-imx u-boot-wandboard-bootloader u-boot-wandboard)
-(define u-boot-pinebook-pro-rk3399-bootloader
+(define-u-bootloader-imx u-boot-novena-bootloader u-boot-novena)
+
+
+;;;
+;;; Rockchip bootloader definitions.
+;;;
+(define-syntax-rule (define-u-bootloader-rockchip def-name package)
;; SD and eMMC use the same format
- (bootloader
- (inherit u-boot-bootloader)
- (package u-boot-pinebook-pro-rk3399)
- (disk-image-installer install-pinebook-pro-rk3399-u-boot)))
-
-(define u-boot-ts7970-q-2g-1000mhz-c-bootloader
- ;; This bootloader doesn't really need to be installed, as it is read from
- ;; an SPI memory chip, not the SD card. It is copied to /boot/u-boot.imx
- ;; for convenience and should be manually flashed at the U-Boot prompt.
- (bootloader
- (inherit u-boot-bootloader)
- (package u-boot-ts7970-q-2g-1000mhz-c)
- (installer install-u-boot-ts7970-q-2g-1000mhz-c-u-boot)
- (disk-image-installer #f)))
-
-(define u-boot-sifive-unmatched-bootloader
- (bootloader
- (inherit u-boot-bootloader)
- (package u-boot-sifive-unmatched)
- (disk-image-installer install-sifive-unmatched-u-boot)))
-
-(define u-boot-starfive-visionfive2-bootloader
- (bootloader
- (inherit u-boot-bootloader)
- (package u-boot-starfive-visionfive2)
- (installer install-starfive-visionfive2-uEnv.txt)
- (disk-image-installer install-starfive-visionfive2-u-boot)))
-
-(define u-boot-qemu-riscv64-bootloader
- (bootloader
- (inherit u-boot-bootloader)
- (package u-boot-qemu-riscv64)
- (installer install-qemu-riscv64-u-boot)
- (disk-image-installer #f)))
+ (define-u-bootloader def-name package #f
+ ("idbloader.img" #f (* 64 512))
+ ("u-boot.itb" #f (* 16384 512))))
+
+(define-u-bootloader-rockchip u-boot-firefly-rk3399-bootloader
+ u-boot-firefly-rk3399)
+
+(define-u-bootloader-rockchip u-boot-orangepi-r1-plus-lts-rk3328-bootloader
+ u-boot-orangepi-r1-plus-lts-rk3328)
+
+(define-u-bootloader-rockchip u-boot-rock64-rk3328-bootloader
+ u-boot-rock64-rk3328)
+
+(define-u-bootloader-rockchip u-boot-rockpro64-rk3399-bootloader
+ u-boot-rockpro64-rk3399)
+
+(define-u-bootloader-rockchip u-boot-pinebook-pro-rk3399-bootloader
+ u-boot-pinebook-pro-rk3399)
+
+(define-u-bootloader u-boot-puma-rk3399-bootloader u-boot-puma-rk3399 #f
+ ("idbloader.img" #f (* 64 512))
+ ("u-boot.itb" #f (* 512 512)))
+
+
+;;;
+;;; Copy-only bootloader definitions.
+;;;
+
+;; These bootloaders don't really need to be installed, as they are read from
+;; an SPI memory chip or directly from the FS, not the disk.
+(define-syntax-rule (define-u-bootloader-copy def-name package file)
+ (define-u-bootloader def-name package
+ #~(install-file #$(file-append package "/libexec/" file) path)))
+
+;; user should manually install this to SPI flash
+;; TODO: write directly to SPI flash? unless wear issues are a problem.
+(define-u-bootloader-copy u-boot-ts7970-q-2g-1000mhz-c-bootloader
+ u-boot-ts7970-q-2g-1000mhz-c "u-boot.imx")
+
+(define-u-bootloader-copy u-boot-qemu-riscv64-bootloader
+ u-boot-qemu-riscv64 "u-boot.bin")
@@ -3,6 +3,7 @@
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
;;; Copyright © 2022 Timothy Sample <samplet@ngyro.com>
+;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -20,20 +21,45 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build bootloader)
+ #:autoload (guix build syscalls) (free-disk-space)
#:use-module (guix build utils)
- #:use-module (guix utils)
- #:use-module (ice-9 binary-ports)
+ #:use-module (guix diagnostics)
+ #:use-module (guix i18n)
#:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 regex)
#:use-module (rnrs io ports)
#:use-module (rnrs io simple)
- #:export (write-file-on-device
- install-efi-loader))
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-35)
+ #:export (atomic-copy
+ in-temporary-directory
+ write-file-on-device
+ install-efi))
;;;
;;; Writing utils.
;;;
+(define (atomic-copy from to)
+ (let ((pivot (string-append to ".new")))
+ (copy-file from pivot)
+ (rename-file pivot to)))
+
+(define-syntax-rule (in-temporary-directory block ...)
+ "Run blocks... while chdir'd into a temporary directory."
+ ;; mkdtemp under POSIX.1-2008 must make the dir with 700 perms
+ (let* ((tmp (or (getenv "TMPDIR") "/tmp"))
+ (dir (mkdtemp (string-append tmp "/guix-bootloader.XXXXXX")))
+ (cwd (getcwd)))
+ (dynamic-wind (lambda () (chdir dir))
+ (lambda () block ...)
+ (lambda () (chdir cwd) (delete-file-recursively dir)))))
+
(define (write-file-on-device file size device offset)
"Write SIZE bytes from FILE to DEVICE starting at OFFSET."
(call-with-input-file file
@@ -56,57 +82,78 @@ (define (write-file-on-device file size device offset)
;;; EFI bootloader.
;;;
-(define* (install-efi grub grub-config esp #:key targets)
- "Write a self-contained GRUB EFI loader to the mounted ESP using
-GRUB-CONFIG.
-
-If TARGETS is set, use its car as the GRUB image format and its cdr as
-the output filename. Otherwise, use defaults for the host platform."
- (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 (or 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 parse-bootnums
+ (make-regexp "^Boot([0-9a-fA-F]+).*[^A-Za-z]File\\(([^)]+)\\)$" regexp/newline))
-(define* (install-efi-loader grub-efi esp #:key targets)
- "Install in ESP directory the given GRUB-EFI bootloader. Configure it to
-load the Grub bootloader located in the 'Guix_image' root partition.
+;; XXX: parsing efibootmgr output may be kinda jank? a better way may exist
+(define (efi-bootnums efibootmgr)
+ "Returns '(path . bootnum) pairs for each EFI boot entry. bootnum is a string,
+and path is backslash-deliminated and relative to the ESP."
+ (let* ((pipe (open-pipe* OPEN_READ efibootmgr))
+ (text (get-string-all pipe))
+ (status (status:exit-val (close-pipe pipe))))
+ (unless (zero? status)
+ (raise-exception
+ (formatted-message (G_ "efibootmgr exited with error code ~a") status)))
+ (fold-matches parse-bootnums text '()
+ (lambda (match acc)
+ (let* ((path (match:substring match 2))
+ (bootnum (match:substring match 1)))
+ (cons (cons path bootnum) acc))))))
-If TARGETS is set, use its car as the GRUB image format and its cdr as
-the output filename. Otherwise, use defaults for the host platform."
- (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~@
- insmod part_gpt~@
- search --set=root --label Guix_image~@
- configfile /boot/grub/grub.cfg~%")))
- (install-efi grub-efi grub-config esp #:targets targets)
- (delete-file grub-config)))
+(define (install-efi efibootmgr vendir loader* disk plan)
+ "See install-efi in (gnu bootloader)."
+ (let* ((loader (string-map (match-lambda (#\/ #\\) (x x)) loader*))
+ (bootnums (filter (compose (cut string-prefix? loader <>) car)
+ (efi-bootnums efibootmgr)))
+ (plan-files (map cadr plan)))
+ (define (size file) (if (file-exists? file) (stat:size (stat file)) 0))
+ (define (vendirof file) (string-append vendir "/" file))
+ (define (loaderof file) (string-append loader "\\" file))
+ (define (delete-boot num file)
+ (invoke efibootmgr "--quiet" "--bootnum" num "--delete-bootnum")
+ (when (file-exists? file) (delete-file file)))
+ (mkdir-p vendir)
+ ;; delete old entries first, to clear up space
+ (for-each (lambda (spec) ; '(path . bootnum)
+ (let* ((s (substring (car spec) (string-length loader)))
+ (file (substring s (if (string-prefix? "\\" s) 1 0))))
+ (unless (member file plan-files)
+ (delete-boot (cdr spec) (vendirof file)))))
+ bootnums)
+ ;; new and updated entries
+ (in-temporary-directory
+ (for-each
+ (lambda (spec)
+ (let* ((builder (car spec)) (name (cadr spec))
+ (dest (vendirof name)) (loadest (loaderof name))
+ (rest (reverse (cdr (member name plan-files)))))
+ (builder name) ; build to a tmp file so we can check size
+ ;; disk space is usually limited on esps.
+ ;; try to clear space as we install new bootloaders.
+ (if (while (> (- (size name) (size dest)) (free-disk-space vendir))
+ (let ((del (find (compose file-exists? vendirof) rest)))
+ (if del (delete-file (vendirof del)) (break #t))))
+ (begin
+ (and=> (assoc-ref bootnums loadest) (cut delete-boot <> dest))
+ (warning (G_ "ESP too small for bootloader ~a!~%") name))
+ ;; esp too small for atomic copy
+ (begin
+ (copy-file name dest)
+ (unless (assoc loadest bootnums)
+ (invoke efibootmgr "--quiet" "--create-only"
+ "--label" (cddr spec) "--disk" disk "--loader" loadest))))
+ (delete-file name)))
+ plan))
+ ;; verify at least the first entry was installed
+ (unless (file-exists? (vendirof (cadr (car plan))))
+ ;; extremely fatal error so we use leave instead of raise
+ (leave (G_ "not enough space in ESP to install bootloader!
+ SYSTEM WILL NOT BOOT UNLESS THIS IS FIXED!~%")))
+ ;; boot order. recall efi-bootnums to get fresh list with new installs
+ ;; some UEFI systems will refuse to acknowledge the existence of boot
+ ;; entries unless they're in bootorder, so just shove everything in there
+ (invoke efibootmgr "--quiet" "--bootorder"
+ (let ((num (cute assoc-ref (efi-bootnums efibootmgr) <>))) ; cute is eager
+ (string-join (filter-map (compose num loaderof) plan-files) ",")))))
@@ -28,6 +28,7 @@ (define-module (gnu build image)
#:use-module (guix build store-copy)
#:use-module (guix build syscalls)
#:use-module (guix build utils)
+ #:use-module (guix deprecation)
#:use-module (guix store database)
#:use-module (guix utils)
#:use-module (gnu build bootloader)
@@ -181,30 +182,13 @@ (define* (register-closure prefix closure
#: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-efi-partition root . rest)
+ (mkdir-p (string-append root "/EFI")))
+
+(define-deprecated/alias initialize-efi32-partition initialize-efi-partition)
(define* (initialize-root-partition root
#:key
- bootcfg
- bootcfg-location
- bootloader-package
- bootloader-installer
(copy-closures? #t)
(deduplicate? #t)
references-graphs
@@ -251,18 +235,10 @@ (define* (initialize-root-partition root
(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))))
+ (rename-file tmp-store root-store))))
(define* (make-iso9660-image xorriso grub-mkrescue-environment
- grub bootcfg system-directory root target
+ grub grub.dir system-directory root target
#:key (volume-id "Guix_image") (volume-uuid #f)
register-closures? (references-graphs '())
(compression? #t))
@@ -321,7 +297,7 @@ (define* (make-iso9660-image xorriso grub-mkrescue-environment
(apply invoke grub-mkrescue
(string-append "--xorriso=" grub-mkrescue-sed.sh)
"-o" target
- (string-append "boot/grub/grub.cfg=" bootcfg)
+ (string-append "boot/grub=" grub.dir)
root
"--"
;; Set all timestamps to 1.
@@ -25,8 +25,7 @@ (define-module (gnu build install)
#:use-module (guix build store-copy)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
- #:export (install-boot-config
- evaluate-populate-directive
+ #:export (evaluate-populate-directive
populate-root-file-system
install-database-and-gc-roots
populate-single-profile-directory
@@ -42,19 +41,6 @@ (define-module (gnu build install)
;;;
;;; Code:
-(define (install-boot-config bootcfg bootcfg-location mount-point)
- "Atomically copy BOOTCFG into BOOTCFG-LOCATION on the MOUNT-POINT. Note
-that the caller must make sure that BOOTCFG is registered as a GC root so
-that the fonts, background images, etc. referred to by BOOTCFG are not GC'd."
- (let* ((target (string-append mount-point bootcfg-location))
- (pivot (string-append target ".new")))
- (mkdir-p (dirname target))
-
- ;; Copy BOOTCFG instead of just symlinking it, because symlinks won't
- ;; work when /boot is on a separate partition. Do that atomically.
- (copy-file bootcfg pivot)
- (rename-file pivot target)))
-
(define* (evaluate-populate-directive directive target
#:key
(default-gid 0)
@@ -35,6 +35,7 @@ (define-module (gnu image)
partition-label
partition-uuid
partition-flags
+ partition-target
partition-initializer
image
@@ -131,6 +132,8 @@ (define-record-type* <partition> partition make-partition
(flags partition-flags
(default '()) ;list of symbols
(sanitize validate-partition-flags))
+ (target partition-target ; bootloader target type: symbol | #f
+ (default #f))
(initializer partition-initializer
(default #false))) ;gexp | #false
@@ -1454,15 +1454,19 @@ (define (root-user-partition? partition)
(define (bootloader-configuration user-partitions)
"Return the bootloader configuration field for USER-PARTITIONS."
- (let* ((root-partition (find root-user-partition?
- user-partitions))
+ (let* ((root-partition (find root-user-partition? user-partitions))
(root-partition-disk (user-partition-disk-file-name root-partition)))
`((bootloader-configuration
,@(if (efi-installation?)
`((bootloader grub-efi-bootloader)
- (targets (list ,(default-esp-mount-point))))
+ (targets (list (bootloader-target
+ (type 'esp)
+ (path ,(default-esp-mount-point))))))
`((bootloader grub-bootloader)
- (targets (list ,root-partition-disk))))
+ (targets (list (bootloader-target
+ (type 'disk)
+ ;; TODO: we should provide a uuid or label here
+ (device ,root-partition-disk))))))
;; XXX: Assume we defined the 'keyboard-layout' field of
;; <operating-system> right above.
@@ -505,18 +505,15 @@ (define (deploy-managed-host machine)
(machine-ssh-session machine)
(machine-become-command machine)))
- (mlet %store-monad ((_ (check-deployment-sanity machine))
- (boot-alternatives (machine->boot-alternatives machine)))
+ (mlet %store-monad ((_ (check-deployment-sanity machine)))
;; Make sure code that check %CURRENT-SYSTEM, such as
;; %BASE-INITRD-MODULES, gets to see the right value.
(parameterize ((%current-system system)
(%current-target-system #f))
(let* ((os (machine-operating-system machine))
(eval (cut machine-remote-eval machine <>))
- (menu-entries (map boot-parameters->menu-entry
- (map boot-alternative-parameters boot-alternatives)))
- (bootloader-configuration (operating-system-bootloader os))
- (bootcfg (operating-system-bootcfg os menu-entries)))
+ (bootloader-config (operating-system-bootloader os))
+ (bootmeta (operating-system-bootmeta os)))
(define-syntax-rule (eval/error-handling condition handler ...)
;; Return a wrapper around EVAL such that HANDLER is evaluated if an
;; exception is raised.
@@ -548,13 +545,15 @@ (define (deploy-managed-host machine)
(inferior-exception-arguments
c)))
os)
- (install-bootloader (eval/error-handling c
- (raise (formatted-message
- (G_ "\
+ (mlet %store-monad
+ ((boot-alternatives (machine->boot-alternatives machine)))
+ (apply install-bootloader
+ (eval/error-handling c
+ (raise (formatted-message
+ (G_ "\
failed to install bootloader on '~a':~%~{~s ~}~%")
- host
- (inferior-exception-arguments c))))
- bootloader-configuration bootcfg)))))))))
+ host (inferior-exception-arguments c))))
+ bootloader-config boot-alternatives bootmeta))))))))))
;;;
@@ -585,32 +584,28 @@ (define (roll-back-managed-host machine)
(define roll-back-failure
(condition (&message (message (G_ "could not roll-back machine")))))
- (mlet* %store-monad ((boot-alternatives (machine->boot-alternatives machine))
- (_ -> (if (< (length boot-alternatives) 2)
- (raise roll-back-failure)))
- (chosen-alternative (second boot-alternatives))
- (parameters (boot-alternative-parameters chosen-alternative))
- (entries -> (list (boot-parameters->menu-entry parameters)))
- (locale -> (boot-parameters-locale parameters))
- (crypto-dev -> (boot-parameters-store-crypto-devices parameters))
- (store-dir -> (boot-parameters-store-directory-prefix parameters))
- (old-entries -> (map boot-parameters->menu-entry
- (map boot-alternative-parameters
- (drop boot-alternatives 2))))
- (bootloader -> (operating-system-bootloader
- (machine-operating-system machine)))
- (bootcfg (lower-object
- ((bootloader-configuration-file-generator
- (bootloader-configuration-bootloader
- bootloader))
- bootloader entries
- #:locale locale
- #:store-crypto-devices crypto-dev
- #:store-directory-prefix store-dir
- #:old-entries old-entries)))
- (remote-result (machine-remote-eval machine remote-exp)))
- (when (eqv? 'error remote-result)
- (raise roll-back-failure))))
+ (mlet %store-monad ((boot-alternatives (machine->boot-alternatives machine)))
+ (when (< (length boot-alternatives) 2) (raise roll-back-failure))
+ (mlet* %store-monad ((remote-result (machine-remote-eval machine remote-exp)))
+ (mwhen (eqv? 'error remote-result)
+ (raise roll-back-failure)))
+
+ (mlet* %store-monad ((os -> (machine-operating-system machine))
+ (chosen -> (cadr boot-alternatives))
+ (alts -> (cons* chosen (car boot-alternatives)
+ (cddr boot-alternatives)))
+ (params -> (boot-alternative-parameters chosen))
+ (locale -> (boot-parameters-locale chosen))
+ (crypto-dev -> (boot-parameters-store-crypto-devices
+ chosen))
+ (store-pre -> (boot-parameters-store-directory-prefix
+ chosen)))
+ (install-bootloader (cute machine-remote-eval machine <>)
+ (operating-system-bootloader os)
+ alts
+ #:locale locale
+ #:store-crypto-devices crypto-dev
+ #:store-directory-prefix store-pre))))
;;;
@@ -498,92 +498,6 @@ (define-public grub-hybrid
basename))))
(scandir input-dir)))))))))))
-(define-public (make-grub-efi-netboot name subdir)
- "Make a grub-efi-netboot package named NAME, which will be able to boot over
-network via TFTP by accessing its files in the SUBDIR of a TFTP root directory.
-This package is also able to boot from local storage devices.
-
-A bootloader-installer basically needs to copy the package content into the
-bootloader-target directory, which will usually be the TFTP root, as
-'grub-mknetdir' will be invoked already during the package creation.
-
-Alternatively the bootloader-target directory can be a mounted EFI System
-Partition (ESP), or a similar partition with a FAT file system, for booting
-from local storage devices.
-
-The name of the GRUB EFI binary will conform to the UEFI specification for
-removable media. Depending on the system it will be e.g. bootx64.efi or
-bootaa64.efi below SUBDIR.
-
-The SUBDIR argument needs to be set to \"efi/boot\" to create a package which
-conforms to the UEFI specification for removable media.
-
-The SUBDIR argument defaults to \"efi/Guix\", as it is also the case for
-'grub-efi-bootloader'."
- (package
- (name name)
- (version (package-version grub-efi))
- ;; Source is not needed, but it cannot be omitted.
- (source #f)
- (build-system trivial-build-system)
- (arguments
- (let* ((system (string-split (nix-system->gnu-triplet
- (or (%current-target-system)
- (%current-system)))
- #\-))
- (arch (first system))
- (boot-efi
- (match system
- ;; These are the supportend systems and the names defined by
- ;; the UEFI standard for removable media.
- (("i686" _ ...) "/bootia32.efi")
- (("x86_64" _ ...) "/bootx64.efi")
- (("arm" _ ...) "/bootarm.efi")
- (("aarch64" _ ...) "/bootaa64.efi")
- (("riscv" _ ...) "/bootriscv32.efi")
- (("riscv64" _ ...) "/bootriscv64.efi")
- ;; Other systems are not supported, although defined.
- ;; (("riscv128" _ ...) "/bootriscv128.efi")
- ;; (("ia64" _ ...) "/bootia64.efi")
- ((_ ...) #f)))
- (core-efi (string-append
- ;; This is the arch dependent file name of GRUB, e.g.
- ;; i368-efi/core.efi or arm64-efi/core.efi.
- (match arch
- ("i686" "i386")
- ("aarch64" "arm64")
- ("riscv" "riscv32")
- (_ arch))
- "-efi/core.efi")))
- (list
- #:modules '((guix build utils))
- #:builder
- #~(begin
- (use-modules (guix build utils))
- (let* ((bootloader #$(this-package-input "grub-efi"))
- (net-dir #$output)
- (sub-dir (string-append net-dir "/" #$subdir "/"))
- (boot-efi (string-append sub-dir #$boot-efi))
- (core-efi (string-append sub-dir #$core-efi)))
- ;; Install GRUB, which refers to the grub.cfg, with support for
- ;; encrypted partitions,
- (setenv "GRUB_ENABLE_CRYPTODISK" "y")
- (invoke/quiet (string-append bootloader "/bin/grub-mknetdir")
- (string-append "--net-directory=" net-dir)
- (string-append "--subdir=" #$subdir)
- ;; These modules must be pre-loaded to allow booting
- ;; from an ESP or a similar partition with a FAT
- ;; file system.
- (string-append "--modules=part_msdos part_gpt fat"))
- ;; Move GRUB's core.efi to the removable media name.
- (false-if-exception (delete-file boot-efi))
- (rename-file core-efi boot-efi))))))
- (inputs (list grub-efi))
- (synopsis (package-synopsis grub-efi))
- (description (package-description grub-efi))
- (home-page (package-home-page grub-efi))
- (license (package-license grub-efi))))
-
(define-public syslinux
(let ((commit "bb41e935cc83c6242de24d2271e067d76af3585c"))
(package
@@ -19,8 +19,6 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu packages raspberry-pi)
- #:use-module (gnu bootloader)
- #:use-module (gnu bootloader grub)
#:use-module (gnu packages)
#:use-module (gnu packages admin)
#:use-module (gnu packages algebra)
@@ -328,22 +326,6 @@ (define (make-raspi-bcm28-dtbs linux)
(format #f "The device-tree files for Raspberry Pi models from ~a."
(package-name linux)))))
-(define-public grub-efi-bootloader-chain-raspi-64
- ;; A bootloader capable to boot a Raspberry Pi over network via TFTP or from
- ;; a local storage like a micro SD card. It neither installs firmware nor
- ;; device-tree files for the Raspberry Pi. It just assumes them to be
- ;; existing in boot/efi in the same way that some UEFI firmware with ACPI
- ;; data is usually assumed to be existing on PCs. It creates firmware
- ;; configuration files and a bootloader-chain with U-Boot to provide an EFI
- ;; API for the final GRUB bootloader. It also serves as a blue-print to
- ;; create an a custom bootloader-chain with firmware and device-tree
- ;; packages or files.
- (efi-bootloader-chain grub-efi-netboot-removable-bootloader
- #:packages (list u-boot-rpi-arm64-efi-bin)
- #:files (list %raspi-config-txt
- %raspi-bcm27-dtb-txt
- %raspi-u-boot-bootloader-txt)))
-
(define (make-raspi-defconfig arch defconfig sha256-as-base32)
"Make for the architecture ARCH a file-like object from the DEFCONFIG file
with the hash SHA256-AS-BASE32. This object can be used as the #:defconfig
@@ -140,10 +140,11 @@ (define-module (gnu system)
operating-system-derivation
operating-system-profile
- operating-system-bootcfg
+ operating-system-bootmeta
operating-system-etc-directory
operating-system-locale-directory
operating-system-boot-script
+ operating-system-boot-parameters
operating-system-uuid
operating-system-with-gc-roots
@@ -171,6 +172,9 @@ (define-module (gnu system)
;;;
;;; Code:
+(define (convert-bootloader-field bootloader)
+ (if (list? bootloader) bootloader (list bootloader)))
+
(define-with-syntax-properties (warn-hosts-file-field-deprecation
(value properties))
(when value
@@ -193,7 +197,9 @@ (define-record-type* <operating-system> operating-system
(default %default-kernel-arguments)) ; list of gexps/strings
(hurd operating-system-hurd
(default #f)) ; package
- (bootloader operating-system-bootloader) ; <bootloader-configuration>
+ (bootloader operating-system-bootloader ; <bootloader-configuration>
+ (default '())
+ (sanitize convert-bootloader-field))
(label operating-system-label ; string
(thunked)
(default (operating-system-default-label this-operating-system)))
@@ -1208,30 +1214,17 @@ (define (operating-system-store-file-system os)
"Return the file system that contains the store of OS."
(store-file-system (operating-system-file-systems os)))
-(define* (operating-system-bootcfg os #:optional (old-entries '()))
- "Return the bootloader configuration file for OS. Use OLD-ENTRIES,
-a list of <menu-entry>, to populate the \"old entries\" menu."
+(define (operating-system-bootmeta os)
+ "Return operating system information to be passed to the bootloader
+installers."
(let* ((file-systems (operating-system-file-systems os))
+ (store-root (btrfs-store-subvolume-file-name file-systems))
(root-fs (operating-system-root-file-system os))
- (root-device (file-system-device root-fs))
(locale (operating-system-locale os))
- (crypto-devices (operating-system-bootloader-crypto-devices os))
- (params (operating-system-boot-parameters
- os root-device
- #:system-kernel-arguments? #t))
- (entry (boot-parameters->menu-entry params))
- (bootloader-conf (operating-system-bootloader os)))
-
- (define generate-config-file
- (bootloader-configuration-file-generator
- (bootloader-configuration-bootloader bootloader-conf)))
-
- (generate-config-file bootloader-conf (list entry)
- #:old-entries old-entries
- #:locale locale
- #:store-crypto-devices crypto-devices
- #:store-directory-prefix
- (btrfs-store-subvolume-file-name file-systems))))
+ (crypto-devices (operating-system-bootloader-crypto-devices os)))
+ (list #:store-crypto-devices crypto-devices
+ #:store-directory-prefix store-root
+ #:locale locale)))
(define (operating-system-multiboot-modules os)
(if (operating-system-hurd os) (hurd-multiboot-modules os) '()))
@@ -1295,9 +1288,9 @@ (define* (operating-system-boot-parameters os root-device
(file-systems (operating-system-file-systems os))
(crypto-devices (operating-system-bootloader-crypto-devices os))
(locale (operating-system-locale os))
- (bootloader (bootloader-configuration-bootloader
- (operating-system-bootloader os)))
- (bootloader-name (bootloader-name bootloader))
+ (bootloader (map bootloader-configuration-bootloader
+ (operating-system-bootloader os)))
+ (bootloader-name (map bootloader-name bootloader))
(label (operating-system-label os))
(multiboot-modules (operating-system-multiboot-modules os)))
(boot-parameters
@@ -81,6 +81,7 @@ (define-module (gnu system boot)
epoch->date-string
decorated-boot-label
boot-parameters->menu-entry
+ boot-alternative->menu-entry
ensure-not-/dev
system-linux-image-file-name))
@@ -171,7 +172,8 @@ (define (read-boot-parameters port)
(bootloader-name
(match (assq 'bootloader-name rest)
- ((_ args) args)
+ ((_ (args ...)) args)
+ ((_ args) (list args))
(#f 'grub))) ; for compatibility reasons.
(bootloader-menu-entries
@@ -340,6 +342,7 @@ (define (boot-parameters->menu-entry conf)
(label (boot-parameters-label conf))
(device (boot-parameters-store-device conf))
(device-mount-point (boot-parameters-store-mount-point conf))
+ (device-subvol (boot-parameters-store-directory-prefix conf))
(linux (and (not multiboot?) kernel))
(linux-arguments (if (not multiboot?)
(boot-parameters-kernel-arguments conf)
@@ -353,6 +356,9 @@ (define (boot-parameters->menu-entry conf)
(boot-parameters-multiboot-modules conf)
'())))))
+(define boot-alternative->menu-entry
+ (compose boot-parameters->menu-entry boot-alternative-parameters))
+
(define (ensure-not-/dev device)
"If DEVICE starts with a slash, return #f. This is meant to filter out
Linux device names such as /dev/sda, and to preserve GRUB device names and
@@ -6,6 +6,7 @@
;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
+;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -23,6 +24,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu system image)
+ #:use-module (guix deprecation)
#:use-module (guix diagnostics)
#:use-module (guix discovery)
#:use-module (guix gexp)
@@ -42,6 +44,7 @@ (define-module (gnu system image)
#:use-module (gnu services base)
#:use-module (gnu system)
#:use-module (gnu system accounts)
+ #:use-module (gnu system boot)
#:use-module (gnu system file-systems)
#:use-module (gnu system linux-container)
#:use-module (gnu system uuid)
@@ -133,12 +136,10 @@ (define esp-partition
;; FAT-ness is based on file system size (16 in this case).
(file-system "vfat")
(flags '(esp))
- (initializer (gexp initialize-efi-partition))))
+ (target 'esp)
+ (initializer #~initialize-efi-partition)))
-(define esp32-partition
- (partition
- (inherit esp-partition)
- (initializer (gexp initialize-efi32-partition))))
+(define-deprecated/alias esp32-partition esp-partition)
(define root-partition
(partition
@@ -149,6 +150,7 @@ (define root-partition
;; with U-Boot.
(file-system-options (list "-O" "^metadata_csum,^64bit"))
(flags '(boot))
+ (target 'root)
(initializer (gexp initialize-root-partition))))
(define mbr-disk-image
@@ -173,11 +175,7 @@ (define efi-disk-image
(partition-table-type 'gpt)
(partitions (list esp-partition root-partition))))
-(define efi32-disk-image
- (image-without-os
- (format 'disk-image)
- (partition-table-type 'gpt)
- (partitions (list esp32-partition root-partition))))
+(define-deprecated/alias efi32-disk-image efi-disk-image)
(define iso9660-image
(image-without-os
@@ -238,10 +236,7 @@ (define efi-raw-image-type
(name 'efi-raw)
(constructor (cut image-with-os efi-disk-image <>))))
-(define efi32-raw-image-type
- (image-type
- (name 'efi32-raw)
- (constructor (cut image-with-os efi32-disk-image <>))))
+(define-deprecated/alias efi32-raw-image-type efi-raw-image-type)
(define qcow2-image-type
(image-type
@@ -350,10 +345,6 @@ (define (find-root-partition image)
(raise (formatted-message
(G_ "image lacks a partition with the 'boot' flag")))))
-(define (root-partition-index image)
- "Return the index of the root partition of the given IMAGE."
- (1+ (srfi-1:list-index root-partition? (image-partitions image))))
-
;;
;; Disk image.
@@ -362,8 +353,8 @@ (define (root-partition-index image)
(define* (system-disk-image image
#:key
(name "disk-image")
- bootcfg
- bootloader
+ bootloader-config
+ bootmeta
register-closures?
(inputs '()))
"Return as a file-like object, the disk-image described by IMAGE. Said
@@ -380,6 +371,28 @@ (define* (system-disk-image image
(define genimage-name "image")
+ (define (targets current)
+ ;; provides list of target overrides for a given CURRENT partition, which
+ ;; may be #f for the full-disk targets.
+
+ ;; XXX: how we pass paths is v much a hack
+ (cons (bootloader-target
+ (type 'disk)
+ (device (and (not current) (string-append "images/" genimage-name)))
+ (expected? (->bool current)))
+ (map (lambda (partition)
+ (let ((current? (and current (eq? (partition-target partition)
+ (partition-target current)))))
+ (bootloader-target
+ (type (partition-target partition))
+ (expected? (not current?))
+ (path (and current? "tmp-root"))
+ (offset #f)
+ (file-system (partition-file-system partition))
+ (label (partition-label partition))
+ (uuid (partition-uuid partition)))))
+ (filter partition-target (image-partitions image)))))
+
(define (image->genimage-cfg image)
;; Return as a file-like object, the genimage configuration file
;; describing the given IMAGE.
@@ -460,7 +473,8 @@ (define* (system-disk-image image
(list dosfstools fakeroot mtools))
(else
'())))
- (image-root "tmp-root"))
+ (image-root (string-append (getcwd) "/tmp-root"))
+ (copy-closures? (not #$(image-shared-store? image))))
(sql-schema #$schema)
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
@@ -476,18 +490,13 @@ (define* (system-disk-image image
(initializer image-root
#:references-graphs '#$graph
#:deduplicate? #f
- #:copy-closures? (not
- #$(image-shared-store? image))
- #:system-directory #$os
- #:grub-efi #+grub-efi
- #:grub-efi32 #+grub-efi32
- #:bootloader-package
- #+(bootloader-package bootloader)
- #:bootloader-installer
- #+(bootloader-installer bootloader)
- #:bootcfg #$bootcfg
- #:bootcfg-location
- #$(bootloader-configuration-file bootloader))
+ #:copy-closures? copy-closures?
+ #:system-directory #$os)
+ ;; no point installing a bootloader if we don't populate store
+ (when copy-closures?
+ ;; root-offset isn't necessary - we override 'root
+ #$(bootloader-configurations->gexp bootloader-config bootmeta
+ #:overrides (targets partition)))
(make-partition-image #$(partition->gexp partition)
#$output
image-root)))))
@@ -534,14 +543,6 @@ (define* (system-disk-image image
(image-partition-table-type image)))
(else "")))
- (when (and (memq (bootloader-name bootloader)
- '(grub-efi grub-efi32 grub-efi-removable-bootloader))
- (not
- (gpt-image? image)))
- (raise
- (formatted-message
- (G_ "EFI bootloader required with GPT partitioning"))))
-
(let* ((format (image-format image))
(image-type (format->image-type format))
(image-type-options (genimage-type-options image-type image))
@@ -552,13 +553,15 @@ (define* (system-disk-image image
(let ((format (@ (ice-9 format) format)))
(call-with-output-file #$output
(lambda (port)
- (format port
- "\
+ (format port "\
image ~a {
~/~a {~a}
~{~a~^~%~}
-}~%" #$genimage-name #$image-type #$image-type-options
- (list #$@partitions-config))))))))
+}~%"
+ #$genimage-name
+ #$image-type
+ #$image-type-options
+ (list #$@partitions-config))))))))
(computed-file "genimage.cfg" builder)))
(let* ((image-name (image-name image))
@@ -570,17 +573,13 @@ (define* (system-disk-image image
(builder
(with-imported-modules*
(let ((inputs '#+(list genimage coreutils findutils qemu-minimal))
- (bootloader-installer
- #+(bootloader-disk-image-installer bootloader))
(out-image (string-append "images/" #$genimage-name)))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
(genimage #$(image->genimage-cfg image))
- ;; Install the bootloader directly on the disk-image.
- (when bootloader-installer
- (bootloader-installer
- #+(bootloader-package bootloader)
- #$(root-partition-index image)
- out-image))
+ ;; don't install bootloader unless installing store
+ (unless #$(image-shared-store? image)
+ #$(bootloader-configurations->gexp bootloader-config bootmeta
+ #:overrides (targets #f)))
(convert-disk-image out-image '#$format #$output)))))
(computed-file name builder
#:local-build? #f ;too I/O-intensive
@@ -600,8 +599,8 @@ (define (has-guix-service-type? os)
(define* (system-iso9660-image image
#:key
(name "image.iso")
- bootcfg
- bootloader
+ bootloader-config
+ bootmeta
register-closures?
(inputs '())
(grub-mkrescue-environment '()))
@@ -621,7 +620,6 @@ (define* (system-iso9660-image image
(uuid-bytevector (partition-uuid partition)))))
(let* ((os (image-operating-system image))
- (bootloader (bootloader-package bootloader))
(compression? (image-compression? image))
(substitutable? (image-substitutable? image))
(schema (local-file (search-path %load-path
@@ -629,6 +627,14 @@ (define* (system-iso9660-image image
(graph (match inputs
(((names . _) ...)
names)))
+ (config (bootloader-configuration
+ (bootloader grub-bootloader)
+ (targets (list (bootloader-target
+ (type 'root)
+ (path "tmp-root"))
+ (bootloader-target
+ (type 'install)
+ (path "boot/grub"))))))
(builder
(with-imported-modules*
(let* ((inputs '#$(list parted e2fsprogs dosfstools xorriso
@@ -649,10 +655,12 @@ (define* (system-iso9660-image image
#:references-graphs '#$graph
#:deduplicate? #f
#:system-directory #$os)
+
(make-iso9660-image #$xorriso
'#$grub-mkrescue-environment
- #$bootloader
- #$bootcfg
+ #$grub-hybrid
+ #$(apply grub.dir grub-hybrid
+ #:bootloader-config config bootmeta)
#$os
image-root
#$output
@@ -954,11 +962,7 @@ (define (operating-system-for-image image)
file-systems
#:volatile-root? volatile-root?
rest)))
- (bootloader (if (eq? format 'iso9660)
- (bootloader-configuration
- (inherit
- (operating-system-bootloader base-os))
- (bootloader grub-mkrescue-bootloader))
+ (bootloader (if (eq? format 'iso9660) '()
(operating-system-bootloader base-os)))
(file-systems (cons (file-system
(mount-point "/")
@@ -1007,17 +1011,28 @@ (define* (system-image image)
(image* (image-with-os* image os))
(image-format (image-format image))
(register-closures? (has-guix-service-type? os))
- (bootcfg (operating-system-bootcfg os))
- (bootloader (bootloader-configuration-bootloader
- (operating-system-bootloader os))))
+ ;; force removable - images don't have efivarfs
+ (bootloader-config (map (lambda (c) (bootloader-configuration
+ (inherit c)
+ (efi-removable? #t)))
+ (operating-system-bootloader os)))
+ (alt (boot-alternative
+ (generation 1)
+ (system-path "/var/guix/profiles/system-1-link")
+ (epoch 0)
+ (parameters (operating-system-boot-parameters os
+ (partition-uuid (find-root-partition image*))
+ #:system-kernel-arguments? #t))))
+ (bootmeta (cons* #:current-boot-alternative alt
+ #:old-boot-alternatives '()
+ (operating-system-bootmeta os))))
(cond
((memq image-format '(disk-image compressed-qcow2))
(system-disk-image image*
- #:bootcfg bootcfg
- #:bootloader bootloader
+ #:bootloader-config bootloader-config
+ #:bootmeta bootmeta
#:register-closures? register-closures?
- #:inputs `(("system" ,os)
- ("bootcfg" ,bootcfg))))
+ #:inputs `(("system" ,os))))
((memq image-format '(docker))
(system-docker-image image*))
((memq image-format '(tarball))
@@ -1027,11 +1042,10 @@ (define* (system-image image)
((memq image-format '(iso9660))
(system-iso9660-image
image*
- #:bootcfg bootcfg
- #:bootloader bootloader
+ #:bootloader-config bootloader-config
+ #:bootmeta bootmeta
#:register-closures? register-closures?
- #:inputs `(("system" ,os)
- ("bootcfg" ,bootcfg))
+ #:inputs `(("system" ,os))
;; Make sure to use a mode that does no imply
;; HFS+ tree creation that may fail with:
;;
@@ -41,9 +41,7 @@ (define-module (gnu system images hurd)
(define hurd-barebones-os
(operating-system
(inherit %hurd-default-operating-system)
- (bootloader (bootloader-configuration
- (bootloader grub-minimal-bootloader)
- (targets '("/dev/sdX"))))
+ (bootloader (bootloader-configuration (bootloader grub-minimal-bootloader)))
(file-systems (cons (file-system
(device (file-system-label "my-root"))
(mount-point "/")
@@ -39,8 +39,7 @@ (define novena-barebones-os
(timezone "Europe/Paris")
(locale "en_US.utf8")
(bootloader (bootloader-configuration
- (bootloader u-boot-novena-bootloader)
- (targets '("/dev/vda"))))
+ (bootloader u-boot-novena-bootloader)))
(initrd-modules '())
(kernel linux-libre-arm-generic)
(kernel-arguments '("console=ttymxc1,115200"))
@@ -39,8 +39,7 @@ (define orangepi-r1-plus-lts-rk3328-barebones-os
(timezone "Europe/Amsterdam")
(locale "en_US.utf8")
(bootloader (bootloader-configuration
- (bootloader u-boot-orangepi-r1-plus-lts-rk3328-bootloader)
- (targets '("/dev/mmcblk0"))))
+ (bootloader u-boot-orangepi-r1-plus-lts-rk3328-bootloader)))
(initrd-modules '())
(kernel linux-libre-arm64-generic)
(file-systems (cons (file-system
@@ -41,8 +41,7 @@ (define pine64-barebones-os
(timezone "Europe/Paris")
(locale "en_US.utf8")
(bootloader (bootloader-configuration
- (bootloader u-boot-pine64-lts-bootloader)
- (targets '("/dev/vda"))))
+ (bootloader u-boot-pine64-lts-bootloader)))
(initrd-modules '())
(kernel linux-libre-arm64-generic)
(file-systems (cons (file-system
@@ -38,8 +38,7 @@ (define pinebook-pro-barebones-os
(timezone "Europe/Paris")
(locale "en_US.utf8")
(bootloader (bootloader-configuration
- (bootloader u-boot-pinebook-pro-rk3399-bootloader)
- (targets '("/dev/vda"))))
+ (bootloader u-boot-pinebook-pro-rk3399-bootloader)))
(initrd-modules '())
(kernel linux-libre-arm64-generic)
(file-systems (cons (file-system
@@ -39,8 +39,7 @@ (define rock64-barebones-os
(timezone "Europe/Oslo")
(locale "en_US.utf8")
(bootloader (bootloader-configuration
- (bootloader u-boot-rock64-rk3328-bootloader)
- (targets '("/dev/sda"))))
+ (bootloader u-boot-rock64-rk3328-bootloader)))
(initrd-modules '())
(kernel linux-libre-arm64-generic)
(file-systems (cons (file-system
@@ -39,8 +39,7 @@ (define unmatched-barebones-os
(timezone "Asia/Jerusalem")
(locale "en_US.utf8")
(bootloader (bootloader-configuration
- (bootloader u-boot-sifive-unmatched-bootloader)
- (targets '("/dev/vda"))))
+ (bootloader u-boot-sifive-unmatched-bootloader)))
(initrd-modules '())
(kernel linux-libre-riscv64-generic)
(file-systems (cons (file-system
@@ -62,8 +62,7 @@ (define visionfive2-barebones-os
(timezone "Etc/UTC")
(locale "en_US.utf8")
(bootloader (bootloader-configuration
- (bootloader u-boot-starfive-visionfive2-bootloader)
- (targets '("/dev/mmcblk0"))))
+ (bootloader u-boot-starfive-visionfive2-bootloader)))
(file-systems (cons (file-system
(device (file-system-label "Guix_image"))
(mount-point "/")
@@ -127,16 +127,6 @@ (define dummy-package
(description #f)
(license (fsdg-compatible "dummy"))))
-(define dummy-bootloader
- (bootloader
- (name 'dummy-bootloader)
- (package dummy-package)
- (configuration-file "/dev/null")
- (configuration-file-generator
- (lambda (. _rest)
- (plain-file "dummy-bootloader" "")))
- (installer #~(const #t))))
-
(define dummy-kernel dummy-package)
(define (dummy-initrd . _rest)
@@ -146,9 +136,7 @@ (define-public wsl-os
(operating-system
(host-name "gnu")
(timezone "Etc/UTC")
- (bootloader
- (bootloader-configuration
- (bootloader dummy-bootloader)))
+ ;; no bootloader
(kernel dummy-kernel)
(initrd dummy-initrd)
(initrd-modules '())
@@ -77,8 +77,7 @@ (define-module (gnu system install)
rock64-installation-os
rockpro64-installation-os
rk3399-puma-installation-os
- wandboard-installation-os
- os-with-u-boot))
+ wandboard-installation-os))
;;; Commentary:
;;;
@@ -503,9 +502,7 @@ (define installation-os
(timezone "Europe/Paris")
(locale "en_US.utf8")
(name-service-switch %mdns-host-lookup-nss)
- (bootloader (bootloader-configuration
- (bootloader grub-bootloader)
- (targets '("/dev/sda"))))
+ (bootloader (bootloader-configuration (bootloader grub-bootloader)))
(label (string-append "GNU Guix installation "
(or (getenv "GUIX_DISPLAYED_VERSION")
(package-version guix))))
@@ -555,30 +552,14 @@ (define installation-os
%installer-disk-utilities
%base-packages))))
-(define* (os-with-u-boot os board #:key (bootloader-target "/dev/mmcblk0")
- (triplet "arm-linux-gnueabihf"))
- "Given OS, amend it with the u-boot bootloader for BOARD,
-installed to BOOTLOADER-TARGET (a drive), compiled for TRIPLET.
-
-If you want a serial console, make sure to specify one in your
-operating-system's kernel-arguments (\"console=ttyS0\" or similar)."
- (operating-system (inherit os)
- (bootloader (bootloader-configuration
- (bootloader (bootloader (inherit u-boot-bootloader)
- (package (make-u-boot-package board triplet))))
- (targets (list bootloader-target))))))
-
-(define* (embedded-installation-os bootloader bootloader-target tty
- #:key (extra-modules '()))
+(define* (embedded-installation-os bootloader tty #:key (extra-modules '()))
"Return an installation os for embedded systems.
The initrd gets the extra modules EXTRA-MODULES.
A getty is provided on TTY.
The bootloader BOOTLOADER is installed to BOOTLOADER-TARGET."
(operating-system
(inherit installation-os)
- (bootloader (bootloader-configuration
- (bootloader bootloader)
- (targets (list bootloader-target))))
+ (bootloader (bootloader-configuration (bootloader bootloader)))
(kernel linux-libre)
(kernel-arguments
(cons (string-append "console=" tty)
@@ -587,7 +568,6 @@ (define* (embedded-installation-os bootloader bootloader-target tty
(define beaglebone-black-installation-os
(embedded-installation-os u-boot-beaglebone-black-bootloader
- "/dev/sda"
"ttyO0"
#:extra-modules
;; This module is required to mount the sd card.
@@ -596,77 +576,62 @@ (define beaglebone-black-installation-os
(define a20-olinuxino-lime-installation-os
(embedded-installation-os u-boot-a20-olinuxino-lime-bootloader
- "/dev/mmcblk0" ; SD card storage
"ttyS0"))
(define a20-olinuxino-lime2-emmc-installation-os
(embedded-installation-os u-boot-a20-olinuxino-lime2-bootloader
- "/dev/mmcblk1" ; eMMC storage
"ttyS0"))
(define a20-olinuxino-micro-installation-os
(embedded-installation-os u-boot-a20-olinuxino-micro-bootloader
- "/dev/mmcblk0" ; SD card storage
"ttyS0"))
(define bananapi-m2-ultra-installation-os
(embedded-installation-os u-boot-bananapi-m2-ultra-bootloader
- "/dev/mmcblk1" ; eMMC storage
"ttyS0"))
(define firefly-rk3399-installation-os
(embedded-installation-os u-boot-firefly-rk3399-bootloader
- "/dev/mmcblk0" ; SD card/eMMC (SD priority) storage
"ttyS2")) ; UART2 connected on the Pi2 bus
(define mx6cuboxi-installation-os
(embedded-installation-os u-boot-mx6cuboxi-bootloader
- "/dev/mmcblk0" ; SD card storage
"ttymxc0"))
(define novena-installation-os
(embedded-installation-os u-boot-novena-bootloader
- "/dev/mmcblk1" ; SD card storage
"ttymxc1"))
(define nintendo-nes-classic-edition-installation-os
(embedded-installation-os u-boot-nintendo-nes-classic-edition-bootloader
- "/dev/mmcblk0" ; SD card (solder it yourself)
"ttyS0"))
(define orangepi-r1-plus-lts-rk3328-installation-os
(embedded-installation-os u-boot-orangepi-r1-plus-lts-rk3328-bootloader
- "/dev/mmcblk0" ; SD card storage
"ttyS0"))
(define pine64-plus-installation-os
(embedded-installation-os u-boot-pine64-plus-bootloader
- "/dev/mmcblk0" ; SD card storage
"ttyS0"))
(define pinebook-installation-os
(embedded-installation-os u-boot-pinebook-bootloader
- "/dev/mmcblk0" ; SD card storage
"ttyS0"))
(define rock64-installation-os
(embedded-installation-os u-boot-rock64-rk3328-bootloader
- "/dev/mmcblk0" ; SD card/eMMC (SD priority) storage
"ttyS2")) ; UART2 connected on the Pi2 bus
(define rockpro64-installation-os
(embedded-installation-os u-boot-rockpro64-rk3399-bootloader
- "/dev/mmcblk0" ; SD card/eMMC (SD priority) storage
"ttyS2")) ; UART2 connected on the Pi2 bus
(define rk3399-puma-installation-os
(embedded-installation-os u-boot-puma-rk3399-bootloader
- "/dev/mmcblk0" ; SD card storage
"ttyS0"))
(define wandboard-installation-os
(embedded-installation-os u-boot-wandboard-bootloader
- "/dev/mmcblk0" ; SD card storage
"ttymxc0"))
;; Return the default os here so 'guix system' can consume it directly.
@@ -172,17 +172,6 @@ (define* (virtualized-operating-system os
(operating-system
(inherit os)
- ;; XXX: Until we run QEMU with UEFI support (with the OVMF firmware),
- ;; force the traditional i386/BIOS method.
- ;; See <https://bugs.gnu.org/28768>.
- (bootloader (bootloader-configuration
- (inherit (operating-system-bootloader os))
- (bootloader
- (if (target-riscv64? (or target system))
- u-boot-qemu-riscv64-bootloader
- grub-bootloader))
- (targets '("/dev/vda"))))
-
(initrd (lambda (file-systems . rest)
(apply (operating-system-initrd os)
file-systems
@@ -140,7 +140,7 @@ (define-os-with-source (%minimal-extlinux-os
(locale "en_US.UTF-8")
(bootloader (bootloader-configuration
- (bootloader extlinux-bootloader-gpt)
+ (bootloader extlinux-gpt-bootloader)
(targets (list "/dev/vdb"))))
(kernel-arguments '("console=ttyS0"))
(file-systems (cons (file-system
@@ -1464,9 +1464,11 @@ (define-os-with-source (%btrfs-raid10-root-os
(host-name "hurd")
(timezone "Europe/Paris")
(locale "en_US.UTF-8")
- (bootloader (bootloader-configuration
- (bootloader grub-bootloader)
- (targets (list "/dev/vdb" "/dev/vdc" "/dev/vdd" "/dev/vde"))))
+ (bootloader (map (lambda (targ)
+ (bootloader-configuration
+ (bootloader grub-bootloader)
+ (targets (list targ))))
+ '("/dev/vdb" "/dev/vdc" "/dev/vdd" "/dev/vde")))
(kernel-arguments '("console=ttyS0"))
(file-systems (cons* (file-system
(device (uuid "16ff18e2-eb41-4324-8df5-80d3b53c411b"))
@@ -30,8 +30,7 @@ (define-module (gnu tests reconfigure)
#:use-module (guix scripts system reconfigure)
#:use-module (guix store)
#:export (%test-switch-to-system
- %test-upgrade-services
- %test-install-bootloader))
+ %test-upgrade-services))
;;; Commentary:
;;;
@@ -178,83 +177,6 @@ (define* (run-upgrade-services-test)
(disable (upgrade-services-program '() '() '(dummy) '())))
(test enable disable))))
-(define* (run-install-bootloader-test)
- "Run a test of an OS running INSTALL-BOOTLOADER-PROGRAM, which installs a
-bootloader's configuration file."
- (define os
- (marionette-operating-system
- (simple-operating-system)
- #:imported-modules '((gnu services herd)
- (guix combinators))))
-
- (define vm (virtual-machine
- (operating-system os)
- (volatile? #f)))
-
- (define (test script)
- (with-imported-modules '((gnu build marionette))
- #~(begin
- (use-modules (gnu build marionette)
- (ice-9 regex)
- (srfi srfi-1)
- (srfi srfi-64))
-
- (define marionette
- (make-marionette (list #$vm)))
-
- ;; Return the system generation paths that have GRUB menu entries.
- (define (generations-in-grub-cfg marionette)
- (let ((grub-cfg (marionette-eval
- '(begin
- (use-modules (rnrs io ports))
- (call-with-input-file "/boot/grub/grub.cfg"
- get-string-all))
- marionette)))
- (map (lambda (parameter)
- (second (string-split (match:substring parameter) #\=)))
- (list-matches "system=[^ ]*" grub-cfg))))
-
- (test-runner-current (system-test-runner #$output))
- (test-begin "install-bootloader")
-
- (test-assert "no prior menu entry for system generation"
- (not (member #$os (generations-in-grub-cfg marionette))))
-
- (test-assert "script successfully evaluated"
- (marionette-eval
- '(primitive-load #$script)
- marionette))
-
- (test-assert "menu entry created for system generation"
- (member #$os (generations-in-grub-cfg marionette)))
-
- (test-end))))
-
- (let* ((bootloader ((compose bootloader-configuration-bootloader
- operating-system-bootloader)
- os))
- ;; The typical use-case for 'install-bootloader-program' is to read
- ;; the boot parameters for the existing menu entries on the system,
- ;; parse them with 'boot-parameters->menu-entry', and pass the
- ;; results to 'operating-system-bootcfg'. However, to obtain boot
- ;; parameters, we would need to start the marionette, which we should
- ;; ideally avoid doing outside of the 'test' G-Expression. Thus, we
- ;; generate a bootloader configuration for the script as if there
- ;; were no existing menu entries. In the grand scheme of things, this
- ;; matters little -- these tests should not make assertions about the
- ;; behavior of 'operating-system-bootcfg'.
- (bootcfg (operating-system-bootcfg os '()))
- (bootcfg-file (bootloader-configuration-file bootloader)))
- (gexp->derivation
- "install-bootloader"
- ;; Due to the read-only nature of the virtual machines used in the system
- ;; test suite, the bootloader installer script is omitted. 'grub-install'
- ;; would attempt to write directly to the virtual disk if the
- ;; installation script were run.
- (test
- (install-bootloader-program #f #f #f bootcfg bootcfg-file '(#f) "/")))))
-
-
(define %test-switch-to-system
(system-test
(name "switch-to-system")
@@ -267,9 +189,3 @@ (define %test-upgrade-services
(description "Upgrade the Shepherd by unloading obsolete services and
loading new services.")
(value (run-upgrade-services-test))))
-
-(define %test-install-bootloader
- (system-test
- (name "install-bootloader")
- (description "Install a bootloader and its configuration file.")
- (value (run-install-bootloader-test))))
@@ -209,7 +209,7 @@ (define* (copy-closure item target
(define* (install os-drv target
#:key (log-port (current-output-port))
- install-bootloader? bootloader bootcfg)
+ install-bootloader? bootloaders bootmeta)
"Copy the closure of BOOTCFG, which includes the output of OS-DRV, to
directory TARGET. TARGET must be an absolute directory name since that's what
'register-path' expects.
@@ -247,24 +247,27 @@ (define* (install os-drv target
(chmod target #o755)
(let ((os-dir (derivation->output-path os-drv))
(format (lift format %store-monad))
- (populate (lift2 populate-root-file-system %store-monad)))
-
- (mlet %store-monad ((bootcfg (lower-object bootcfg)))
- (mbegin %store-monad
- ;; Copy the closure of BOOTCFG, which includes OS-DIR,
- ;; eventual background image and so on.
- (maybe-copy (derivation->output-path bootcfg))
-
- ;; Create a bunch of additional files.
- (format log-port "populating '~a'...~%" target)
- (populate os-dir target)
-
+ (populate (lift2 populate-root-file-system %store-monad))
+ (profile (string-append target "/var/guix/profiles/system")))
+
+ (mbegin %store-monad
+ ;; Create a bunch of system files.
+ (format log-port "populating '~a'...~%" target)
+ (populate os-dir target)
+
+ ;; Copy the bootloader's closure, which includes OS-DIR,
+ ;; eventual background image and so on.
+ (mlet* %store-monad
+ ((alt -> (generation->boot-alternative profile 1))
+ (inst (apply install-bootloader local-eval bootloaders
+ (list alt) #:dry-run (not install-bootloader?)
+ #:root-offset target bootmeta)))
+ (maybe-copy (derivation->output-path inst)))
(mwhen install-bootloader?
- (install-bootloader local-eval bootloader bootcfg
- #:target target)
(return
(info (G_ "bootloader successfully installed on~{ ~a~}~%")
- (bootloader-configuration-targets bootloader))))))))
+ (fold append '()
+ (map bootloader-configuration-targets bootloaders))))))))
;;;
@@ -389,20 +392,13 @@ (define (install-bootloader-from-provenance store number)
(let* ((generation (generation-file-name %system-profile number))
(os (receive (_ os) (system-provenance generation)
(and=> os read-operating-system)))
- (bootloader-config (operating-system-bootloader os))
- (bootloader (bootloader-configuration-bootloader bootloader-config))
+ (new (generation->boot-alternative %system-profile number))
(numbers (delv number (reverse (generation-numbers %system-profile))))
(old (profile->boot-alternatives %system-profile numbers)))
(if os
(run-with-store store
- (mlet* %store-monad
- ((bootcfg (lower-object (operating-system-bootcfg os old)))
- (drvs -> (list bootcfg)))
- (mbegin %store-monad
- (built-derivations drvs)
- ;; Only install bootloader configuration file.
- (install-bootloader local-eval bootloader-config bootcfg
- #:run-installer? #f))))
+ (apply install-bootloader local-eval (operating-system-bootloader os)
+ (cons new old) (operating-system-bootmeta os)))
(leave (G_ "cannot rollback to provenanceless generation '~a'~%")
number))))
@@ -489,7 +485,7 @@ (define* (display-system-generation number
(format #t (G_ " canonical file name: ~a~%") (readlink* generation))
;; TRANSLATORS: Please preserve the two-space indentation.
(format #t (G_ " label: ~a~%") label)
- (format #t (G_ " bootloader: ~a~%") bootloader-name)
+ (format #t (G_ " bootloader: ~a~%") (string-join bootloader-name))
;; TRANSLATORS: The '~[', '~;', and '~]' sequences in this string must
;; be preserved. They denote conditionals, such that the result will
@@ -775,18 +771,11 @@ (define* (perform-action action image
(define os
(image-operating-system image))
- (define bootloader
+ (define bootloaders
(operating-system-bootloader os))
- (define bootcfg
- (and (memq action '(init reconfigure))
- (operating-system-bootcfg
- os
- (if (eq? action 'init)
- '()
- (map boot-parameters->menu-entry
- (map boot-alternative-parameters
- (profile->boot-alternatives)))))))
+ (define bootmeta
+ (operating-system-bootmeta os))
(when (eq? action 'reconfigure)
(maybe-suggest-running-guix-pull)
@@ -817,10 +806,7 @@ (define* (perform-action action image
;; For 'init' and 'reconfigure', always build BOOTCFG, even if
;; --no-bootloader is passed, because we then use it as a GC root.
;; See <http://bugs.gnu.org/21068>.
- (drvs (mapm/accumulate-builds lower-object
- (if (memq action '(init reconfigure))
- (list sys bootcfg)
- (list sys))))
+ (drvs (mapm/accumulate-builds lower-object (list sys)))
(% (if derivations-only?
(return (for-each (compose println derivation-file-name)
drvs))
@@ -838,12 +824,16 @@ (define* (perform-action action image
(format #t (G_ "activating system...~%"))
(mbegin %store-monad
(switch-to-system local-eval os)
+ (apply install-bootloader local-eval bootloaders
+ (profile->boot-alternatives)
+ #:dry-run? (not install-bootloader?)
+ (if target (cons* #:root-offset target bootmeta) bootmeta))
(mwhen install-bootloader?
- (install-bootloader local-eval bootloader bootcfg
- #:target (or target "/"))
(return
(info (G_ "bootloader successfully installed on '~a'~%")
- (bootloader-configuration-targets bootloader))))
+ (map bootloader-target-path
+ (fold append '()
+ (map bootloader-configuration-targets bootloaders))))))
(with-shepherd-error-handling
(upgrade-shepherd-services local-eval os)
(return (format #t (G_ "\
@@ -857,8 +847,8 @@ (define* (perform-action action image
target)
(install sys (canonicalize-path target)
#:install-bootloader? install-bootloader?
- #:bootloader bootloader
- #:bootcfg bootcfg))
+ #:bootloaders bootloaders
+ #:bootmeta bootmeta))
(else
;; All we had to do was to build SYS and maybe register an
;; indirect GC root.
@@ -1254,11 +1244,7 @@ (define (process-action action args opts)
(G_ "image lacks an operating-system")))))
(target-file (match args
((first second) second)
- (_ #f)))
- (bootloader-targets
- (and bootloader?
- (bootloader-configuration-targets
- (operating-system-bootloader os)))))
+ (_ #f))))
(define (graph-backend)
(lookup-backend (assoc-ref opts 'graph-backend)))
@@ -7,6 +7,7 @@
;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -209,101 +210,83 @@ (define* (upgrade-shepherd-services eval os)
;;; Bootloader configuration.
;;;
-(define (install-bootloader-program installer disk-installer
- bootloader-package bootcfg
- bootcfg-file devices target)
+(define (install-bootloader-program configs offset chosen-alt old-alts locale
+ store-crypto-devices store-directory-prefix)
"Return an executable store item that, upon being evaluated, will install
BOOTCFG to BOOTCFG-FILE, a target file name, on DEVICES, a list of file system
devices, at TARGET, a mount point, and subsequently run INSTALLER from
BOOTLOADER-PACKAGE."
(program-file
- "install-bootloader.scm"
- (with-extensions (list guile-gcrypt)
- (with-imported-modules `(,@(source-module-closure
- '((gnu build bootloader)
- (gnu build install)
- (guix store)
- (guix utils))
- #:select? not-config?)
- ((guix config) => ,(make-config.scm)))
- #~(begin
- (use-modules (gnu build bootloader)
- (gnu build install)
- (guix build utils)
- (guix store)
- (guix utils)
- (ice-9 binary-ports)
- (ice-9 match)
- (srfi srfi-34)
- (srfi srfi-35))
-
- (let* ((gc-root (string-append #$target %gc-roots-directory "/bootcfg"))
- (new-gc-root (string-append gc-root ".new")))
- ;; #$bootcfg has dependencies.
- ;; The bootloader magically loads the configuration from
- ;; (string-append #$target #$bootcfg-file) (for example
- ;; "/boot/grub/grub.cfg").
- ;; If we didn't do something special, the garbage collector
- ;; would remove the dependencies of #$bootcfg.
- ;; Register #$bootcfg as a GC root.
- ;; Preserve the previous activation's garbage collector root
- ;; until the bootloader installer has run, so that a failure in
- ;; the bootloader's installer script doesn't leave the user with
- ;; a broken installation.
- (switch-symlinks new-gc-root #$bootcfg)
- (install-boot-config #$bootcfg #$bootcfg-file #$target)
- (when (or #$installer #$disk-installer)
- (catch #t
- (lambda ()
- ;; The bootloader might not support installation on a
- ;; mounted directory using the BOOTLOADER-INSTALLER
- ;; procedure. In that case, fallback to installing the
- ;; bootloader directly on DEVICES using the
- ;; BOOTLOADER-DISK-IMAGE-INSTALLER procedure.
- (if #$installer
- (for-each (lambda (device)
- (#$installer #$bootloader-package device
- #$target))
- '#$devices)
- (for-each (lambda (device)
- (#$disk-installer #$bootloader-package
- 0 device))
- '#$devices)))
- (lambda args
- (delete-file new-gc-root)
- (match args
- (('%exception exception) ;Guile 3 SRFI-34 or similar
- (raise-exception exception))
- ((key . args)
- (apply throw key args))))))
- ;; We are sure that the installation of the bootloader
- ;; succeeded, so we can replace the old GC root by the new
- ;; GC root now.
- (rename-file new-gc-root gc-root)))))))
+ "install-bootloader.scm"
+ ;; three sources of boot entries: bootloader-configuration-menu-entries,
+ ;; current-boot-alternative, and old-boot-alternatives.
+ (let ((args (list #:current-boot-alternative chosen-alt
+ #:old-boot-alternatives old-alts
+ #:locale locale
+ #:store-directory-prefix store-directory-prefix
+ #:store-crypto-devices store-crypto-devices)))
+ (with-extensions (list guile-gcrypt)
+ (with-imported-modules
+ `(,@(source-module-closure '((gnu build bootloader)
+ (gnu build install)
+ (guix store)
+ (guix utils))
+ #:select? not-config?)
+ ((guix config) => ,(make-config.scm)))
+ #~(begin
+ (use-modules (gnu build bootloader)
+ (gnu build install)
+ (guix build utils)
+ (guix store)
+ (guix utils)
+ (ice-9 binary-ports)
+ (ice-9 match)
+ (srfi srfi-34)
+ (srfi srfi-35))
+ ;; bootloader-installer is passed an additional #:target argument
+ ;; denoting the specific target currently being installed to.
+ ;; bootloaders should determine when to fully reinstall themselves.
+ #$(bootloader-configurations->gexp configs args
+ #:root-offset offset)))))))
-(define* (install-bootloader eval configuration bootcfg
- #:key
- (run-installer? #t)
- (target "/"))
+(define* (install-bootloader eval configs alts #:key locale
+ store-crypto-devices store-directory-prefix
+ (root-offset "/") (dry-run? #f))
"Using EVAL, a monadic procedure taking a single G-Expression as an argument,
-configure the bootloader on TARGET such that OS will be booted by default and
-additional configurations specified by MENU-ENTRIES can be selected."
- (let* ((bootloader (bootloader-configuration-bootloader configuration))
- (installer (and run-installer?
- (bootloader-installer bootloader)))
- (disk-installer (and run-installer?
- (bootloader-disk-image-installer bootloader)))
- (package (bootloader-package bootloader))
- (devices (bootloader-configuration-targets configuration))
- (bootcfg-file (bootloader-configuration-file bootloader)))
- (eval #~(parameterize ((current-warning-port (%make-void-port "w")))
- (primitive-load #$(install-bootloader-program installer
- disk-installer
- package
- bootcfg
- bootcfg-file
- devices
- target))))))
+configure the bootloader with bootloader-configuration CONFIG such that
+ALTS may be selected, with the first element being the default. If QUICK? only
+the bootloader config is reinstalled. Returns the config installer drv."
+ (mlet* %store-monad
+ ((program (lower-object
+ (install-bootloader-program configs root-offset
+ (car alts) (cdr alts) locale
+ store-crypto-devices store-directory-prefix))))
+ (mbegin %store-monad
+ (eval
+ (with-imported-modules `(,@(source-module-closure '((guix build utils)
+ (guix store))
+ #:select? not-config?)
+ ((guix config) => ,(make-config.scm)))
+ #~(begin
+ (use-modules (guix build utils) (guix store))
+ (parameterize ((current-warning-port (%make-void-port "w")))
+ (let* ((gc-root (string-append
+ #$root-offset %gc-roots-directory "/bootcfg"))
+ (new-gc-root (string-append gc-root ".new")))
+ ;; since the installers are gexps directly included, we add
+ ;; the installer runner as a gc root. this should make sure
+ ;; no bootloader files get gc'd. only remove the old one on
+ ;; success.
+ ;; XXX: is this still necessary?
+ (switch-symlinks new-gc-root #$program)
+ (dynamic-wind (const #t)
+ (lambda ()
+ (unless #$dry-run? (primitive-load #$program))
+ (rename-file new-gc-root gc-root))
+ (lambda () ; delete new root if failed
+ (when (file-exists? new-gc-root)
+ (delete-file new-gc-root)))))))))
+ (return program))))
;;;