From 63b8c089c1596cd3e814ac13e1a8b3fa45bb2b54 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 22 Jan 2020 22:57:14 +0100
Subject: 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.
---
 gnu/installer/utils.scm | 88 +++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 86 insertions(+), 2 deletions(-)

(limited to 'gnu/installer/utils.scm')

diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 842bd02ced..4dc26374b1 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -21,7 +21,9 @@
   #:use-module (guix utils)
   #:use-module (guix build utils)
   #:use-module (guix i18n)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-34)
+  #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 format)
@@ -33,7 +35,12 @@
             run-shell-command
 
             syslog-port
-            syslog))
+            syslog
+
+            with-server-socket
+            current-server-socket
+            current-clients
+            send-to-clients))
 
 (define* (read-lines #:optional (port (current-input-port)))
   "Read lines from PORT and return them as a list."
@@ -66,7 +73,11 @@ number. If no percentage is found, return #f"
 COMMAND exited successfully, #f otherwise."
   (define (pause)
     (format #t (G_ "Press Enter to continue.~%"))
-    (read-line (current-input-port)))
+    (send-to-clients '(pause))
+    (match (select (cons (current-input-port) (current-clients))
+             '() '())
+      (((port _ ...) _ _)
+       (read-line port))))
 
   (call-with-temporary-output-file
    (lambda (file port)
@@ -134,3 +145,76 @@ COMMAND exited successfully, #f otherwise."
        (with-syntax ((fmt (string-append "installer[~d]: "
                                          (syntax->datum #'fmt))))
          #'(format (syslog-port) fmt (getpid) args ...))))))
+
+
+;;;
+;;; Client protocol.
+;;;
+
+(define %client-socket-file
+  ;; Unix-domain socket where the installer accepts connections.
+  "/var/guix/installer-socket")
+
+(define current-server-socket
+  ;; Socket on which the installer is currently accepting connections, or #f.
+  (make-parameter #f))
+
+(define current-clients
+  ;; List of currently connected clients.
+  (make-parameter '()))
+
+(define* (open-server-socket
+          #:optional (socket-file %client-socket-file))
+  "Open SOCKET-FILE as a Unix-domain socket to accept incoming connections and
+return it."
+  (mkdir-p (dirname socket-file))
+  (when (file-exists? socket-file)
+    (delete-file socket-file))
+  (let ((sock (socket AF_UNIX SOCK_STREAM 0)))
+    (bind sock AF_UNIX socket-file)
+    (listen sock 0)
+    sock))
+
+(define (call-with-server-socket thunk)
+  (if (current-server-socket)
+      (thunk)
+      (let ((socket (open-server-socket)))
+        (dynamic-wind
+          (const #t)
+          (lambda ()
+            (parameterize ((current-server-socket socket))
+              (thunk)))
+          (lambda ()
+            (close-port socket))))))
+
+(define-syntax-rule (with-server-socket exp ...)
+  "Evaluate EXP with 'current-server-socket' parameterized to a currently
+accepting socket."
+  (call-with-server-socket (lambda () exp ...)))
+
+(define* (send-to-clients exp)
+  "Send EXP to all the current clients."
+  (define remainder
+    (fold (lambda (client remainder)
+            (catch 'system-error
+              (lambda ()
+                (write exp client)
+                (newline client)
+                (force-output client)
+                (cons client remainder))
+              (lambda args
+                ;; We might get EPIPE if the client disconnects; when that
+                ;; happens, remove CLIENT from the set of available clients.
+                (let ((errno (system-error-errno args)))
+                  (if (memv errno (list EPIPE ECONNRESET ECONNABORTED))
+                      (begin
+                        (syslog "removing client ~s due to ~s while replying~%"
+                                (fileno client) (strerror errno))
+                        (false-if-exception (close-port client))
+                        remainder)
+                      (cons client remainder))))))
+          '()
+          (current-clients)))
+
+  (current-clients (reverse remainder))
+  exp)
-- 
cgit v1.2.3