92/197: installer: Remove mkfs capability from mount points page.

[Danny Milosavljevic]

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

commit 68537e68116a6edc90a1204fa454ef44eb6abdc4
Author: John Darrington <address@hidden>
Date:   Sat Jan 14 12:55:55 2017 +0100

    installer: Remove mkfs capability from mount points page.
    
    * gnu/system/installer/configure.scm (generate-config): Specify filesystems 
by label
    instead of device.
    * gnu/system/installer/filesystems.scm (<file-system-spec>): New record 
type.
    * gnu/system/installer/guixsd-installer.scm (mount-options): filesystems is 
now
    dependent upon hostname.
    * gnu/system/installer/mount-point.scm (mount-point-init): Remove text 
window and
    filesytem creation capability.
    * gnu/system/installer/utils.scm (pair->mp): New procedure.
---
 gnu/system/installer/configure.scm        |  15 ++--
 gnu/system/installer/filesystems.scm      |  88 ++++++++++++++---------
 gnu/system/installer/guixsd-installer.scm |   7 +-
 gnu/system/installer/mount-point.scm      | 114 +++++++++++-------------------
 gnu/system/installer/utils.scm            |   8 ++-
 5 files changed, 113 insertions(+), 119 deletions(-)

diff --git a/gnu/system/installer/configure.scm 
b/gnu/system/installer/configure.scm
index c952983..c0f10dd 100644
--- a/gnu/system/installer/configure.scm
+++ b/gnu/system/installer/configure.scm
@@ -24,6 +24,7 @@
   #:use-module (gnu system installer misc)
   #:use-module (gnu system installer role)
   #:use-module (gnu system installer partition-reader)
+  #:use-module (gnu system installer filesystems)
   #:use-module (gnu system installer disks)
   #:use-module (ice-9 format)
   #:use-module (ice-9 rdelim)
@@ -129,8 +130,8 @@
 (define (generate-guix-config p width)
   (let ((grub-mount-point
          (find-mount-device "/boot/grub"
-                            mount-points)))
-    
+                                 mount-points)))
+
     (pretty-print `(use-modules
                     (gnu)
                     ,(when grub-mount-point
@@ -168,12 +169,12 @@
         (file-systems
          ,(append (list 'cons*)
                   (map (lambda (x)
-                         (let ((z (find-partition (car x))))
+                         (let ((fss (cdr x)))
                            `(file-system
-                              (device ,(car x))
-                              (title 'device)
-                              (mount-point ,(cdr x))
-                              (type ,(partition-fs z))))) mount-points)
+                              (device ,(file-system-spec-label fss))
+                              (title 'label)
+                              (mount-point ,(file-system-spec-mount-point fss))
+                              (type ,(file-system-spec-type fss))))) 
mount-points)
                   (list '%base-file-systems)))
         (users (cons* %base-user-accounts))
         (packages (cons*
diff --git a/gnu/system/installer/filesystems.scm 
b/gnu/system/installer/filesystems.scm
index 05d8310..cba8333 100644
--- a/gnu/system/installer/filesystems.scm
+++ b/gnu/system/installer/filesystems.scm
@@ -30,11 +30,28 @@
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+
+  #:export (make-file-system-spec)
+  #:export (<file-system-spec>)
+  #:export (file-system-spec-mount-point)
+  #:export (file-system-spec-label)
+  #:export (file-system-spec-type)
 
   #:export (minimum-store-size)
   #:export (filesystem-task-complete?)
   #:export (make-filesystem-page))
 
+
+;; File system spec declaration.
+(define-record-type <file-system-spec>
+  (make-file-system-spec mount-point label type)
+  file-system-spec?
+  (mount-point      file-system-spec-mount-point)      ; string
+  (label            file-system-spec-label)            ; string
+  (type             file-system-spec-type))             ; symbol
+
+
 (define minimum-store-size 7000)
 
 (define (filesystem-task-complete?)
@@ -47,12 +64,15 @@
         (N_ "You must specify a mount point for the root (/)."))
 
 
-   (let ((non-absolute-list (fold (lambda (x prev)
-                (if (absolute-file-name? (cdr x))
-                    prev
-                    (cons (cdr x) prev)))
-              '()
-              mount-points)))
+   (let ((non-absolute-list
+          (fold (lambda (x prev)
+                  (match x
+                         ((dev . fss)
+                          (if (absolute-file-name? 
(file-system-spec-mount-point fss))
+                              prev
+                              (cons (file-system-spec-mount-point fss) 
prev)))))
+                '()
+                mount-points)))
      (and (not (null? non-absolute-list))
           (ngettext
            (format #f
@@ -73,27 +93,28 @@
               (ac '()))
      (match ll
        ('() #f)
-       (((_ . directory) . rest)
-        (if (member directory ac)
+       (((_ . (? file-system-spec? fss)) . rest)
+        (if (member fss ac)
             (format #f
                     (N_ "You have specified the mount point ~a more than 
once.")
-                    directory)
-            (loop rest (cons directory ac))))))
+                    (file-system-spec-mount-point fss))
+            (loop rest (cons fss ac))))))
 
    (let ((partitions-without-filesystems
           (fold (lambda (x prev)
-                  (if (not (string-prefix? "ext"
-                                           (partition-fs (string->partition
-                                                          (car x)))))
-                      (cons (car x) prev)
-                      prev)) '() mount-points)))
+                  (match x
+                         ((dev . (? file-system-spec? fss))
+                          (if (not (string-prefix? "ext"
+                                                   (file-system-spec-type 
fss)))
+                              (cons dev prev)
+                              prev)))) '() mount-points)))
 
      (if (null? partitions-without-filesystems)
          #f
          (ngettext
-          (format #f (N_ "The partition ~a does not contain a filesystem.")
+          (format #f (N_ "The filesystem type for partition ~a is not valid.")
                   (car partitions-without-filesystems))
-          (format #f (N_ "The partitions ~a do not contain filesystems.")
+          (format #f (N_ "The filesystem type for partitions ~a are not 
valid.")
                   partitions-without-filesystems)
           (length partitions-without-filesystems))))))
 
@@ -125,8 +146,8 @@
     (touchwin (outer (page-wwin page)))
     (refresh (outer (page-wwin page)))
     (refresh (inner (page-wwin page)))
-    (menu-refresh menu)
-    (menu-redraw menu)))
+    (menu-redraw menu)
+    (menu-refresh menu)))
 
 
 (define (size-of-partition device)
@@ -225,19 +246,22 @@
                       (- (getmaxx (inner pr)) 0)
                       (getmaxy text-window)  0 #:panel #f))
 
-        (menu (make-menu  (partition-volume-pairs)
-                          #:disp-proc
-                          (lambda (d row)
-                            (let* ((part (car d))
-                                    (name (partition-name part)))
-
-                              (format #f "~30a ~7a ~16a ~a"
-                                      name
-                                      (number->size (partition-size part))
-                                      (partition-fs part)
-                                      (let ((x (assoc-ref mount-points name)))
-                                         (if x x ""))))))))
-
+        (menu (make-menu
+                (partition-volume-pairs)
+                #:disp-proc
+                (lambda (d row)
+                  (let* ((part (car d))
+                         (name (partition-name part))
+                         (fs-spec
+                          (assoc-ref mount-points name)))
+                    
+                    (format #f "~30a ~7a ~16a ~a"
+                            name
+                            (number->size (partition-size part))
+                            (if fs-spec (file-system-spec-type fs-spec) "")
+                            (if fs-spec
+                                (file-system-spec-mount-point fs-spec) 
"")))))))
+    
     (push-cursor (page-cursor-visibility p))
     (page-set-wwin! p pr)
     (page-set-datum! p 'menu menu)
diff --git a/gnu/system/installer/guixsd-installer.scm 
b/gnu/system/installer/guixsd-installer.scm
index 6da3b89..8314d08 100644
--- a/gnu/system/installer/guixsd-installer.scm
+++ b/gnu/system/installer/guixsd-installer.scm
@@ -78,7 +78,7 @@
                            partition-menu-title))))
 
     (filesystems . ,(make-task filesystem-menu-title
-                               '(disk)
+                               '(disk hostname)
                                filesystem-task-complete?
                                (lambda (page)
                                  (make-filesystem-page
@@ -113,7 +113,6 @@
                                page
                                hostname-menu-title))))
 
-
     (role . ,(make-task role-menu-title
                             '()
                             (lambda () (and system-role (role? system-role)))
@@ -122,9 +121,8 @@
                                page
                                role-menu-title))))
 
-
     (generate . , (make-task generate-menu-title
-                             '(role filesystems timezone hostname)
+                             '(role filesystems timezone)
                              (lambda ()
                                (and config-file
                                     (file-exists? config-file)
@@ -178,7 +176,6 @@
 
 (define (do-task-list task-name-list page)
   "Queue the tasks whose names are the members of TASK-NAME-LIST"
-
   (for-each
    (lambda (task-name)
      (let ((task (assoc-ref main-options task-name)))
diff --git a/gnu/system/installer/mount-point.scm 
b/gnu/system/installer/mount-point.scm
index f9757b1..b5b653e 100644
--- a/gnu/system/installer/mount-point.scm
+++ b/gnu/system/installer/mount-point.scm
@@ -18,6 +18,7 @@
 
 (define-module (gnu system installer mount-point)
   #:use-module (gnu system installer partition-reader)
+  #:use-module (gnu system installer filesystems)
   #:use-module (gnu system installer page)
   #:use-module (gnu system installer misc)
   #:use-module (gnu system installer utils)
@@ -28,21 +29,9 @@
   #:export (mount-point-refresh)
   #:export (mount-point-page-key-handler))
 
-(define (efs-params device)
-  (slurp
-   (string-append "tune2fs -l " device)
-   (lambda (line)
-     (let ((sep (string-contains line ":")))
-       (if (not sep)
-          ""
-          (cons
-                (string->symbol
-                 (string-map (lambda (c) (if (eq? c #\space) #\- c))
-                             (string-downcase (substring line 0 sep))))
-                (string-trim-both (substring line (+ sep 2)))))))))
-
-(define my-fields `((label       ,(N_ "Label") 40)
-                   (mount-point ,(N_ "Mount Point") 10)))
+(define my-fields `((mount-point ,(N_ "Mount Point") 40)
+                    (fs-type     ,(N_ "File System Type") 10)
+                    (label       ,(N_ "Label") 16)))
 
 (define (mount-point-refresh page)
   (when (not (page-initialised? page))
@@ -57,41 +46,16 @@
        (nav   (page-datum page 'navigation))
        (dev   (page-datum page 'device)))
 
-    (if (not (form-enabled? form))
-       (if (or
-            (eq? ch #\space)
-            (eq? ch #\nl))
-           (cond
-            ((buttons-key-matches-symbol? nav ch 'continue)
-              (let ((mp (form-get-value form 'mount-point)))
-                (if (equal? "" mp)
-                    (set! mount-points
-                      (assoc-remove! mount-points dev))
-                    
-                    (set! mount-points (assoc-set! mount-points
-                                                   dev mp))))
-
-             (page-leave))
-
-            ((buttons-key-matches-symbol? nav ch 'check)
-             (window-pipe (page-datum page 'output) "fsck.ext4" "fsck.ext4" 
"-n" "-v"
-                          "-f"
-                          dev))
-
-            ((buttons-key-matches-symbol? nav ch 'write)
-             (window-pipe (page-datum page 'output)
-                          "tune2fs" "tune2fs"
-                          "-L" (form-get-value form 'label)
-                          dev))
-
-            ((buttons-key-matches-symbol? nav ch 'recreate)
-             (window-pipe (page-datum page 'output)
-                          "mkfs.ext4" "mkfs.ext4" "-v" "-F"
-                          "-L" (form-get-value form 'label)
-                          dev))
-            )))
-    
     (cond
+     ((buttons-key-matches-symbol? nav ch 'continue)
+      (set! mount-points
+            (assoc-set! mount-points dev
+                        (make-file-system-spec
+                         (form-get-value form 'mount-point)
+                         (form-get-value form 'label)
+                         (form-get-value form 'fs-type))))
+      (page-leave))
+
      ((buttons-key-matches-symbol? nav ch 'cancel)
       ;; Close the menu and return 
       (page-leave))
@@ -118,9 +82,6 @@
   #f)
 
 (define my-buttons `((continue ,(N_ "Continue") #f)
-                    (check    ,(N_ "Check") #f)
-                    (write    ,(N_ "Write") #f)
-                    (recreate ,(N_ "(re)Create") #f)
                     (cancel     ,(N_ "Cancel") #f)))
 
 (define (mount-point-page-init p)
@@ -142,24 +103,23 @@
         (nav (make-buttons my-buttons 1))
         
         (fw (derwin (inner pr)
-                    2
+                    (length my-fields)
                     (getmaxx (inner pr))
                     (getmaxy text-window) 0))
 
 
-        (out (derwin (inner pr)
-                    (- (getmaxy (inner pr)) (getmaxy bwin) (getmaxy 
text-window) (getmaxy fw))
-                    (getmaxx (inner pr))
-                    (+ (getmaxy text-window) (getmaxy fw))
-                    0))
-        
-        (form (make-form my-fields)))
+        (form (make-form
+                my-fields
+                (lambda (f)
+                  (let ((field (get-current-field f)))
+                    (if (eq? (field-symbol field) 'mount-point)
+                        (form-set-value! f 'label
+                                         (string-append
+                                          host-name "-"
+                                          (form-get-value f 
'mount-point)))))))))
 
-    (box out 0 0)
-    (page-set-datum! p 'output out)
     (page-set-datum! p 'navigation nav)    
-    (let* ((dev (page-datum p 'device))
-          (efsp (efs-params dev)))
+    (let ((dev (page-datum p 'device)))
       (addstr*
        text-window
        (format #f
@@ -167,16 +127,24 @@
                "The device ~s is currently configured as follows.  You may 
change the configuration here if desired.")
               dev))
 
-      (form-post form fw)
-      (if efsp
-         (form-set-value! form 'label
-                          (assq-ref efsp
-                                    'filesystem-volume-name)))
-
-      (form-set-value! form 'mount-point
-                      (or (assoc-ref mount-points dev)
-                          "")))
+      (form-post form fw))
 
+    (let* ((dev (page-datum p 'device))
+           (fss (assoc-ref mount-points dev)))
+
+      (form-set-value! form 'label
+                       (if fss
+                           (file-system-spec-label fss)
+                           (string-append host-name
+                           "-")))
+      (when fss
+            (form-set-value! form 'mount-point
+                             (file-system-spec-mount-point fss))
+            (form-set-value! form 'fs-type
+                             (file-system-spec-type fss))))
+    
+    (form-set-current-field form 0)
+    
     (push-cursor (page-cursor-visibility p))
     (buttons-post nav bwin)
     (page-set-datum! p 'form form)
diff --git a/gnu/system/installer/utils.scm b/gnu/system/installer/utils.scm
index 6de519b..2d417af 100644
--- a/gnu/system/installer/utils.scm
+++ b/gnu/system/installer/utils.scm
@@ -50,6 +50,7 @@
              (ice-9 match)
             (ncurses menu)
             (gnu system installer misc)
+             (gnu system installer filesystems)
             (ncurses form)
              (ncurses curses))
 
@@ -318,6 +319,9 @@ mounts return the device on which the path IN would be 
mounted."
              p))
        p))
 
+  (define (pair->mp pr)
+    (file-system-spec-mount-point (cdr pr)))
+
   (if (not (absolute-file-name? in))
       (error (format #f "Path is not absolute")))
 
@@ -326,8 +330,8 @@ mounts return the device on which the path IN would be 
mounted."
         (map-in-order
          (lambda (p)
            (cons (car p)
-                 (string-split (normalise-directory-path (cdr p)) dir-sep)))
-         (sort mp (lambda (x y) (string> (cdr x) (cdr y)))))))
+                 (string-split (normalise-directory-path (pair->mp p)) 
dir-sep)))
+         (sort mp (lambda (x y) (string> (pair->mp x) (pair->mp y)))))))
     
     (let loop ((pp paths))
       (if (null? pp)