@@ -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))
+
+;;;
+;;; 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))))
+
;;;
;;; 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.
@@ -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