12/22: installer: Write the configuration to a temporary file.

[John Darrington]

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

commit 94f15d1e873d5ee5019f67c4ec0e74dcf1197325
Author: John Darrington <address@hidden>
Date:   Sun Dec 25 14:11:21 2016 +0100

    installer: Write the configuration to a temporary file.
    
    * gnu/system/installer/configure.scm: New file.
    * gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
    * gnu/system/installer/misc.scm (%temporary-configuration-file-port): New
    variable.
    * gnu/system/installer/new.scm (main-options): Simplify "generate" member.
---
 gnu/local.mk                       |    1 +
 gnu/system/installer/configure.scm |  185 ++++++++++++++++++++++++++++++++++++
 gnu/system/installer/misc.scm      |    3 +
 gnu/system/installer/new.scm       |   60 +++---------
 4 files changed, 200 insertions(+), 49 deletions(-)

diff --git a/gnu/local.mk b/gnu/local.mk
index 8c8c5c5..32e6555 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -450,6 +450,7 @@ GNU_SYSTEM_MODULES =                                \
   %D%/system/installer/file-browser.scm         \
   %D%/system/installer/utils.scm                \
   %D%/system/installer/page.scm                 \
+  %D%/system/installer/configure.scm            \
   %D%/system/installer/time-zone.scm            \
   %D%/system/installer/misc.scm                 \
   %D%/system/installer/partition-reader.scm     \
diff --git a/gnu/system/installer/configure.scm 
b/gnu/system/installer/configure.scm
new file mode 100644
index 0000000..69a3bce
--- /dev/null
+++ b/gnu/system/installer/configure.scm
@@ -0,0 +1,185 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 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 configure)
+  #:use-module (gnu system installer page)
+  #:use-module (gnu system installer ping)
+  #:use-module (gnu system installer misc)
+  #:use-module (gnu system installer utils)
+  #:use-module  (gnu system installer misc)
+  #:use-module  (gnu system installer partition-reader)
+  #:use-module  (gnu system installer disks)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (gurses buttons)
+  #:use-module (ncurses curses)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+
+  #:export (make-configure-page))
+
+
+(define (make-configure-page parent title)
+  (let ((page (make-page (page-surface parent)
+                         title
+                         configure-page-refresh
+                         configure-page-key-handler)))
+    page))
+
+
+(define my-buttons `((save ,(N_ "_Save") #t)
+                     (back ,(N_ "_Back") #t)))
+
+(define (configure-page-key-handler page ch)
+
+  (let ((nav  (page-datum page 'navigation))
+       (test-window  (page-datum page 'test-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 'back)
+      ;; Close the menu and return 
+      (delwin (outer (page-wwin page)))
+      (delwin (inner (page-wwin page)))
+      (set! page-stack (cdr page-stack)))
+
+
+
+     ((buttons-key-matches-symbol? nav ch 'save)
+      ;; Write the configuration
+      (truncate-file %temporary-configuration-file-port 0)
+      (generate-guix-config %temporary-configuration-file-port)
+      (force-output %temporary-configuration-file-port)
+
+      ;; Close the menu and return 
+      (delwin (outer (page-wwin page)))
+      (delwin (inner (page-wwin page)))
+      (set! page-stack (cdr page-stack)))
+     )
+
+    #f))
+
+(define (configure-page-refresh page)
+  (when (not (page-initialised? page))
+    (configure-page-init page)
+    (page-set-initialised! page #t))
+  (touchwin (outer (page-wwin page)))
+  (refresh (outer (page-wwin page)))
+  (refresh (inner (page-wwin page))))
+
+
+(define (generate-guix-config p)
+  (pretty-print
+   `(operating-system
+      (timezone ,time-zone)
+      (host-name ,host-name)
+      (locale "POSIX")
+      ,(let ((grub-mount-point
+              (find-mount-device "/boot/grub"
+                                 mount-points)))
+         (if grub-mount-point
+             `(bootloader
+               (grub-configuration
+                (device
+                 ,(disk-name
+                   (assoc-ref
+                    (partition-volume-pairs)
+                    (find-partition grub-mount-point))))
+                (timeout 2)))))
+
+      (file-systems
+       (cons*
+        ,(map (lambda (x)
+                (let ((z (find-partition (car x))))
+                  `(filesystem
+                    (device ,(car x))
+                    (title 'device)
+                    (mount-point ,(cdr x))
+                    (type ,(partition-fs z)))))
+              mount-points)
+        %base-file-systems))
+      (users (cons* %base-user-accounts))
+      (packages (cons* nss-certs %base-packages))
+      (services (cons* %desktop-services))
+      (name-service-switch %mdns-host-lookup-nss)) p))
+
+
+(define (configure-page-init p)
+  (let* ((s (page-surface p))
+        (pr (make-boxed-window  #f
+             (- (getmaxy s) 3) (- (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
+              "The following configuration has been generated for you.  If you 
are satisfied with it you may save it and continue.  Otherwise go back and 
change some options."))
+
+    (let ((p (make-window-port (inner config-window))))
+      (generate-guix-config p)
+      (force-output p))
+
+    (page-set-wwin! p pr)
+    (page-set-datum! p 'navigation buttons)
+    (buttons-post buttons bwin)
+    (refresh (outer pr))
+    (refresh text-window)
+
+    (refresh (outer config-window))
+
+    (refresh bwin)))
diff --git a/gnu/system/installer/misc.scm b/gnu/system/installer/misc.scm
index aa30bdd..291974e 100644
--- a/gnu/system/installer/misc.scm
+++ b/gnu/system/installer/misc.scm
@@ -22,6 +22,7 @@
   #:export (livery-title)
   #:export (time-zone)
   #:export (host-name)
+  #:export (%temporary-configuration-file-port)
   #:export (mount-points))
 
 (define livery-title 1)
@@ -32,3 +33,5 @@
 
 (define host-name "")
 
+(define %temporary-configuration-file-port
+  (mkstemp! (string-copy "/tmp/guix-config-XXXXXX")))
diff --git a/gnu/system/installer/new.scm b/gnu/system/installer/new.scm
index b97bf74..01ff36d 100644
--- a/gnu/system/installer/new.scm
+++ b/gnu/system/installer/new.scm
@@ -25,7 +25,8 @@
             (gnu system installer misc)
             (gnu system installer partition-reader)
             (gnu system installer disks)
-            (gnu system installer filesystems)
+            (gnu system installer configure)
+             (gnu system installer filesystems)
             (gnu system installer hostname)
             (gnu system installer file-browser)
             (gnu system installer time-zone)
@@ -58,6 +59,7 @@
 (define timezone-menu-title     (N_ "Set the time zone"))
 (define hostname-menu-title     (N_ "Set the host name"))
 (define installation-menu-title (N_ "Install the system"))
+(define generate-menu-title     (N_ "Generate the configuration"))
 
 (define (size-of-largest-disk)
   (fold (lambda (disk prev) (max (disk-size disk) prev))
@@ -109,49 +111,14 @@
                                page
                                hostname-menu-title))))
 
-    (generate .  ,(make-task
-                   (N_ "Generate the configuration")
-                   '(filesystems timezone hostname)
-                   (lambda () #f)
-                   (lambda (page)
-                     (make-dialog
-                      page
-                      (delay
-                        (generate-guix-config
-                         `(operating-system
-                            (timezone ,time-zone)
-                            (host-name ,host-name)
-                            (locale "POSIX")
-                            ,(let ((grub-mount-point
-                                    (find-mount-device "/boot/grub"
-                                                       mount-points)))
-                               (if grub-mount-point
-                                   `(bootloader
-                                     (grub-configuration
-                                      (device
-                                       ,(disk-name
-                                         (assoc-ref
-                                          (partition-volume-pairs)
-                                          (find-partition grub-mount-point))))
-                                      (timeout 2)))))
-
-                            (file-systems
-                             (cons*
-                              ,(map (lambda (x)
-                                      (let ((z (find-partition (car x))))
-                                        `(filesystem
-                                          (device ,(car x))
-                                          (title 'device)
-                                          (mount-point ,(cdr x))
-                                          (type ,(partition-fs z)))))
-                                    mount-points)
-                              %base-file-systems))
-                            (users (cons* %base-user-accounts))
-                            (packages (cons* nss-certs %base-packages))
-                            (services (cons* %desktop-services))
-                            (name-service-switch %mdns-host-lookup-nss))))
-                      #:justify #f))))
-
+    (generate . , (make-task generate-menu-title
+                             '(filesystems timezone hostname)
+                             (lambda () #f)
+                             (lambda (page)
+                               (make-configure-page
+                                page
+                                generate-menu-title))))
+                             
     (install .  ,(make-task installation-menu-title
                             ;;                            '(generate network)
                             '(filesystems)
@@ -161,11 +128,6 @@
                                page
                                installation-menu-title))))))
 
-(define (generate-guix-config cfg)
-  (call-with-output-string
-    (lambda (p) (pretty-print cfg p))))
-
-
 (define (base-page-key-handler page ch)
   (cond
    ((eqv? ch (key-f 1))