03/03: installer: Support btrfs

[John Darrington]

jmd pushed a commit to branch wip-installer
in repository guix.

commit 613ab984f14b53ddebdc9a346532487fc36870c0
Author: John Darrington <address@hidden>
Date:   Sun Jan 15 19:34:27 2017 +0100

    installer: Support btrfs
    
    * gnu/system/install.scm (guix-installer): Add path to btrfs tools.
    * gnu/system/installer/filesystems.scm (file-system-task-incomplete-reason):
    Add "btrfs" to the list of acceptable filesystems.
    * gnu/system/installer/format.scm (format-page-key-handler): Change args to 
suit
    mkfs.btrfs.
---
 gnu/system/install.scm               |    1 +
 gnu/system/installer/filesystems.scm |   11 ++++++-----
 gnu/system/installer/format.scm      |   12 +++++++-----
 3 files changed, 14 insertions(+), 10 deletions(-)

diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index e1545c3..05e6caa 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -132,6 +132,7 @@ manual."
                              (list
                               (string-append #$bash       "/bin")
                               (string-append #$coreutils  "/bin")  ; for ls (!)
+                              (string-append #$btrfs-progs "/bin")
                               (string-append #$e2fsprogs  "/sbin")
                               (string-append #$(current-guix)  "/bin") ; for 
guix system init
                               (string-append #$inetutils  "/bin") ; for ping
diff --git a/gnu/system/installer/filesystems.scm 
b/gnu/system/installer/filesystems.scm
index 68105c3..93db3bf 100644
--- a/gnu/system/installer/filesystems.scm
+++ b/gnu/system/installer/filesystems.scm
@@ -116,11 +116,12 @@
    (let ((partitions-without-filesystems
           (fold (lambda (x prev)
                   (match x
-                         ((dev . (? file-system-spec? fss))
-                          (if (not (string-prefix? "ext"
-                                                   (file-system-spec-type 
fss)))
-                              (cons dev prev)
-                              prev)))) '() mount-points)))
+                         ((dev . ($ <file-system-spec> mp label type uuid))
+                          (cond
+                           ((string-prefix? "ext" type) prev)
+                           ((equal? "btrfs" type) prev)
+                           (else (cons dev prev))))))
+                '() mount-points)))
 
      (if (null? partitions-without-filesystems)
          #f
diff --git a/gnu/system/installer/format.scm b/gnu/system/installer/format.scm
index 1f32196..3a5f8af 100644
--- a/gnu/system/installer/format.scm
+++ b/gnu/system/installer/format.scm
@@ -106,13 +106,15 @@ match those uuids read from the respective partitions"
         (for-each
          (lambda (x)
            (match x
-                  ((dev . (? file-system-spec? fss))
-                   (let ((cmd (string-append "mkfs." (file-system-spec-type 
fss))))
+                  ((dev . ($ <file-system-spec> mp label type uuid))
+                   (let ((cmd (string-append "mkfs." type)))
                      (zero? (pipe-cmd window-port
                                       cmd cmd
-                                      "-L" (file-system-spec-label fss)
-                                      "-U" (file-system-spec-uuid fss)
-                                      "-v"
+                                      "-L" label
+                                      "-U" uuid
+                                      (if (equal? type "btrfs")
+                                          "-f"
+                                          "-v")
                                       dev))
                      )))) mount-points)