mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-06 23:16:13 -05:00
gnu: Core bootloader changes.
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
parent
d09d96bccc
commit
689cca0c75
GPG key ID:
81B0E222A3E2308E
8 changed files with 241 additions and 295 deletions
|
|
@ -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 tmp-store ".tmp-store")
|
|||
|
||||
(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 grub-mkrescue-sed.sh
|
|||
(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 system (machine-ssh-configuration-system config))
|
|||
(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-syntax-rule (eval/error-handling condition handler ...)
|
|||
(inferior-exception-arguments
|
||||
c)))
|
||||
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
|
||||
(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 target-generation
|
|||
(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
|
||||
(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 store-dir
|
||||
#:old-entries old-entries)))
|
||||
(remote-result (machine-remote-eval machine remote-exp)))
|
||||
(when (eqv? 'error remote-result)
|
||||
(raise roll-back-failure))))
|
||||
#: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
|
||||
(bootloader (map bootloader-configuration-bootloader
|
||||
(operating-system-bootloader os)))
|
||||
(bootloader-name (bootloader-name bootloader))
|
||||
(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 (version? n)
|
|||
|
||||
(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 (partition-image partition)
|
|||
(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 (partition-image partition)
|
|||
(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 (genimage-type-options image-type 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,12 +553,14 @@ (define (genimage-type-options image-type 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
|
||||
}~%"
|
||||
#$genimage-name
|
||||
#$image-type
|
||||
#$image-type-options
|
||||
(list #$@partitions-config))))))))
|
||||
(computed-file "genimage.cfg" builder)))
|
||||
|
||||
|
|
@ -564,17 +573,13 @@ (define (genimage-type-options image-type 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 root-uuid
|
|||
(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 root-uuid
|
|||
(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 root-uuid
|
|||
#: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 (root-uuid os)
|
|||
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 target (cond
|
|||
(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 target (cond
|
|||
((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 state
|
|||
|
||||
(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 (maybe-copy to-copy)
|
|||
(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)))
|
||||
(populate (lift2 populate-root-file-system %store-monad))
|
||||
(profile (string-append target "/var/guix/profiles/system")))
|
||||
(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.
|
||||
;; Create a bunch of system files.
|
||||
(format log-port "populating '~a'...~%" target)
|
||||
(populate os-dir target)
|
||||
|
||||
;; Copy the bootloader's closure, which includes OS-DIR,
|
||||
;; eventual background image and so on.
|
||||
(mlet* %store-monad
|
||||
((alt -> (generation->boot-alternative profile 1))
|
||||
(inst (apply install-bootloader local-eval bootloaders
|
||||
(list alt) #:dry-run? (not install-bootloader?)
|
||||
#:root-offset target bootmeta)))
|
||||
(maybe-copy (derivation->output-path inst)))
|
||||
(mwhen install-bootloader?
|
||||
(install-bootloader local-eval bootloader bootcfg
|
||||
#:target target)
|
||||
(return
|
||||
(info (G_ "bootloader successfully installed on~{ ~a~}~%")
|
||||
(bootloader-configuration-targets bootloader))))))))
|
||||
(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-values (channels config-file)
|
|||
(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 println
|
|||
(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 bootcfg
|
|||
;; 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 bootcfg
|
|||
(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 bootcfg
|
|||
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 save-provenance?
|
|||
(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,18 +210,24 @@ (define target-services
|
|||
;;; 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"
|
||||
;; 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)
|
||||
(with-imported-modules
|
||||
`(,@(source-module-closure '((gnu build bootloader)
|
||||
(gnu build install)
|
||||
(guix store)
|
||||
(guix utils))
|
||||
|
|
@ -236,74 +243,51 @@ (define (install-bootloader-program installer disk-installer
|
|||
(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)))))))
|
||||
|
||||
(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)))))))
|
||||
|
||||
(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))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
Loading…
Reference in a new issue