aboutsummaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
authorMaxim Cournoyer <maxim.cournoyer@gmail.com>2019-07-14 20:50:23 +0900
committerMaxim Cournoyer <maxim.cournoyer@gmail.com>2020-05-20 08:30:35 -0400
commitb460ba7992a0b4af2ddb5927dcf062784539ef7b (patch)
tree4d77d01574da9a7aedf31dc3f16e94d82fa31adb /gnu
parentfa35fb58c84d1c1741e4e63c0b37074e35ed2a61 (diff)
downloadguix-b460ba7992a0b4af2ddb5927dcf062784539ef7b.tar
guix-b460ba7992a0b4af2ddb5927dcf062784539ef7b.tar.gz
bootloader: grub: Allow booting from a Btrfs subvolume.
* gnu/bootloader/grub.scm (strip-mount-point): Remove procedure. (normalize-file): Add procedure. (grub-configuration-file): New BTRFS-SUBVOLUME-FILE-NAME parameter. When defined, prepend its value to the kernel and initrd file names, using the NORMALIZE-FILE procedure. Adjust the call to EYE-CANDY to pass the BTRFS-SUBVOLUME-FILE-NAME argument. Normalize the KEYMAP file as well. (eye-candy): Add a BTRFS-SUBVOLUME-FILE-NAME parameter, and use it, along with the NORMALIZE-FILE procedure, to normalize the FONT-FILE and IMAGE nested variables. Adjust doc. * gnu/bootloader/depthcharge.scm (depthcharge-configuration-file): Adapt. * gnu/bootloader/extlinux.scm (extlinux-configuration-file): Likewise. * gnu/system/file-systems.scm (btrfs-subvolume?) (btrfs-store-subvolume-file-name): New procedures. * gnu/system.scm (operating-system-bootcfg): Specify the Btrfs subvolume file name the store resides on to the `operating-system-bootcfg' procedure, using the new BTRFS-SUBVOLUME-FILE-NAME argument. * doc/guix.texi (File Systems): Add a Btrfs subsection to document the use of subvolumes. * gnu/tests/install.scm (%btrfs-root-on-subvolume-os) (%btrfs-root-on-subvolume-os-source) (%btrfs-root-on-subvolume-installation-script) (%test-btrfs-root-on-subvolume-os): New variables.
Diffstat (limited to 'gnu')
-rw-r--r--gnu/bootloader/depthcharge.scm3
-rw-r--r--gnu/bootloader/extlinux.scm3
-rw-r--r--gnu/bootloader/grub.scm123
-rw-r--r--gnu/system.scm9
-rw-r--r--gnu/system/file-systems.scm55
-rw-r--r--gnu/tests/install.scm94
6 files changed, 236 insertions, 51 deletions
diff --git a/gnu/bootloader/depthcharge.scm b/gnu/bootloader/depthcharge.scm
index 58cc3f3932..0a50374bd9 100644
--- a/gnu/bootloader/depthcharge.scm
+++ b/gnu/bootloader/depthcharge.scm
@@ -82,7 +82,8 @@
(define* (depthcharge-configuration-file config entries
#:key
(system (%current-system))
- (old-entries '()))
+ (old-entries '())
+ #:allow-other-keys)
(match entries
((entry)
(let ((kernel (menu-entry-linux entry))
diff --git a/gnu/bootloader/extlinux.scm b/gnu/bootloader/extlinux.scm
index 5b4dd84965..6b5ff298e7 100644
--- a/gnu/bootloader/extlinux.scm
+++ b/gnu/bootloader/extlinux.scm
@@ -28,7 +28,8 @@
(define* (extlinux-configuration-file config entries
#:key
(system (%current-system))
- (old-entries '()))
+ (old-entries '())
+ #:allow-other-keys)
"Return the U-Boot configuration file corresponding to CONFIG, a
<u-boot-configuration> object, and where the store is available at STORE-FS, a
<file-system> object. OLD-ENTRIES is taken to be a list of menu entries
diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index fb871c6e96..bb40c551a7 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -58,18 +58,29 @@
;;;
;;; Code:
-(define (strip-mount-point mount-point file)
- "Strip MOUNT-POINT from FILE, which is a gexp or other lowerable object
-denoting a file name."
- (match mount-point
- ((? string? mount-point)
- (if (string=? mount-point "/")
- file
- #~(let ((file #$file))
- (if (string-prefix? #$mount-point file)
- (substring #$file #$(string-length mount-point))
- file))))
- (#f file)))
+(define* (normalize-file file mount-point btrfs-subvolume-file-name)
+ "Strip MOUNT-POINT and prepend BTRFS-SUBVOLUME-FILE-NAME to FILE, a
+G-expression or other lowerable object denoting a file name."
+
+ (define (strip-mount-point mount-point file)
+ (if mount-point
+ (if (string=? mount-point "/")
+ file
+ #~(let ((file #$file))
+ (if (string-prefix? #$mount-point file)
+ (substring #$file #$(string-length mount-point))
+ file)))
+ file))
+
+ (define (prepend-btrfs-subvolume-file-name btrfs-subvolume-file-name file)
+ (if btrfs-subvolume-file-name
+ #~(string-append #$btrfs-subvolume-file-name #$file)
+ file))
+
+ (prepend-btrfs-subvolume-file-name btrfs-subvolume-file-name
+ (strip-mount-point mount-point file)))
+
+
(define-record-type* <grub-theme>
;; Default theme contributed by Felipe López.
@@ -124,13 +135,14 @@ file with the resolution provided in CONFIG."
(_ #f)))))
(define* (eye-candy config store-device store-mount-point
- #:key system port)
- "Return a gexp that writes to PORT (a port-valued gexp) the
-'grub.cfg' part concerned with graphics mode, background images, colors, and
-all that. STORE-DEVICE designates the device holding the store, and
-STORE-MOUNT-POINT is its mount point; these are used to determine where the
-background image and fonts must be searched for. SYSTEM must be the target
-system string---e.g., \"x86_64-linux\"."
+ #:key btrfs-store-subvolume-file-name system port)
+ "Return a gexp that writes to PORT (a port-valued gexp) the 'grub.cfg' part
+concerned with graphics mode, background images, colors, and all that.
+STORE-DEVICE designates the device holding the store, and STORE-MOUNT-POINT is
+its mount point; these are used to determine where the background image and
+fonts must be searched for. SYSTEM must be the target system string---e.g.,
+\"x86_64-linux\". BTRFS-STORE-SUBVOLUME-FILE-NAME is the file name of the
+Btrfs subvolume, to be prepended to any store path, if any."
(define setup-gfxterm-body
(let ((gfxmode
(or (and-let* ((theme (bootloader-configuration-theme config))
@@ -167,11 +179,14 @@ fi~%" #+font-file)
(symbol->string (assoc-ref colors 'bg)))))
(define font-file
- (strip-mount-point store-mount-point
- (file-append grub "/share/grub/unicode.pf2")))
+ (normalize-file (file-append grub "/share/grub/unicode.pf2")
+ store-mount-point
+ btrfs-store-subvolume-file-name))
(define image
- (grub-background-image config))
+ (normalize-file (grub-background-image config)
+ store-mount-point
+ btrfs-store-subvolume-file-name))
(and image
#~(format #$port "
@@ -196,7 +211,7 @@ fi~%"
#$(setup-gfxterm config font-file)
#$(grub-setup-io config)
- #$(strip-mount-point store-mount-point image)
+ #$image
#$(theme-colors grub-theme-color-normal)
#$(theme-colors grub-theme-color-highlight))))
@@ -304,52 +319,66 @@ code."
(define* (grub-configuration-file config entries
#:key
(system (%current-system))
- (old-entries '()))
+ (old-entries '())
+ btrfs-subvolume-file-name)
"Return the GRUB configuration file corresponding to CONFIG, a
<bootloader-configuration> object, and where the store is available at
-STORE-FS, a <file-system> object. OLD-ENTRIES is taken to be a list of menu
-entries corresponding to old generations of the system."
+STORE-FS, a <file-system> object. OLD-ENTRIES is taken to be a list
+of menu entries corresponding to old generations of the system.
+BTRFS-SUBVOLUME-FILE-NAME may be used to specify on which subvolume a
+Btrfs root file system resides."
(define all-entries
(append entries (bootloader-configuration-menu-entries config)))
(define (menu-entry->gexp entry)
- (let ((device (menu-entry-device entry))
- (device-mount-point (menu-entry-device-mount-point entry))
- (label (menu-entry-label entry))
- (kernel (menu-entry-linux entry))
- (arguments (menu-entry-linux-arguments entry))
- (initrd (menu-entry-initrd entry)))
+ (let* ((device (menu-entry-device entry))
+ (device-mount-point (menu-entry-device-mount-point entry))
+ (label (menu-entry-label entry))
+ (arguments (menu-entry-linux-arguments entry))
+ (kernel (normalize-file (menu-entry-linux entry)
+ device-mount-point
+ btrfs-subvolume-file-name))
+ (initrd (normalize-file (menu-entry-initrd entry)
+ device-mount-point
+ btrfs-subvolume-file-name)))
;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
;; Use the right file names for KERNEL and INITRD in case
;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
;; separate partition.
- (let ((kernel (strip-mount-point device-mount-point kernel))
- (initrd (strip-mount-point device-mount-point initrd)))
- #~(format port "menuentry ~s {
+
+ ;; When BTRFS-SUBVOLUME-FILE-NAME is defined, prepend it the kernel and
+ ;; initrd paths, to allow booting from a Btrfs subvolume.
+ #~(format port "menuentry ~s {
~a
linux ~a ~a
initrd ~a
}~%"
- #$label
- #$(grub-root-search device kernel)
- #$kernel (string-join (list #$@arguments))
- #$initrd))))
+ #$label
+ #$(grub-root-search device kernel)
+ #$kernel (string-join (list #$@arguments))
+ #$initrd)))
(define sugar
(eye-candy config
(menu-entry-device (first all-entries))
(menu-entry-device-mount-point (first all-entries))
+ #:btrfs-store-subvolume-file-name btrfs-subvolume-file-name
#:system system
#:port #~port))
(define keyboard-layout-config
- (let ((layout (bootloader-configuration-keyboard-layout config))
- (grub (bootloader-package
- (bootloader-configuration-bootloader config))))
- #~(let ((keymap #$(and layout
- (keyboard-layout-file layout #:grub grub))))
- (when keymap
- (format port "\
+ (let* ((layout (bootloader-configuration-keyboard-layout config))
+ (grub (bootloader-package
+ (bootloader-configuration-bootloader config)))
+ (keymap* (and layout
+ (keyboard-layout-file layout #:grub grub)))
+ (keymap (and keymap*
+ (if btrfs-subvolume-file-name
+ #~(string-append #$btrfs-subvolume-file-name
+ #$keymap*)
+ keymap*))))
+ #~(when #$keymap
+ (format port "\
insmod keylayouts
-keymap ~a~%" keymap)))))
+keymap ~a~%" #$keymap))))
(define builder
#~(call-with-output-file #$output
diff --git a/gnu/system.scm b/gnu/system.scm
index cd75e4d4ba..d929187695 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -8,6 +8,7 @@
;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
+;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -1102,19 +1103,23 @@ entry."
(define* (operating-system-bootcfg os #:optional (old-entries '()))
"Return the bootloader configuration file for OS. Use OLD-ENTRIES,
a list of <menu-entry>, to populate the \"old entries\" menu."
- (let* ((root-fs (operating-system-root-file-system os))
+ (let* ((file-systems (operating-system-file-systems os))
+ (root-fs (operating-system-root-file-system os))
(root-device (file-system-device root-fs))
(params (operating-system-boot-parameters
os root-device
#:system-kernel-arguments? #t))
(entry (boot-parameters->menu-entry params))
(bootloader-conf (operating-system-bootloader os)))
+
(define generate-config-file
(bootloader-configuration-file-generator
(bootloader-configuration-bootloader bootloader-conf)))
(generate-config-file bootloader-conf (list entry)
- #:old-entries old-entries)))
+ #:old-entries old-entries
+ #:btrfs-subvolume-file-name
+ (btrfs-store-subvolume-file-name file-systems))))
(define* (operating-system-boot-parameters os root-device
#:key system-kernel-arguments?)
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 07f272db7c..0f94577760 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -22,7 +22,10 @@
#:use-module (ice-9 match)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-2)
#:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-35)
#:use-module (srfi srfi-9 gnu)
#:use-module (guix records)
#:use-module (gnu system uuid)
@@ -49,6 +52,8 @@
file-system-location
file-system-type-predicate
+ btrfs-subvolume?
+ btrfs-store-subvolume-file-name
file-system-label
file-system-label?
@@ -566,4 +571,54 @@ system has the given TYPE."
(lambda (fs)
(string=? (file-system-type fs) type)))
+
+;;;
+;;; Btrfs specific helpers.
+;;;
+
+(define (btrfs-subvolume? fs)
+ "Predicate to check if FS, a file-system object, is a Btrfs subvolume."
+ (and-let* ((btrfs-file-system? (string= "btrfs" (file-system-type fs)))
+ (option-keys (map (match-lambda
+ ((key . value) key)
+ (key key))
+ (file-system-options->alist
+ (file-system-options fs)))))
+ (find (cut string-prefix? "subvol" <>) option-keys)))
+
+(define (btrfs-store-subvolume-file-name file-systems)
+ "Return the subvolume file name within the Btrfs top level onto which the
+store is located, else #f."
+
+ (define (prepend-slash/maybe s)
+ (if (string=? "/" (string-take s 1))
+ s
+ (string-append "/" s)))
+
+ (define (file-name-depth file-name)
+ (length (string-tokenize file-name %not-slash)))
+
+ (and-let* ((btrfs-subvolume-fs (filter btrfs-subvolume? file-systems))
+ (btrfs-subvolume-fs*
+ (sort btrfs-subvolume-fs
+ (lambda (fs1 fs2)
+ (> (file-name-depth (file-system-mount-point fs1))
+ (file-name-depth (file-system-mount-point fs2))))))
+ (store-subvolume-fs
+ (find (lambda (fs) (file-prefix? (file-system-mount-point fs)
+ (%store-prefix)))
+ btrfs-subvolume-fs*))
+ (options (file-system-options->alist
+ (file-system-options store-subvolume-fs))))
+ ;; XXX: Deriving the subvolume name based from a subvolume ID is not
+ ;; supported, as we'd need to query the actual file system.
+ (or (and=> (assoc-ref options "subvol") prepend-slash/maybe)
+ ;; FIXME: Use &fix-hint once it no longer pulls in (guix utils).
+ (raise (condition
+ (&message
+ (message "The store is on a Btrfs subvolume, but the \
+subvolume name is unknown.
+Hint: Use the \"subvol\" Btrfs file system option.")))))))
+
+
;;; file-systems.scm ends here
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index 94d970e1cc..cea26c8ef3 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -61,6 +61,7 @@
%test-raid-root-os
%test-encrypted-root-os
%test-btrfs-root-os
+ %test-btrfs-root-on-subvolume-os
%test-jfs-root-os
%test-f2fs-root-os
@@ -865,6 +866,99 @@ build (current-guix) and then store a couple of full system images.")
;;;
+;;; Btrfs root file system on a subvolume.
+;;;
+
+(define-os-with-source (%btrfs-root-on-subvolume-os
+ %btrfs-root-on-subvolume-os-source)
+ ;; The OS we want to install.
+ (use-modules (gnu) (gnu tests) (srfi srfi-1))
+
+ (operating-system
+ (host-name "hurd")
+ (timezone "America/Montreal")
+ (locale "en_US.UTF-8")
+ (bootloader (bootloader-configuration
+ (bootloader grub-bootloader)
+ (target "/dev/vdb")))
+ (kernel-arguments '("console=ttyS0"))
+ (file-systems (cons* (file-system
+ (device (file-system-label "btrfs-pool"))
+ (mount-point "/")
+ (options "subvol=rootfs,compress=zstd")
+ (type "btrfs"))
+ (file-system
+ (device (file-system-label "btrfs-pool"))
+ (mount-point "/home")
+ (options "subvol=homefs,compress=lzo")
+ (type "btrfs"))
+ %base-file-systems))
+ (users (cons (user-account
+ (name "charlie")
+ (group "users")
+ (supplementary-groups '("wheel" "audio" "video")))
+ %base-user-accounts))
+ (services (cons (service marionette-service-type
+ (marionette-configuration
+ (imported-modules '((gnu services herd)
+ (guix combinators)))))
+ %base-services))))
+
+(define %btrfs-root-on-subvolume-installation-script
+ ;; Shell script of a simple installation.
+ "\
+. /etc/profile
+set -e -x
+guix --version
+
+export GUIX_BUILD_OPTIONS=--no-grafts
+ls -l /run/current-system/gc-roots
+parted --script /dev/vdb mklabel gpt \\
+ mkpart primary ext2 1M 3M \\
+ mkpart primary ext2 3M 2G \\
+ set 1 boot on \\
+ set 1 bios_grub on
+
+# Setup the top level Btrfs file system with its subvolume.
+mkfs.btrfs -L btrfs-pool /dev/vdb2
+mount /dev/vdb2 /mnt
+btrfs subvolume create /mnt/rootfs
+btrfs subvolume create /mnt/homefs
+umount /dev/vdb2
+
+# Mount the subvolumes, ready for installation.
+mount LABEL=btrfs-pool -o 'subvol=rootfs,compress=zstd' /mnt
+mkdir /mnt/home
+mount LABEL=btrfs-pool -o 'subvol=homefs,compress=zstd' /mnt/home
+
+herd start cow-store /mnt
+mkdir /mnt/etc
+cp /etc/target-config.scm /mnt/etc/config.scm
+guix system build /mnt/etc/config.scm
+guix system init /mnt/etc/config.scm /mnt --no-substitutes
+sync
+reboot\n")
+
+(define %test-btrfs-root-on-subvolume-os
+ (system-test
+ (name "btrfs-root-on-subvolume-os")
+ (description
+ "Test basic functionality of an OS installed like one would do by hand.
+This test is expensive in terms of CPU and storage usage since we need to
+build (current-guix) and then store a couple of full system images.")
+ (value
+ (mlet* %store-monad
+ ((image
+ (run-install %btrfs-root-on-subvolume-os
+ %btrfs-root-on-subvolume-os-source
+ #:script
+ %btrfs-root-on-subvolume-installation-script))
+ (command (qemu-command/writable-image image)))
+ (run-basic-test %btrfs-root-on-subvolume-os command
+ "btrfs-root-on-subvolume-os")))))
+
+
+;;;
;;; JFS root file system.
;;;