[bug#73202] [PATCH v2 08/15] gnu: bootloader: Add bootloader-target record and infastructure.

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

From: Lilah Tascheter <lilah@lunabee.space>

* gnu/bootloader.scm (bootloader-target): New record.
(&target-error): New condition.
(pathcat, get-target-of-type, parent-of, unfold-pathcat, target-base?,
type-major?, ensure, ensure-target-types, ensure-majors, gbegin): New
procedures.
(define-literal, with-targets, :path, :devpath, :device, :fs, :label,
:uuid): New macros.
* guix/ui.scm (call-with-error-handling)[target-error?]: Handle
target-errors.

Change-Id: I3f07c9096dd8b91c04449b6360b3b7d21640da14
---
 gnu/bootloader.scm | 229 ++++++++++++++++++++++++++++++++++++++++++++-
 guix/ui.scm        |   9 ++
 2 files changed, 233 insertions(+), 5 deletions(-)

diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm
index 3ea50a4004..0c24996205 100644
--- a/gnu/bootloader.scm
+++ b/gnu/bootloader.scm
@@ -7,6 +7,7 @@
 ;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
 ;;; Copyright © 2022 Reza Alizadeh Majd <r.majd@pantherx.org>
 ;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz>
+;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,19 +25,28 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu bootloader)
+  #:autoload   (gnu build file-systems)
+               (read-partition-label read-partition-uuid
+                find-partition-by-label find-partition-by-uuid)
   #:use-module (gnu system file-systems)
   #:use-module (gnu system uuid)
-  #:use-module (guix gexp)
-  #:use-module (guix profiles)
-  #:use-module (guix records)
+  #:autoload   (guix build syscalls)
+               (mounts mount-source mount-point mount-type)
   #:use-module (guix deprecation)
-  #:use-module ((guix ui) #:select (warn-about-load-error))
   #:use-module (guix diagnostics)
+  #:use-module (guix gexp)
   #:use-module (guix i18n)
+  #:use-module (guix modules)
+  #:use-module (guix profiles)
+  #:use-module (guix records)
+  #:use-module (guix utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 receive)
+  #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
-  #:use-module (ice-9 match)
   #:export (menu-entry
             menu-entry?
             menu-entry-label
@@ -62,6 +72,25 @@ (define-module (gnu bootloader)
             bootloader-configuration-file
             bootloader-configuration-file-generator
 
+            bootloader-target
+            bootloader-target?
+            bootloader-target-type
+            bootloader-target-expected?
+            bootloader-target-path
+            bootloader-target-offset
+            bootloader-target-device
+            bootloader-target-file-system
+            bootloader-target-label
+            bootloader-target-uuid
+
+            target-error?
+            target-error-type
+            target-error-targets
+
+            gbegin
+            :path :devpath :device :fs :label :uuid
+            with-targets
+
             bootloader-configuration
             bootloader-configuration?
             bootloader-configuration-bootloader
@@ -232,6 +261,196 @@ (define-record-type* <bootloader>
   (configuration-file              bootloader-configuration-file)
   (configuration-file-generator    bootloader-configuration-file-generator))
 
+\f
+;;;
+;;; Bootloader target record.
+;;;
+
+;; <bootloader-target> represents different kinds of targets in a
+;; normalized form.
+
+(define-record-type* <bootloader-target>
+  bootloader-target make-bootloader-target bootloader-target?
+  (type bootloader-target-type)                            ; symbol
+  (expected? bootloader-target-expected? (default #f))     ; bool
+
+  (path bootloader-target-path (default #f))               ; string|#f
+  (offset bootloader-target-offset (thunked)               ; symbol|#f
+          (default (and (bootloader-target-path this-record)
+                        (not (eq? (bootloader-target-type this-record) 'root))
+                        'root)))
+  (device bootloader-target-device (default #f))           ; string|#f
+  (file-system bootloader-target-file-system (default #f)) ; string|#f
+  (label bootloader-target-label (default #f))             ; string|#f
+  (uuid bootloader-target-uuid (default #f)))              ; uuid|#f
+
+(define-condition-type &target-error &error target-error?
+  (type target-error-type)
+  (targets target-error-targets))
+
+(define (pathcat p1 p2)
+  (string-append (string-trim-right p1 #\/) "/" (string-trim p2 #\/)))
+
+(define* (get-target-of-type type targets #:optional require?)
+  "Finds a target in TARGETS of type TYPE, returns REQUIRE? if #false,
+or provides an error otherwise."
+  (define (type? target)
+    (eq? type (bootloader-target-type target)))
+  (match (filter type? targets)
+    ((target _ ...) target)
+    (_ (and require?
+            (raise
+              (condition
+                (&message (message (G_ "required, but not provided")))
+                (&target-error (type type) (targets targets))))))))
+
+(define (parent-of target targets)
+  "Resolve the parent of TARGET in TARGETS, return #f if orphan."
+  (and=> (bootloader-target-offset target)
+         (cut get-target-of-type <> targets #t)))
+
+(define (unfold-pathcat target targets)
+  "Find the full VFS path of TARGET."
+  (let ((quit (lambda (t) (not (and=> t bootloader-target-path))))
+        (parent-of (cut parent-of <> targets)))
+    (reduce pathcat #f
+      (unfold quit bootloader-target-path parent-of target))))
+
+(define (target-base? t)
+  (or (not t) (match-record t <bootloader-target>
+                (expected? offset device label uuid)
+                (or device label uuid (not offset) expected?))))
+
+(define (type-major? target) (memq target '(root esp disk)))
+
+(define (ensure types targets end)
+  (let* ((used-in (cute unfold end identity (cut parent-of <> targets) <>))
+         (cons-in (lambda (t) (cons t (used-in t))))
+         (ensure (map (cut get-target-of-type <> targets #t) types)))
+    (filter identity (apply append (map cons-in ensure)))))
+
+(define* (ensure-target-types types targets #:optional (base? #f))
+  "Ensures all TYPES are provided in TARGETS.  Returns #t iff every ensured
+target and its requirements are fully provided.  Errors out when a required TYPE
+isn't provided.  When BASE?, only ensure path requirements up to a device."
+  (not (any bootloader-target-expected?
+         (ensure types targets (if base? target-base? not)))))
+
+(define (ensure-majors types targets)
+  "Errors out when a required TYPE isn't provided, or when use of multiple major
+targets is detected."
+  (let* ((all (map bootloader-target-type (ensure types targets target-base?)))
+         (majors (delete-duplicates (filter type-major? all) eq?)))
+    (if (< (length majors) 2) #t
+      (raise (condition (&message (message (G_ "multiple major targets used")))
+                        (&target-error (type majors) (targets targets)))))))
+
+
+
+(define (gbegin . gex)
+  "Sequence provided g-expressions."
+  (case (length gex) ((0) #f) ((1) (car gex)) (else #~(begin #$@gex))))
+
+;; syntax matching on free literals breaks easily, so bind them
+(define-syntax-rule (define-literal id) (define-syntax id (syntax-rules ())))
+(define-literal :path)
+(define-literal :devpath)
+(define-literal :device)
+(define-literal :fs)
+(define-literal :label)
+(define-literal :uuid)
+
+(define-syntax with-targets
+  (cut syntax-case <> ()
+    ((_ targets-expr block ...)
+     (let* ((genvars (compose generate-temporaries make-list))
+            (targets (car (genvars 1))))
+       (define (resolve in target base)
+         (with-syntax ((target target) (base base) (targets targets))
+           (syntax-case in
+             (:path :devpath :device :fs :label :uuid)
+             ((name _) (not (identifier? #'name))
+              #`(_ (syntax-error "binds must be to identifiers" #,in)))
+             ((name :device) #'(name (bootloader-target-device base)))
+             ((name :label) #'(name (bootloader-target-label base)))
+             ((name :uuid) #'(name (bootloader-target-uuid base)))
+             ((name :fs) #'(name (bootloader-target-file-system base)))
+             ((name :path) #'(name (unfold-pathcat target targets)))
+             ((name :devpath)
+              #'(name (if (target-base? target)
+                          "/"
+                          (pathcat "/" (bootloader-target-path target)))))
+             (_ #`(_ (syntax-error "invalid binding spec" #,in))))))
+
+       (define (binds spec)
+         (syntax-case spec (=>)
+           ((type => binds ...)
+            (with-syntax (((target base) (genvars 2)) (targets targets))
+              (append
+                #`((get (lambda (t) (get-target-of-type t targets #t)))
+                   (target (get type))
+                   (base (if (target-base? target)
+                             target
+                             (get (bootloader-target-offset target)))))
+                (map (cut resolve <> #'target #'base) #'(binds ...)))))
+           (_ #f)))
+
+       (define blocks
+         (cut syntax-case <> ()
+           ((spec ... expr)
+            (let* ((path? (cut syntax-case <> (:path) ((_ :path) #t) (_ #f)))
+                   (qualified? (cut syntax-case <> (=>)
+                                 ((_ => spec ...) (any path? #'(spec ...)))
+                                 (_ #f)))
+                   (specs #'(spec ...))
+                   (lets (apply append (filter-map binds specs)))
+                   (type (cut syntax-case <> (=>)
+                           ((t => _ ...) #'t) (t #'t))))
+              (receive (full part) (partition qualified? specs)
+                #`(and (ensure-majors (list #,@(map type specs)) #,targets)
+                       (ensure-target-types (list #,@(map type part))
+                                            #,targets #t)
+                       (ensure-target-types (list #,@(map type full))
+                                            #,targets #f)
+                       (let* #,lets expr)))))
+           (bad #'(syntax-error "malformed block" bad))))
+       "Using the list TARGETS, evaluate and sequence each BLOCK to produce a
+gexp.  BLOCK is a set of SPECs followed by an EXPR (evaluating to a gexp).
+Each SPEC denotes a type of target to guard EXPR on their existance and
+full-qualification.  This procedure is linear in regard to BLOCKs.
+
+SPEC may be of the following forms:
+@itemize
+@item 'TYPE Requires TYPE to be fully present or promised. Errors otherwise.
+@item ('TYPE => (VAR COMPONENT) ...): As type, but also binds variables. TYPE's
+      COMPONENT is bound to the variable VAR as described below.
+@end itemize
+
+Available COMPONENTs are:
+@itemize
+@item :path (fully-qualified)
+@item :devpath (relative from device)
+@item :device (auto-detected from uuid and label if not user-provided)
+@item :fs
+@item :label
+@item :uuid
+@end itemize
+
+Note that installers may be called multiple times with different targets being
+fully-qualified.  To ensure that targets aren't installed multiple times, make sure
+that each BLOCK ensures at least one major target, either directly or indirectly.
+Likewise, at most one major target should be ensured per BLOCK, under the same
+conditions.  Major targets originate from disk image handling, and are currently:
+@itemize
+@item disk
+@item root
+@item esp
+@end itemize"
+       #`(let ((#,targets targets-expr))
+           (apply gbegin (filter identity
+                                 (list #,@(map blocks #'(block ...))))))))
+    (bad #'(syntax-error "must provide targets" bad))))
+
 \f
 ;;;
 ;;; Bootloader configuration record.
diff --git a/guix/ui.scm b/guix/ui.scm
index 966f0611f6..0b1455cb3c 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -19,6 +19,7 @@
 ;;; Copyright © 2018 Steve Sprang <scs@stevesprang.com>
 ;;; Copyright © 2022 Taiju HIGASHI <higashi@taiju.info>
 ;;; Copyright © 2022 Liliana Marie Prikler <liliana.prikler@gmail.com>
+;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -36,6 +37,8 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix ui)                       ;import in user interfaces only
+  #:use-module ((gnu bootloader)
+                #:select (target-error? target-error-type target-error-targets))
   #:use-module (guix i18n)
   #:use-module (guix colors)
   #:use-module (guix diagnostics)
@@ -861,6 +864,12 @@ (define (call-with-error-handling thunk)
                      (invoke-error-stop-signal c)
                      (cons (invoke-error-program c)
                            (invoke-error-arguments c))))
+              ((target-error? c)
+               (leave (G_ "bootloader-target '~a'~@[: ~a~] ~
+                          among the following targets:~%~{~y~}")
+                      (target-error-type c)
+                      (and (message-condition? c) (condition-message c))
+                      (target-error-targets c)))
 
              ((formatted-message? c)
               (apply report-error
-- 
2.45.2