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.
This commit is contained in:
Ludovic Courtès
parent
5ce84b1713
commit
63b8c089c1
@ -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
|
||||
|
||||
@ -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))
|
||||
(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
|
||||
(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)))
|
||||
(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))
|
||||
;; 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 (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 (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
|
||||
(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))
|
||||
(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)))
|
||||
(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)))))))
|
||||
(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))))))
|
||||
|
||||
(when listbox-default-item
|
||||
(set-default-item listbox keys listbox-default-item))
|
||||
;; 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 allow-delete?
|
||||
(form-add-hotkey form KEY-DELETE))
|
||||
(when listbox-default-item
|
||||
(set-default-item listbox keys listbox-default-item))
|
||||
|
||||
(add-form-to-grid grid form #t)
|
||||
(make-wrapped-grid-window grid title)
|
||||
(when allow-delete?
|
||||
(form-add-hotkey form KEY-DELETE))
|
||||
|
||||
(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))))))
|
||||
(add-form-to-grid grid form #t)
|
||||
(make-wrapped-grid-window grid title)
|
||||
|
||||
(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)))))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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))))))
|
||||
|
||||
|
||||
@ -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))))))
|
||||
|
||||
|
||||
@ -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:
|
||||
|
||||
@ -21,7 +21,9 @@
|
||||
#:use-module (guix utils)
|
||||
#:use-module (guix build utils)
|
||||
#:use-module (guix i18n)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (ice-9 regex)
|
||||
#:use-module (ice-9 format)
|
||||
@ -33,7 +35,12 @@
|
||||
run-shell-command
|
||||
|
||||
syslog-port
|
||||
syslog))
|
||||
syslog
|
||||
|
||||
with-server-socket
|
||||
current-server-socket
|
||||
current-clients
|
||||
send-to-clients))
|
||||
|
||||
(define* (read-lines #:optional (port (current-input-port)))
|
||||
"Read lines from PORT and return them as a list."
|
||||
@ -66,7 +73,11 @@ number. If no percentage is found, return #f"
|
||||
COMMAND exited successfully, #f otherwise."
|
||||
(define (pause)
|
||||
(format #t (G_ "Press Enter to continue.~%"))
|
||||
(read-line (current-input-port)))
|
||||
(send-to-clients '(pause))
|
||||
(match (select (cons (current-input-port) (current-clients))
|
||||
'() '())
|
||||
(((port _ ...) _ _)
|
||||
(read-line port))))
|
||||
|
||||
(call-with-temporary-output-file
|
||||
(lambda (file port)
|
||||
@ -134,3 +145,76 @@ COMMAND exited successfully, #f otherwise."
|
||||
(with-syntax ((fmt (string-append "installer[~d]: "
|
||||
(syntax->datum #'fmt))))
|
||||
#'(format (syslog-port) fmt (getpid) args ...))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Client protocol.
|
||||
;;;
|
||||
|
||||
(define %client-socket-file
|
||||
;; Unix-domain socket where the installer accepts connections.
|
||||
"/var/guix/installer-socket")
|
||||
|
||||
(define current-server-socket
|
||||
;; Socket on which the installer is currently accepting connections, or #f.
|
||||
(make-parameter #f))
|
||||
|
||||
(define current-clients
|
||||
;; List of currently connected clients.
|
||||
(make-parameter '()))
|
||||
|
||||
(define* (open-server-socket
|
||||
#:optional (socket-file %client-socket-file))
|
||||
"Open SOCKET-FILE as a Unix-domain socket to accept incoming connections and
|
||||
return it."
|
||||
(mkdir-p (dirname socket-file))
|
||||
(when (file-exists? socket-file)
|
||||
(delete-file socket-file))
|
||||
(let ((sock (socket AF_UNIX SOCK_STREAM 0)))
|
||||
(bind sock AF_UNIX socket-file)
|
||||
(listen sock 0)
|
||||
sock))
|
||||
|
||||
(define (call-with-server-socket thunk)
|
||||
(if (current-server-socket)
|
||||
(thunk)
|
||||
(let ((socket (open-server-socket)))
|
||||
(dynamic-wind
|
||||
(const #t)
|
||||
(lambda ()
|
||||
(parameterize ((current-server-socket socket))
|
||||
(thunk)))
|
||||
(lambda ()
|
||||
(close-port socket))))))
|
||||
|
||||
(define-syntax-rule (with-server-socket exp ...)
|
||||
"Evaluate EXP with 'current-server-socket' parameterized to a currently
|
||||
accepting socket."
|
||||
(call-with-server-socket (lambda () exp ...)))
|
||||
|
||||
(define* (send-to-clients exp)
|
||||
"Send EXP to all the current clients."
|
||||
(define remainder
|
||||
(fold (lambda (client remainder)
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(write exp client)
|
||||
(newline client)
|
||||
(force-output client)
|
||||
(cons client remainder))
|
||||
(lambda args
|
||||
;; We might get EPIPE if the client disconnects; when that
|
||||
;; happens, remove CLIENT from the set of available clients.
|
||||
(let ((errno (system-error-errno args)))
|
||||
(if (memv errno (list EPIPE ECONNRESET ECONNABORTED))
|
||||
(begin
|
||||
(syslog "removing client ~s due to ~s while replying~%"
|
||||
(fileno client) (strerror errno))
|
||||
(false-if-exception (close-port client))
|
||||
remainder)
|
||||
(cons client remainder))))))
|
||||
'()
|
||||
(current-clients)))
|
||||
|
||||
(current-clients (reverse remainder))
|
||||
exp)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user