[bug#37305] Allow booting from a Btrfs subvolume [review part 2]

[maxim.cournoyer@gmail.com]

[-- Attachment #1: Type: text/plain, Size: 1227 bytes --]

Hi Ludovic,

Ludovic Courtès <ludo@gnu.org> writes:

> Hi Maxim,
>
> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>
>>>> +              (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."))))
>>
>>> Rather use ‘raise’ with ‘&message’ and ‘&fix-hint’ conditions.
>>
>> I tried this, but importing (guix utils) to acces &fix-hint caused the init
>> RAM disk to fail mysteriously:
>
> Oh, my bad.  We should move ‘&fix-hint’ to (guix diagnostics)
> eventually.
>
> In the meantime, I’d say just raise a ‘&message’ and leave the hint as a
> comment (it’s not supposed to be a user-facing interface).  Or maybe you
> could define a specific error condition type for this?
>
> Thanks,
> Ludo’.
>
> PS: I’ll comment on the other bits ASAP!

The remaining, reworked patches for this series are attached below.  If
you don't want to merge the 0001 for now (speeding up tests), I don't
mind too much (though it still provides value to me, when using old
hardware).

Thanks for your patience :-)

Maxim


[-- Attachment #2: 0001-gnu-tests-Reduce-the-time-required-to-run-the-system.patch --]
[-- Type: text/x-patch, Size: 5668 bytes --]

From 62bb442870864a8e867023f95d814dc1b389512a Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Sun, 17 Nov 2019 06:01:00 +0900
Subject: [PATCH 1/5] gnu: tests: Reduce the time required to run the system
 tests.

When setting the GUIX_DEV_HACKS environment variable, the Guix package used
inside the instrumented VMs recycles the binaries already found in the Guix
checkout of the developer instead of rebuilding Guix from scratch.  This
brings the time required for this component from 20+ minutes down to 2-3
minutes on an X200 machine.

* gnu/packages/package-management.scm (current-guix/pre-built): New procedure.
* etc/system-tests.scm (tests-for-channel-instance): Use it, when
GUIX_DEV_HACKS is defined.
---
 etc/system-tests.scm                |  5 ++-
 gnu/packages/package-management.scm | 66 +++++++++++++++++++++++++++++
 2 files changed, 70 insertions(+), 1 deletion(-)

diff --git a/etc/system-tests.scm b/etc/system-tests.scm
index ab2827e70a..5fc5d91ea3 100644
--- a/etc/system-tests.scm
+++ b/etc/system-tests.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -49,7 +50,9 @@ instance."
   ;;
   ;;   make check-system TESTS=installed-os
   (parameterize ((current-guix-package
-                  (channel-source->package source #:commit commit)))
+                  (if (getenv "GUIX_DEV_HACKS")
+                      (current-guix/pre-built)
+                      (channel-source->package source #:commit commit))))
     (match (getenv "TESTS")
       (#f
        (all-system-tests))
diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm
index b0457ba87a..4788358e5a 100644
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@@ -468,6 +468,72 @@ out) and returning a package that uses that as its 'source'."
                                 #:recursive? #t
                                 #:select? (force select?))))))))
 
+(define-public (current-guix/pre-built)
+  "Similar to `current-guix', but with a modified build procedure that
+reuses the existing byte compiled artifacts to save recompilation time."
+
+  (let* ( ;; The `current-source-directory' macro doesn't work from the REPL.
+         ;; For testing, you can replace it with a static string pointing to
+         ;; your Guix checkout directory.
+         (repository-root (delay (canonicalize-path
+                                  (string-append (current-source-directory)
+                                                 "/../.."))))
+         (select? (lambda (file stat)
+                    (match (basename file)
+                      ((or ".git"
+                           "configure" "autom4te.cache"
+                           "config.log" "config.status"
+                           "stamp-1" "stamp-2" "stamp-3" "stamp-4" "stamp-5"
+                           "stamp-h1" "stamp-vti"
+                           "Makefile" "Makefile.in" ".libs"
+                           ".deps" ".dirstamp"
+                           "test-tmp"
+                           ) #f)
+                      (_ #t)))))
+    (package
+      (inherit guix)
+      (version (string-append (package-version guix) "+"))
+      (source (local-file (force repository-root) "guix-current"
+                          #:recursive? #t
+                          #:select? select?))
+      (arguments
+       (substitute-keyword-arguments (package-arguments guix)
+         ((#:phases phases)
+          `(modify-phases ,phases
+             ;; XXX: References to tools such as 'mkdir' and 'install' are
+             ;; captured in Makefile.in when 'autoconf' is run.  It'd be nicer
+             ;; to find those at configuration time.
+             (delete 'copy-bootstrap-guile)
+             (delete 'check)
+             (delete 'disable-failing-tests)
+             (delete 'strip)            ;can't strip .go files anyway
+             (replace 'build
+               (lambda _
+                 ;; Set the write permission bit on some files that need to be
+                 ;; touched.
+                 (chmod "nix" #o777)
+                 (for-each (lambda (f)
+                             (chmod f #o666))
+                           (cons* "guix-daemon"
+                                  (find-files "." ".*\\.(a|o)$")))
+
+                 ;; The following prevent 'make install' from rebuilding the
+                 ;; daemon and the documentation.
+                 (invoke "make" "--touch" "info"
+                         ;; TODO: Currently we must rebuild the daemon as it
+                         ;; was linked against external dependencies that
+                         ;; depend on the provenance of the profile (or
+                         ;; environment) that was used to build it.
+
+                         ;; If we could query the provenance of any profile,
+                         ;; we could make this package inherit from the guix
+                         ;; inferior that was used to provide such
+                         ;; dependencies.  The most reliable way would
+                         ;; probably be to record that provenance at build
+                         ;; time (as a make target).
+                         ;"guix-daemon"
+                         ))))))))))
+
 \f
 ;;;
 ;;; Other tools.
-- 
2.25.1


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-linux-boot-Refactor-boot-system.patch --]
[-- Type: text/x-patch, Size: 5410 bytes --]

From c60913505af32c2005ffc9bb3ea7078de5379c54 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Tue, 11 Feb 2020 14:00:06 -0500
Subject: [PATCH 2/5] linux-boot: Refactor boot-system.

The --root option can now be omitted, and inferred from the root file system
declaration instead.

* gnu/build/linux-boot.scm (boot-system): Remove nested definitions for
root-fs-type, root-fs-flags and root-fs-options, and bind those inside the
let* instead.  Make "--root" take precedence over the device field string
representation of the root file system.
* doc/guix.texi (Initial RAM Disk): Document that "--root" can be left
unspecified.
---
 doc/guix.texi            |  7 +++--
 gnu/build/linux-boot.scm | 60 +++++++++++++++++++---------------------
 2 files changed, 32 insertions(+), 35 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index d1fa8d033a..11b6884cab 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -26058,9 +26058,10 @@ service activation programs and then spawns the GNU@tie{}Shepherd, the
 initialization system.
 
 @item --root=@var{root}
-Mount @var{root} as the root file system.  @var{root} can be a
-device name like @code{/dev/sda1}, a file system label, or a file system
-UUID.
+Mount @var{root} as the root file system.  @var{root} can be a device
+name like @code{/dev/sda1}, a file system label, or a file system UUID.
+When unspecified, the device name from the root file system of the
+operating system declaration is used.
 
 @item --system=@var{system}
 Have @file{/run/booted-system} and @file{/run/current-system} point to
diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index 4fb711b8f2..3a9c761a69 100644
--- a/gnu/build/linux-boot.scm
+++ b/gnu/build/linux-boot.scm
@@ -467,25 +467,13 @@ upon error."
   (define (root-mount-point? fs)
     (string=? (file-system-mount-point fs) "/"))
 
-  (define root-fs-type
-    (or (any (lambda (fs)
-               (and (root-mount-point? fs)
-                    (file-system-type fs)))
-             mounts)
-        "ext4"))
-
-  (define root-fs-flags
-    (mount-flags->bit-mask (or (any (lambda (fs)
-                                      (and (root-mount-point? fs)
-                                           (file-system-flags fs)))
-                                    mounts)
-                               '())))
-
-  (define root-fs-options
-    (any (lambda (fs)
-           (and (root-mount-point? fs)
-                (file-system-options fs)))
-         mounts))
+  (define (device-string->file-system-device device-string)
+    ;; The "--root=SPEC" kernel command-line option always provides a
+    ;; string, but the string can represent a device, a UUID, or a
+    ;; label.  So check for all three.
+    (cond ((string-prefix? "/" device-string) device-string)
+          ((uuid device-string) => identity)
+          (else (file-system-label device-string))))
 
   (display "Welcome, this is GNU's early boot Guile.\n")
   (display "Use '--repl' for an initrd REPL.\n\n")
@@ -495,7 +483,21 @@ upon error."
       (mount-essential-file-systems)
       (let* ((args    (linux-command-line))
              (to-load (find-long-option "--load" args))
-             (root    (find-long-option "--root" args)))
+             (root-fs (find root-mount-point? mounts))
+             (root-fs-type (or (and=> root-fs file-system-type)
+                               "ext4"))
+             (root-fs-device (and=> root-fs file-system-device))
+             (root-fs-flags (mount-flags->bit-mask
+                             (or (and=> root-fs file-system-flags)
+                                 '())))
+             (root-options (if root-fs
+                               (file-system-options root-fs)
+                               #f))
+             ;; --root takes precedence over the 'device' field of the root
+             ;; <file-system> record.
+             (root-device (or (and=> (find-long-option "--root" args)
+                                     device-string->file-system-device)
+                              root-fs-device)))
 
         (when (member "--repl" args)
           (start-repl))
@@ -530,18 +532,12 @@ upon error."
 
         (setenv "EXT2FS_NO_MTAB_OK" "1")
 
-        (if root
-            ;; The "--root=SPEC" kernel command-line option always provides a
-            ;; string, but the string can represent a device, a UUID, or a
-            ;; label.  So check for all three.
-            (let ((root (cond ((string-prefix? "/" root) root)
-                              ((uuid root) => identity)
-                              (else (file-system-label root)))))
-              (mount-root-file-system (canonicalize-device-spec root)
-                                      root-fs-type
-                                      #:volatile-root? volatile-root?
-                                      #:flags root-fs-flags
-                                      #:options root-fs-options))
+        (if root-device
+            (mount-root-file-system (canonicalize-device-spec root-device)
+                                    root-fs-type
+                                    #:volatile-root? volatile-root?
+                                    #:flags root-fs-flags
+                                    #:options root-options)
             (mount "none" "/root" "tmpfs"))
 
         ;; Mount the specified file systems.
-- 
2.25.1


[-- Attachment #4: 0003-file-systems-Add-helpers-for-parsing-the-options-str.patch --]
[-- Type: text/x-patch, Size: 5212 bytes --]

From 62f62a1b49adbe13a1d401ac16f56d58fda2af78 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Wed, 25 Sep 2019 22:43:41 +0900
Subject: [PATCH 3/5] file-systems: Add helpers for parsing the options string
 into an alist.

* gnu/system/file-systems.scm (file-system-options->alist)
(alist->file-system-options): New procedures.
* tests/file-systems.scm: New tests.
* doc/guix.texi (File Systems): Add note about the newly added procedures.
---
 doc/guix.texi               | 12 ++++++++----
 gnu/system/file-systems.scm | 31 +++++++++++++++++++++++++++++++
 tests/file-systems.scm      | 19 +++++++++++++++++++
 3 files changed, 58 insertions(+), 4 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 11b6884cab..f55098cfd5 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -11501,10 +11501,14 @@ update time on the in-memory version of the file inode), and
 Manual}, for more information on these flags.
 
 @item @code{options} (default: @code{#f})
-This is either @code{#f}, or a string denoting mount options passed to the
-file system driver.  @xref{Mount-Unmount-Remount,,, libc, The GNU C Library
-Reference Manual}, for details and run @command{man 8 mount} for options for
-various file systems.
+This is either @code{#f}, or a string denoting mount options passed to
+the file system driver.  @xref{Mount-Unmount-Remount,,, libc, The GNU C
+Library Reference Manual}, for details and run @command{man 8 mount} for
+options for various file systems.  Note that the
+@code{file-system-options->alist} and @code{alist->file-system-options}
+procedures from @code{(gnu system file-systems)} can be used to convert
+file system options given as an association list to the string
+representation, and vice-versa.
 
 @item @code{mount?} (default: @code{#t})
 This value indicates whether to automatically mount the file system when
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 3b599efa8e..bde2b93702 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -37,6 +38,9 @@
             file-system-needed-for-boot?
             file-system-flags
             file-system-options
+            file-system-options->alist
+            alist->file-system-options
+
             file-system-mount?
             file-system-check?
             file-system-create-mount-point?
@@ -250,6 +254,33 @@ UUID-TYPE, a symbol such as 'dce or 'iso9660."
     ((? string?)
      device)))
 
+(define (file-system-options->alist string)
+  "Translate the option string format of a <file-system> record into an
+association list of options or option/value pairs."
+  (if string
+      (let ((options (string-split string #\,)))
+        (map (lambda (param)
+               (let ((=index (string-index param #\=)))
+                 (if =index
+                     (cons (string-take param =index)
+                           (string-drop param (1+ =index)))
+                     param)))
+             options))
+      '()))
+
+(define (alist->file-system-options options)
+  "Return the string representation of OPTIONS, an association list.  The
+string obtained can be used as the option field of a <file-system> record."
+  (if (null? options)
+      #f
+      (string-join (map (match-lambda
+                          ((key . value)
+                           (string-append key "=" value))
+                          (key
+                           key))
+                        options)
+                   ",")))
+
 (define (file-system-needed-for-boot? fs)
   "Return true if FS has the 'needed-for-boot?' flag set, or if it holds the
 store--e.g., if FS is the root file system."
diff --git a/tests/file-systems.scm b/tests/file-systems.scm
index 4c28d0ebc5..41f1021067 100644
--- a/tests/file-systems.scm
+++ b/tests/file-systems.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -64,4 +65,22 @@
           (_ #f))
         (source-module-closure '((gnu system file-systems)))))
 
+(test-equal "file-system-options->alist"
+  '("autodefrag" ("subvol" . "home") ("compress" . "lzo"))
+  (file-system-options->alist "autodefrag,subvol=home,compress=lzo"))
+
+(test-equal "file-system-options->alist (#f)"
+  '()
+  (file-system-options->alist #f))
+
+(test-equal "alist->file-system-options"
+  "autodefrag,subvol=root,compress=lzo"
+  (alist->file-system-options '("autodefrag"
+                                ("subvol" . "root")
+                                ("compress" . "lzo"))))
+
+(test-equal "alist->file-system-options (null)"
+  #f
+  (alist->file-system-options '()))
+
 (test-end)
-- 
2.25.1


[-- Attachment #5: 0004-bootloader-grub-Allow-booting-from-a-Btrfs-subvolume.patch --]
[-- Type: text/x-patch, Size: 26952 bytes --]

From 12e7ca2628a7e16a1afacfd8953bd6bcfe5c10bd Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Sun, 14 Jul 2019 20:50:23 +0900
Subject: [PATCH 4/5] 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: Add test "btrfs-root-on-subvolume-os".
---
 doc/guix.texi                  | 104 ++++++++++++++++++++++++++++
 gnu/bootloader/depthcharge.scm |   3 +-
 gnu/bootloader/extlinux.scm    |   3 +-
 gnu/bootloader/grub.scm        | 122 ++++++++++++++++++++-------------
 gnu/system.scm                 |   9 ++-
 gnu/system/file-systems.scm    |  58 ++++++++++++++++
 gnu/tests/install.scm          |  94 +++++++++++++++++++++++++
 tests/file-systems.scm         |  45 ++++++++++++
 8 files changed, 388 insertions(+), 50 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index f55098cfd5..5dfd62d02f 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -11589,6 +11589,110 @@ 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}):
+
+@lisp
+(file-system
+  (device (file-system-label "my-btrfs-pool"))
+  (mount-point "/")
+  (type "btrfs")
+  (options "subvol=rootfs")
+  (dependencies mapped-devices))
+@end lisp
+
+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, initrd binaries and any other files referred to in the
+GRUB configuration that must be found during the early boot.
+
+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.  Alternatively, the
+'store' subvolume could be referred to by setting the @code{subvol}
+option to either @code{/rootfs/gnu/store} or @code{rootfs/gnu/store}.
+
+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' subvolume doesn't match its intended mount point,
+so it is necessary to mount it.  The subvolume must be fully specified,
+by passing its file name to the @code{subvol} option.  To illustrate,
+the 'guix-store' subvolume could be mounted on @file{/gnu/store} by using
+a file system declaration such as:
+
+@lisp
+(file-system
+  (device (file-system-label "btrfs-pool-1"))
+  (mount-point "/gnu/store")
+  (type "btrfs")
+  (options "subvol=root-snapshots/root-current/guix-store"
+  ("compress" . "zstd")))
+@end lisp
+
 @node Mapped Devices
 @section Mapped Devices
 
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 28e6cb1f5f..e7a6f928c6 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -63,18 +63,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-image>
   grub-image make-grub-image
@@ -142,13 +153,15 @@ WIDTH/HEIGHT, or #f if none was found."
                    #:width width #:height height))))
 
 (define* (eye-candy config store-device store-mount-point
+                    btrfs-store-subvolume-file-name
                     #: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\"."
+  "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))
@@ -185,11 +198,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 "
@@ -214,7 +230,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))))
 
@@ -318,52 +334,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-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 06c58c27ba..d1f1b43426 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019 Meiyo Peng <meiyo.peng@gmail.com>
+;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -1001,19 +1002,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 bde2b93702..617ef97814 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -21,7 +21,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)
@@ -48,6 +51,8 @@
             file-system-location
 
             file-system-type-predicate
+            btrfs-subvolume?
+            btrfs-store-subvolume-file-name
 
             file-system-label
             file-system-label?
@@ -565,4 +570,57 @@ system has the given TYPE."
   (lambda (fs)
     (string=? (file-system-type fs) type)))
 
+\f
+;;;
+;;; 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)
+        ;; XXX: Importing (guix utils) and using &fix-hint causes the
+        ;; following error when booting the init RAM disk: "ERROR: In
+        ;; procedure dynamic-func:\nIn procedure dynamic-pointer: Symbol not
+        ;; found: strverscmp", so we just embed the hint in the message.
+        (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 9ecc45cc04..af266e03a1 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -48,6 +48,7 @@
             %test-raid-root-os
             %test-encrypted-root-os
             %test-btrfs-root-os
+            %test-btrfs-root-on-subvolume-os
             %test-jfs-root-os
 
             %test-gui-installed-os
@@ -834,6 +835,99 @@ build (current-guix) and then store a couple of full system images.")
                          (command (qemu-command/writable-image image)))
       (run-basic-test %btrfs-root-os command "btrfs-root-os")))))
 
+\f
+;;;
+;;; 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")))))
+
 \f
 ;;;
 ;;; JFS root file system.
diff --git a/tests/file-systems.scm b/tests/file-systems.scm
index 41f1021067..7f7c373884 100644
--- a/tests/file-systems.scm
+++ b/tests/file-systems.scm
@@ -83,4 +83,49 @@
   #f
   (alist->file-system-options '()))
 
+\f
+;;;
+;;; Btrfs related.
+;;;
+
+(define %btrfs-root-subvolume
+  (file-system
+    (device (file-system-label "btrfs-pool"))
+    (mount-point "/")
+    (type "btrfs")
+    (options "subvol=rootfs,compress=zstd")))
+
+(define %btrfs-store-subvolid
+  (file-system
+    (device (file-system-label "btrfs-pool"))
+    (mount-point "/gnu/store")
+    (type "btrfs")
+    (options "subvolid=10,compress=zstd")
+    (dependencies (list %btrfs-root-subvolume))))
+
+(define %btrfs-store-subvolume
+  (file-system
+    (device (file-system-label "btrfs-pool"))
+    (mount-point "/gnu/store")
+    (type "btrfs")
+    (options "subvol=/some/nested/file/name")
+    (dependencies (list %btrfs-root-subvolume))))
+
+(test-assert "btrfs-subvolume? (subvol)"
+  (btrfs-subvolume? %btrfs-root-subvolume))
+
+(test-assert "btrfs-subvolume? (subvolid)"
+  (btrfs-subvolume? %btrfs-store-subvolid))
+
+(test-equal "btrfs-store-subvolume-file-name"
+  "/some/nested/file/name"
+  (parameterize ((%store-prefix "/gnu/store"))
+    (btrfs-store-subvolume-file-name (list %btrfs-root-subvolume
+                                           %btrfs-store-subvolume))))
+
+(test-error "btrfs-store-subvolume-file-name (subvolid)"
+            (parameterize ((%store-prefix "/gnu/store"))
+              (btrfs-store-subvolume-file-name (list %btrfs-root-subvolume
+                                                     %btrfs-store-subvolid))))
+
 (test-end)
-- 
2.25.1