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 device-subvol field to menu-entry record.

Browse source 
* gnu/bootloader.scm (menu-entry-device-subvol): Add and export field.
(normalize-file): Add procedure.
(device->sexp): Match device-subvol and include in S-expression.
(sexp->menu-entry): Try match device-subvol and include in menu-entry.
* gnu/system/boot.scm (boot-parameters->menu-entry): Add device-subvol
value to menu-entry.

Change-Id: I3654d160f7306bb45a78b82ea6b249ff4281f739
This commit is contained in:
Lilah Tascheter 2024-08-06 19:11:17 -05:00 committed by Ryan Schanzenbacher
parent c2482d9e1d
commit b52e2a33f8
Signed by: ryan77627
GPG key ID: 81B0E222A3E2308E
2 changed files with 40 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

51
gnu/bootloader.scm
View file

@ -51,15 +51,17 @@ (define-module (gnu bootloader)
menu-entry?
menu-entry-label
menu-entry-device
menu-entry-device-mount-point
menu-entry-device-subvol
menu-entry-linux
menu-entry-linux-arguments
menu-entry-initrd
menu-entry-device-mount-point
menu-entry-multiboot-kernel
menu-entry-multiboot-arguments
menu-entry-multiboot-modules
menu-entry-chain-loader
normalize-file
menu-entry->sexp
sexp->menu-entry
@ -126,6 +128,8 @@ (define-record-type* <menu-entry>
(default #f))
(device-mount-point menu-entry-device-mount-point
(default #f))
(device-subvol menu-entry-device-subvol
(default #f))
(linux menu-entry-linux
(default #f))
(linux-arguments menu-entry-linux-arguments
@ -142,6 +146,18 @@ (define-record-type* <menu-entry>
(chain-loader menu-entry-chain-loader
(default #f))) ; string, path of efi file
(define (normalize-file entry file)
"Normalize a file FILE stored in a menu entry into one suitable for a
bootloader. Realizes device-mount-point and device-subvol."
(match-menu-entry entry (device-mount-point device-subvol)
;; Avoid using cut procedure from SRFI-26 inside G-exp.
(let ((mount (and=> device-mount-point (cut string-trim <> #\/))))
#~(let* ((file (string-trim #$file #\/))
(file (if (and #$mount (string-prefix? #$mount file))
(substring file (string-length #$mount))
file)))
(string-append (or #$device-subvol "") "/" file)))))
(define (report-menu-entry-error menu-entry)
(raise
(condition
@ -169,7 +185,7 @@ (define (device->sexp device)
`(label ,(file-system-label->string label)))
(_ device)))
(match entry
(($ <menu-entry> label device mount-point
(($ <menu-entry> label device mount-point subvol
(? identity linux) linux-arguments (? identity initrd)
#f () () #f)
`(menu-entry (version 0)
@ -178,8 +194,9 @@ (define (device->sexp device)
(device-mount-point ,mount-point)
(linux ,linux)
(linux-arguments ,linux-arguments)
(initrd ,initrd)))
(($ <menu-entry> label device mount-point #f () #f
(initrd ,initrd)
(device-subvol ,subvol)))
(($ <menu-entry> label device mount-point subvol #f () #f
(? identity multiboot-kernel) multiboot-arguments
multiboot-modules #f)
`(menu-entry (version 0)
@ -188,19 +205,23 @@ (define (device->sexp device)
(device-mount-point ,mount-point)
(multiboot-kernel ,multiboot-kernel)
(multiboot-arguments ,multiboot-arguments)
(multiboot-modules ,multiboot-modules)))
(($ <menu-entry> label device mount-point #f () #f #f () ()
(multiboot-modules ,multiboot-modules)
(device-subvol ,subvol)))
(($ <menu-entry> label device mount-point subvol #f () #f #f () ()
(? identity chain-loader))
`(menu-entry (version 0)
(label ,label)
(device ,(device->sexp device))
(device-mount-point ,mount-point)
(chain-loader ,chain-loader)))
(chain-loader ,chain-loader)
(device-subvol ,subvol)))
(_ (report-menu-entry-error entry))))
(define (sexp->menu-entry sexp)
"Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
record."
;; XXX: The match ORs shadow subvol.
(define subvol #f)
(define (sexp->device device-sexp)
(match device-sexp
(('uuid type uuid-string)
@ -213,35 +234,41 @@ (define (sexp->device device-sexp)
('label label) ('device device)
('device-mount-point mount-point)
('linux linux) ('linux-arguments linux-arguments)
('initrd initrd) _ ...)
('initrd initrd)
(or ('device-subvol subvol _ ...) (_ ...)))
(menu-entry
(label label)
(device (sexp->device device))
(device-mount-point mount-point)
(device-subvol subvol)
(linux linux)
(linux-arguments linux-arguments)
(initrd initrd)))
(('menu-entry ('version 0)
('label label) ('device device)
('device-mount-point mount-point)
('device-mount-point mount-point) ('device-subvol subvol)
('multiboot-kernel multiboot-kernel)
('multiboot-arguments multiboot-arguments)
('multiboot-modules multiboot-modules) _ ...)
('multiboot-modules multiboot-modules)
(or ('device-subvol subvol _ ...) (_ ...)))
(menu-entry
(label label)
(device (sexp->device device))
(device-mount-point mount-point)
(device-subvol subvol)
(multiboot-kernel multiboot-kernel)
(multiboot-arguments multiboot-arguments)
(multiboot-modules multiboot-modules)))
(('menu-entry ('version 0)
('label label) ('device device)
('device-mount-point mount-point)
('chain-loader chain-loader) _ ...)
('device-mount-point mount-point) ('device-subvol subvol)
('chain-loader chain-loader)
(or ('device-subvol subvol _ ...) (_ ...)))
(menu-entry
(label label)
(device (sexp->device device))
(device-mount-point mount-point)
(device-subvol subvol)
(chain-loader chain-loader)))))

1
gnu/system/boot.scm
View file

@ -328,6 +328,7 @@ (define (boot-parameters->menu-entry conf)
(label (boot-parameters-label conf))
(device (boot-parameters-store-device conf))
(device-mount-point (boot-parameters-store-mount-point conf))
(device-subvol (boot-parameters-store-directory-prefix conf))
(linux (and (not multiboot?) kernel))
(linux-arguments (if (not multiboot?)
(boot-parameters-kernel-arguments conf)