[bug#37305,V3] Allow booting from a Btrfs subvolume.
diff mbox series

Message ID 871rqkf4ix.fsf_-_@gmail.com
State New
Headers show
Series
  • [bug#37305,V3] Allow booting from a Btrfs subvolume.
Related show

Checks

Context Check Description
cbaines/applying patch fail View Laminar job

Commit Message

Maxim Cournoyer Feb. 24, 2020, 2:23 p.m. UTC
I've added a `normalize-file' procedure to the attached patch, which
simplify producing correct store references in the GRUB configuration
file generated.

This fixed the GRUB video mode issues reported in a another issue.

Thanks!

Maxim

Patch
diff mbox series

From 1c0aafd5d0e013387a8f9bede3c42622b85957c5 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] 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.  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        | 123 +++++++++++++++++++++------------
 gnu/system.scm                 |   9 ++-
 gnu/system/file-systems.scm    |  58 ++++++++++++++++
 gnu/tests/install.scm          |  96 +++++++++++++++++++++++++
 7 files changed, 356 insertions(+), 50 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index d6bfbd7b55..f0956f965a 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 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 b99f5fa4f4..99cb42c4a2 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -4,6 +4,7 @@ 
 ;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -61,18 +62,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
@@ -140,13 +152,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 prefixed to any store path, if any."
   (define setup-gfxterm-body
     ;; Intel and EFI systems need to be switched into graphics mode, whereas
     ;; most other modern architectures have no other mode and therefore don't
@@ -194,11 +208,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 "
@@ -223,7 +240,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))))
 
@@ -327,52 +344,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 2e6d03272d..59c3526098 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.
 ;;;
@@ -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-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 4f0c5ad99e..7b78731524 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)
@@ -44,9 +47,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-file-name
 
             file-system-label
             file-system-label?
@@ -112,6 +118,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)))
@@ -584,4 +592,54 @@  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-file-name file-systems)
+  "Return the subvolume file name within the Btrfs top level onto
+which the store is located.  When the BTRFS-SUBVOLUME-FILE-NAME file
+system property is not set, it is assumed that the store subvolume
+file name is 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-file-name")
+              (and=> subvol (cut string-append "/" <>))
+              ;; 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.\nHint: Define the \"btrfs-subvolume-file-name\" \
+file system property or use the \"subvol\" Btrfs file system")))))))
+       (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 d475bda2c7..82e2b46e3e 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:
@@ -811,6 +812,101 @@  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")))))
 
+
+;;;
+;;; 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.
-- 
2.25.0