Subject: [PATCH v5 10/10] Encapsulate <boot-parameters> to retain generation, system-path and epoch.

From: Herman Rimm <[email-masked]>
Date: Sat, 21 Sep 2024 12:23:23 +0200

From: Felix Lechner <[email-masked]>

* 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
---
 gnu/machine/ssh.scm     | 49 ++++++++++++++++++++++++-----------------
 gnu/system/boot.scm     | 19 ++++++++++++++++
 guix/scripts/system.scm | 32 +++++++++++++++++----------
 3 files changed, 68 insertions(+), 32 deletions(-)

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index eb8dba3120..3a0c5f45c6 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -418,8 +418,9 @@ (define not-config?
     (_ #f)))
 
 (define (machine->boot-alternatives machine)
-  "Monadic procedure returning a list of 'boot-parameters' for the generations
-of MACHINE's system profile, ordered from most recent to oldest."
+  "Monadic procedure returning a list of <boot-alternative> records for
+the generations of MACHINE's system profile, ordered from most recent to
+oldest."
   (define remote-exp
     (with-extensions (list guile-gcrypt)
       (with-imported-modules `(((guix config) => ,(make-config.scm))
@@ -451,24 +452,30 @@ (define (machine->boot-alternatives machine)
                            (read-file boot-parameters-path))))
                  (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
       ((remote-results (machine-remote-eval machine remote-exp)))
-    (return
-     (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))))
+    (return (map remote-result->boot-alternative remote-results))))
 
 (define-syntax-rule (with-roll-back should-roll-back? mbody ...)
   "Catch exceptions that arise when binding MBODY, a monadic expression in
@@ -511,7 +518,8 @@ (define (deploy-managed-host machine)
                    (%current-target-system #f))
       (let* ((os (machine-operating-system 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))
              (bootcfg (operating-system-bootcfg os menu-entries)))
         (define-syntax-rule (eval/error-handling condition handler ...)
@@ -586,7 +594,8 @@ (define (roll-back-managed-host machine)
          ((boot-alternatives (machine->boot-alternatives machine))
           (_ -> (when (< (length boot-alternatives) 2)
                   (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)))
           (locale -> (boot-parameters-locale parameters))
           (crypto-dev -> (boot-parameters-store-crypto-devices parameters))
diff --git a/gnu/system/boot.scm b/gnu/system/boot.scm
index 1e0d75212f..de312c7208 100644
--- a/gnu/system/boot.scm
+++ b/gnu/system/boot.scm
@@ -12,6 +12,7 @@
 ;;; Copyright © 2024 Nicolas Graves <[email-masked]>
 ;;; Copyright © 2024 Felix Lechner <[email-masked]>
 ;;; Copyright © 2024 Herman Rimm <[email-masked]>
+;;; Copyright © 2024 Lilah Tascheter <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -67,9 +68,17 @@ (define-module (gnu system boot)
             read-boot-parameters-file
             bootable-kernel-arguments
 
+            boot-alternative
+            boot-alternative?
+            boot-alternative-generation
+            boot-alternative-system-path
+            boot-alternative-epoch
+            boot-alternative-parameters
+
             epoch->date-string
             decorated-boot-label
             boot-parameters->menu-entry
+            boot-alternative->menu-entry
 
             ensure-not-/dev
             system-linux-image-file-name))
@@ -295,6 +304,13 @@ (define* (bootable-kernel-arguments system root-device version)
            #~(string-append (if #$version>0? "gnu.load=" "--load=")
                             #$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)
   "Return a string representing the date for EPOCH seconds."
   (let ((time (make-time time-utc 0 epoch)))
@@ -333,6 +349,9 @@ (define (boot-parameters->menu-entry conf)
                             (boot-parameters-multiboot-modules conf)
                             '())))))
 
+(define boot-alternative->menu-entry
+  (compose boot-parameters->menu-entry boot-alternative-parameters))
+
 (define (ensure-not-/dev device)
   "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
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 4ca4f1fa85..0fd153a278 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -328,25 +328,30 @@ (define-syntax-rule (unless-file-not-found exp)
           #f
           (apply throw args)))))
 
-(define (generation->boot-parameters profile number)
-  "Return the 'boot-parameters' for the generation of PROFILE specified
+(define (generation->boot-alternative profile number)
+  "Return the 'boot-alternative' for the generation of PROFILE specified
 by NUMBER."
   (unless-file-not-found
    (let* ((system (generation-file-name profile number))
           (params (read-boot-parameters-file system))
           (epoch (stat:mtime (lstat system)))
           (text (boot-parameters-label params)))
-     (boot-parameters
-      (inherit params)
-      (label (decorated-boot-label text number epoch))))))
+     (boot-alternative
+      (generation number)
+      (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)
                                      (numbers
                                       (reverse (generation-numbers profile))))
-  "Return a list of 'boot-parameters' for the generations of PROFILE specified
-by NUMBERS, which is a list of generation numbers. The list is ordered from
-the most recent to the oldest profiles."
-  (filter-map (cut generation->boot-parameters profile <>) numbers))
+  "Return a list of 'boot-alternative' for the generations of PROFILE
+specified by NUMBERS, which is a list of generation numbers. The list is
+ordered from the most recent to the oldest profiles."
+  (filter-map (cut generation->boot-alternative profile <>) numbers))
 
 
 ;;;
@@ -394,7 +399,9 @@ (define (reinstall-bootloader store number)
                              (bootloader bootloader)))
 
          ;; 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))
          (store-crypto-devices (boot-parameters-store-crypto-devices params))
          (store-directory-prefix
@@ -404,7 +411,7 @@ (define (reinstall-bootloader store number)
          (previous-boot-alternatives (profile->boot-alternatives
                                       %system-profile old-generations))
          (entries (list (boot-parameters->menu-entry params)))
-         (old-entries (map boot-parameters->menu-entry
+         (old-entries (map boot-alternative->menu-entry
                            previous-boot-alternatives)))
     (run-with-store store
       (mlet* %store-monad
@@ -822,7 +829,8 @@ (define* (perform-action action image
           os
           (if (eq? action 'init)
               '()
-              (map boot-parameters->menu-entry (profile->boot-alternatives))))))
+              (map boot-alternative->menu-entry
+                   (profile->boot-alternatives))))))
 
   (when (eq? action 'reconfigure)
     (maybe-suggest-running-guix-pull)
-- 
2.45.2