104/197: installer: Support btrfs

[Danny Milosavljevic]

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

commit 70a960f8f3d950ecfd4a69f5915c10e023d67a8c
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               | 36 ++++++++++++++++++++++++++++++++++++
 gnu/system/installer/filesystems.scm | 11 ++++++-----
 gnu/system/installer/format.scm      | 12 +++++++-----
 3 files changed, 49 insertions(+), 10 deletions(-)

diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index 2c408c1..2fbf6e3 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -62,6 +62,42 @@ manual."
                            "-f" (string-append #$guix "/share/info/guix.info")
                            "-n" "System Installation"))))
 
+(define (guix-installer)
+  "Return a script that spawns the guix installer."
+  (program-file "guix-installer"
+                #~(begin
+                    (setenv "TZDIR"
+                            (string-append #$tzdata "/share/zoneinfo"))
+                    (setenv "PATH"
+                            (string-join
+                             (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
+                              (string-append #$iproute    "/sbin")
+                              (string-append #$isc-dhcp   "/sbin")
+                              (string-append #$iw         "/sbin")
+                              (string-append #$kbd        "/bin")
+                              (string-append #$parted     "/sbin")
+                              (string-append #$pciutils   "/sbin")
+                              (string-append #$shepherd   "/bin")  ; for herd
+                              (string-append #$shepherd   "/sbin") ; for reboot
+                              (string-append #$util-linux "/bin")  ; for mount
+                              (string-append #$util-linux "/sbin")
+                              (string-append #$wireless-tools "/sbin") ; for 
iwlist
+                              (string-append #$wpa-supplicant-minimal   
"/sbin")
+                              (string-append #$which      "/bin"))
+                             ":"))
+                    (setenv "GUILE_LOAD_PATH"
+                            (string-append #$guile-ncurses 
"/share/guile/site/2.0"))
+                    ;; "(current-guix)" should probably be changed to "guix"
+                    ;; at some point.
+                    (execl (string-append #$(current-guix) "/bin/guix")
+                           "guix" "system" "installer"))))
+
 (define %backing-directory
   ;; Sub-directory used as the backing store for copy-on-write.
   "/tmp/guix-inst")
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)