[bug#73202] [PATCH v2 10/15] gnu: bootloader: Add device-subvol field to menu-entry record.

[Herman Rimm via Guix-patches via <guix-patches@gnu.org>]

From: Lilah Tascheter <lilah@lunabee.space>

* gnu/bootloader.scm (menu-entry-device-subvol): Add and export field.
(normalize-file): Add procedure.
(device->sexp): Match device-subvol and include in S-expression.
(sexp->menu-entry): Try match device-subvol and include in menu-entry.
* gnu/system/boot.scm (boot-parameters->menu-entry): Add device-subvol
value to menu-entry.

Change-Id: I3654d160f7306bb45a78b82ea6b249ff4281f739
---
 gnu/bootloader.scm  | 51 ++++++++++++++++++++++++++++++++++-----------
 gnu/system/boot.scm |  2 ++
 2 files changed, 41 insertions(+), 12 deletions(-)

diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm
index c77de6f55e..f1352122a9 100644
--- a/gnu/bootloader.scm
+++ b/gnu/bootloader.scm
@@ -51,15 +51,17 @@ (define-module (gnu bootloader)
             menu-entry?
             menu-entry-label
             menu-entry-device
+            menu-entry-device-mount-point
+            menu-entry-device-subvol
             menu-entry-linux
             menu-entry-linux-arguments
             menu-entry-initrd
-            menu-entry-device-mount-point
             menu-entry-multiboot-kernel
             menu-entry-multiboot-arguments
             menu-entry-multiboot-modules
             menu-entry-chain-loader
 
+            normalize-file
             menu-entry->sexp
             sexp->menu-entry
 
@@ -126,6 +128,8 @@ (define-record-type* <menu-entry>
                    (default #f))
   (device-mount-point menu-entry-device-mount-point
                    (default #f))
+  (device-subvol menu-entry-device-subvol
+                   (default #f))
   (linux           menu-entry-linux
                    (default #f))
   (linux-arguments menu-entry-linux-arguments
@@ -142,6 +146,18 @@ (define-record-type* <menu-entry>
   (chain-loader     menu-entry-chain-loader
                     (default #f)))         ; string, path of efi file
 
+(define (normalize-file entry file)
+  "Normalize a file FILE stored in a menu entry into one suitable for a
+bootloader.  Realizes device-mount-point and device-subvol."
+  (match-menu-entry entry (device-mount-point device-subvol)
+    ;; Avoid using cut procedure from SRFI-26 inside G-exp.
+    (let ((mount (and=> device-mount-point (cut string-trim <> #\/))))
+      #~(let* ((file (string-trim #$file #\/))
+               (file (if (and #$mount (string-prefix? #$mount file))
+                         (substring file (string-length #$mount))
+                         file)))
+          (string-append (or #$device-subvol "") "/" file)))))
+
 (define (report-menu-entry-error menu-entry)
   (raise
    (condition
@@ -169,7 +185,7 @@ (define (menu-entry->sexp entry)
        `(label ,(file-system-label->string label)))
       (_ device)))
   (match entry
-    (($ <menu-entry> label device mount-point
+    (($ <menu-entry> label device mount-point subvol
                      (? identity linux) linux-arguments (? identity initrd)
                      #f () () #f)
      `(menu-entry (version 0)
@@ -178,8 +194,9 @@ (define (menu-entry->sexp entry)
                   (device-mount-point ,mount-point)
                   (linux ,linux)
                   (linux-arguments ,linux-arguments)
-                  (initrd ,initrd)))
-    (($ <menu-entry> label device mount-point #f () #f
+                  (initrd ,initrd)
+                  (device-subvol ,subvol)))
+    (($ <menu-entry> label device mount-point subvol #f () #f
                      (? identity multiboot-kernel) multiboot-arguments
                      multiboot-modules #f)
      `(menu-entry (version 0)
@@ -188,19 +205,23 @@ (define (menu-entry->sexp entry)
                   (device-mount-point ,mount-point)
                   (multiboot-kernel ,multiboot-kernel)
                   (multiboot-arguments ,multiboot-arguments)
-                  (multiboot-modules ,multiboot-modules)))
-    (($ <menu-entry> label device mount-point #f () #f #f () ()
+                  (multiboot-modules ,multiboot-modules)
+                  (device-subvol ,subvol)))
+    (($ <menu-entry> label device mount-point subvol #f () #f #f () ()
                      (? identity chain-loader))
      `(menu-entry (version 0)
                   (label ,label)
                   (device ,(device->sexp device))
                   (device-mount-point ,mount-point)
-                  (chain-loader ,chain-loader)))
+                  (chain-loader ,chain-loader)
+                  (device-subvol ,subvol)))
     (_ (report-menu-entry-error entry))))
 
 (define (sexp->menu-entry sexp)
   "Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
 record."
+  ;; XXX: The match ORs shadow subvol.
+  (define subvol #f)
   (define (sexp->device device-sexp)
     (match device-sexp
       (('uuid type uuid-string)
@@ -213,35 +234,41 @@ (define (sexp->menu-entry sexp)
                   ('label label) ('device device)
                   ('device-mount-point mount-point)
                   ('linux linux) ('linux-arguments linux-arguments)
-                  ('initrd initrd) _ ...)
+                  ('initrd initrd)
+                  (or ('device-subvol subvol _ ...) (_ ...)))
      (menu-entry
       (label label)
       (device (sexp->device device))
       (device-mount-point mount-point)
+      (device-subvol subvol)
       (linux linux)
       (linux-arguments linux-arguments)
       (initrd initrd)))
     (('menu-entry ('version 0)
                   ('label label) ('device device)
-                  ('device-mount-point mount-point)
+                  ('device-mount-point mount-point) ('device-subvol subvol)
                   ('multiboot-kernel multiboot-kernel)
                   ('multiboot-arguments multiboot-arguments)
-                  ('multiboot-modules multiboot-modules) _ ...)
+                  ('multiboot-modules multiboot-modules)
+                  (or ('device-subvol subvol _ ...) (_ ...)))
      (menu-entry
       (label label)
       (device (sexp->device device))
       (device-mount-point mount-point)
+      (device-subvol subvol)
       (multiboot-kernel multiboot-kernel)
       (multiboot-arguments multiboot-arguments)
       (multiboot-modules multiboot-modules)))
     (('menu-entry ('version 0)
                   ('label label) ('device device)
-                  ('device-mount-point mount-point)
-                  ('chain-loader chain-loader) _ ...)
+                  ('device-mount-point mount-point) ('device-subvol subvol)
+                  ('chain-loader chain-loader)
+                  (or ('device-subvol subvol _ ...) (_ ...)))
      (menu-entry
       (label label)
       (device (sexp->device device))
       (device-mount-point mount-point)
+      (device-subvol subvol)
       (chain-loader chain-loader)))))
 
 \f
diff --git a/gnu/system/boot.scm b/gnu/system/boot.scm
index a898ab9549..8a183ebe3a 100644
--- a/gnu/system/boot.scm
+++ b/gnu/system/boot.scm
@@ -16,6 +16,7 @@
 ;;; Copyright © 2021 raid5atemyhomework <raid5atemyhomework@protonmail.com>
 ;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu>
 ;;; Copyright © 2023 Felix Lechner <felix.lechner@lease-up.com>
+;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -332,6 +333,7 @@ (define (boot-parameters->menu-entry conf)
      (label (boot-parameters-label conf))
      (device (boot-parameters-store-device conf))
      (device-mount-point (boot-parameters-store-mount-point conf))
+     (device-subvol (boot-parameters-store-directory-prefix conf))
      (linux (and (not multiboot?) kernel))
      (linux-arguments (if (not multiboot?)
                           (boot-parameters-kernel-arguments conf)
-- 
2.45.2