@@ -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))
+
+;;;
+;;; 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))))
+
;;;
;;; Bootloader configuration record.
@@ -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)
@@ -862,6 +865,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
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(-)