installer: Implement a dialog on /var/guix/installer-socket.

This will allow us to automate testing of the installer.

* gnu/installer/utils.scm (%client-socket-file)
(current-server-socket, current-clients): New variables.
(open-server-socket, call-with-server-socket): New procedure.
(with-server-socket): New macro.
(run-shell-command): Add call to 'send-to-clients'.  Select on both
current-input-port and current-clients.
* gnu/installer/steps.scm (run-installer-steps): Wrap 'call-with-prompt'
in 'with-socket-server'.  Call 'sigaction' for SIGPIPE.
* gnu/installer/newt/page.scm (watch-clients!, close-port-and-reuse-fd)
(run-form-with-clients, send-to-clients): New procedures.
(draw-info-page): Add call to 'run-form-with-clients'.
(run-input-page): Likewise.  Handle EXIT-REASON equal to 'exit-fd-ready.
(run-confirmation-page): Likewise.
(run-listbox-selection-page): Likewise.  Define 'choice->item' and use it.
(run-checkbox-tree-page): Likewise.
(run-file-textbox-page): Add call to 'run-form-with-clients'.  Handle
'exit-fd-ready'.
* gnu/installer/newt/partition.scm (run-disk-page): Pass
 #:client-callback-procedure to 'run-listbox-selection-page'.
* gnu/installer/newt/user.scm (run-user-page): Call
'run-form-with-clients'.  Handle 'exit-fd-ready'.
* gnu/installer/newt/welcome.scm (run-menu-page): Define
'choice->item' and use it.  Call 'run-form-with-clients'.
* gnu/installer/newt/final.scm (run-install-success-page)
(run-install-failed-page): When (current-clients) is non-empty, call
'send-to-clients' without displaying a choice window.

1 files changed, 34 insertions, 10 deletions

diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm
index aec3e7a612..1b4b2df816 100644
--- a/gnu/installer/newt/welcome.scm
+++ b/gnu/installer/newt/welcome.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Mathieu Othacehe <[email protected]>
+;;; Copyright © 2020 Ludovic Courtès <[email protected]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -11,16 +12,20 @@
 ;;; 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
-
 ;;;
 ;;; 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 installer newt welcome)
+  #:use-module (gnu installer steps)
   #:use-module (gnu installer utils)
+  #:use-module (gnu installer newt page)
   #:use-module (gnu installer newt utils)
   #:use-module (guix build syscalls)
   #:use-module (guix i18n)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
   #:use-module (ice-9 receive)
   #:use-module (newt)
@@ -66,24 +71,43 @@ we want this page to occupy all the screen space available."
                 GRID-ELEMENT-COMPONENT options-listbox))
          (form (make-form)))
 
+    (define (choice->item str)
+      ;; Return the item that corresponds to STR.
+      (match (find (match-lambda
+                     ((key . item)
+                      (string=? str (listbox-item->text item))))
+                   keys)
+        ((key . item) item)
+        (#f (raise (condition (&installer-step-abort))))))
+
     (set-textbox-text logo-textbox (read-all logo))
 
     (add-form-to-grid grid form #t)
     (make-wrapped-grid-window grid title)
 
     (receive (exit-reason argument)
-        (run-form form)
+        (run-form-with-clients form
+                               `(menu (title ,title)
+                                      (text ,info-text)
+                                      (items
+                                       ,(map listbox-item->text
+                                             listbox-items))))
       (dynamic-wind
         (const #t)
         (lambda ()
-          (when (eq? exit-reason 'exit-component)
-            (cond
-             ((components=? argument options-listbox)
-              (let* ((entry (current-listbox-entry options-listbox))
-                     (item (assoc-ref keys entry)))
-                (match item
-                  ((text . proc)
-                   (proc))))))))
+          (match exit-reason
+            ('exit-component
+             (let* ((entry (current-listbox-entry options-listbox))
+                    (item (assoc-ref keys entry)))
+               (match item
+                 ((text . proc)
+                  (proc)))))
+            ('exit-fd-ready
+             (let* ((choice argument)
+                    (item   (choice->item choice)))
+               (match item
+                 ((text . proc)
+                  (proc)))))))
         (lambda ()
           (destroy-form-and-pop form))))))