[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)
- branch wip-installer-test created (now 299ae5b), guix-commits, 2020/02/19
- 01/10: marionette: 'wait-for' procedures no longer leak a port., guix-commits, 2020/02/19
- 02/10: installer: Add 'syslog' macro to write to syslog., guix-commits, 2020/02/19
- 04/10: DRAFT installer: Use a Guile-Newt snapshot that supports 'form-watch-fd'., guix-commits, 2020/02/19
- 07/10: installer: Bypass connectivity check when /tmp/installer-assume-online exists., guix-commits, 2020/02/19
- 05/10: DRAFT installer: Implement a dialog on /var/guix/installer-socket., guix-commits, 2020/02/19
- 09/10: installer: Honor /tmp/installer-system-init-options., guix-commits, 2020/02/19
- 06/10: DRAFT installer: Better support for multiple clients.,
guix-commits <=
- 10/10: DRAFT tests: install: Add "gui-installed-os"., guix-commits, 2020/02/19
- 08/10: installer: Run commands without hopping through the shell., guix-commits, 2020/02/19
- 03/10: installer: Log important bits to syslog., guix-commits, 2020/02/19