ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

gnu: bootloader: Add bootloader-target record and infastructure.

Browse source 
* 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
This commit is contained in:
Lilah Tascheter 2024-08-06 19:11:15 -05:00 committed by Ryan Schanzenbacher
parent 38ca46212c
commit 3e536e9efd
Signed by: ryan77627
GPG key ID: 81B0E222A3E2308E
2 changed files with 233 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

229
gnu/bootloader.scm
View file

@ -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)
#: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* <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.

9
guix/ui.scm
View file

@ -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 (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