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.

7 files changed, 590 insertions, 261 deletions

diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm
index 405eee2540..5cb4f6816d 100644
--- a/gnu/installer/newt/final.scm
+++ b/gnu/installer/newt/final.scm
@@ -63,28 +63,38 @@ This will take a few minutes.")
          (&installer-step-abort)))))))
 
 (define (run-install-success-page)
-  (message-window
-   (G_ "Installation complete")
-   (G_ "Reboot")
-   (G_ "Congratulations!  Installation is now complete.  \
+  (match (current-clients)
+    (()
+     (message-window
+      (G_ "Installation complete")
+      (G_ "Reboot")
+      (G_ "Congratulations!  Installation is now complete.  \
 You may remove the device containing the installation image and \
-press the button to reboot."))
+press the button to reboot.")))
+    (_
+     ;; When there are clients connected, send them a message and keep going.
+     (send-to-clients '(installation-complete))))
 
   ;; Return success so that the installer happily reboots.
   'success)
 
 (define (run-install-failed-page)
-  (match (choice-window
-          (G_ "Installation failed")
-          (G_ "Resume")
-          (G_ "Restart the installer")
-          (G_ "The final system installation step failed.  You can resume from \
+  (match (current-clients)
+    (()
+     (match (choice-window
+             (G_ "Installation failed")
+             (G_ "Resume")
+             (G_ "Restart the installer")
+             (G_ "The final system installation step failed.  You can resume from \
 a specific step, or restart the installer."))
-    (1 (raise
-        (condition
-         (&installer-step-abort))))
-    (2
-     ;; Keep going, the installer will be restarted later on.
+       (1 (raise
+           (condition
+            (&installer-step-abort))))
+       (2
+        ;; Keep going, the installer will be restarted later on.
+        #t)))
+    (_
+     (send-to-clients '(installation-failure))
      #t)))
 
 (define* (run-install-shell locale
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index 8aea5a1109..c01124aa0d 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -19,6 +19,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu installer newt page)
+  #:use-module (gnu installer steps)
   #:use-module (gnu installer utils)
   #:use-module (gnu installer newt utils)
   #:use-module (guix i18n)
@@ -26,7 +27,10 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 receive)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (newt)
   #:export (draw-info-page
             draw-connecting-page
@@ -36,7 +40,9 @@
             run-listbox-selection-page
             run-scale-page
             run-checkbox-tree-page
-            run-file-textbox-page))
+            run-file-textbox-page
+
+            run-form-with-clients))
 
 ;;; Commentary:
 ;;;
@@ -49,9 +55,123 @@
 ;;;
 ;;; Code:
 
+(define* (watch-clients! form #:optional (clients (current-clients)))
+  "Have FORM watch the file descriptors corresponding to current client
+connections.  Consequently, FORM may exit with the 'exit-fd-ready' reason."
+  (when (current-server-socket)
+    (form-watch-fd form (fileno (current-server-socket))
+                   FD-READ))
+
+  (for-each (lambda (client)
+              (form-watch-fd form (fileno client)
+                             (logior FD-READ FD-EXCEPT)))
+            clients))
+
+(define close-port-and-reuse-fd
+  (let ((bit-bucket #f))
+    (lambda (port)
+      "Close PORT and redirect its underlying FD to point to a valid open file
+descriptor."
+      (let ((fd (fileno port)))
+        (unless bit-bucket
+          (set! bit-bucket (car (pipe))))
+        (close-port port)
+
+        ;; FIXME: We're leaking FD.
+        (dup2 (fileno bit-bucket) fd)))))
+
+(define* (run-form-with-clients form exp)
+  "Run FORM such as it watches the file descriptors beneath CLIENTS after
+sending EXP to all the clients.
+
+Automatically restart the form when it exits with 'exit-fd-ready but without
+an actual client reply--e.g., it got a connection request or a client
+disconnect.
+
+Like 'run-form', return two values: the exit reason, and an \"argument\"."
+  (define* (discard-client! port #:optional errno)
+    (if errno
+        (syslog "removing client ~d due to ~s~%"
+                (fileno port) (strerror errno))
+        (syslog "removing client ~d due to EOF~%"
+                (fileno port)))
+
+    ;; XXX: Watch out!  There's no 'form-unwatch-fd' procedure in Newt so we
+    ;; cheat: we keep PORT's file descriptor open, but make it a duplicate of
+    ;; a valid but inactive FD.  Failing to do that, 'run-form' would
+    ;; select(2) on the now-closed port and keep spinning as select(2) returns
+    ;; EBADF.
+    (close-port-and-reuse-fd port)
+
+    (current-clients (delq port (current-clients)))
+    (close-port port))
+
+  (define title
+    ;; Title of FORM.
+    (match exp
+      (((? symbol? tag) alist ...)
+       (match (assq 'title alist)
+         ((_ title) title)
+         (_         tag)))
+      (((? symbol? tag) _ ...)
+       tag)
+      (_
+       'unknown)))
+
+  ;; Send EXP to all the currently-connected clients.
+  (send-to-clients exp)
+
+  (let loop ()
+    (syslog "running form ~s (~s) with ~d clients~%"
+            form title (length (current-clients)))
+
+    ;; Call 'watch-clients!' within the loop because there might be new
+    ;; clients.
+    (watch-clients! form)
+
+    (let-values (((reason argument) (run-form form)))
+      (match reason
+        ('exit-fd-ready
+         (match (fdes->ports argument)
+           ((port _ ...)
+            (if (memq port (current-clients))
+
+                ;; Read a reply from a client or handle its departure.
+                (catch 'system-error
+                  (lambda ()
+                    (match (read port)
+                      ((? eof-object? eof)
+                       (discard-client! port)
+                       (loop))
+                      (obj
+                       (syslog "form ~s (~s): client ~d replied ~s~%"
+                               form title (fileno port) obj)
+                       (values 'exit-fd-ready obj))))
+                  (lambda args
+                    (discard-client! port (system-error-errno args))
+                    (loop)))
+
+                ;; Accept a new client and send it EXP.
+                (match (accept port)
+                  ((client . _)
+                   (syslog "accepting new client ~d while on form ~s~%"
+                           (fileno client) form)
+                   (catch 'system-error
+                     (lambda ()
+                       (write exp client)
+                       (newline client)
+                       (force-output client)
+                       (current-clients (cons client (current-clients))))
+                     (lambda _
+                       (close-port client)))
+                   (loop)))))))
+        (_
+         (values reason argument))))))
+
 (define (draw-info-page text title)
   "Draw an informative page with the given TEXT as content.  Set the title of
 this page to TITLE."
+  (send-to-clients `(info (title ,title) (text ,text)))
   (let* ((text-box
           (make-reflowed-textbox -1 -1 text 40
                                  #:flags FLAG-BORDER))
@@ -126,20 +246,25 @@ input box, such as FLAG-PASSWORD."
                                         (G_ "Empty input")))))
       (let loop ()
         (receive (exit-reason argument)
-            (run-form form)
-          (let ((input (entry-value input-entry)))
-            (if (and (not allow-empty-input?)
-                     (eq? exit-reason 'exit-component)
-                     (string=? input ""))
-                (begin
-                  ;; Display the error page.
-                  (error-page)
-                  ;; Set the focus back to the input input field.
-                  (set-current-component form input-entry)
-                  (loop))
-                (begin
-                  (destroy-form-and-pop form)
-                  input))))))))
+            (run-form-with-clients form
+                                   `(input (title ,title) (text ,text)
+                                           (default ,default-text)))
+          (let ((input (if (eq? exit-reason 'exit-fd-ready)
+                           argument
+                           (entry-value input-entry))))
+            (cond ((not input)                 ;client disconnect or something
+                   (loop))
+                  ((and (not allow-empty-input?)
+                        (eq? exit-reason 'exit-component)
+                        (string=? input ""))
+                   ;; Display the error page.
+                   (error-page)
+                   ;; Set the focus back to the input input field.
+                   (set-current-component form input-entry)
+                   (loop))
+                  (else
+                   (destroy-form-and-pop form)
+                   input))))))))
 
 (define (run-error-page text title)
   "Run a page to inform the user of an error. The page contains the given TEXT
@@ -160,7 +285,8 @@ of the page is set to TITLE."
     (newt-set-color COLORSET-ROOT "white" "red")
     (add-components-to-form form text-box ok-button)
     (make-wrapped-grid-window grid title)
-    (run-form form)
+    (run-form-with-clients form
+                           `(error (title ,title) (text ,text)))
     ;; Restore the background to its original color.
     (newt-set-color COLORSET-ROOT "white" "blue")
     (destroy-form-and-pop form)))
@@ -187,17 +313,23 @@ of the page is set to TITLE."
     (make-wrapped-grid-window grid title)
 
     (receive (exit-reason argument)
-        (run-form form)
+        (run-form-with-clients form
+                               `(confirmation (title ,title)
+                                              (text ,text)))
       (dynamic-wind
         (const #t)
         (lambda ()
-          (case exit-reason
-            ((exit-component)
+          (match exit-reason
+            ('exit-component
              (cond
               ((components=? argument ok-button)
                #t)
               ((components=? argument exit-button)
-               (exit-button-procedure))))))
+               (exit-button-procedure))))
+            ('exit-fd-ready
+             (if argument
+                 #t
+                 (exit-button-procedure)))))
         (lambda ()
           (destroy-form-and-pop form))))))
 
@@ -222,6 +354,8 @@ of the page is set to TITLE."
                                       (const #t))
                                      (listbox-callback-procedure
                                       identity)
+                                     (client-callback-procedure
+                                      listbox-callback-procedure)
                                      (hotkey-callback-procedure
                                       (const #t)))
   "Run a page asking the user to select an item in a listbox. The page
@@ -254,9 +388,9 @@ Each time the listbox current item changes, call SKIP-ITEM-PROCEDURE? with the
 current listbox item as argument. If it returns #t, skip the element and jump
 to the next/previous one depending on the previous item, otherwise do
 nothing."
-
-  (define (fill-listbox listbox items)
-    "Append the given ITEMS to LISTBOX, once they have been converted to text
+  (let loop ()
+    (define (fill-listbox listbox items)
+      "Append the given ITEMS to LISTBOX, once they have been converted to text
 with LISTBOX-ITEM->TEXT. Each item appended to the LISTBOX is given a key by
 newt. Save this key by returning an association list under the form:
 
@@ -264,144 +398,165 @@ newt. Save this key by returning an association list under the form:
 
 where NEWT-LISTBOX-KEY is the key returned by APPEND-ENTRY-TO-LISTBOX, when
 ITEM was inserted into LISTBOX."
-    (map (lambda (item)
-           (let* ((text (listbox-item->text item))
-                  (key (append-entry-to-listbox listbox text)))
-             (cons key item)))
-         items))
-
-  (define (sort-listbox-items listbox-items)
-    "Return LISTBOX-ITEMS sorted using the 'string-locale<?' procedure on the text
+      (map (lambda (item)
+             (let* ((text (listbox-item->text item))
+                    (key (append-entry-to-listbox listbox text)))
+               (cons key item)))
+           items))
+
+    (define (sort-listbox-items listbox-items)
+      "Return LISTBOX-ITEMS sorted using the 'string-locale<?' procedure on the text
 corresponding to each item in the list."
-    (let* ((items (map (lambda (item)
-                         (cons item (listbox-item->text item)))
-                       listbox-items))
-           (sorted-items
-            (sort items (lambda (a b)
-                          (let ((text-a (cdr a))
-                                (text-b (cdr b)))
-                            (string-locale<? text-a text-b))))))
-      (map car sorted-items)))
-
-  ;; Store the last selected listbox item's key.
-  (define last-listbox-key (make-parameter #f))
-
-  (define (previous-key keys key)
-    (let ((index (list-index (cut eq? key <>) keys)))
-      (and index
-           (> index 0)
-           (list-ref keys (- index 1)))))
-
-  (define (next-key keys key)
-    (let ((index (list-index (cut eq? key <>) keys)))
-      (and index
-           (< index (- (length keys) 1))
-           (list-ref keys (+ index 1)))))
-
-  (define (set-default-item listbox listbox-keys default-item)
-    "Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the
+      (let* ((items (map (lambda (item)
+                           (cons item (listbox-item->text item)))
+                         listbox-items))
+             (sorted-items
+              (sort items (lambda (a b)
+                            (let ((text-a (cdr a))
+                                  (text-b (cdr b)))
+                              (string-locale<? text-a text-b))))))
+        (map car sorted-items)))
+
+    ;; Store the last selected listbox item's key.
+    (define last-listbox-key (make-parameter #f))
+
+    (define (previous-key keys key)
+      (let ((index (list-index (cut eq? key <>) keys)))
+        (and index
+             (> index 0)
+             (list-ref keys (- index 1)))))
+
+    (define (next-key keys key)
+      (let ((index (list-index (cut eq? key <>) keys)))
+        (and index
+             (< index (- (length keys) 1))
+             (list-ref keys (+ index 1)))))
+
+    (define (set-default-item listbox listbox-keys default-item)
+      "Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the
 association list returned by the FILL-LISTBOX procedure. It is used because
 the current listbox item has to be selected by key."
-    (for-each (match-lambda
-                ((key . item)
-                 (when (equal? item default-item)
-                   (set-current-listbox-entry-by-key listbox key))))
-              listbox-keys))
-
-  (let* ((listbox (make-listbox
-                   -1 -1
-                   listbox-height
-                   (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT
-                           (if listbox-allow-multiple?
-                               FLAG-MULTIPLE
-                               0))))
-         (form (make-form #:flags FLAG-NOF12))
-         (info-textbox
-          (make-reflowed-textbox -1 -1 info-text
-                                 info-textbox-width
-                                 #:flags FLAG-BORDER))
-         (button (make-button -1 -1 button-text))
-         (button2 (and button2-text
-                       (make-button -1 -1 button2-text)))
-         (grid (vertically-stacked-grid
-                GRID-ELEMENT-COMPONENT info-textbox
-                GRID-ELEMENT-COMPONENT listbox
-                GRID-ELEMENT-SUBGRID
-                (apply
-                 horizontal-stacked-grid
-                 GRID-ELEMENT-COMPONENT button
-                 `(,@(if button2
-                         (list GRID-ELEMENT-COMPONENT button2)
-                         '())))))
-         (sorted-items (if sort-listbox-items?
-                           (sort-listbox-items listbox-items)
-                           listbox-items))
-         (keys (fill-listbox listbox sorted-items)))
-
-    ;; On every listbox element change, check if we need to skip it. If yes,
-    ;; depending on the 'last-listbox-key', jump forward or backward. If no,
-    ;; do nothing.
-    (add-component-callback
-     listbox
-     (lambda (component)
-       (let* ((current-key (current-listbox-entry listbox))
-              (listbox-keys (map car keys))
-              (last-key (last-listbox-key))
-              (item (assoc-ref keys current-key))
-              (prev-key (previous-key listbox-keys current-key))
-              (next-key (next-key listbox-keys current-key)))
-         ;; Update last-listbox-key before a potential call to
-         ;; set-current-listbox-entry-by-key, because it will immediately
-         ;; cause this callback to be called for the new entry.
-         (last-listbox-key current-key)
-         (when (skip-item-procedure? item)
-           (when (eq? prev-key last-key)
-             (if next-key
-                 (set-current-listbox-entry-by-key listbox next-key)
-                 (set-current-listbox-entry-by-key listbox prev-key)))
-           (when (eq? next-key last-key)
-             (if prev-key
-                 (set-current-listbox-entry-by-key listbox prev-key)
-                 (set-current-listbox-entry-by-key listbox next-key)))))))
-
-    (when listbox-default-item
-      (set-default-item listbox keys listbox-default-item))
-
-    (when allow-delete?
-      (form-add-hotkey form KEY-DELETE))
+      (for-each (match-lambda
+                  ((key . item)
+                   (when (equal? item default-item)
+                     (set-current-listbox-entry-by-key listbox key))))
+                listbox-keys))
+
+    (let* ((listbox (make-listbox
+                     -1 -1
+                     listbox-height
+                     (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT
+                             (if listbox-allow-multiple?
+                                 FLAG-MULTIPLE
+                                 0))))
+           (form (make-form #:flags FLAG-NOF12))
+           (info-textbox
+            (make-reflowed-textbox -1 -1 info-text
+                                   info-textbox-width
+                                   #:flags FLAG-BORDER))
+           (button (make-button -1 -1 button-text))
+           (button2 (and button2-text
+                         (make-button -1 -1 button2-text)))
+           (grid (vertically-stacked-grid
+                  GRID-ELEMENT-COMPONENT info-textbox
+                  GRID-ELEMENT-COMPONENT listbox
+                  GRID-ELEMENT-SUBGRID
+                  (apply
+                   horizontal-stacked-grid
+                   GRID-ELEMENT-COMPONENT button
+                   `(,@(if button2
+                           (list GRID-ELEMENT-COMPONENT button2)
+                           '())))))
+           (sorted-items (if sort-listbox-items?
+                             (sort-listbox-items listbox-items)
+                             listbox-items))
+           (keys (fill-listbox listbox sorted-items)))
+
+      (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))))))
+
+      ;; On every listbox element change, check if we need to skip it. If yes,
+      ;; depending on the 'last-listbox-key', jump forward or backward. If no,
+      ;; do nothing.
+      (add-component-callback
+       listbox
+       (lambda (component)
+         (let* ((current-key (current-listbox-entry listbox))
+                (listbox-keys (map car keys))
+                (last-key (last-listbox-key))
+                (item (assoc-ref keys current-key))
+                (prev-key (previous-key listbox-keys current-key))
+                (next-key (next-key listbox-keys current-key)))
+           ;; Update last-listbox-key before a potential call to
+           ;; set-current-listbox-entry-by-key, because it will immediately
+           ;; cause this callback to be called for the new entry.
+           (last-listbox-key current-key)
+           (when (skip-item-procedure? item)
+             (when (eq? prev-key last-key)
+               (if next-key
+                   (set-current-listbox-entry-by-key listbox next-key)
+                   (set-current-listbox-entry-by-key listbox prev-key)))
+             (when (eq? next-key last-key)
+               (if prev-key
+                   (set-current-listbox-entry-by-key listbox prev-key)
+                   (set-current-listbox-entry-by-key listbox next-key)))))))
+
+      (when listbox-default-item
+        (set-default-item listbox keys listbox-default-item))
+
+      (when allow-delete?
+        (form-add-hotkey form KEY-DELETE))
 
-    (add-form-to-grid grid form #t)
-    (make-wrapped-grid-window grid title)
+      (add-form-to-grid grid form #t)
+      (make-wrapped-grid-window grid title)
 
-    (receive (exit-reason argument)
-        (run-form form)
-      (dynamic-wind
-        (const #t)
-        (lambda ()
-          (case exit-reason
-            ((exit-component)
-             (cond
-              ((components=? argument button)
-               (button-callback-procedure))
-              ((and button2
-                    (components=? argument button2))
-               (button2-callback-procedure))
-              ((components=? argument listbox)
-               (if listbox-allow-multiple?
-                   (let* ((entries (listbox-selection listbox))
-                          (items (map (lambda (entry)
-                                        (assoc-ref keys entry))
-                                      entries)))
-                     (listbox-callback-procedure items))
-                   (let* ((entry (current-listbox-entry listbox))
-                          (item (assoc-ref keys entry)))
-                     (listbox-callback-procedure item))))))
-            ((exit-hotkey)
-             (let* ((entry (current-listbox-entry listbox))
-                    (item (assoc-ref keys entry)))
-               (hotkey-callback-procedure argument item)))))
-        (lambda ()
-          (destroy-form-and-pop form))))))
+      (receive (exit-reason argument)
+          (run-form-with-clients form
+                                 `(list-selection (title ,title)
+                                                  (multiple-choices?
+                                                   ,listbox-allow-multiple?)
+                                                  (items
+                                                   ,(map listbox-item->text
+                                                         listbox-items))))
+        (dynamic-wind
+          (const #t)
+          (lambda ()
+            (match exit-reason
+              ('exit-component
+               (cond
+                ((components=? argument button)
+                 (button-callback-procedure))
+                ((and button2
+                      (components=? argument button2))
+                 (button2-callback-procedure))
+                ((components=? argument listbox)
+                 (if listbox-allow-multiple?
+                     (let* ((entries (listbox-selection listbox))
+                            (items (map (lambda (entry)
+                                          (assoc-ref keys entry))
+                                        entries)))
+                       (listbox-callback-procedure items))
+                     (let* ((entry (current-listbox-entry listbox))
+                            (item (assoc-ref keys entry)))
+                       (listbox-callback-procedure item))))))
+              ('exit-fd-ready
+               (let* ((choice argument)
+                      (item   (if listbox-allow-multiple?
+                                  (map choice->item choice)
+                                  (choice->item choice))))
+                 (client-callback-procedure item)))
+              ('exit-hotkey
+               (let* ((entry (current-listbox-entry listbox))
+                      (item (assoc-ref keys entry)))
+                 (hotkey-callback-procedure argument item)))))
+          (lambda ()
+            (destroy-form-and-pop form)))))))
 
 (define* (run-scale-page #:key
                          title
@@ -498,48 +653,65 @@ ITEMS when 'Ok' is pressed."
          items
          selection))
 
-  (let* ((checkbox-tree
-          (make-checkboxtree -1 -1
-                             checkbox-tree-height
-                             FLAG-BORDER))
-         (info-textbox
-          (make-reflowed-textbox -1 -1 info-text
-                                 info-textbox-width
-                                 #:flags FLAG-BORDER))
-         (ok-button (make-button -1 -1 (G_ "OK")))
-         (exit-button (make-button -1 -1 (G_ "Exit")))
-         (grid (vertically-stacked-grid
-                GRID-ELEMENT-COMPONENT info-textbox
-                GRID-ELEMENT-COMPONENT checkbox-tree
-                GRID-ELEMENT-SUBGRID
-                (horizontal-stacked-grid
-                 GRID-ELEMENT-COMPONENT ok-button
-                 GRID-ELEMENT-COMPONENT exit-button)))
-         (keys (fill-checkbox-tree checkbox-tree items))
-         (form (make-form #:flags FLAG-NOF12)))
+  (let loop ()
+    (let* ((checkbox-tree
+            (make-checkboxtree -1 -1
+                               checkbox-tree-height
+                               FLAG-BORDER))
+           (info-textbox
+            (make-reflowed-textbox -1 -1 info-text
+                                   info-textbox-width
+                                   #:flags FLAG-BORDER))
+           (ok-button (make-button -1 -1 (G_ "OK")))
+           (exit-button (make-button -1 -1 (G_ "Exit")))
+           (grid (vertically-stacked-grid
+                  GRID-ELEMENT-COMPONENT info-textbox
+                  GRID-ELEMENT-COMPONENT checkbox-tree
+                  GRID-ELEMENT-SUBGRID
+                  (horizontal-stacked-grid
+                   GRID-ELEMENT-COMPONENT ok-button
+                   GRID-ELEMENT-COMPONENT exit-button)))
+           (keys (fill-checkbox-tree checkbox-tree items))
+           (form (make-form #:flags FLAG-NOF12)))
 
-    (add-form-to-grid grid form #t)
-    (make-wrapped-grid-window grid title)
+      (define (choice->item str)
+        ;; Return the item that corresponds to STR.
+        (match (find (match-lambda
+                       ((key . item)
+                        (string=? str (item->text item))))
+                     keys)
+          ((key . item) item)
+          (#f (raise (condition (&installer-step-abort))))))
 
-    (receive (exit-reason argument)
-        (run-form form)
-      (dynamic-wind
-        (const #t)
-        (lambda ()
-          (case exit-reason
-            ((exit-component)
-             (cond
-              ((components=? argument ok-button)
-               (let* ((entries (current-checkbox-selection checkbox-tree))
-                      (current-items (map (lambda (entry)
-                                            (assoc-ref keys entry))
-                                          entries)))
-                 (ok-button-callback-procedure)
-                 current-items))
-              ((components=? argument exit-button)
-               (exit-button-callback-procedure))))))
-        (lambda ()
-          (destroy-form-and-pop form))))))
+      (add-form-to-grid grid form #t)
+      (make-wrapped-grid-window grid title)
+
+      (receive (exit-reason argument)
+          (run-form-with-clients form
+                                 `(checkbox-list (title ,title)
+                                                 (text ,info-text)
+                                                 (items
+                                                  ,(map item->text items))))
+        (dynamic-wind
+          (const #t)
+
+          (lambda ()
+            (match exit-reason
+              ('exit-component
+               (cond
+                ((components=? argument ok-button)
+                 (let* ((entries (current-checkbox-selection checkbox-tree))
+                        (current-items (map (lambda (entry)
+                                              (assoc-ref keys entry))
+                                            entries)))
+                   (ok-button-callback-procedure)
+                   current-items))
+                ((components=? argument exit-button)
+                 (exit-button-callback-procedure))))
+              ('exit-fd-ready
+               (map choice->item argument))))
+          (lambda ()
+            (destroy-form-and-pop form)))))))
 
 (define* (edit-file file #:key locale)
   "Spawn an editor for FILE."
@@ -606,13 +778,16 @@ ITEMS when 'Ok' is pressed."
                           text))
 
       (receive (exit-reason argument)
-          (run-form form)
+          (run-form-with-clients form
+                                 `(file-dialog (title ,title)
+                                               (text ,info-text)
+                                               (file ,file)))
         (define result
           (dynamic-wind
             (const #t)
             (lambda ()
-              (case exit-reason
-                ((exit-component)
+              (match exit-reason
+                ('exit-component
                  (cond
                   ((components=? argument ok-button)
                    (ok-button-callback-procedure))
@@ -621,10 +796,15 @@ ITEMS when 'Ok' is pressed."
                    (exit-button-callback-procedure))
                   ((and edit-button?
                         (components=? argument edit-button))
-                   (edit-file file))))))
+                   (edit-file file))))
+                ('exit-fd-ready
+                 (if argument
+                     (ok-button-callback-procedure)
+                     (exit-button-callback-procedure)))))
             (lambda ()
               (destroy-form-and-pop form))))
 
-        (if (components=? argument edit-button)
+        (if (and (eq? exit-reason 'exit-component)
+                 (components=? argument edit-button))
             (loop)                                ;recurse in tail position
             result)))))
diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm
index 3cba7f77dd..c925e410a9 100644
--- a/gnu/installer/newt/partition.scm
+++ b/gnu/installer/newt/partition.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -682,6 +682,12 @@ by pressing the Exit button.~%~%")))
           #:allow-delete? #t
           #:button-text (G_ "OK")
           #:button-callback-procedure button-ok-action
+
+          ;; Consider client replies equivalent to hitting the "OK" button.
+          ;; XXX: In practice this means that clients cannot do anything but
+          ;; approve the predefined list of partitions.
+          #:client-callback-procedure (lambda (_) (button-ok-action))
+
           #:button2-text (G_ "Exit")
           #:button2-callback-procedure button-exit-action
           #:listbox-callback-procedure listbox-action
diff --git a/gnu/installer/newt/user.scm b/gnu/installer/newt/user.scm
index b01d52172b..ad711d665a 100644
--- a/gnu/installer/newt/user.scm
+++ b/gnu/installer/newt/user.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -23,6 +23,7 @@
   #:use-module ((gnu installer steps) #:select (&installer-step-abort))
   #:use-module (gnu installer newt page)
   #:use-module (gnu installer newt utils)
+  #:use-module (gnu installer utils)
   #:use-module (guix i18n)
   #:use-module (newt)
   #:use-module (ice-9 match)
@@ -115,6 +116,7 @@ REAL-NAME, and HOME-DIRECTORY as the initial values in the form."
                                GRID-ELEMENT-SUBGRID entry-grid
                                GRID-ELEMENT-SUBGRID button-grid)
                               title)
+
     (let ((error-page
            (lambda ()
              (run-error-page (G_ "Empty inputs are not allowed.")
@@ -230,33 +232,45 @@ administrator (\"root\").")
           (set-current-component form ok-button))
 
       (receive (exit-reason argument)
-          (run-form form)
+          (run-form-with-clients form '(add-users))
         (dynamic-wind
           (const #t)
           (lambda ()
-            (when (eq? exit-reason 'exit-component)
-              (cond
-               ((components=? argument add-button)
-                (run (cons (run-user-add-page) users)))
-               ((components=? argument del-button)
-                (let* ((current-user-key (current-listbox-entry listbox))
-                       (users
-                        (map (cut assoc-ref <> 'user)
-                             (remove (lambda (element)
-                                       (equal? (assoc-ref element 'key)
-                                               current-user-key))
-                                     listbox-elements))))
-                  (run users)))
-               ((components=? argument ok-button)
-                (when (null? users)
-                  (run-error-page (G_ "Please create at least one user.")
-                                  (G_ "No user"))
-                  (run users))
-                (reverse users))
-               ((components=? argument exit-button)
-                (raise
-                 (condition
-                  (&installer-step-abort)))))))
+            (match exit-reason
+              ('exit-component
+               (cond
+                ((components=? argument add-button)
+                 (run (cons (run-user-add-page) users)))
+                ((components=? argument del-button)
+                 (let* ((current-user-key (current-listbox-entry listbox))
+                        (users
+                         (map (cut assoc-ref <> 'user)
+                              (remove (lambda (element)
+                                        (equal? (assoc-ref element 'key)
+                                                current-user-key))
+                                      listbox-elements))))
+                   (run users)))
+                ((components=? argument ok-button)
+                 (when (null? users)
+                   (run-error-page (G_ "Please create at least one user.")
+                                   (G_ "No user"))
+                   (run users))
+                 (reverse users))
+                ((components=? argument exit-button)
+                 (raise
+                  (condition
+                   (&installer-step-abort))))))
+              ('exit-fd-ready
+               ;; Read the complete user list at once.
+               (match argument
+                 ((('user ('name names) ('real-name real-names)
+                          ('home-directory homes) ('password passwords))
+                   ..1)
+                  (map (lambda (name real-name home password)
+                         (user (name name) (real-name real-name)
+                               (home-directory home)
+                               (password password)))
+                       names real-names homes passwords))))))
           (lambda ()
             (destroy-form-and-pop form))))))
 
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 <m.othacehe@gmail.com>
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; 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))))))
 
diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm
index b2fc819d89..0b6d8e4649 100644
--- a/gnu/installer/steps.scm
+++ b/gnu/installer/steps.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,6 +20,7 @@
 (define-module (gnu installer steps)
   #:use-module (guix records)
   #:use-module (guix build utils)
+  #:use-module (gnu installer utils)
   #:use-module (ice-9 match)
   #:use-module (ice-9 pretty-print)
   #:use-module (srfi srfi-1)
@@ -185,13 +187,18 @@ return the accumalated result so far."
                 #:todo-steps rest-steps
                 #:done-steps (append done-steps (list step))))))))
 
-  (call-with-prompt 'raise-above
-    (lambda ()
-      (run '()
-           #:todo-steps steps
-           #:done-steps '()))
-    (lambda (k condition)
-      (raise condition))))
+  ;; Ignore SIGPIPE so that we don't die if a client closes the connection
+  ;; prematurely.
+  (sigaction SIGPIPE SIG_IGN)
+
+  (with-server-socket
+    (call-with-prompt 'raise-above
+      (lambda ()
+        (run '()
+             #:todo-steps steps
+             #:done-steps '()))
+      (lambda (k condition)
+        (raise condition)))))
 
 (define (find-step-by-id steps id)
   "Find and return the step in STEPS whose id is equal to ID."
@@ -249,3 +256,7 @@ found in RESULTS."
                       (pretty-print part port)))
                 configuration)
       (flush-output-port port))))
+
+;;; Local Variables:
+;;; eval: (put 'with-server-socket 'scheme-indent-function 0)
+;;; End:
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)