From 886b410e6f641b473931d7269a9ddbf10a67937f Mon Sep 17 00:00:00 2001
From: Roman Scherer <roman@burningswell.com>
Date: Thu, 3 Oct 2024 14:13:32 +0200
Subject: image: Add support for btrfs.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

* gnu/build/image.scm (make-btrfs-image): New variable.
* gnu/system/image.scm (system-disk-image): Support btrfs.

Change-Id: I80a5b52ec478ce5927d6208e324cbb70282c647a
Signed-off-by: Ludovic Courtès <ludo@gnu.org>
---
 doc/guix.texi        |  2 +-
 gnu/build/image.scm  | 19 +++++++++++++++++++
 gnu/system/image.scm |  8 ++++++--
 3 files changed, 26 insertions(+), 3 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 60af6cb9ce..0b7e67cbe2 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -48340,7 +48340,7 @@ there is no offset applied.
 The partition file system as a string, defaulting to @code{"ext4"}.
 
 The supported values are @code{"vfat"}, @code{"fat16"}, @code{"fat32"},
-and @code{"ext4"}.
+@code{"btrfs"}, and @code{"ext4"}.
 
 @code{"vfat"}, @code{"fat16"}, and @code{"fat32"} partitions without the
 @code{'esp} flag are by default LBA compatible.
diff --git a/gnu/build/image.scm b/gnu/build/image.scm
index 50518585f8..2332b72b17 100644
--- a/gnu/build/image.scm
+++ b/gnu/build/image.scm
@@ -73,6 +73,23 @@ (define (estimate-partition-size root)
   (max (ash 1 20)
        (* 1.25 (file-size root))))
 
+(define* (make-btrfs-image partition target root)
+  "Handle the creation of BTRFS partition images. See
+'make-partition-image'."
+  (let ((size (partition-size partition))
+        (fs-options (partition-file-system-options partition))
+        (label (partition-label partition))
+        (uuid (partition-uuid partition)))
+    (apply invoke
+           `("fakeroot" "mkfs.btrfs" "-r" ,root
+             "-L" ,label
+             ,@(if uuid
+                   `("-U" ,(uuid->string uuid))
+                   '())
+             "--shrink"
+             ,@fs-options
+             ,target))))
+
 (define* (make-ext-image partition target root
                          #:key
                          (owner-uid 0)
@@ -141,6 +158,8 @@ (define* (make-partition-image partition-sexp target root)
   (let* ((partition (sexp->partition partition-sexp))
          (type (partition-file-system partition)))
     (cond
+     ((string=? "btrfs" type)
+      (make-btrfs-image partition target root))
      ((string-prefix? "ext" type)
       (make-ext-image partition target root))
      ((or (string=? type "vfat") (string=? type "fat16"))
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index b0c96c60f0..af0f3eb354 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -402,7 +402,8 @@ (define (partition->dos-type partition)
             (file-system (partition-file-system partition)))
         (cond
          ((member 'esp flags) "0xEF")
-         ((string-prefix? "ext" file-system) "0x83")
+         ((or (string=? file-system "btrfs")
+              (string-prefix? "ext" file-system)) "0x83")
          ((or (string=? file-system "vfat")
               (string=? file-system "fat16")) "0x0E")
          ((string=? file-system "fat32") "0x0C")
@@ -421,7 +422,8 @@ (define (partition->gpt-type partition)
             (file-system (partition-file-system partition)))
         (cond
          ((member 'esp flags) "U")
-         ((string-prefix? "ext" file-system) "L")
+         ((or (string=? file-system "btrfs")
+              (string-prefix? "ext" file-system)) "L")
          ((or (string=? file-system "vfat")
               (string=? file-system "fat16")
               (string=? file-system "fat32")) "F")
@@ -453,6 +455,8 @@ (define (partition-image partition)
                (let ((initializer (or #$(partition-initializer partition)
                                       initialize-root-partition))
                      (inputs '#+(cond
+                                  ((string=? type "btrfs")
+                                   (list btrfs-progs fakeroot))
                                   ((string-prefix? "ext" type)
                                    (list e2fsprogs fakeroot))
                                   ((or (string=? type "vfat")
-- 
cgit v1.2.3