guix-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

06/10: DRAFT installer: Better support for multiple clients.


From: guix-commits
Subject: 06/10: DRAFT installer: Better support for multiple clients.
Date: Wed, 19 Feb 2020 17:48:48 -0500 (EST)

civodul pushed a commit to branch wip-installer-test
in repository guix.

commit 6beee464c517c50eb9b01b6031129e8e04afb320
Author: Ludovic Court├Ęs <address@hidden>
AuthorDate: Tue Feb 18 18:20:19 2020 +0100

    DRAFT installer: Better support for multiple clients.
    
    Previously we'd incorrectly deal with client disconnects, multiple
    clients, connections while a form is running, etc.
    
    DRAFT: Needs more testing + ChangeLog.
---
 gnu/installer/newt/final.scm   |  40 +++--
 gnu/installer/newt/page.scm    | 335 +++++++++++++++++++++++------------------
 gnu/installer/newt/user.scm    |  27 ++--
 gnu/installer/newt/welcome.scm |  53 +++----
 gnu/installer/steps.scm        |   4 +
 gnu/installer/utils.scm        |  32 +++-
 6 files changed, 279 insertions(+), 212 deletions(-)

diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm
index 405eee2..5cb4f68 100644
--- a/gnu/installer/newt/final.scm
+++ b/gnu/installer/newt/final.scm
@@ -63,28 +63,38 @@ This will take a few minutes.")
          (&installer-step-abort)))))))
 
 (define (run-install-success-page)
-  (message-window
-   (G_ "Installation complete")
-   (G_ "Reboot")
-   (G_ "Congratulations!  Installation is now complete.  \
+  (match (current-clients)
+    (()
+     (message-window
+      (G_ "Installation complete")
+      (G_ "Reboot")
+      (G_ "Congratulations!  Installation is now complete.  \
 You may remove the device containing the installation image and \
-press the button to reboot."))
+press the button to reboot.")))
+    (_
+     ;; When there are clients connected, send them a message and keep going.
+     (send-to-clients '(installation-complete))))
 
   ;; Return success so that the installer happily reboots.
   'success)
 
 (define (run-install-failed-page)
-  (match (choice-window
-          (G_ "Installation failed")
-          (G_ "Resume")
-          (G_ "Restart the installer")
-          (G_ "The final system installation step failed.  You can resume from 
\
+  (match (current-clients)
+    (()
+     (match (choice-window
+             (G_ "Installation failed")
+             (G_ "Resume")
+             (G_ "Restart the installer")
+             (G_ "The final system installation step failed.  You can resume 
from \
 a specific step, or restart the installer."))
-    (1 (raise
-        (condition
-         (&installer-step-abort))))
-    (2
-     ;; Keep going, the installer will be restarted later on.
+       (1 (raise
+           (condition
+            (&installer-step-abort))))
+       (2
+        ;; Keep going, the installer will be restarted later on.
+        #t)))
+    (_
+     (send-to-clients '(installation-failure))
      #t)))
 
 (define* (run-install-shell locale
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index ac43763..c01124a 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -27,6 +27,7 @@
   #: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)
@@ -41,8 +42,7 @@
             run-checkbox-tree-page
             run-file-textbox-page
 
-            watch-clients!
-            with-client))
+            run-form-with-clients))
 
 ;;; Commentary:
 ;;;
@@ -55,7 +55,7 @@
 ;;;
 ;;; Code:
 
-(define (watch-clients! form)
+(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)
@@ -65,31 +65,108 @@ connections.  Consequently, FORM may exit with the 
'exit-fd-ready' reason."
   (for-each (lambda (client)
               (form-watch-fd form (fileno client)
                              (logior FD-READ FD-EXCEPT)))
-            (current-clients)))
-
-(define (call-with-client fd proc fallback)
-  (match (fdes->ports fd)
-    ((port _ ...)
-     (if (memq port (current-clients))
-         (if (catch 'system-error
-               (lambda ()
-                 (eof-object? (peek-char port)))
-               (const #t))                        ;ECONNRESET, etc.
-             (begin
-               (close-port port)
-               (current-clients (delq port (current-clients)))
-               (fallback))
-             (proc port))
-         (match (accept port)
-           ((client . _)
-            (current-clients (cons client (current-clients)))
-            (fallback)))))))
-
-(define-syntax-rule (with-client fd port exp fallback)
-  "Evaluate EXP with PORT bound to the client connection corresponding to FD.
-Alternately, if FD is not available for reading (e.g., because the client
-disconnected), evaluate FALLBACK."
-  (call-with-client fd (lambda (port) exp) (lambda () fallback)))
+            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
@@ -152,11 +229,6 @@ input box, such as FLAG-PASSWORD."
                 GRID-ELEMENT-COMPONENT ok-button))
          (form (make-form #:flags FLAG-NOF12)))
 
-    (watch-clients! form)
-    (send-to-clients
-     `(input (title ,title) (text ,text)
-             (default ,default-text)))
-
     (add-component-callback
      input-visible-cb
      (lambda (component)
@@ -174,11 +246,11 @@ input box, such as FLAG-PASSWORD."
                                         (G_ "Empty input")))))
       (let loop ()
         (receive (exit-reason argument)
-            (run-form form)
+            (run-form-with-clients form
+                                   `(input (title ,title) (text ,text)
+                                           (default ,default-text)))
           (let ((input (if (eq? exit-reason 'exit-fd-ready)
-                           (with-client argument port
-                             (read port)
-                             #f)
+                           argument
                            (entry-value input-entry))))
             (cond ((not input)                 ;client disconnect or something
                    (loop))
@@ -213,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)))
@@ -239,12 +312,10 @@ of the page is set to TITLE."
     (add-form-to-grid grid form #t)
     (make-wrapped-grid-window grid title)
 
-    (watch-clients! form)
-    (send-to-clients
-     `(confirmation (title ,title) (text ,text)))
-
     (receive (exit-reason argument)
-        (run-form form)
+        (run-form-with-clients form
+                               `(confirmation (title ,title)
+                                              (text ,text)))
       (dynamic-wind
         (const #t)
         (lambda ()
@@ -256,11 +327,9 @@ of the page is set to TITLE."
               ((components=? argument exit-button)
                (exit-button-procedure))))
             ('exit-fd-ready
-             (with-client argument port
-               (if (read port)
-                   #t
-                   (exit-button-procedure))
-               #f))))                             ;FIXME: retry
+             (if argument
+                 #t
+                 (exit-button-procedure)))))
         (lambda ()
           (destroy-form-and-pop form))))))
 
@@ -412,8 +481,6 @@ the current listbox item has to be selected by key."
           ((key . item) item)
           (#f (raise (condition (&installer-step-abort))))))
 
-      (watch-clients! form)
-
       ;; 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.
@@ -449,56 +516,47 @@ the current listbox item has to be selected by key."
       (add-form-to-grid grid form #t)
       (make-wrapped-grid-window grid title)
 
-      (send-to-clients
-       `(list-selection (title ,title)
-                        (multiple-choices? ,listbox-allow-multiple?)
-                        (items ,(map listbox-item->text listbox-items))))
-
       (receive (exit-reason argument)
-          (run-form form)
-        (define &retry
-          (list 'retry))
-
-        (define result
-          (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
-                 (with-client argument port
-                   (let* ((choice (read port))
-                          (item   (if listbox-allow-multiple?
-                                      (map choice->item choice)
-                                      (choice->item choice))))
-                     (client-callback-procedure item))
-                   &retry))
-                ('exit-hotkey
-                 (let* ((entry (current-listbox-entry listbox))
-                        (item (assoc-ref keys entry)))
-                   (hotkey-callback-procedure argument item)))))
-            (lambda ()
-              (destroy-form-and-pop form))))
-
-        (if (eq? &retry result)
-            (loop)
-            result)))))
+          (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
@@ -628,42 +686,32 @@ ITEMS when 'Ok' is pressed."
       (add-form-to-grid grid form #t)
       (make-wrapped-grid-window grid title)
 
-      (watch-clients! form)
-      (send-to-clients
-       `(checkbox-list (title ,title) (text ,info-text)
-                       (items ,(map item->text items))))
-
       (receive (exit-reason argument)
-          (run-form form)
-        (define &retry
-          (list 'retry))
-
-        (define result
-          (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
-                 (with-client argument port
-                   (map choice->item (read port))
-                   &retry))))
-            (lambda ()
-              (destroy-form-and-pop form))))
-
-        (if (eq? result &retry)
-            (loop)
-            result)))))
+          (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."
@@ -719,12 +767,6 @@ ITEMS when 'Ok' is pressed."
                            '())))))
            (form (make-form #:flags FLAG-NOF12)))
 
-      (watch-clients! form)
-      (send-to-clients
-       `(file-dialog (title ,title)
-                     (text ,info-text)
-                     (file ,file)))
-
       (add-form-to-grid grid form #t)
       (make-wrapped-grid-window grid title)
 
@@ -736,7 +778,10 @@ 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)
@@ -753,11 +798,9 @@ ITEMS when 'Ok' is pressed."
                         (components=? argument edit-button))
                    (edit-file file))))
                 ('exit-fd-ready
-                 (with-client argument port
-                   (if (read port)
-                       (ok-button-callback-procedure)
-                       (exit-button-callback-procedure))
-                   #f))))                         ;FIXME: retry
+                 (if argument
+                     (ok-button-callback-procedure)
+                     (exit-button-callback-procedure)))))
             (lambda ()
               (destroy-form-and-pop form))))
 
diff --git a/gnu/installer/newt/user.scm b/gnu/installer/newt/user.scm
index ae54268..ad711d6 100644
--- a/gnu/installer/newt/user.scm
+++ b/gnu/installer/newt/user.scm
@@ -231,11 +231,8 @@ administrator (\"root\").")
           (set-current-component form add-button)
           (set-current-component form ok-button))
 
-      (watch-clients! form)
-      (send-to-clients `(add-users))
-
       (receive (exit-reason argument)
-          (run-form form)
+          (run-form-with-clients form '(add-users))
         (dynamic-wind
           (const #t)
           (lambda ()
@@ -265,19 +262,15 @@ administrator (\"root\").")
                    (&installer-step-abort))))))
               ('exit-fd-ready
                ;; Read the complete user list at once.
-               (with-client argument port
-                 (match (read port)
-                   ((('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)))
-                 (raise
-                  (condition
-                   (&installer-step-abort)))))))
+               (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 3fac57d..1b4b2df 100644
--- a/gnu/installer/newt/welcome.scm
+++ b/gnu/installer/newt/welcome.scm
@@ -85,34 +85,31 @@ we want this page to occupy all the screen space available."
     (add-form-to-grid grid form #t)
     (make-wrapped-grid-window grid title)
 
-    (watch-clients! form)
-    (send-to-clients
-     `(menu (title ,title) (text ,info-text)
-            (items ,(map listbox-item->text listbox-items))))
-
-    (let loop ()
-      (receive (exit-reason argument)
-          (run-form form)
-        (dynamic-wind
-          (const #t)
-          (lambda ()
-            (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
-               (with-client argument port
-                 (let* ((choice (read port))
-                        (item   (choice->item choice)))
-                   (match item
-                     ((text . proc)
-                      (proc))))
-                 (loop)))))
-          (lambda ()
-            (destroy-form-and-pop form)))))))
+    (receive (exit-reason argument)
+        (run-form-with-clients form
+                               `(menu (title ,title)
+                                      (text ,info-text)
+                                      (items
+                                       ,(map listbox-item->text
+                                             listbox-items))))
+      (dynamic-wind
+        (const #t)
+        (lambda ()
+          (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))))))
 
 (define (run-welcome-page logo)
   "Run a welcome page with the given textual LOGO displayed at the center of
diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm
index 34cf7df..0b6d8e4 100644
--- a/gnu/installer/steps.scm
+++ b/gnu/installer/steps.scm
@@ -187,6 +187,10 @@ return the accumalated result so far."
                 #:todo-steps rest-steps
                 #:done-steps (append done-steps (list step))))))))
 
+  ;; 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 ()
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 5f9d052..4dc2637 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -21,6 +21,7 @@
   #: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)
@@ -191,10 +192,29 @@ return it."
 accepting socket."
   (call-with-server-socket (lambda () exp ...)))
 
-(define (send-to-clients exp)
+(define* (send-to-clients exp)
   "Send EXP to all the current clients."
-  (for-each (lambda (client)
-              (write exp client)
-              (newline client)
-              (force-output client))
-            (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)



reply via email to

[Prev in Thread] Current Thread [Next in Thread]