mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
Encapsulate <boot-parameters> to retain generation, system-path and epoch.
* gnu/system/boot.scm (<boot-alternative>): New record. (boot-alternative->menu-entry): New procedure. * gnu/machine/ssh.scm (machine->boot-alternatives): Return a boot-alternative encapsulating previous return value. (deploy-managed-host): Get menu-entries from boot-alternatives. (roll-back-managed-host): Get parameters from boot-alternatives. * guix/scripts/system.scm (generation->boot-parameters): Rename to... (generation->boot-alternative): ...this. Return a boot-alternative encapsulating previous return value. (profile->boot-alternatives): Rename uses as above. (reinstall-bootloader, perform-action): Get menu-entries from boot-alternatives. Change-Id: Iaef0b0a3fa9240ca8315a9699bcf4a7bfe908e33
This commit is contained in:
parent
4b2cfd9794
commit
a1de2abd8e
3 changed files with 68 additions and 32 deletions
|
@ -418,8 +418,9 @@ (define not-config?
|
||||||
(_ #f)))
|
(_ #f)))
|
||||||
|
|
||||||
(define (machine->boot-alternatives machine)
|
(define (machine->boot-alternatives machine)
|
||||||
"Monadic procedure returning a list of 'boot-parameters' for the generations
|
"Monadic procedure returning a list of <boot-alternative> records for
|
||||||
of MACHINE's system profile, ordered from most recent to oldest."
|
the generations of MACHINE's system profile, ordered from most recent to
|
||||||
|
oldest."
|
||||||
(define remote-exp
|
(define remote-exp
|
||||||
(with-extensions (list guile-gcrypt)
|
(with-extensions (list guile-gcrypt)
|
||||||
(with-imported-modules `(((guix config) => ,(make-config.scm))
|
(with-imported-modules `(((guix config) => ,(make-config.scm))
|
||||||
|
@ -451,24 +452,30 @@ (define (read-file path)
|
||||||
(read-file boot-parameters-path))))
|
(read-file boot-parameters-path))))
|
||||||
(reverse (generation-numbers %system-profile)))))))
|
(reverse (generation-numbers %system-profile)))))))
|
||||||
|
|
||||||
|
(define remote-result->boot-alternative
|
||||||
|
(match-lambda
|
||||||
|
((generation system-path epoch serialized-params)
|
||||||
|
(boot-alternative
|
||||||
|
(generation generation)
|
||||||
|
(system-path system-path)
|
||||||
|
(epoch epoch)
|
||||||
|
(parameters
|
||||||
|
(let* ((params (call-with-input-string serialized-params
|
||||||
|
read-boot-parameters))
|
||||||
|
(root (boot-parameters-root-device params))
|
||||||
|
(text (boot-parameters-label params))
|
||||||
|
(version (boot-parameters-version params)))
|
||||||
|
(boot-parameters
|
||||||
|
(inherit params)
|
||||||
|
(label (decorated-boot-label text generation epoch))
|
||||||
|
(kernel-arguments
|
||||||
|
(append
|
||||||
|
(bootable-kernel-arguments system-path root version)
|
||||||
|
(boot-parameters-kernel-arguments params))))))))))
|
||||||
|
|
||||||
(mlet %store-monad
|
(mlet %store-monad
|
||||||
((remote-results (machine-remote-eval machine remote-exp)))
|
((remote-results (machine-remote-eval machine remote-exp)))
|
||||||
(return
|
(return (map remote-result->boot-alternative remote-results))))
|
||||||
(map (lambda (remote-result)
|
|
||||||
(match remote-result
|
|
||||||
((generation system-path epoch serialized-params)
|
|
||||||
(let* ((params (call-with-input-string serialized-params
|
|
||||||
read-boot-parameters))
|
|
||||||
(root (boot-parameters-root-device params))
|
|
||||||
(text (boot-parameters-label params))
|
|
||||||
(version (boot-parameters-version params)))
|
|
||||||
(boot-parameters
|
|
||||||
(inherit params)
|
|
||||||
(label (decorated-boot-label text generation epoch))
|
|
||||||
(kernel-arguments
|
|
||||||
(append (bootable-kernel-arguments system-path root version)
|
|
||||||
(boot-parameters-kernel-arguments params))))))))
|
|
||||||
remote-results))))
|
|
||||||
|
|
||||||
(define-syntax-rule (with-roll-back should-roll-back? mbody ...)
|
(define-syntax-rule (with-roll-back should-roll-back? mbody ...)
|
||||||
"Catch exceptions that arise when binding MBODY, a monadic expression in
|
"Catch exceptions that arise when binding MBODY, a monadic expression in
|
||||||
|
@ -511,7 +518,8 @@ (define system (machine-ssh-configuration-system config))
|
||||||
(%current-target-system #f))
|
(%current-target-system #f))
|
||||||
(let* ((os (machine-operating-system machine))
|
(let* ((os (machine-operating-system machine))
|
||||||
(eval (cut machine-remote-eval machine <>))
|
(eval (cut machine-remote-eval machine <>))
|
||||||
(menu-entries (map boot-parameters->menu-entry boot-alternatives))
|
(menu-entries (map boot-alternative->menu-entry
|
||||||
|
boot-alternatives))
|
||||||
(bootloader-configuration (operating-system-bootloader os))
|
(bootloader-configuration (operating-system-bootloader os))
|
||||||
(bootcfg (operating-system-bootcfg os menu-entries)))
|
(bootcfg (operating-system-bootcfg os menu-entries)))
|
||||||
(define-syntax-rule (eval/error-handling condition handler ...)
|
(define-syntax-rule (eval/error-handling condition handler ...)
|
||||||
|
@ -586,7 +594,8 @@ (define roll-back-failure
|
||||||
((boot-alternatives (machine->boot-alternatives machine))
|
((boot-alternatives (machine->boot-alternatives machine))
|
||||||
(_ -> (when (< (length boot-alternatives) 2)
|
(_ -> (when (< (length boot-alternatives) 2)
|
||||||
(raise roll-back-failure)))
|
(raise roll-back-failure)))
|
||||||
(parameters (second boot-alternatives))
|
(chosen-alternative (second boot-alternatives))
|
||||||
|
(parameters (boot-alternative-parameters chosen-alternative))
|
||||||
(entries -> (list (boot-parameters->menu-entry parameters)))
|
(entries -> (list (boot-parameters->menu-entry parameters)))
|
||||||
(locale -> (boot-parameters-locale parameters))
|
(locale -> (boot-parameters-locale parameters))
|
||||||
(crypto-dev -> (boot-parameters-store-crypto-devices parameters))
|
(crypto-dev -> (boot-parameters-store-crypto-devices parameters))
|
||||||
|
|
|
@ -12,6 +12,7 @@
|
||||||
;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr>
|
;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr>
|
||||||
;;; Copyright © 2024 Felix Lechner <felix.lechner@lease-up.com>
|
;;; Copyright © 2024 Felix Lechner <felix.lechner@lease-up.com>
|
||||||
;;; Copyright © 2024 Herman Rimm <herman@rimm.ee>
|
;;; Copyright © 2024 Herman Rimm <herman@rimm.ee>
|
||||||
|
;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -67,9 +68,17 @@ (define-module (gnu system boot)
|
||||||
read-boot-parameters-file
|
read-boot-parameters-file
|
||||||
bootable-kernel-arguments
|
bootable-kernel-arguments
|
||||||
|
|
||||||
|
boot-alternative
|
||||||
|
boot-alternative?
|
||||||
|
boot-alternative-generation
|
||||||
|
boot-alternative-system-path
|
||||||
|
boot-alternative-epoch
|
||||||
|
boot-alternative-parameters
|
||||||
|
|
||||||
epoch->date-string
|
epoch->date-string
|
||||||
decorated-boot-label
|
decorated-boot-label
|
||||||
boot-parameters->menu-entry
|
boot-parameters->menu-entry
|
||||||
|
boot-alternative->menu-entry
|
||||||
|
|
||||||
ensure-not-/dev
|
ensure-not-/dev
|
||||||
system-linux-image-file-name))
|
system-linux-image-file-name))
|
||||||
|
@ -295,6 +304,13 @@ (define version>0? (> version 0))
|
||||||
#~(string-append (if #$version>0? "gnu.load=" "--load=")
|
#~(string-append (if #$version>0? "gnu.load=" "--load=")
|
||||||
#$system "/boot")))))
|
#$system "/boot")))))
|
||||||
|
|
||||||
|
(define-record-type* <boot-alternative>
|
||||||
|
boot-alternative make-boot-alternative boot-alternative?
|
||||||
|
(generation boot-alternative-generation)
|
||||||
|
(system-path boot-alternative-system-path)
|
||||||
|
(epoch boot-alternative-epoch)
|
||||||
|
(parameters boot-alternative-parameters)) ; <boot-parameters>
|
||||||
|
|
||||||
(define (epoch->date-string epoch)
|
(define (epoch->date-string epoch)
|
||||||
"Return a string representing the date for EPOCH seconds."
|
"Return a string representing the date for EPOCH seconds."
|
||||||
(let ((time (make-time time-utc 0 epoch)))
|
(let ((time (make-time time-utc 0 epoch)))
|
||||||
|
@ -333,6 +349,9 @@ (define (boot-parameters->menu-entry conf)
|
||||||
(boot-parameters-multiboot-modules conf)
|
(boot-parameters-multiboot-modules conf)
|
||||||
'())))))
|
'())))))
|
||||||
|
|
||||||
|
(define boot-alternative->menu-entry
|
||||||
|
(compose boot-parameters->menu-entry boot-alternative-parameters))
|
||||||
|
|
||||||
(define (ensure-not-/dev device)
|
(define (ensure-not-/dev device)
|
||||||
"If DEVICE starts with a slash, return #f. This is meant to filter out
|
"If DEVICE starts with a slash, return #f. This is meant to filter out
|
||||||
Linux device names such as /dev/sda, and to preserve GRUB device names and
|
Linux device names such as /dev/sda, and to preserve GRUB device names and
|
||||||
|
|
|
@ -328,25 +328,30 @@ (define-syntax-rule (unless-file-not-found exp)
|
||||||
#f
|
#f
|
||||||
(apply throw args)))))
|
(apply throw args)))))
|
||||||
|
|
||||||
(define (generation->boot-parameters profile number)
|
(define (generation->boot-alternative profile number)
|
||||||
"Return the 'boot-parameters' for the generation of PROFILE specified
|
"Return the 'boot-alternative' for the generation of PROFILE specified
|
||||||
by NUMBER."
|
by NUMBER."
|
||||||
(unless-file-not-found
|
(unless-file-not-found
|
||||||
(let* ((system (generation-file-name profile number))
|
(let* ((system (generation-file-name profile number))
|
||||||
(params (read-boot-parameters-file system))
|
(params (read-boot-parameters-file system))
|
||||||
(epoch (stat:mtime (lstat system)))
|
(epoch (stat:mtime (lstat system)))
|
||||||
(text (boot-parameters-label params)))
|
(text (boot-parameters-label params)))
|
||||||
(boot-parameters
|
(boot-alternative
|
||||||
(inherit params)
|
(generation number)
|
||||||
(label (decorated-boot-label text number epoch))))))
|
(system-path system)
|
||||||
|
(epoch epoch)
|
||||||
|
(parameters
|
||||||
|
(boot-parameters
|
||||||
|
(inherit params)
|
||||||
|
(label (decorated-boot-label text number epoch))))))))
|
||||||
|
|
||||||
(define* (profile->boot-alternatives #:optional (profile %system-profile)
|
(define* (profile->boot-alternatives #:optional (profile %system-profile)
|
||||||
(numbers
|
(numbers
|
||||||
(reverse (generation-numbers profile))))
|
(reverse (generation-numbers profile))))
|
||||||
"Return a list of 'boot-parameters' for the generations of PROFILE specified
|
"Return a list of 'boot-alternative' for the generations of PROFILE
|
||||||
by NUMBERS, which is a list of generation numbers. The list is ordered from
|
specified by NUMBERS, which is a list of generation numbers. The list is
|
||||||
the most recent to the oldest profiles."
|
ordered from the most recent to the oldest profiles."
|
||||||
(filter-map (cut generation->boot-parameters profile <>) numbers))
|
(filter-map (cut generation->boot-alternative profile <>) numbers))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
|
@ -394,7 +399,9 @@ (define (reinstall-bootloader store number)
|
||||||
(bootloader bootloader)))
|
(bootloader bootloader)))
|
||||||
|
|
||||||
;; Make the specified system generation the default entry.
|
;; Make the specified system generation the default entry.
|
||||||
(params (generation->boot-parameters %system-profile number))
|
(chosen-alternative (generation->boot-alternative
|
||||||
|
%system-profile number))
|
||||||
|
(params (boot-alternative-parameters chosen-alternative))
|
||||||
(locale (boot-parameters-locale params))
|
(locale (boot-parameters-locale params))
|
||||||
(store-crypto-devices (boot-parameters-store-crypto-devices params))
|
(store-crypto-devices (boot-parameters-store-crypto-devices params))
|
||||||
(store-directory-prefix
|
(store-directory-prefix
|
||||||
|
@ -404,7 +411,7 @@ (define (reinstall-bootloader store number)
|
||||||
(previous-boot-alternatives (profile->boot-alternatives
|
(previous-boot-alternatives (profile->boot-alternatives
|
||||||
%system-profile old-generations))
|
%system-profile old-generations))
|
||||||
(entries (list (boot-parameters->menu-entry params)))
|
(entries (list (boot-parameters->menu-entry params)))
|
||||||
(old-entries (map boot-parameters->menu-entry
|
(old-entries (map boot-alternative->menu-entry
|
||||||
previous-boot-alternatives)))
|
previous-boot-alternatives)))
|
||||||
(run-with-store store
|
(run-with-store store
|
||||||
(mlet* %store-monad
|
(mlet* %store-monad
|
||||||
|
@ -822,7 +829,8 @@ (define bootcfg
|
||||||
os
|
os
|
||||||
(if (eq? action 'init)
|
(if (eq? action 'init)
|
||||||
'()
|
'()
|
||||||
(map boot-parameters->menu-entry (profile->boot-alternatives))))))
|
(map boot-alternative->menu-entry
|
||||||
|
(profile->boot-alternatives))))))
|
||||||
|
|
||||||
(when (eq? action 'reconfigure)
|
(when (eq? action 'reconfigure)
|
||||||
(maybe-suggest-running-guix-pull)
|
(maybe-suggest-running-guix-pull)
|
||||||
|
|
Loading…
Reference in a new issue