01/26: installer: Extend the 'file-system' concept to include swap spaces.

[John Darrington]

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

commit 2019856810ff437d5823e7400c50c62a3600f4ba
Author: John Darrington <address@hidden>
Date:   Mon Jan 16 13:54:15 2017 +0100

    installer: Extend the 'file-system' concept to include swap spaces.
    
    * gnu/system/installer/filesystems.scm (valid-file-system-types): New 
variable.
    (<file-system-spec-type>): Change to expect a symbol instead of a string
    * gnu/system/installer/format.scm (format-page-key-handler) : Generalise the
    code to execute commands somewhat.
    * gnu/system/installer/mount-point.scm (mount-point-page-init): Deal with
    the file-system-spec-type function returning a symbol.
---
 gnu/system/installer/filesystems.scm |   20 +++++++++++-------
 gnu/system/installer/format.scm      |   38 ++++++++++++++++++++++++++--------
 gnu/system/installer/mount-point.scm |    3 ++-
 3 files changed, 44 insertions(+), 17 deletions(-)

diff --git a/gnu/system/installer/filesystems.scm 
b/gnu/system/installer/filesystems.scm
index 93db3bf..e100bbd 100644
--- a/gnu/system/installer/filesystems.scm
+++ b/gnu/system/installer/filesystems.scm
@@ -56,12 +56,18 @@
   file-system-spec?
   (mount-point      file-system-spec-mount-point)
   (label            file-system-spec-label)
-  (type             file-system-spec-type)
+  (type             file-system-spec-type)  ; symbol
   (uuid             file-system-spec-uuid))
 
+(define valid-file-system-types `(ext2 ext3 ext4 btrfs swap))
+
 (define (make-file-system-spec mount-point label type)
   (let ((uuid (slurp "uuidgen" identity)))
-    (make-file-system-spec' mount-point label type (car uuid))))
+    (make-file-system-spec' mount-point label
+                            (if (memq (string->symbol type) 
valid-file-system-types)
+                                (string->symbol type)
+                                #f)
+                            (car uuid))))
 
 
 
@@ -81,7 +87,9 @@
           (fold (lambda (x prev)
                   (match x
                          ((dev . fss)
-                          (if (absolute-file-name? 
(file-system-spec-mount-point fss))
+                          (if (or
+                               (eq? (file-system-spec-type fss) 'swap)
+                               (absolute-file-name? 
(file-system-spec-mount-point fss)))
                               prev
                               (cons (file-system-spec-mount-point fss) 
prev)))))
                 '()
@@ -117,10 +125,8 @@
           (fold (lambda (x prev)
                   (match x
                          ((dev . ($ <file-system-spec> mp label type uuid))
-                          (cond
-                           ((string-prefix? "ext" type) prev)
-                           ((equal? "btrfs" type) prev)
-                           (else (cons dev prev))))))
+                          (if type prev
+                              (cons dev prev)))))
                 '() mount-points)))
 
      (if (null? partitions-without-filesystems)
diff --git a/gnu/system/installer/format.scm b/gnu/system/installer/format.scm
index 3a5f8af..d4840b0 100644
--- a/gnu/system/installer/format.scm
+++ b/gnu/system/installer/format.scm
@@ -107,16 +107,36 @@ match those uuids read from the respective partitions"
          (lambda (x)
            (match x
                   ((dev . ($ <file-system-spec> mp label type uuid))
-                   (let ((cmd (string-append "mkfs." type)))
-                     (zero? (pipe-cmd window-port
-                                      cmd cmd
-                                      "-L" label
-                                      "-U" uuid
-                                      (if (equal? type "btrfs")
+                   (let ((type-str (symbol->string type)))
+                     (cond
+                      ((string-prefix? "ext" type-str)
+                       (let ((cmd (string-append "mkfs." type-str)))
+                         (zero? (pipe-cmd window-port
+                                          cmd cmd
+                                          "-L" label
+                                          "-U" uuid
+                                          "-v"
+                                          dev))))
+
+                      ((eq? type 'btrfs)
+                       (let ((cmd (string-append "mkfs.btrfs")))
+                         (zero? (pipe-cmd window-port
+                                          cmd cmd
+                                          "-L" label
+                                          "-U" uuid
                                           "-f"
-                                          "-v")
-                                      dev))
-                     )))) mount-points)
+                                          dev))))
+
+                      ((eq? type 'swap)
+                       (let ((cmd (string-append "mkswap")))
+                         (zero? (pipe-cmd window-port
+                                          cmd cmd
+                                          "-L" label
+                                          "-U" uuid
+                                          "-f"
+                                          dev))))
+
+                      ))))) mount-points)
 
         (close-port window-port))
 
diff --git a/gnu/system/installer/mount-point.scm 
b/gnu/system/installer/mount-point.scm
index 5715a2f..3abf675 100644
--- a/gnu/system/installer/mount-point.scm
+++ b/gnu/system/installer/mount-point.scm
@@ -147,7 +147,8 @@
             (form-set-value! form 'mount-point
                              (file-system-spec-mount-point fss))
             (form-set-value! form 'fs-type
-                             (file-system-spec-type fss))))
+                             (symbol->string
+                             (file-system-spec-type fss)))))
 
     (form-set-current-field form 0)