08/10: bootloader: grub: Allow booting from a Btrfs subvolume.

[guix-commits]

apteryx pushed a commit to branch allow-booting-from-btrfs-subvolume
in repository guix.

commit 6cf2ece21683e98544f8f46675aef58d5a7231fd
Author: Maxim Cournoyer <address@hidden>
AuthorDate: Sun Jul 14 20:50:23 2019 +0900

    bootloader: grub: Allow booting from a Btrfs subvolume.
    
    * gnu/bootloader/grub.scm (grub-configuration-file) [btrfs-subvolume-path]:
    New parameter.  When it is defined, prepend its value to the kernel and
    initrd file paths.
    * 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-path): New procedures.
    * gnu/system.scm (operating-system-bootcfg): Specify the Btrfs subvolume 
path
    of the GNU store to the `operating-system-bootcfg' procedure, using the new
    BTRFS-SUBVOLUME-PATH argument.
    * doc/guix.texi (File Systems): Add a Btrfs subsection to document the use 
of
    subvolumes.  Document the new `properties' field of the `<file-system>'
    record.
    * gnu/tests/install.scm: Add test "btrfs-root-on-subvolume-os".
---
 doc/guix.texi                  | 114 +++++++++++++++++++++++++++++++++++++++++
 gnu/bootloader/depthcharge.scm |   3 +-
 gnu/bootloader/extlinux.scm    |   3 +-
 gnu/bootloader/grub.scm        |  42 +++++++++------
 gnu/system.scm                 |   9 +++-
 gnu/system/file-systems.scm    |  51 ++++++++++++++++++
 gnu/tests/install.scm          |  87 +++++++++++++++++++++++++++++++
 7 files changed, 290 insertions(+), 19 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index d6bfbd7..f0956f9 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -11442,6 +11442,13 @@ a dependency of @file{/sys/fs/cgroup/cpu} and
 
 Another example is a file system that depends on a mapped device, for
 example for an encrypted partition (@pxref{Mapped Devices}).
+
+@item @code{properties} (default: @code{'()})
+This is a list of key-value pairs that can be used to specify properties
+not captured by other fields.  For example, the top level path of a
+Btrfs subvolume within its Btrfs pool can be specified using the
+@code{btrfs-subvolume-path} property (@pxref{Btrfs file system}).
+
 @end table
 @end deftp
 
@@ -11491,6 +11498,113 @@ and unmount user-space FUSE file systems.  This 
requires the
 @code{fuse.ko} kernel module to be loaded.
 @end defvr
 
+@node Btrfs file system
+@subsection Btrfs file system
+
+The Btrfs has special features, such as subvolumes, that merit being
+explained in more details.  The following section attempts to cover
+basic as well as complex uses of a Btrfs file system with the Guix
+System.
+
+In its simplest usage, a Btrfs file system can be described, for
+example, by:
+
+@lisp
+(file-system
+  (mount-point "/home")
+  (type "btrfs")
+  (device (file-system-label "my-home")))
+@end lisp
+
+The example below is more complex, as it makes use of a Btrfs
+subvolume, named @code{rootfs}.  The parent Btrfs file system is labeled
+@code{my-btrfs-pool}, and is located on an encrypted device (hence the
+dependency on @code{mapped-devices}):
+
+@example
+(file-system
+  (device (file-system-label "my-btrfs-pool"))
+  (mount-point "/")
+  (type "btrfs")
+  (options '("defaults" ("subvol" . "rootfs"))
+  (dependencies mapped-devices))
+@end example
+
+Some bootloaders, for example GRUB, only mount a Btrfs partition at its
+top level during the early boot, and rely on their configuration to
+refer to the correct subvolume path within that top level.  The
+bootloaders operating in this way typically produce their configuration
+on a running system where the Btrfs partitions are already mounted and
+where the subvolume information is readily available.  As an example,
+@command{grub-mkconfig}, the configuration generator command shipped
+with GRUB, reads @file{/proc/self/mountinfo} to determine the top-level
+path of a subvolume.
+
+The Guix System produces a bootloader configuration using the operating
+system configuration as its sole input; it is therefore necessary to
+extract the subvolume name on which @file{/gnu/store} lives (if any)
+from that operating system configuration.  To better illustrate,
+consider a subvolume named 'rootfs' which contains the root file system
+data.  In such situation, the GRUB bootloader would only see the top
+level of the root Btrfs partition, e.g.:
+
+@example
+/                   (top level)
+├── rootfs          (subvolume directory)
+    ├── gnu         (normal directory)
+        ├── store   (normal directory)
+[...]
+@end example
+
+Thus, the subvolume name must be prepended to the @file{/gnu/store} path
+of the kernel and initrd binaries in the GRUB configuration in order for
+those to be found.
+
+The next example shows a nested hierarchy of subvolumes and
+directories:
+
+@example
+/                   (top level)
+├── rootfs          (subvolume)
+    ├── gnu         (normal directory)
+        ├── store   (subvolume)
+[...]
+@end example
+
+This scenario would work without mounting the 'store' subvolume.
+Mounting 'rootfs' is sufficient, since the subvolume name matches its
+intended mount point in the file system hierarchy.
+
+Finally, a more contrived example of nested subvolumes:
+
+@example
+/                           (top level)
+├── root-snapshots          (subvolume)
+    ├── root-current        (subvolume)
+        ├── guix-store      (subvolume)
+[...]
+@end example
+
+Here, the 'guix-store' module name doesn't match its intended mount
+point, so it is necessary to mount it.  The layout cannot simply be
+described by the <file-system> record, so it is required to specify the
+exact path at which the subvolume exists within the top level of its
+parent file system.  This can be achieved by attaching a
+@code{btrfs-subvolume-path} property to the corresponding file system
+record:
+
+@lisp
+(file-system
+  ...
+  (properties '((btrfs-subvolume-path
+                 . "/root-snapshots/root-current/guix-store"))))
+@end lisp
+
+The default behavior of Guix is to assume that a subvolume exists
+directly at the root of the top volume hierarchy.  When this is not the
+case, the above property must be used for the system to boot correctly
+when using a GRUB based bootloader.
+
 @node Mapped Devices
 @section Mapped Devices
 
diff --git a/gnu/bootloader/depthcharge.scm b/gnu/bootloader/depthcharge.scm
index 58cc3f3..0a50374 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 5b4dd84..6b5ff29 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 b99f5fa..c9794c3 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2017 Leo Famulari <address@hidden>
 ;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
 ;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <address@hidden>
+;;; Copyright © 2020 Maxim Cournoyer <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -327,35 +328,46 @@ code."
 (define* (grub-configuration-file config entries
                                   #:key
                                   (system (%current-system))
-                                  (old-entries '()))
+                                  (old-entries '())
+                                  btrfs-subvolume-path)
   "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."
+entries corresponding to old generations of the system.  BTRFS-SUBVOLUME-PATH
+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* (strip-mount-point
+                     device-mount-point (menu-entry-linux entry)))
+           (initrd* (strip-mount-point
+                     device-mount-point (menu-entry-initrd entry)))
+           (kernel (if btrfs-subvolume-path
+                       #~(string-append #$btrfs-subvolume-path #$kernel*)
+                       kernel*))
+           (initrd (if btrfs-subvolume-path
+                       #~(string-append #$btrfs-subvolume-path #$initrd*)
+                       initrd*)))
       ;; 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-PATH 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))
diff --git a/gnu/system.scm b/gnu/system.scm
index 2e6d032..ebc8bf1 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2016 Chris Marusich <address@hidden>
 ;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
 ;;; Copyright © 2019 Meiyo Peng <address@hidden>
+;;; Copyright © 2019 Maxim Cournoyer <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -992,19 +993,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-path (btrfs-store-subvolume-path
+                                                  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 2c3c159..daef1c9 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -21,7 +21,9 @@
   #: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-9 gnu)
   #:use-module (guix records)
   #:use-module (gnu system uuid)
@@ -44,9 +46,12 @@
             file-system-create-mount-point?
             file-system-dependencies
             file-system-location
+            file-system-properties
 
             file-system-type-predicate
             file-system-independent-mount-option?
+            btrfs-subvolume?
+            btrfs-store-subvolume-path
 
             file-system-label
             file-system-label?
@@ -112,6 +117,8 @@
                        (default #f))
   (dependencies     file-system-dependencies      ; list of <file-system>
                     (default '()))                ; or <mapped-device>
+  (properties       file-system-properties        ; list of name-value pairs
+                    (default '()))
   (location         file-system-location
                     (default (current-source-location))
                     (innate)))
@@ -582,4 +589,48 @@ system has the given TYPE."
     (or (string-prefix-ci? "x-" option-name)
         (member option-name %file-system-independent-mount-options))))
 
+(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 fs))))
+    (find (cut string-prefix? "subvol" <>) option-keys)))
+
+(define (btrfs-store-subvolume-path file-systems)
+  "Return the subvolume path within the Btrfs top level onto which the store
+is located.  When the BTRFS-SUBVOLUME-PATH file system property is not set, it
+is assumed that the store subvolume path is a located at the root of the top
+level of the file system."
+
+  (define (find-mount-point-fs mount-point file-systems)
+    (find (lambda (fs)
+            (string= mount-point (file-system-mount-point fs)))
+          file-systems))
+
+  ;; Find a subvolume mounted at either /gnu/store, /gnu, or /.
+  (let loop ((mount-point (%store-prefix)))
+    (let ((mount-point-fs (find-mount-point-fs mount-point file-systems)))
+      (cond
+       ((string-null? mount-point)
+        #f)                             ;store is not on a Btrfs subvolume
+       ((and=> mount-point-fs btrfs-subvolume?)
+        (let* ((fs-options (file-system-options mount-point-fs))
+               (subvolid (assoc-ref fs-options "subvolid"))
+               (subvol (assoc-ref fs-options "subvol")))
+          (or (assoc-ref (file-system-properties mount-point-fs)
+                         "btrfs-subvolume-path")
+              (and=> subvol (cut string-append "/" <>))
+              (error "The store is on a Btrfs subvolume, but the \
+subvolume name is unknown.
+Hint: Define the \"btrfs-subvolume-path\" file system property or
+use the \"subvol\" Btrfs file system option."))))
+       (else
+        (loop
+         (cond ((string-suffix? "/" mount-point)
+                (string-drop-right mount-point 1))
+               ((string-take mount-point
+                             (1+ (string-index-right mount-point #\/)))))))))))
+
 ;;; file-systems.scm ends here
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index d475bda..b32130c 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -44,6 +44,7 @@
             %test-raid-root-os
             %test-encrypted-root-os
             %test-btrfs-root-os
+            %test-btrfs-root-on-subvolume-os
             %test-jfs-root-os))
 
 ;;; Commentary:
@@ -813,6 +814,92 @@ 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
+mkfs.btrfs -L btrfs-pool /dev/vdb2
+mount /dev/vdb2 /mnt
+btrfs subvolume create /mnt/rootfs
+btrfs subvolume create /mnt/homefs
+herd start cow-store /mnt/rootfs
+mkdir /mnt/rootfs/etc
+cp /etc/target-config.scm /mnt/rootfs/etc/config.scm
+guix system build /mnt/rootfs/etc/config.scm
+guix system init /mnt/rootfs/etc/config.scm /mnt/rootfs --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.
 ;;;