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 ;;; Copyright © 2022 Reza Alizadeh Majd ;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz> +;;; Copyright © 2024 Lilah Tascheter ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,19 +25,28 @@ ;;; along with GNU Guix. If not, see . (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) + #:autoload (guix build syscalls) + (mounts mount-source mount-point mount-type) + #:use-module (guix deprecation) + #: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 deprecation) - #:use-module ((guix ui) #:select (warn-about-load-error)) - #:use-module (guix diagnostics) - #:use-module (guix i18n) + #: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* (configuration-file bootloader-configuration-file) (configuration-file-generator bootloader-configuration-file-generator)) + +;;; +;;; Bootloader target record. +;;; + +;; represents different kinds of targets in a +;; normalized form. + +(define-record-type* + 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 + (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. 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 ;;; Copyright © 2022 Taiju HIGASHI ;;; Copyright © 2022 Liliana Marie Prikler +;;; Copyright © 2024 Lilah Tascheter ;;; ;;; This file is part of GNU Guix. ;;; @@ -36,6 +37,8 @@ ;;; along with GNU Guix. If not, see . (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 (manifest-entry-output* entry) (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