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

This will allow us to automate testing of the installer.

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

1 files changed, 381 insertions, 201 deletions

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)))))