image: Add support for btrfs.

* 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>

1 files changed, 19 insertions, 0 deletions

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 @@ turn doesn't take any constant overhead into account, force a 1-MiB minimum."
   (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 @@ ROOT directory to populate the image."
   (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"))