From b460ba7992a0b4af2ddb5927dcf062784539ef7b Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Sun, 14 Jul 2019 20:50:23 +0900
Subject: 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.
---
 gnu/system/file-systems.scm | 55 +++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 55 insertions(+)

(limited to 'gnu/system')

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 @@ (define-module (gnu system file-systems)
   #: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 @@ (define-module (gnu system file-systems)
             file-system-location
 
             file-system-type-predicate
+            btrfs-subvolume?
+            btrfs-store-subvolume-file-name
 
             file-system-label
             file-system-label?
@@ -566,4 +571,54 @@ (define (file-system-type-predicate 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
-- 
cgit v1.2.3