93/197: installer: Add a dedicated make to format filesystems.

[Danny Milosavljevic]

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

commit 6f6ebcfb72ac0462ea5c082bec816e692946d24d
Author: John Darrington <address@hidden>
Date:   Sun Jan 15 12:45:00 2017 +0100

    installer: Add a dedicated make to format filesystems.
    
    * gnu/system/installer/format.scm: New file.
    * gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
---
 gnu/local.mk                              |   1 +
 gnu/system/installer/format.scm           | 154 ++++++++++++++++++++++++++++++
 gnu/system/installer/guixsd-installer.scm |  10 ++
 3 files changed, 165 insertions(+)

diff --git a/gnu/local.mk b/gnu/local.mk
index 20284f9..39a1a96 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -471,6 +471,7 @@ GNU_SYSTEM_MODULES =                                \
   %D%/system/installer/mount-point.scm          \
   %D%/system/installer/guixsd-installer.scm     \
   %D%/system/installer/disks.scm                \
+  %D%/system/installer/format.scm               \
   %D%/system/installer/ping.scm                 \
   %D%/system/installer/key-map.scm              \
   %D%/system/installer/role.scm                 \
diff --git a/gnu/system/installer/format.scm b/gnu/system/installer/format.scm
new file mode 100644
index 0000000..2f965cc
--- /dev/null
+++ b/gnu/system/installer/format.scm
@@ -0,0 +1,154 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system installer format)
+   #:use-module (gnu system installer page)
+   #:use-module (gnu system installer misc)
+   #:use-module (gnu system installer filesystems)
+   #:use-module (gnu system installer utils)
+   #:use-module (ice-9 rdelim)
+   #:use-module (ice-9 match)
+   #:use-module (gurses buttons)
+   #:use-module (ncurses curses)
+   
+   #:export (make-format-page))
+
+
+(define (make-format-page parent title)
+  (let ((page (make-page (page-surface parent)
+                         title
+                         format-page-refresh
+                         0
+                         format-page-key-handler)))
+    page))
+
+
+(define my-buttons `((format ,(N_ "_Format") #t)
+                     (cancel ,(N_ "Canc_el") #t)))
+
+
+(define (format-page-key-handler page ch)
+
+  (let ((nav  (page-datum page 'navigation))
+       (config-window  (page-datum page 'config-window)))
+
+    (cond
+     ((eq? ch KEY_RIGHT)
+      (buttons-select-next nav))
+
+     ((eq? ch #\tab)
+      (cond
+       ((eqv? (buttons-selected nav) (1- (buttons-n-buttons nav)))
+       (buttons-unselect-all nav))
+
+       (else
+       (buttons-select-next nav))))
+
+     ((eq? ch KEY_LEFT)
+      (buttons-select-prev nav))
+
+     ((eq? ch KEY_UP)
+      (buttons-unselect-all nav))
+
+     
+     ((buttons-key-matches-symbol? nav ch 'cancel)
+      ;; Close the menu and return 
+      (page-leave))
+
+
+     ((buttons-key-matches-symbol? nav ch 'format)
+      (let ((window-port (make-window-port config-window)))
+        (for-each
+         (lambda (x)
+           (match x
+                  ((dev . (? file-system-spec? fss))
+                   (let ((cmd (string-append "mkfs." (file-system-spec-type 
fss))))
+                     (zero? (pipe-cmd window-port
+                                      cmd cmd
+                                      "-L" (file-system-spec-label fss)
+                                      "-U" (file-system-spec-uuid fss)
+                                      "-v"
+                                      dev))
+                     )))) mount-points)
+        
+        (close-port window-port))
+      
+      ;;(page-leave)
+      ))
+     
+    #f))
+
+(define (format-page-refresh page)
+  (when (not (page-initialised? page))
+    (format-page-init page)
+    (page-set-initialised! page #t))
+  (touchwin (outer (page-wwin page)))
+  (refresh (outer (page-wwin page)))
+  (refresh (inner (page-wwin page))))
+
+
+(define (format-page-init p)
+  (let* ((s (page-surface p))
+        (pr (make-boxed-window  #f
+             (- (getmaxy s) 4) (- (getmaxx s) 2)
+             2 1
+             #:title (page-title p)))
+         
+        (text-window (derwin
+                      (inner pr)
+                      3 (getmaxx (inner pr))
+                      0 0
+                      #:panel #f))
+
+        (bwin (derwin (inner pr)
+                      3 (getmaxx (inner pr))
+                      (- (getmaxy (inner pr)) 3) 0
+                         #:panel #f))
+        (buttons (make-buttons my-buttons 1))
+
+
+         (config-window (make-boxed-window 
+                         (inner pr)
+                         (- (getmaxy (inner pr))
+                            (getmaxy bwin)
+                            (getmaxy text-window))
+                         (getmaxx (inner pr))
+                         (getmaxy text-window)
+                         0)))
+
+    (addstr* text-window
+              (gettext
+               (format #f
+                       "The partitions ~s will be formatted.  All data on 
these partitions will be destroyed if you continue."
+                       (map (lambda (x)
+                              (car x))
+                            mount-points))))
+
+
+        
+    (push-cursor (page-cursor-visibility p))
+    (page-set-wwin! p pr)
+    (page-set-datum! p 'navigation buttons)
+    (page-set-datum! p 'config-window (inner config-window))
+    (buttons-post buttons bwin)
+    (refresh (outer pr))
+    (refresh text-window)
+
+    (refresh (outer config-window))
+
+    (refresh bwin)))
diff --git a/gnu/system/installer/guixsd-installer.scm 
b/gnu/system/installer/guixsd-installer.scm
index 8314d08..1be2bea 100644
--- a/gnu/system/installer/guixsd-installer.scm
+++ b/gnu/system/installer/guixsd-installer.scm
@@ -33,6 +33,7 @@
              (gnu system installer role)
             (gnu system installer network)
              (gnu system installer install)
+             (gnu system installer format)
             (gnu system installer page)
              (gnu system installer ping)
             (gnu system installer dialog)
@@ -57,6 +58,7 @@
 
 (define partition-menu-title    (N_ "Partition the disk(s)"))
 (define filesystem-menu-title   (N_ "Allocate disk partitions"))
+(define format-menu-title       (N_ "Format the partitions"))
 (define network-menu-title      (N_ "Set up the network"))
 (define timezone-menu-title     (N_ "Set the time zone"))
 (define hostname-menu-title     (N_ "Set the host name"))
@@ -85,6 +87,14 @@
                                   page
                                   filesystem-menu-title))))
 
+    (format . ,(make-task format-menu-title
+                          '(filesystems)
+                          (lambda () #f)
+                          (lambda (page)
+                            (make-format-page
+                             page
+                             format-menu-title))))
+
     (network . ,(make-task network-menu-title
                            '()
                            substitute-is-reachable?