@@ -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))))
;;;
From: Lilah Tascheter <lilah@lunabee.space> 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 --- gnu/build/image.scm | 18 +--- gnu/build/install.scm | 16 +-- gnu/machine/ssh.scm | 66 +++++------- gnu/system.scm | 42 +++----- gnu/system/boot.scm | 3 +- gnu/system/image.scm | 140 +++++++++++++----------- guix/scripts/system.scm | 93 +++++++--------- guix/scripts/system/reconfigure.scm | 158 +++++++++++++--------------- 8 files changed, 241 insertions(+), 295 deletions(-)