Merge branch 'master' into core-updates

10 files changed, 1060 insertions, 314 deletions

diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm
index 8c2185e36f..3c170e5d0f 100644
--- a/gnu/installer/final.scm
+++ b/gnu/installer/final.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,6 +28,12 @@
   #:use-module (gnu build accounts)
   #:use-module ((gnu system shadow) #:prefix sys:)
   #:use-module (rnrs io ports)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 rdelim)
   #:export (install-system))
 
 (define %seed
@@ -97,24 +103,92 @@ USERS."
   (write-passwd password (string-append etc "/passwd"))
   (write-shadow shadow (string-append etc "/shadow")))
 
+(define* (kill-cow-users cow-path #:key (spare '("udevd")))
+  "Kill all processes that have references to the given COW-PATH in their
+'maps' file.  The process whose names are in SPARE list are spared."
+  (define %not-nul
+    (char-set-complement (char-set #\nul)))
+
+  (let ((pids
+         (filter-map (lambda (pid)
+                       (call-with-input-file
+                           (string-append "/proc/" pid "/maps")
+                         (lambda (port)
+                           (and (string-contains (get-string-all port)
+                                                 cow-path)
+                                (string->number pid)))))
+                     (scandir "/proc" string->number))))
+    (for-each (lambda (pid)
+                ;; cmdline does not always exist.
+                (false-if-exception
+                 (call-with-input-file
+                     (string-append "/proc/" (number->string pid) "/cmdline")
+                   (lambda (port)
+                     (match (string-tokenize (read-string port) %not-nul)
+                       ((argv0 _ ...)
+                        (unless (member (pk (basename argv0)) spare)
+                          (syslog "Killing process ~a~%" pid)
+                          (kill pid SIGKILL)))
+                       (_ #f))))))
+              pids)))
+
 (define (umount-cow-store)
   "Remove the store overlay and the bind-mount on /tmp created by the
-cow-store service."
-  (let ((tmp-dir "/remove"))
-    (mkdir-p tmp-dir)
-    (mount (%store-directory) tmp-dir "" MS_MOVE)
-    (umount tmp-dir)
-    (umount "/tmp")))
+cow-store service.  This procedure is very fragile and a better approach would
+be much appreciated."
+
+  ;; Remove when integrated in (gnu services herd).
+  (define (restart-service name)
+    (with-shepherd-action name ('restart) result
+      result))
+
+  (catch #t
+    (lambda ()
+      (let ((tmp-dir "/remove"))
+        (mkdir-p tmp-dir)
+        (mount (%store-directory) tmp-dir "" MS_MOVE)
+
+        ;; The guix-daemon has possibly opened files from the cow-store,
+        ;; restart it.
+        (restart-service 'guix-daemon)
+
+        ;; Kill all processes started while the cow-store was active (logins
+        ;; on other TTYs for instance).
+        (kill-cow-users tmp-dir)
+
+        ;; Try to umount the store overlay. Some process such as udevd
+        ;; workers might still be active, so do some retries.
+        (let loop ((try 5))
+          (sleep 1)
+          (let ((umounted? (false-if-exception (umount tmp-dir))))
+            (if (and (not umounted?) (> try 0))
+                (loop (- try 1))
+                (if umounted?
+                    (syslog "Umounted ~a successfully.~%" tmp-dir)
+                    (syslog "Failed to umount ~a.~%" tmp-dir)))))
+
+        (umount "/tmp")))
+    (lambda args
+      (syslog "~a~%" args))))
 
 (define* (install-system locale #:key (users '()))
   "Create /etc/shadow and /etc/passwd on the installation target for USERS.
 Start COW-STORE service on target directory and launch guix install command in
 a subshell.  LOCALE must be the locale name under which that command will run,
 or #f.  Return #t on success and #f on failure."
-  (let ((install-command
-         (format #f "guix system init --fallback ~a ~a"
-                 (%installer-configuration-file)
-                 (%installer-target-dir))))
+  (let* ((options         (catch 'system-error
+                            (lambda ()
+                              ;; If this file exists, it can provide
+                              ;; additional command-line options.
+                              (call-with-input-file
+                                  "/tmp/installer-system-init-options"
+                                read))
+                            (const '())))
+         (install-command (append (list "guix" "system" "init"
+                                        "--fallback")
+                                  options
+                                  (list (%installer-configuration-file)
+                                        (%installer-target-dir)))))
     (mkdir-p (%installer-target-dir))
 
     ;; We want to initialize user passwords but we don't want to store them in
@@ -128,7 +202,7 @@ or #f.  Return #t on success and #f on failure."
       (lambda ()
         (start-service 'cow-store (list (%installer-target-dir))))
       (lambda ()
-        (run-shell-command install-command #:locale locale))
+        (run-command install-command #:locale locale))
       (lambda ()
         (stop-service 'cow-store)
         ;; Remove the store overlay created at cow-store service start.
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/network.scm b/gnu/installer/newt/network.scm
index 40d85817b6..461d5d99c0 100644
--- a/gnu/installer/newt/network.scm
+++ b/gnu/installer/newt/network.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>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -119,6 +119,10 @@ network devices were found. Do you want to continue anyway?"))
 (define (wait-service-online)
   "Display a newt scale until connman detects an Internet access. Do
 FULL-VALUE tentatives, spaced by 1 second."
+  (define (online?)
+    (or (connman-online?)
+        (file-exists? "/tmp/installer-assume-online")))
+
   (let* ((full-value 5))
     (run-scale-page
      #:title (G_ "Checking connectivity")
@@ -127,10 +131,10 @@ FULL-VALUE tentatives, spaced by 1 second."
      #:scale-update-proc
      (lambda (value)
        (sleep 1)
-       (if (connman-online?)
+       (if (online?)
            full-value
            (+ value 1))))
-    (unless (connman-online?)
+    (unless (online?)
       (run-error-page
        (G_ "The selected network does not provide access to the \
 Internet, please try again.")
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index 8aea5a1109..9031c7d4ba 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."
@@ -547,9 +719,8 @@ ITEMS when 'Ok' is pressed."
   (newt-suspend)
   ;; Use Nano because it syntax-highlights Scheme by default.
   ;; TODO: Add a menu to choose an editor?
-  (run-shell-command (string-append "/run/current-system/profile/bin/nano "
-                                    file)
-                     #:locale locale)
+  (run-command (list "/run/current-system/profile/bin/nano" file)
+               #:locale locale)
   (newt-resume))
 
 (define* (run-file-textbox-page #:key
@@ -606,13 +777,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 +795,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/tests.scm b/gnu/installer/tests.scm
new file mode 100644
index 0000000000..6f5393e3ab
--- /dev/null
+++ b/gnu/installer/tests.scm
@@ -0,0 +1,340 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 installer tests)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 pretty-print)
+  #:export (&pattern-not-matched
+            pattern-not-matched?
+
+            %installer-socket-file
+            open-installer-socket
+
+            converse
+            conversation-log-port
+
+            choose-locale+keyboard
+            enter-host-name+passwords
+            choose-services
+            choose-partitioning
+            conclude-installation
+
+            edit-configuration-file))
+
+;;; Commentary:
+;;;
+;;; This module provides tools to test the guided "graphical" installer in a
+;;; non-interactive fashion.  The core of it is 'converse': it allows you to
+;;; state Expect-style dialogues, which happen over the Unix-domain socket the
+;;; installer listens to.  Higher-level procedures such as
+;;; 'choose-locale+keyboard' are provided to perform specific parts of the
+;;; dialogue.
+;;;
+;;; Code:
+
+(define %installer-socket-file
+  ;; Socket the installer listens to.
+  "/var/guix/installer-socket")
+
+(define* (open-installer-socket #:optional (file %installer-socket-file))
+  "Return a socket connected to the installer."
+  (let ((sock (socket AF_UNIX SOCK_STREAM 0)))
+    (connect sock AF_UNIX file)
+    sock))
+
+(define-condition-type &pattern-not-matched &error
+  pattern-not-matched?
+  (pattern pattern-not-matched-pattern)
+  (sexp    pattern-not-matched-sexp))
+
+(define (pattern-error pattern sexp)
+  (raise (condition
+          (&pattern-not-matched
+           (pattern pattern) (sexp sexp)))))
+
+(define conversation-log-port
+  ;; Port where debugging info is logged
+  (make-parameter (current-error-port)))
+
+(define (converse-debug pattern)
+  (format (conversation-log-port)
+          "conversation expecting pattern ~s~%"
+          pattern))
+
+(define-syntax converse
+  (lambda (s)
+    "Convert over PORT: read sexps from there, match them against each
+PATTERN, and send the corresponding REPLY.  Raise to '&pattern-not-matched'
+when one of the PATTERNs is not matched."
+
+    ;; XXX: Strings that appear in PATTERNs must be in the language the
+    ;; installer is running in.  In the future, we should add support to allow
+    ;; writing English strings in PATTERNs and have the pattern matcher
+    ;; automatically translate them.
+
+    ;; Here we emulate 'pmatch' syntax on top of 'match'.  This is ridiculous
+    ;; but that's because 'pmatch' compares objects with 'eq?', making it
+    ;; pretty useless, and it doesn't support ellipses and such.
+
+    (define (quote-pattern s)
+      ;; Rewrite the pattern S from pmatch style (a ,b) to match style like
+      ;; ('a b).
+      (with-ellipsis :::
+        (syntax-case s (unquote _ ...)
+          ((unquote id) #'id)
+          (_ #'_)
+          (... #'...)
+          (id
+           (identifier? #'id)
+           #''id)
+          ((lst :::) (map quote-pattern #'(lst :::)))
+          (pattern #'pattern))))
+
+    (define (match-pattern s)
+      ;; Match one pattern without a guard.
+      (syntax-case s ()
+        ((port (pattern reply) continuation)
+         (with-syntax ((pattern (quote-pattern #'pattern)))
+           #'(let ((pat 'pattern))
+               (converse-debug pat)
+               (match (read port)
+                 (pattern
+                  (let ((data (call-with-values (lambda () reply)
+                                list)))
+                    (for-each (lambda (obj)
+                                (write obj port)
+                                (newline port))
+                              data)
+                    (force-output port)
+                    (continuation port)))
+                 (sexp
+                  (pattern-error pat sexp))))))))
+
+    (syntax-case s ()
+      ((_ port (pattern reply) rest ...)
+       (match-pattern #'(port (pattern reply)
+                              (lambda (port)
+                                (converse port rest ...)))))
+      ((_ port (pattern guard reply) rest ...)
+       #`(let ((skip? (not guard))
+               (next  (lambda (p)
+                        (converse p rest ...))))
+           (if skip?
+               (next port)
+               #,(match-pattern #'(port (pattern reply) next)))))
+      ((_ port)
+       #t))))
+
+(define* (choose-locale+keyboard port
+                                 #:key
+                                 (language "English")
+                                 (location "Hong Kong")
+                                 (timezone '("Europe" "Zagreb"))
+                                 (keyboard
+                                  '("English (US)"
+                                    "English (intl., with AltGr dead keys)")))
+  "Converse over PORT with the guided installer to choose the specified
+LANGUAGE, LOCATION, TIMEZONE, and KEYBOARD."
+  (converse port
+    ((list-selection (title "Locale language")
+                     (multiple-choices? #f)
+                     (items _))
+     language)
+    ((list-selection (title "Locale location")
+                     (multiple-choices? #f)
+                     (items _))
+     location)
+    ((menu (title "GNU Guix install")
+           (text _)
+           (items (,guided _ ...)))           ;"Guided graphical installation"
+     guided)
+    ((list-selection (title "Timezone")
+                     (multiple-choices? #f)
+                     (items _))
+     (first timezone))
+    ((list-selection (title "Timezone")
+                     (multiple-choices? #f)
+                     (items _))
+     (second timezone))
+    ((list-selection (title "Layout")
+                     (multiple-choices? #f)
+                     (items _))
+     (first keyboard))
+    ((list-selection (title "Variant")
+                     (multiple-choices? #f)
+                     (items _))
+     (second keyboard))))
+
+(define* (enter-host-name+passwords port
+                                    #:key
+                                    (host-name "guix")
+                                    (root-password "foo")
+                                    (users '(("alice" "pass1")
+                                             ("bob" "pass2")
+                                             ("charlie" "pass3"))))
+  "Converse over PORT with the guided installer to choose HOST-NAME,
+ROOT-PASSWORD, and USERS."
+  (converse port
+    ((input (title "Hostname") (text _) (default _))
+     host-name)
+    ((input (title "System administrator password") (text _) (default _))
+     root-password)
+    ((input (title "Password confirmation required") (text _) (default _))
+     root-password)
+    ((add-users)
+     (match users
+       (((names passwords) ...)
+        (map (lambda (name password)
+               `(user (name ,name) (real-name ,(string-titlecase name))
+                      (home-directory ,(string-append "/home/" name))
+                      (password ,password)))
+             names passwords))))))
+
+(define* (choose-services port
+                          #:key
+                          (desktop-environments '("GNOME"))
+                          (choose-network-service?
+                           (lambda (service)
+                             (or (string-contains service "SSH")
+                                 (string-contains service "NSS"))))
+                          (choose-network-management-tool?
+                           (lambda (service)
+                             (string-contains service "DHCP"))))
+  "Converse over PORT to choose networking services."
+  (converse port
+    ((checkbox-list (title "Desktop environment") (text _)
+                    (items _))
+     desktop-environments)
+    ((checkbox-list (title "Network service") (text _)
+                    (items ,services))
+     (filter choose-network-service? services))
+
+    ;; The "Network management" dialog shows up only when no desktop
+    ;; environments have been selected, hence the guard.
+    ((list-selection (title "Network management")
+                     (multiple-choices? #f)
+                     (items ,services))
+     (null? desktop-environments)
+     (find choose-network-management-tool? services))))
+
+(define (edit-configuration-file file)
+  "Edit FILE, an operating system configuration file generated by the
+installer, by adding a marionette service such that the installed OS is
+instrumented for further testing."
+  (define (read-expressions port)
+    (let loop ((result '()))
+      (match (read port)
+        ((? eof-object?)
+         (reverse result))
+        (exp
+         (loop (cons exp result))))))
+
+  (define (edit exp)
+    (match exp
+      (('operating-system _ ...)
+       `(marionette-operating-system ,exp
+                                     #:imported-modules
+                                     '((gnu services herd)
+                                       (guix build utils)
+                                       (guix combinators))))
+      (_
+       exp)))
+
+  (let ((content (call-with-input-file file read-expressions)))
+    (call-with-output-file file
+      (lambda (port)
+        (format port "\
+;; Operating system configuration edited for automated testing.~%~%")
+
+        (pretty-print '(use-modules (gnu tests)) port)
+        (for-each (lambda (exp)
+                    (pretty-print (edit exp) port)
+                    (newline port))
+                  content)))
+
+    #t))
+
+(define* (choose-partitioning port
+                              #:key
+                              (encrypted? #t)
+                              (passphrase "thepassphrase")
+                              (edit-configuration-file
+                               edit-configuration-file))
+  "Converse over PORT to choose the partitioning method.  When ENCRYPTED? is
+true, choose full-disk encryption with PASSPHRASE as the LUKS passphrase.
+This conversation goes past the final dialog box that shows the configuration
+file, actually starting the installation process."
+  (converse port
+    ((list-selection (title "Partitioning method")
+                     (multiple-choices? #f)
+                     (items (,not-encrypted ,encrypted _ ...)))
+     (if encrypted?
+         encrypted
+         not-encrypted))
+    ((list-selection (title "Disk") (multiple-choices? #f)
+                     (items (,disk _ ...)))
+     disk)
+
+    ;; The "Partition table" dialog pops up only if there's not already a
+    ;; partition table.
+    ((list-selection (title "Partition table")
+                     (multiple-choices? #f)
+                     (items _))
+     "gpt")
+    ((list-selection (title "Partition scheme")
+                     (multiple-choices? #f)
+                     (items (,one-partition _ ...)))
+     one-partition)
+    ((list-selection (title "Guided partitioning")
+                     (multiple-choices? #f)
+                     (items (,disk _ ...)))
+     disk)
+    ((input (title "Password required")
+            (text _) (default #f))
+     encrypted?                                   ;only when ENCRYPTED?
+     passphrase)
+    ((input (title "Password confirmation required")
+            (text _) (default #f))
+     encrypted?
+     passphrase)
+    ((confirmation (title "Format disk?") (text _))
+     #t)
+    ((info (title "Preparing partitions") _ ...)
+     (values))                                    ;nothing to return
+    ((file-dialog (title "Configuration file")
+                  (text _)
+                  (file ,configuration-file))
+     (edit-configuration-file configuration-file))))
+
+(define (conclude-installation port)
+  "Conclude the installation by checking over PORT that we get the final
+messages once the 'guix system init' process has completed."
+  (converse port
+    ((pause)                                      ;"Press Enter to continue."
+     #t)
+    ((installation-complete)                      ;congratulations!
+     (values))))
+
+;;; Local Variables:
+;;; eval: (put 'converse 'scheme-indent-function 1)
+;;; eval: (put 'with-ellipsis 'scheme-indent-function 1)
+;;; End:
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 842bd02ced..0a91ae1e4a 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)
@@ -30,10 +32,15 @@
             read-all
             nearest-exact-integer
             read-percentage
-            run-shell-command
+            run-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."
@@ -61,44 +68,48 @@ number. If no percentage is found, return #f"
     (and result
          (string->number (match:substring result 1)))))
 
-(define* (run-shell-command command #:key locale)
-  "Run COMMAND, a string, with Bash, and in the given LOCALE.  Return true if
+(define* (run-command command #:key locale)
+  "Run COMMAND, a list of strings, in the given LOCALE.  Return true if
 COMMAND exited successfully, #f otherwise."
+  (define env (environ))
+
   (define (pause)
     (format #t (G_ "Press Enter to continue.~%"))
-    (read-line (current-input-port)))
-
-  (call-with-temporary-output-file
-   (lambda (file port)
-     (when locale
-       (let ((supported? (false-if-exception
-                          (setlocale LC_ALL locale))))
-         ;; If LOCALE is not supported, then set LANGUAGE, which might at
-         ;; least give us translated messages.
-         (if supported?
-             (format port "export LC_ALL=\"~a\"~%" locale)
-             (format port "export LANGUAGE=\"~a\"~%"
-                     (string-take locale
-                                  (string-index locale #\_))))))
-
-     (format port "exec ~a~%" command)
-     (close port)
-
-     (guard (c ((invoke-error? c)
-                (newline)
-                (format (current-error-port)
-                        (G_ "Command failed with exit code ~a.~%")
-                        (invoke-error-exit-status c))
-                (syslog "command ~s failed with exit code ~a"
-                        command (invoke-error-exit-status c))
-                (pause)
-                #f))
-       (syslog "running command ~s~%" command)
-       (invoke "bash" "--init-file" file)
-       (syslog "command ~s succeeded~%" command)
-       (newline)
-       (pause)
-       #t))))
+    (send-to-clients '(pause))
+    (environ env)                               ;restore environment variables
+    (match (select (cons (current-input-port) (current-clients))
+             '() '())
+      (((port _ ...) _ _)
+       (read-line port))))
+
+  (setenv "PATH" "/run/current-system/profile/bin")
+
+  (when locale
+    (let ((supported? (false-if-exception
+                       (setlocale LC_ALL locale))))
+      ;; If LOCALE is not supported, then set LANGUAGE, which might at
+      ;; least give us translated messages.
+      (if supported?
+          (setenv "LC_ALL" locale)
+          (setenv "LANGUAGE"
+                  (string-take locale
+                               (string-index locale #\_))))))
+
+  (guard (c ((invoke-error? c)
+             (newline)
+             (format (current-error-port)
+                     (G_ "Command failed with exit code ~a.~%")
+                     (invoke-error-exit-status c))
+             (syslog "command ~s failed with exit code ~a"
+                     command (invoke-error-exit-status c))
+             (pause)
+             #f))
+    (syslog "running command ~s~%" command)
+    (apply invoke command)
+    (syslog "command ~s succeeded~%" command)
+    (newline)
+    (pause)
+    #t))
 
 
 ;;;
@@ -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)