diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm index c77de6f55e..f1352122a9 100644 --- a/gnu/bootloader.scm +++ b/gnu/bootloader.scm @@ -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* (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* (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 - (($ label device mount-point + (($ 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))) - (($ label device mount-point #f () #f + (initrd ,initrd) + (device-subvol ,subvol))) + (($ 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))) - (($ label device mount-point #f () #f #f () () + (multiboot-modules ,multiboot-modules) + (device-subvol ,subvol))) + (($ 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 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))))) diff --git a/gnu/system/boot.scm b/gnu/system/boot.scm index 54e5673a54..98fcd2b3a0 100644 --- a/gnu/system/boot.scm +++ b/gnu/system/boot.scm @@ -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)