[bug#72457] [PATCH v2 02/15] gnu: Add bootloader target infastructure.

[Lilah Tascheter via Guix-patches <guix-patches@gnu.org>]

* 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.

  (bootloader-modules): Prevent mutual imports.

* guix/ui.scm (call-with-error-handling)[target-error?]:
  Handle target-errors.

Change-Id: I3f07c9096dd8b91c04449b6360b3b7d21640da14
---
 gnu/bootloader.scm | 212 ++++++++++++++++++++++++++++++++++++++++++++-
 guix/ui.scm        |   8 ++
 2 files changed, 217 insertions(+), 3 deletions(-)

diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm
index f32e90e79d..3ddc112cc6 100644
--- a/gnu/bootloader.scm
+++ b/gnu/bootloader.scm
@@ -31,10 +31,11 @@ (define-module (gnu bootloader)
   #:use-module (guix profiles)
   #:use-module (guix records)
   #:use-module (guix deprecation)
-  #:use-module ((guix ui) #:select (warn-about-load-error))
   #:use-module (guix diagnostics)
   #:use-module (guix i18n)
+  #:use-module (guix modules)
   #: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)
@@ -63,6 +64,26 @@ (define-module (gnu bootloader)
             bootloader-configuration-file
             bootloader-configuration-file-generator
 
+            <bootloader-target>
+            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
@@ -236,6 +257,191 @@ (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? #f))
+  "Finds a target in TARGETS of type TYPE, optionally providing an error when
+not found if REQUIRE? is provided."
+  (let* ((pred (lambda (target) (eq? type (bootloader-target-type target))))
+         (candidates (filter pred targets))
+         (ret (if (pair? candidates) (car candidates) #f)))
+    (if (and require? (not ret))
+      (raise (condition
+               (&message (message (G_ "required, but not provided")))
+               (&target-error (type type) (targets targets))))
+      ret)))
+
+(define (parent-of target targets)
+  (and=> (bootloader-target-offset target)
+         (cut get-target-of-type <> targets #t)))
+
+(define (unfold-pathcat target targets)
+  (let ((quit (lambda (t) (not (and=> t bootloader-target-path)))))
+    (reduce pathcat #f
+      (unfold quit bootloader-target-path (cut parent-of <> targets) 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 ->bool (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 iota))
+            (targets (car (genvars 1)))
+
+            (path? (cut syntax-case <> (:path) ((_ :path) #t) (_ #f)))
+            (qualified? (cut syntax-case <> (=>)
+                          ((_ => spec ...) (any path? #'(spec ...)))
+                          (_ #f)))
+
+            (resolve
+              (lambda (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 (pathcat "/" (bootloader-target-path target))))
+                    (_ #`(_ (syntax-error "invalid binding spec" #,in)))))))
+            (binds
+              (lambda (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))))
+
+            (blocks
+              (cut syntax-case <> ()
+                ((spec ... expr)
+                 (let* ((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 regards 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.
+Corrolarily, 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 ->bool
+                           (list #,@(map blocks #'(block ...))))))))
+    (bad #'(syntax-error "must provide targets" bad))))
+
 \f
 ;;;
 ;;; Bootloader configuration record.
@@ -305,10 +511,10 @@ (define (bootloader-configuration-targets config)
 
 (define (bootloader-modules)
   "Return the list of bootloader modules."
+  ;; don't provide #:warn to prevent mutual imports
   (all-modules (map (lambda (entry)
                       `(,entry . "gnu/bootloader"))
-                    %load-path)
-               #:warn warn-about-load-error))
+                    %load-path)))
 
 (define %bootloaders
   ;; The list of publically-known bootloaders.
diff --git a/guix/ui.scm b/guix/ui.scm
index 9db6f6e9d7..1c9300c9eb 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -36,6 +36,8 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix ui)
+  #: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)
@@ -857,6 +859,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