ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

gnu: Core bootloader changes.

Browse source 
Sorry this is a massive commit.  It's kinda impossible to split it
without either completely breaking basic functionality or making a buggy
shim layer that's written just to be immediately removed.

But anyway, this is the real body of the bootloader subsystem update.
One of my favorite new things possible with this is easy generation of
disk images using arbitrary bootloaders, including ones that require one
or more data/install partitions, such as p-boot or depthcharge!

* gnu/build/image.scm (initialize-root-partition): Don't install
bootloader here.
(make-iso9660-image): Pull in grub.dir instead of a bootcfg.
* gnu/build/install.scm (install-boot-config): Delete procedure.
* gnu/machine/ssh.scm (deploy-managed-host, roll-back-managed-host): Use
new bootloader system.
(operating-system)[bootloader]: Use wrap-element sanitizer and support
multiple bootloaders.
(operating-system-bootcfg): Rename to...
(operating-system-bootmeta): ...this.  Rewrite to return relevant
information instead of calling the config procedure directly.
(operating-system-boot-parameters): Support multiple bootloaders.
* gnu/system/boot.scm (read-boot-parameters): Support multiple
bootloaders.
* gnu/system/image.scm (root-partition-index): Delete procedure.
(system-disk-image, system-iso9960-image): Support new bootloader system.
(system-disk-image)[targets]: New subprocedure.
* guix/scripts/system.scm (install, install-bootloader-from-provenance,
perform-action): Support multiple bootloaders and work with new
bootloader system instead of bootcfgs.
(display-system-generation): Support multiple bootloaders.
* guix/scripts/system/reconfigure.scm (install-bootloader-program):
Rewrite to simply insert each bootloader's installer in the gexp
directly, instead of copying bootcfgs.
(install-bootloader): Work with new bootloader system.  Just in case,
add install-bootloader.scm to the gc roots too.

Change-Id: I3654d160f7306bb45a78b82ea6b249ff4281f739
This commit is contained in:
Lilah Tascheter 2024-08-06 19:11:17 -05:00 committed by Ryan Schanzenbacher
parent d09d96bccc
commit 689cca0c75
Signed by: ryan77627
GPG key ID: 81B0E222A3E2308E
8 changed files with 241 additions and 295 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
gnu/build/image.scm
View file

@ -190,10 +190,6 @@ (define-deprecated/alias initialize-efi32-partition initialize-efi-partition)
(define* (initialize-root-partition root (define* (initialize-root-partition root
#:key #:key
bootcfg
bootcfg-location
bootloader-package
bootloader-installer
(copy-closures? #t) (copy-closures? #t)
(deduplicate? #t) (deduplicate? #t)
references-graphs references-graphs
@ -240,18 +236,10 @@ (define tmp-store ".tmp-store")
(unless copy-closures? (unless copy-closures?
(delete-file root-store) (delete-file root-store)
(rename-file tmp-store root-store))) (rename-file tmp-store root-store))))
;; There's no point installing a bootloader if we do not populate the store.
(when copy-closures?
(when bootloader-installer
(display "installing bootloader...\n")
(bootloader-installer bootloader-package #f root))
(when bootcfg
(install-boot-config bootcfg bootcfg-location root))))
(define* (make-iso9660-image xorriso grub-mkrescue-environment (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) #:key (volume-id "Guix_image") (volume-uuid #f)
register-closures? (references-graphs '()) register-closures? (references-graphs '())
(compression? #t)) (compression? #t))
@ -310,7 +298,7 @@ (define grub-mkrescue-sed.sh
(apply invoke grub-mkrescue (apply invoke grub-mkrescue
(string-append "--xorriso=" grub-mkrescue-sed.sh) (string-append "--xorriso=" grub-mkrescue-sed.sh)
"-o" target "-o" target
(string-append "boot/grub/grub.cfg=" bootcfg) (string-append "boot/grub=" grub.dir)
root root
"--" "--"
;; Set all timestamps to 1. ;; Set all timestamps to 1.

16
gnu/build/install.scm
View file

@ -25,8 +25,7 @@ (define-module (gnu build install)
#:use-module (guix build store-copy) #:use-module (guix build store-copy)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (install-boot-config #:export (evaluate-populate-directive
evaluate-populate-directive
populate-root-file-system populate-root-file-system
install-database-and-gc-roots install-database-and-gc-roots
populate-single-profile-directory populate-single-profile-directory
@ -42,19 +41,6 @@ (define-module (gnu build install)
;;; ;;;
;;; Code: ;;; 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 (define* (evaluate-populate-directive directive target
#:key #:key
(default-gid 0) (default-gid 0)

60
gnu/machine/ssh.scm
View file

@ -510,18 +510,15 @@ (define system (machine-ssh-configuration-system config))
(machine-ssh-session machine) (machine-ssh-session machine)
(machine-become-command machine))) (machine-become-command machine)))
(mlet %store-monad ((_ (check-deployment-sanity machine)) (mlet %store-monad ((_ (check-deployment-sanity machine)))
(boot-alternatives (machine->boot-alternatives machine)))
;; Make sure code that check %CURRENT-SYSTEM, such as ;; Make sure code that check %CURRENT-SYSTEM, such as
;; %BASE-INITRD-MODULES, gets to see the right value. ;; %BASE-INITRD-MODULES, gets to see the right value.
(parameterize ((%current-system system) (parameterize ((%current-system system)
(%current-target-system #f)) (%current-target-system #f))
(let* ((os (machine-operating-system machine)) (let* ((os (machine-operating-system machine))
(eval (cut machine-remote-eval machine <>)) (eval (cut machine-remote-eval machine <>))
(menu-entries (map boot-alternative->menu-entry (bootloader-config (operating-system-bootloader os))
boot-alternatives)) (bootmeta (operating-system-bootmeta os)))
(bootloader-configuration (operating-system-bootloader os))
(bootcfg (operating-system-bootcfg os menu-entries)))
(define-syntax-rule (eval/error-handling condition handler ...) (define-syntax-rule (eval/error-handling condition handler ...)
;; Return a wrapper around EVAL such that HANDLER is evaluated if an ;; Return a wrapper around EVAL such that HANDLER is evaluated if an
;; exception is raised. ;; exception is raised.
@ -553,13 +550,15 @@ (define-syntax-rule (eval/error-handling condition handler ...)
(inferior-exception-arguments (inferior-exception-arguments
c))) c)))
os) os)
(install-bootloader (eval/error-handling c (mlet %store-monad
((boot-alternatives (machine->boot-alternatives machine)))
(apply install-bootloader
(eval/error-handling c
(raise (formatted-message (raise (formatted-message
(G_ "\ (G_ "\
failed to install bootloader on '~a':~%~{~s ~}~%") failed to install bootloader on '~a':~%~{~s ~}~%")
host host (inferior-exception-arguments c))))
(inferior-exception-arguments c)))) bootloader-config boot-alternatives bootmeta))))))))))
bootloader-configuration bootcfg)))))))))
;;; ;;;
@ -590,32 +589,23 @@ (define target-generation
(define roll-back-failure (define roll-back-failure
(condition (&message (message (G_ "could not roll-back machine"))))) (condition (&message (message (G_ "could not roll-back machine")))))
(mlet* %store-monad (mlet %store-monad
((boot-alternatives (machine->boot-alternatives machine)) ((boot-alternatives (machine->boot-alternatives machine)))
(_ -> (when (< (length boot-alternatives) 2) (match boot-alternatives
(raise roll-back-failure))) ((first chosen rest ...)
(chosen-alternative (second boot-alternatives)) (mlet %store-monad
(parameters (boot-alternative-parameters chosen-alternative)) ((remote-result (machine-remote-eval machine remote-exp)))
(entries -> (list (boot-parameters->menu-entry parameters))) (when (eqv? 'error remote-result) (raise roll-back-failure)))
(locale -> (boot-parameters-locale parameters)) (let ((os (machine-operating-system machine))
(crypto-dev -> (boot-parameters-store-crypto-devices parameters)) (crypto-dev (boot-parameters-store-crypto-devices chosen))
(store-dir -> (boot-parameters-store-directory-prefix parameters)) (prefix (boot-parameters-store-directory-prefix chosen)))
(old-entries -> (map boot-parameters->menu-entry (install-bootloader (cute machine-remote-eval machine <>)
(drop boot-alternatives 2))) (operating-system-bootloader os)
(bootloader -> (operating-system-bootloader (cons* chosen first rest)
(machine-operating-system machine))) #:locale (boot-parameters-locale chosen)
(bootcfg (lower-object
((bootloader-configuration-file-generator
(bootloader-configuration-bootloader
bootloader))
bootloader entries
#:locale locale
#:store-crypto-devices crypto-dev #:store-crypto-devices crypto-dev
#:store-directory-prefix store-dir #:store-directory-prefix prefix)))
#:old-entries old-entries))) (_ (raise roll-back-failure)))))
(remote-result (machine-remote-eval machine remote-exp)))
(when (eqv? 'error remote-result)
(raise roll-back-failure))))
;;; ;;;

40
gnu/system.scm
View file

@ -142,10 +142,11 @@ (define-module (gnu system)
operating-system-derivation operating-system-derivation
operating-system-profile operating-system-profile
operating-system-bootcfg operating-system-bootmeta
operating-system-etc-directory operating-system-etc-directory
operating-system-locale-directory operating-system-locale-directory
operating-system-boot-script operating-system-boot-script
operating-system-boot-parameters
operating-system-uuid operating-system-uuid
operating-system-with-gc-roots operating-system-with-gc-roots
@ -196,7 +197,9 @@ (define-record-type* <operating-system> operating-system
(default %default-kernel-arguments)) ; list of gexps/strings (default %default-kernel-arguments)) ; list of gexps/strings
(hurd operating-system-hurd (hurd operating-system-hurd
(default #f)) ; package (default #f)) ; package
(bootloader operating-system-bootloader) ; <bootloader-configuration> (bootloader operating-system-bootloader ; <bootloader-configuration>
(default '())
(sanitize wrap-element))
(label operating-system-label ; string (label operating-system-label ; string
(thunked) (thunked)
(default (operating-system-default-label this-operating-system))) (default (operating-system-default-label this-operating-system)))
@ -1195,30 +1198,17 @@ (define (operating-system-store-file-system os)
"Return the file system that contains the store of OS." "Return the file system that contains the store of OS."
(store-file-system (operating-system-file-systems os))) (store-file-system (operating-system-file-systems os)))
(define* (operating-system-bootcfg os #:optional (old-entries '())) (define (operating-system-bootmeta os)
"Return the bootloader configuration file for OS. Use OLD-ENTRIES, "Return operating system information to be passed to the bootloader
a list of <menu-entry>, to populate the \"old entries\" menu." installers."
(let* ((file-systems (operating-system-file-systems os)) (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-fs (operating-system-root-file-system os))
(root-device (file-system-device root-fs))
(locale (operating-system-locale os)) (locale (operating-system-locale os))
(crypto-devices (operating-system-bootloader-crypto-devices os)) (crypto-devices (operating-system-bootloader-crypto-devices os)))
(params (operating-system-boot-parameters (list #:store-crypto-devices crypto-devices
os root-device #:store-directory-prefix store-root
#:system-kernel-arguments? #t)) #:locale locale)))
(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))))
(define (operating-system-multiboot-modules os) (define (operating-system-multiboot-modules os)
(if (operating-system-hurd os) (hurd-multiboot-modules os) '())) (if (operating-system-hurd os) (hurd-multiboot-modules os) '()))
@ -1282,9 +1272,9 @@ (define* (operating-system-boot-parameters os root-device
(file-systems (operating-system-file-systems os)) (file-systems (operating-system-file-systems os))
(crypto-devices (operating-system-bootloader-crypto-devices os)) (crypto-devices (operating-system-bootloader-crypto-devices os))
(locale (operating-system-locale os)) (locale (operating-system-locale os))
(bootloader (bootloader-configuration-bootloader (bootloader (map bootloader-configuration-bootloader
(operating-system-bootloader os))) (operating-system-bootloader os)))
(bootloader-name (bootloader-name bootloader)) (bootloader-name (map bootloader-name bootloader))
(label (operating-system-label os)) (label (operating-system-label os))
(multiboot-modules (operating-system-multiboot-modules os))) (multiboot-modules (operating-system-multiboot-modules os)))
(boot-parameters (boot-parameters

3
gnu/system/boot.scm
View file

@ -166,7 +166,8 @@ (define (version? n)
(bootloader-name (bootloader-name
(match (assq 'bootloader-name rest) (match (assq 'bootloader-name rest)
((_ args) args) ((_ (args ...)) args)
((_ args) (list args))
(#f 'grub))) ; for compatibility reasons. (#f 'grub))) ; for compatibility reasons.
;; In the past, we would store the directory name of linux instead of ;; In the past, we would store the directory name of linux instead of

138
gnu/system/image.scm
View file

@ -44,6 +44,7 @@ (define-module (gnu system image)
#:use-module (gnu services base) #:use-module (gnu services base)
#:use-module (gnu system) #:use-module (gnu system)
#:use-module (gnu system accounts) #:use-module (gnu system accounts)
#:use-module (gnu system boot)
#:use-module (gnu system file-systems) #:use-module (gnu system file-systems)
#:use-module (gnu system linux-container) #:use-module (gnu system linux-container)
#:use-module (gnu system uuid) #:use-module (gnu system uuid)
@ -344,10 +345,6 @@ (define (find-root-partition image)
(raise (formatted-message (raise (formatted-message
(G_ "image lacks a partition with the 'boot' flag"))))) (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. ;; Disk image.
@ -356,8 +353,8 @@ (define (root-partition-index image)
(define* (system-disk-image image (define* (system-disk-image image
#:key #:key
(name "disk-image") (name "disk-image")
bootcfg bootloader-config
bootloader bootmeta
register-closures? register-closures?
(inputs '())) (inputs '()))
"Return as a file-like object, the disk-image described by IMAGE. Said "Return as a file-like object, the disk-image described by IMAGE. Said
@ -374,6 +371,28 @@ (define* (system-disk-image image
(define genimage-name "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) (define (image->genimage-cfg image)
;; Return as a file-like object, the genimage configuration file ;; Return as a file-like object, the genimage configuration file
;; describing the given IMAGE. ;; describing the given IMAGE.
@ -454,7 +473,8 @@ (define (partition-image partition)
(list dosfstools fakeroot mtools)) (list dosfstools fakeroot mtools))
(else (else
'()))) '())))
(image-root "tmp-root")) (image-root (string-append (getcwd) "/tmp-root"))
(copy-closures? (not #$(image-shared-store? image))))
(sql-schema #$schema) (sql-schema #$schema)
(set-path-environment-variable "PATH" '("bin" "sbin") inputs) (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
@ -470,18 +490,13 @@ (define (partition-image partition)
(initializer image-root (initializer image-root
#:references-graphs '#$graph #:references-graphs '#$graph
#:deduplicate? #f #:deduplicate? #f
#:copy-closures? (not #:copy-closures? copy-closures?
#$(image-shared-store? image)) #:system-directory #$os)
#:system-directory #$os ;; no point installing a bootloader if we don't populate store
#:grub-efi #+grub-efi (when copy-closures?
#:grub-efi32 #+grub-efi32 ;; root-offset isn't necessary - we override 'root
#:bootloader-package #$(bootloader-configurations->gexp bootloader-config bootmeta
#+(bootloader-package bootloader) #:overrides (targets partition)))
#:bootloader-installer
#+(bootloader-installer bootloader)
#:bootcfg #$bootcfg
#:bootcfg-location
#$(bootloader-configuration-file bootloader))
(make-partition-image #$(partition->gexp partition) (make-partition-image #$(partition->gexp partition)
#$output #$output
image-root))))) image-root)))))
@ -528,14 +543,6 @@ (define (genimage-type-options image-type image)
(image-partition-table-type image))) (image-partition-table-type image)))
(else ""))) (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)) (let* ((format (image-format image))
(image-type (format->image-type format)) (image-type (format->image-type format))
(image-type-options (genimage-type-options image-type image)) (image-type-options (genimage-type-options image-type image))
@ -546,12 +553,14 @@ (define (genimage-type-options image-type image)
(let ((format (@ (ice-9 format) format))) (let ((format (@ (ice-9 format) format)))
(call-with-output-file #$output (call-with-output-file #$output
(lambda (port) (lambda (port)
(format port (format port "\
"\
image ~a { image ~a {
~/~a {~a} ~/~a {~a}
~{~a~^~%~} ~{~a~^~%~}
}~%" #$genimage-name #$image-type #$image-type-options }~%"
#$genimage-name
#$image-type
#$image-type-options
(list #$@partitions-config)))))))) (list #$@partitions-config))))))))
(computed-file "genimage.cfg" builder))) (computed-file "genimage.cfg" builder)))
@ -564,17 +573,13 @@ (define (genimage-type-options image-type image)
(builder (builder
(with-imported-modules* (with-imported-modules*
(let ((inputs '#+(list genimage coreutils findutils qemu-minimal)) (let ((inputs '#+(list genimage coreutils findutils qemu-minimal))
(bootloader-installer
#+(bootloader-disk-image-installer bootloader))
(out-image (string-append "images/" #$genimage-name))) (out-image (string-append "images/" #$genimage-name)))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs) (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
(genimage #$(image->genimage-cfg image)) (genimage #$(image->genimage-cfg image))
;; Install the bootloader directly on the disk-image. ;; Don't install bootloader unless installing store.
(when bootloader-installer (unless #$(image-shared-store? image)
(bootloader-installer #$(bootloader-configurations->gexp bootloader-config bootmeta
#+(bootloader-package bootloader) #:overrides (targets #f)))
#$(root-partition-index image)
out-image))
(convert-disk-image out-image '#$format #$output))))) (convert-disk-image out-image '#$format #$output)))))
(computed-file name builder (computed-file name builder
#:local-build? #f ;too I/O-intensive #:local-build? #f ;too I/O-intensive
@ -594,8 +599,8 @@ (define (has-guix-service-type? os)
(define* (system-iso9660-image image (define* (system-iso9660-image image
#:key #:key
(name "image.iso") (name "image.iso")
bootcfg bootloader-config
bootloader bootmeta
register-closures? register-closures?
(inputs '()) (inputs '())
(grub-mkrescue-environment '())) (grub-mkrescue-environment '()))
@ -615,7 +620,6 @@ (define root-uuid
(uuid-bytevector (partition-uuid partition))))) (uuid-bytevector (partition-uuid partition)))))
(let* ((os (image-operating-system image)) (let* ((os (image-operating-system image))
(bootloader (bootloader-package bootloader))
(compression? (image-compression? image)) (compression? (image-compression? image))
(substitutable? (image-substitutable? image)) (substitutable? (image-substitutable? image))
(schema (local-file (search-path %load-path (schema (local-file (search-path %load-path
@ -623,6 +627,14 @@ (define root-uuid
(graph (match inputs (graph (match inputs
(((names . _) ...) (((names . _) ...)
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 (builder
(with-imported-modules* (with-imported-modules*
(let* ((inputs '#$(list parted e2fsprogs dosfstools xorriso (let* ((inputs '#$(list parted e2fsprogs dosfstools xorriso
@ -643,10 +655,12 @@ (define root-uuid
#:references-graphs '#$graph #:references-graphs '#$graph
#:deduplicate? #f #:deduplicate? #f
#:system-directory #$os) #:system-directory #$os)
(make-iso9660-image #$xorriso (make-iso9660-image #$xorriso
'#$grub-mkrescue-environment '#$grub-mkrescue-environment
#$bootloader #$grub-hybrid
#$bootcfg #$(apply grub.dir grub-hybrid
#:bootloader-config config bootmeta)
#$os #$os
image-root image-root
#$output #$output
@ -948,11 +962,7 @@ (define (root-uuid os)
file-systems file-systems
#:volatile-root? volatile-root? #:volatile-root? volatile-root?
rest))) rest)))
(bootloader (if (eq? format 'iso9660) (bootloader (if (eq? format 'iso9660) '()
(bootloader-configuration
(inherit
(operating-system-bootloader base-os))
(bootloader grub-mkrescue-bootloader))
(operating-system-bootloader base-os))) (operating-system-bootloader base-os)))
(file-systems (cons (file-system (file-systems (cons (file-system
(mount-point "/") (mount-point "/")
@ -1001,17 +1011,28 @@ (define target (cond
(image* (image-with-os* image os)) (image* (image-with-os* image os))
(image-format (image-format image)) (image-format (image-format image))
(register-closures? (has-guix-service-type? os)) (register-closures? (has-guix-service-type? os))
(bootcfg (operating-system-bootcfg os)) ;; Force removable: images don't have efivarfs.
(bootloader (bootloader-configuration-bootloader (bootloader-config (map (lambda (c) (bootloader-configuration
(operating-system-bootloader os)))) (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 (cond
((memq image-format '(disk-image compressed-qcow2)) ((memq image-format '(disk-image compressed-qcow2))
(system-disk-image image* (system-disk-image image*
#:bootcfg bootcfg #:bootloader-config bootloader-config
#:bootloader bootloader #:bootmeta bootmeta
#:register-closures? register-closures? #:register-closures? register-closures?
#:inputs `(("system" ,os) #:inputs `(("system" ,os))))
("bootcfg" ,bootcfg))))
((memq image-format '(docker)) ((memq image-format '(docker))
(system-docker-image image*)) (system-docker-image image*))
((memq image-format '(tarball)) ((memq image-format '(tarball))
@ -1021,11 +1042,10 @@ (define target (cond
((memq image-format '(iso9660)) ((memq image-format '(iso9660))
(system-iso9660-image (system-iso9660-image
image* image*
#:bootcfg bootcfg #:bootloader-config bootloader-config
#:bootloader bootloader #:bootmeta bootmeta
#:register-closures? register-closures? #:register-closures? register-closures?
#:inputs `(("system" ,os) #:inputs `(("system" ,os))
("bootcfg" ,bootcfg))
;; Make sure to use a mode that does no imply ;; Make sure to use a mode that does no imply
;; HFS+ tree creation that may fail with: ;; HFS+ tree creation that may fail with:
;; ;;

81
guix/scripts/system.scm
View file

@ -211,7 +211,7 @@ (define state
(define* (install os-drv target (define* (install os-drv target
#:key (log-port (current-output-port)) #: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 "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 directory TARGET. TARGET must be an absolute directory name since that's what
'register-path' expects. 'register-path' expects.
@ -249,24 +249,25 @@ (define (maybe-copy to-copy)
(chmod target #o755) (chmod target #o755)
(let ((os-dir (derivation->output-path os-drv)) (let ((os-dir (derivation->output-path os-drv))
(format (lift format %store-monad)) (format (lift format %store-monad))
(populate (lift2 populate-root-file-system %store-monad))) (populate (lift2 populate-root-file-system %store-monad))
(profile (string-append target "/var/guix/profiles/system")))
(mlet %store-monad ((bootcfg (lower-object bootcfg)))
(mbegin %store-monad (mbegin %store-monad
;; Copy the closure of BOOTCFG, which includes OS-DIR, ;; Create a bunch of system files.
;; eventual background image and so on.
(maybe-copy (derivation->output-path bootcfg))
;; Create a bunch of additional files.
(format log-port "populating '~a'...~%" target) (format log-port "populating '~a'...~%" target)
(populate os-dir 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? (mwhen install-bootloader?
(install-bootloader local-eval bootloader bootcfg
#:target target)
(return (return
(info (G_ "bootloader successfully installed on~{ ~a~}~%") (info (G_ "bootloader successfully installed on~{ ~a~}~%")
(bootloader-configuration-targets bootloader)))))))) (flat-map bootloader-configuration-targets
bootloaders)))))))
;;; ;;;
@ -388,18 +389,12 @@ (define (install-bootloader-from-os store number os)
for system profile generation NUMBER, with store STORE." for system profile generation NUMBER, with store STORE."
(let* ((os (read-operating-system os)) (let* ((os (read-operating-system os))
(bootloader-config (operating-system-bootloader os)) (bootloader-config (operating-system-bootloader os))
(new (generation->boot-alternative %system-profile number))
(numbers (generation-numbers %system-profile)) (numbers (generation-numbers %system-profile))
(numbers (delv number (reverse numbers))) (numbers (delv number (reverse numbers)))
(old (profile->boot-alternatives %system-profile numbers)) (old (profile->boot-alternatives %system-profile numbers)))
(bootcfg (operating-system-bootcfg os old))) (apply install-bootloader local-eval (operating-system-bootloader os)
(run-with-store store (cons new old) (operating-system-bootmeta os))))
(mlet* %store-monad ((bootcfg (lower-object bootcfg))
(drvs -> (list bootcfg)))
(mbegin %store-monad
(built-derivations drvs)
;; Only install bootloader configuration file.
(install-bootloader local-eval bootloader-config bootcfg
#:run-installer? #f))))))
(define (install-bootloader-from-provenance store number) (define (install-bootloader-from-provenance store number)
"Re-install an old bootloader using provenance data for system profile "Re-install an old bootloader using provenance data for system profile
@ -494,7 +489,8 @@ (define-values (channels config-file)
(format #t (G_ " canonical file name: ~a~%") (readlink* generation)) (format #t (G_ " canonical file name: ~a~%") (readlink* generation))
;; TRANSLATORS: Please preserve the two-space indentation. ;; TRANSLATORS: Please preserve the two-space indentation.
(format #t (G_ " label: ~a~%") label) (format #t (G_ " label: ~a~%") label)
(format #t (G_ " bootloader: ~a~%") bootloader-name) (format #t (G_ " bootloader: ~a~%")
(string-join (map symbol->string bootloader-name)))
;; TRANSLATORS: The '~[', '~;', and '~]' sequences in this string must ;; TRANSLATORS: The '~[', '~;', and '~]' sequences in this string must
;; be preserved. They denote conditionals, such that the result will ;; be preserved. They denote conditionals, such that the result will
@ -780,17 +776,11 @@ (define println
(define os (define os
(image-operating-system image)) (image-operating-system image))
(define bootloader (define bootloaders
(operating-system-bootloader os)) (operating-system-bootloader os))
(define bootcfg (define bootmeta
(and (memq action '(init reconfigure)) (operating-system-bootmeta os))
(operating-system-bootcfg
os
(if (eq? action 'init)
'()
(map boot-alternative->menu-entry
(profile->boot-alternatives))))))
(when (eq? action 'reconfigure) (when (eq? action 'reconfigure)
(maybe-suggest-running-guix-pull) (maybe-suggest-running-guix-pull)
@ -821,10 +811,7 @@ (define bootcfg
;; For 'init' and 'reconfigure', always build BOOTCFG, even if ;; For 'init' and 'reconfigure', always build BOOTCFG, even if
;; --no-bootloader is passed, because we then use it as a GC root. ;; --no-bootloader is passed, because we then use it as a GC root.
;; See <http://bugs.gnu.org/21068>. ;; See <http://bugs.gnu.org/21068>.
(drvs (mapm/accumulate-builds lower-object (drvs (mapm/accumulate-builds lower-object (list sys)))
(if (memq action '(init reconfigure))
(list sys bootcfg)
(list sys))))
(% (if derivations-only? (% (if derivations-only?
(return (for-each (compose println derivation-file-name) (return (for-each (compose println derivation-file-name)
drvs)) drvs))
@ -842,12 +829,16 @@ (define bootcfg
(format #t (G_ "activating system...~%")) (format #t (G_ "activating system...~%"))
(mbegin %store-monad (mbegin %store-monad
(switch-to-system local-eval os) (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? (mwhen install-bootloader?
(install-bootloader local-eval bootloader bootcfg
#:target (or target "/"))
(return (return
(info (G_ "bootloader successfully installed on '~a'~%") (info (G_ "bootloader successfully installed on '~a'~%")
(bootloader-configuration-targets bootloader)))) (map bootloader-target-path
(flat-map bootloader-configuration-targets
bootloaders)))))
(with-shepherd-error-handling (with-shepherd-error-handling
(upgrade-shepherd-services local-eval os) (upgrade-shepherd-services local-eval os)
(return (format #t (G_ "\ (return (format #t (G_ "\
@ -861,8 +852,8 @@ (define bootcfg
target) target)
(install sys (canonicalize-path target) (install sys (canonicalize-path target)
#:install-bootloader? install-bootloader? #:install-bootloader? install-bootloader?
#:bootloader bootloader #:bootloaders bootloaders
#:bootcfg bootcfg)) #:bootmeta bootmeta))
(else (else
;; All we had to do was to build SYS and maybe register an ;; All we had to do was to build SYS and maybe register an
;; indirect GC root. ;; indirect GC root.
@ -1258,11 +1249,7 @@ (define save-provenance?
(G_ "image lacks an operating-system"))))) (G_ "image lacks an operating-system")))))
(target-file (match args (target-file (match args
((first second) second) ((first second) second)
(_ #f))) (_ #f))))
(bootloader-targets
(and bootloader?
(bootloader-configuration-targets
(operating-system-bootloader os)))))
(define (graph-backend) (define (graph-backend)
(lookup-backend (assoc-ref opts 'graph-backend))) (lookup-backend (assoc-ref opts 'graph-backend)))

124
guix/scripts/system/reconfigure.scm
View file

@ -7,6 +7,7 @@
;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org> ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -209,18 +210,24 @@ (define target-services
;;; Bootloader configuration. ;;; Bootloader configuration.
;;; ;;;
(define (install-bootloader-program installer disk-installer (define (install-bootloader-program configs offset chosen-alt old-alts locale
bootloader-package bootcfg store-crypto-devices store-directory-prefix)
bootcfg-file devices target)
"Return an executable store item that, upon being evaluated, will install "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 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 devices, at TARGET, a mount point, and subsequently run INSTALLER from
BOOTLOADER-PACKAGE." BOOTLOADER-PACKAGE."
(program-file (program-file
"install-bootloader.scm" "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-extensions (list guile-gcrypt)
(with-imported-modules `(,@(source-module-closure (with-imported-modules
'((gnu build bootloader) `(,@(source-module-closure '((gnu build bootloader)
(gnu build install) (gnu build install)
(guix store) (guix store)
(guix utils)) (guix utils))
@ -236,74 +243,51 @@ (define (install-bootloader-program installer disk-installer
(ice-9 match) (ice-9 match)
(srfi srfi-34) (srfi srfi-34)
(srfi srfi-35)) (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)))))))
(let* ((gc-root (string-append #$target %gc-roots-directory "/bootcfg")) (define* (install-bootloader eval configs alts
(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)))))))
(define* (install-bootloader eval configuration bootcfg
#:key #:key
(run-installer? #t) store-crypto-devices store-directory-prefix
(target "/")) (root-offset "/") dry-run? locale)
"Using EVAL, a monadic procedure taking a single G-Expression as an argument, "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 configure the bootloader with bootloader-configuration CONFIG such that
additional configurations specified by MENU-ENTRIES can be selected." ALTS may be selected, with the first element being the default. If QUICK? only
(let* ((bootloader (bootloader-configuration-bootloader configuration)) the bootloader config is reinstalled. Returns the config installer drv."
(installer (and run-installer? (mlet* %store-monad
(bootloader-installer bootloader))) ((program (lower-object
(disk-installer (and run-installer? (install-bootloader-program configs root-offset
(bootloader-disk-image-installer bootloader))) (car alts) (cdr alts) locale
(package (bootloader-package bootloader)) store-crypto-devices store-directory-prefix))))
(devices (bootloader-configuration-targets configuration)) (mbegin %store-monad
(bootcfg-file (bootloader-configuration-file bootloader))) (eval
(eval #~(parameterize ((current-warning-port (%make-void-port "w"))) (with-imported-modules `(,@(source-module-closure '((guix build utils)
(primitive-load #$(install-bootloader-program installer (guix store))
disk-installer #:select? not-config?)
package ((guix config) => ,(make-config.scm)))
bootcfg #~(begin
bootcfg-file (use-modules (guix build utils) (guix store))
devices (parameterize ((current-warning-port (%make-void-port "w")))
target)))))) (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))))
;;; ;;;