@@ -190,10 +190,6 @@ (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
@@ -240,18 +236,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))
@@ -310,7 +298,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)
@@ -510,18 +510,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-alternative->menu-entry
- 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.
@@ -553,13 +550,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))))))))))
;;;
@@ -590,32 +589,23 @@ (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))
- (_ -> (when (< (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
- (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)))
+ (match boot-alternatives
+ ((first chosen rest ...)
+ (mlet %store-monad
+ ((remote-result (machine-remote-eval machine remote-exp)))
+ (when (eqv? 'error remote-result) (raise roll-back-failure)))
+ (let ((os (machine-operating-system machine))
+ (crypto-dev (boot-parameters-store-crypto-devices chosen))
+ (prefix (boot-parameters-store-directory-prefix chosen)))
+ (install-bootloader (cute machine-remote-eval machine <>)
+ (operating-system-bootloader os)
+ (cons* chosen first rest)
+ #:locale (boot-parameters-locale chosen)
+ #:store-crypto-devices crypto-dev
+ #:store-directory-prefix prefix)))
+ (_ (raise roll-back-failure)))))
;;;
@@ -142,10 +142,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
@@ -196,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 wrap-element))
(label operating-system-label ; string
(thunked)
(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."
(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) '()))
@@ -1282,9 +1272,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
@@ -166,7 +166,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.
;; In the past, we would store the directory name of linux instead of
@@ -44,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)
@@ -344,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.
@@ -356,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
@@ -374,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.
@@ -454,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)
@@ -470,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)))))
@@ -528,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))
@@ -546,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))
@@ -564,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
@@ -594,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 '()))
@@ -615,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
@@ -623,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
@@ -643,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
@@ -948,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 "/")
@@ -1001,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))
@@ -1021,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:
;;
@@ -211,7 +211,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.
@@ -249,24 +249,25 @@ (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)
-
- (mwhen install-bootloader?
- (install-bootloader local-eval bootloader bootcfg
- #:target target)
- (return
- (info (G_ "bootloader successfully installed on~{ ~a~}~%")
- (bootloader-configuration-targets bootloader))))))))
+ (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?
+ (return
+ (info (G_ "bootloader successfully installed on~{ ~a~}~%")
+ (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."
(let* ((os (read-operating-system os))
(bootloader-config (operating-system-bootloader os))
+ (new (generation->boot-alternative %system-profile number))
(numbers (generation-numbers %system-profile))
(numbers (delv number (reverse numbers)))
- (old (profile->boot-alternatives %system-profile numbers))
- (bootcfg (operating-system-bootcfg os old)))
- (run-with-store store
- (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))))))
+ (old (profile->boot-alternatives %system-profile numbers)))
+ (apply install-bootloader local-eval (operating-system-bootloader os)
+ (cons new old) (operating-system-bootmeta os))))
(define (install-bootloader-from-provenance store number)
"Re-install an old bootloader using provenance data for system profile
@@ -494,7 +489,8 @@ (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 (map symbol->string bootloader-name)))
;; TRANSLATORS: The '~[', '~;', and '~]' sequences in this string must
;; be preserved. They denote conditionals, such that the result will
@@ -780,17 +776,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-alternative->menu-entry
- (profile->boot-alternatives))))))
+ (define bootmeta
+ (operating-system-bootmeta os))
(when (eq? action 'reconfigure)
(maybe-suggest-running-guix-pull)
@@ -821,10 +811,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))
@@ -842,12 +829,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
+ (flat-map bootloader-configuration-targets
+ bootloaders)))))
(with-shepherd-error-handling
(upgrade-shepherd-services local-eval os)
(return (format #t (G_ "\
@@ -861,8 +852,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.
@@ -1258,11 +1249,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,84 @@ (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
+(define* (install-bootloader eval configs alts
#:key
- (run-installer? #t)
- (target "/"))
+ store-crypto-devices store-directory-prefix
+ (root-offset "/") dry-run? locale)
"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))))
;;;