mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
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:
parent
5ce84b1713
commit
63b8c089c1
7 changed files with 581 additions and 252 deletions
|
@ -63,28 +63,38 @@ (define* (run-config-display-page #:key locale)
|
||||||
(&installer-step-abort)))))))
|
(&installer-step-abort)))))))
|
||||||
|
|
||||||
(define (run-install-success-page)
|
(define (run-install-success-page)
|
||||||
(message-window
|
(match (current-clients)
|
||||||
(G_ "Installation complete")
|
(()
|
||||||
(G_ "Reboot")
|
(message-window
|
||||||
(G_ "Congratulations! Installation is now complete. \
|
(G_ "Installation complete")
|
||||||
|
(G_ "Reboot")
|
||||||
|
(G_ "Congratulations! Installation is now complete. \
|
||||||
You may remove the device containing the installation image and \
|
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.
|
;; Return success so that the installer happily reboots.
|
||||||
'success)
|
'success)
|
||||||
|
|
||||||
(define (run-install-failed-page)
|
(define (run-install-failed-page)
|
||||||
(match (choice-window
|
(match (current-clients)
|
||||||
(G_ "Installation failed")
|
(()
|
||||||
(G_ "Resume")
|
(match (choice-window
|
||||||
(G_ "Restart the installer")
|
(G_ "Installation failed")
|
||||||
(G_ "The final system installation step failed. You can resume from \
|
(G_ "Resume")
|
||||||
|
(G_ "Restart the installer")
|
||||||
|
(G_ "The final system installation step failed. You can resume from \
|
||||||
a specific step, or restart the installer."))
|
a specific step, or restart the installer."))
|
||||||
(1 (raise
|
(1 (raise
|
||||||
(condition
|
(condition
|
||||||
(&installer-step-abort))))
|
(&installer-step-abort))))
|
||||||
(2
|
(2
|
||||||
;; Keep going, the installer will be restarted later on.
|
;; Keep going, the installer will be restarted later on.
|
||||||
|
#t)))
|
||||||
|
(_
|
||||||
|
(send-to-clients '(installation-failure))
|
||||||
#t)))
|
#t)))
|
||||||
|
|
||||||
(define* (run-install-shell locale
|
(define* (run-install-shell locale
|
||||||
|
|
|
@ -19,6 +19,7 @@
|
||||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
(define-module (gnu installer newt page)
|
(define-module (gnu installer newt page)
|
||||||
|
#:use-module (gnu installer steps)
|
||||||
#:use-module (gnu installer utils)
|
#:use-module (gnu installer utils)
|
||||||
#:use-module (gnu installer newt utils)
|
#:use-module (gnu installer newt utils)
|
||||||
#:use-module (guix i18n)
|
#:use-module (guix i18n)
|
||||||
|
@ -26,7 +27,10 @@ (define-module (gnu installer newt page)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:use-module (ice-9 receive)
|
#:use-module (ice-9 receive)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
|
#:use-module (srfi srfi-11)
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
|
#:use-module (srfi srfi-34)
|
||||||
|
#:use-module (srfi srfi-35)
|
||||||
#:use-module (newt)
|
#:use-module (newt)
|
||||||
#:export (draw-info-page
|
#:export (draw-info-page
|
||||||
draw-connecting-page
|
draw-connecting-page
|
||||||
|
@ -36,7 +40,9 @@ (define-module (gnu installer newt page)
|
||||||
run-listbox-selection-page
|
run-listbox-selection-page
|
||||||
run-scale-page
|
run-scale-page
|
||||||
run-checkbox-tree-page
|
run-checkbox-tree-page
|
||||||
run-file-textbox-page))
|
run-file-textbox-page
|
||||||
|
|
||||||
|
run-form-with-clients))
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
;;;
|
;;;
|
||||||
|
@ -49,9 +55,123 @@ (define-module (gnu installer newt page)
|
||||||
;;;
|
;;;
|
||||||
;;; Code:
|
;;; 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)
|
(define (draw-info-page text title)
|
||||||
"Draw an informative page with the given TEXT as content. Set the title of
|
"Draw an informative page with the given TEXT as content. Set the title of
|
||||||
this page to TITLE."
|
this page to TITLE."
|
||||||
|
(send-to-clients `(info (title ,title) (text ,text)))
|
||||||
(let* ((text-box
|
(let* ((text-box
|
||||||
(make-reflowed-textbox -1 -1 text 40
|
(make-reflowed-textbox -1 -1 text 40
|
||||||
#:flags FLAG-BORDER))
|
#:flags FLAG-BORDER))
|
||||||
|
@ -126,20 +246,25 @@ (define* (run-input-page text title
|
||||||
(G_ "Empty input")))))
|
(G_ "Empty input")))))
|
||||||
(let loop ()
|
(let loop ()
|
||||||
(receive (exit-reason argument)
|
(receive (exit-reason argument)
|
||||||
(run-form form)
|
(run-form-with-clients form
|
||||||
(let ((input (entry-value input-entry)))
|
`(input (title ,title) (text ,text)
|
||||||
(if (and (not allow-empty-input?)
|
(default ,default-text)))
|
||||||
(eq? exit-reason 'exit-component)
|
(let ((input (if (eq? exit-reason 'exit-fd-ready)
|
||||||
(string=? input ""))
|
argument
|
||||||
(begin
|
(entry-value input-entry))))
|
||||||
;; Display the error page.
|
(cond ((not input) ;client disconnect or something
|
||||||
(error-page)
|
(loop))
|
||||||
;; Set the focus back to the input input field.
|
((and (not allow-empty-input?)
|
||||||
(set-current-component form input-entry)
|
(eq? exit-reason 'exit-component)
|
||||||
(loop))
|
(string=? input ""))
|
||||||
(begin
|
;; Display the error page.
|
||||||
(destroy-form-and-pop form)
|
(error-page)
|
||||||
input))))))))
|
;; 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)
|
(define (run-error-page text title)
|
||||||
"Run a page to inform the user of an error. The page contains the given TEXT
|
"Run a page to inform the user of an error. The page contains the given TEXT
|
||||||
|
@ -160,7 +285,8 @@ (define (run-error-page text title)
|
||||||
(newt-set-color COLORSET-ROOT "white" "red")
|
(newt-set-color COLORSET-ROOT "white" "red")
|
||||||
(add-components-to-form form text-box ok-button)
|
(add-components-to-form form text-box ok-button)
|
||||||
(make-wrapped-grid-window grid title)
|
(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.
|
;; Restore the background to its original color.
|
||||||
(newt-set-color COLORSET-ROOT "white" "blue")
|
(newt-set-color COLORSET-ROOT "white" "blue")
|
||||||
(destroy-form-and-pop form)))
|
(destroy-form-and-pop form)))
|
||||||
|
@ -187,17 +313,23 @@ (define* (run-confirmation-page text title
|
||||||
(make-wrapped-grid-window grid title)
|
(make-wrapped-grid-window grid title)
|
||||||
|
|
||||||
(receive (exit-reason argument)
|
(receive (exit-reason argument)
|
||||||
(run-form form)
|
(run-form-with-clients form
|
||||||
|
`(confirmation (title ,title)
|
||||||
|
(text ,text)))
|
||||||
(dynamic-wind
|
(dynamic-wind
|
||||||
(const #t)
|
(const #t)
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(case exit-reason
|
(match exit-reason
|
||||||
((exit-component)
|
('exit-component
|
||||||
(cond
|
(cond
|
||||||
((components=? argument ok-button)
|
((components=? argument ok-button)
|
||||||
#t)
|
#t)
|
||||||
((components=? argument exit-button)
|
((components=? argument exit-button)
|
||||||
(exit-button-procedure))))))
|
(exit-button-procedure))))
|
||||||
|
('exit-fd-ready
|
||||||
|
(if argument
|
||||||
|
#t
|
||||||
|
(exit-button-procedure)))))
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(destroy-form-and-pop form))))))
|
(destroy-form-and-pop form))))))
|
||||||
|
|
||||||
|
@ -222,6 +354,8 @@ (define* (run-listbox-selection-page #:key
|
||||||
(const #t))
|
(const #t))
|
||||||
(listbox-callback-procedure
|
(listbox-callback-procedure
|
||||||
identity)
|
identity)
|
||||||
|
(client-callback-procedure
|
||||||
|
listbox-callback-procedure)
|
||||||
(hotkey-callback-procedure
|
(hotkey-callback-procedure
|
||||||
(const #t)))
|
(const #t)))
|
||||||
"Run a page asking the user to select an item in a listbox. The page
|
"Run a page asking the user to select an item in a listbox. The page
|
||||||
|
@ -254,9 +388,9 @@ (define* (run-listbox-selection-page #:key
|
||||||
current listbox item as argument. If it returns #t, skip the element and jump
|
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
|
to the next/previous one depending on the previous item, otherwise do
|
||||||
nothing."
|
nothing."
|
||||||
|
(let loop ()
|
||||||
(define (fill-listbox listbox items)
|
(define (fill-listbox listbox items)
|
||||||
"Append the given ITEMS to LISTBOX, once they have been converted to text
|
"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
|
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:
|
newt. Save this key by returning an association list under the form:
|
||||||
|
|
||||||
|
@ -264,144 +398,165 @@ (define (fill-listbox listbox items)
|
||||||
|
|
||||||
where NEWT-LISTBOX-KEY is the key returned by APPEND-ENTRY-TO-LISTBOX, when
|
where NEWT-LISTBOX-KEY is the key returned by APPEND-ENTRY-TO-LISTBOX, when
|
||||||
ITEM was inserted into LISTBOX."
|
ITEM was inserted into LISTBOX."
|
||||||
(map (lambda (item)
|
(map (lambda (item)
|
||||||
(let* ((text (listbox-item->text item))
|
(let* ((text (listbox-item->text item))
|
||||||
(key (append-entry-to-listbox listbox text)))
|
(key (append-entry-to-listbox listbox text)))
|
||||||
(cons key item)))
|
(cons key item)))
|
||||||
items))
|
items))
|
||||||
|
|
||||||
(define (sort-listbox-items listbox-items)
|
(define (sort-listbox-items listbox-items)
|
||||||
"Return LISTBOX-ITEMS sorted using the 'string-locale<?' procedure on the text
|
"Return LISTBOX-ITEMS sorted using the 'string-locale<?' procedure on the text
|
||||||
corresponding to each item in the list."
|
corresponding to each item in the list."
|
||||||
(let* ((items (map (lambda (item)
|
(let* ((items (map (lambda (item)
|
||||||
(cons item (listbox-item->text item)))
|
(cons item (listbox-item->text item)))
|
||||||
listbox-items))
|
listbox-items))
|
||||||
(sorted-items
|
(sorted-items
|
||||||
(sort items (lambda (a b)
|
(sort items (lambda (a b)
|
||||||
(let ((text-a (cdr a))
|
(let ((text-a (cdr a))
|
||||||
(text-b (cdr b)))
|
(text-b (cdr b)))
|
||||||
(string-locale<? text-a text-b))))))
|
(string-locale<? text-a text-b))))))
|
||||||
(map car sorted-items)))
|
(map car sorted-items)))
|
||||||
|
|
||||||
;; Store the last selected listbox item's key.
|
;; Store the last selected listbox item's key.
|
||||||
(define last-listbox-key (make-parameter #f))
|
(define last-listbox-key (make-parameter #f))
|
||||||
|
|
||||||
(define (previous-key keys key)
|
(define (previous-key keys key)
|
||||||
(let ((index (list-index (cut eq? key <>) keys)))
|
(let ((index (list-index (cut eq? key <>) keys)))
|
||||||
(and index
|
(and index
|
||||||
(> index 0)
|
(> index 0)
|
||||||
(list-ref keys (- index 1)))))
|
(list-ref keys (- index 1)))))
|
||||||
|
|
||||||
(define (next-key keys key)
|
(define (next-key keys key)
|
||||||
(let ((index (list-index (cut eq? key <>) keys)))
|
(let ((index (list-index (cut eq? key <>) keys)))
|
||||||
(and index
|
(and index
|
||||||
(< index (- (length keys) 1))
|
(< index (- (length keys) 1))
|
||||||
(list-ref keys (+ index 1)))))
|
(list-ref keys (+ index 1)))))
|
||||||
|
|
||||||
(define (set-default-item listbox listbox-keys default-item)
|
(define (set-default-item listbox listbox-keys default-item)
|
||||||
"Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the
|
"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
|
association list returned by the FILL-LISTBOX procedure. It is used because
|
||||||
the current listbox item has to be selected by key."
|
the current listbox item has to be selected by key."
|
||||||
(for-each (match-lambda
|
(for-each (match-lambda
|
||||||
((key . item)
|
((key . item)
|
||||||
(when (equal? item default-item)
|
(when (equal? item default-item)
|
||||||
(set-current-listbox-entry-by-key listbox key))))
|
(set-current-listbox-entry-by-key listbox key))))
|
||||||
listbox-keys))
|
listbox-keys))
|
||||||
|
|
||||||
(let* ((listbox (make-listbox
|
(let* ((listbox (make-listbox
|
||||||
-1 -1
|
-1 -1
|
||||||
listbox-height
|
listbox-height
|
||||||
(logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT
|
(logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT
|
||||||
(if listbox-allow-multiple?
|
(if listbox-allow-multiple?
|
||||||
FLAG-MULTIPLE
|
FLAG-MULTIPLE
|
||||||
0))))
|
0))))
|
||||||
(form (make-form #:flags FLAG-NOF12))
|
(form (make-form #:flags FLAG-NOF12))
|
||||||
(info-textbox
|
(info-textbox
|
||||||
(make-reflowed-textbox -1 -1 info-text
|
(make-reflowed-textbox -1 -1 info-text
|
||||||
info-textbox-width
|
info-textbox-width
|
||||||
#:flags FLAG-BORDER))
|
#:flags FLAG-BORDER))
|
||||||
(button (make-button -1 -1 button-text))
|
(button (make-button -1 -1 button-text))
|
||||||
(button2 (and button2-text
|
(button2 (and button2-text
|
||||||
(make-button -1 -1 button2-text)))
|
(make-button -1 -1 button2-text)))
|
||||||
(grid (vertically-stacked-grid
|
(grid (vertically-stacked-grid
|
||||||
GRID-ELEMENT-COMPONENT info-textbox
|
GRID-ELEMENT-COMPONENT info-textbox
|
||||||
GRID-ELEMENT-COMPONENT listbox
|
GRID-ELEMENT-COMPONENT listbox
|
||||||
GRID-ELEMENT-SUBGRID
|
GRID-ELEMENT-SUBGRID
|
||||||
(apply
|
(apply
|
||||||
horizontal-stacked-grid
|
horizontal-stacked-grid
|
||||||
GRID-ELEMENT-COMPONENT button
|
GRID-ELEMENT-COMPONENT button
|
||||||
`(,@(if button2
|
`(,@(if button2
|
||||||
(list GRID-ELEMENT-COMPONENT button2)
|
(list GRID-ELEMENT-COMPONENT button2)
|
||||||
'())))))
|
'())))))
|
||||||
(sorted-items (if sort-listbox-items?
|
(sorted-items (if sort-listbox-items?
|
||||||
(sort-listbox-items listbox-items)
|
(sort-listbox-items listbox-items)
|
||||||
listbox-items))
|
listbox-items))
|
||||||
(keys (fill-listbox listbox sorted-items)))
|
(keys (fill-listbox listbox sorted-items)))
|
||||||
|
|
||||||
;; On every listbox element change, check if we need to skip it. If yes,
|
(define (choice->item str)
|
||||||
;; depending on the 'last-listbox-key', jump forward or backward. If no,
|
;; Return the item that corresponds to STR.
|
||||||
;; do nothing.
|
(match (find (match-lambda
|
||||||
(add-component-callback
|
((key . item)
|
||||||
listbox
|
(string=? str (listbox-item->text item))))
|
||||||
(lambda (component)
|
keys)
|
||||||
(let* ((current-key (current-listbox-entry listbox))
|
((key . item) item)
|
||||||
(listbox-keys (map car keys))
|
(#f (raise (condition (&installer-step-abort))))))
|
||||||
(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
|
;; On every listbox element change, check if we need to skip it. If yes,
|
||||||
(set-default-item listbox keys listbox-default-item))
|
;; 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?
|
(when listbox-default-item
|
||||||
(form-add-hotkey form KEY-DELETE))
|
(set-default-item listbox keys listbox-default-item))
|
||||||
|
|
||||||
(add-form-to-grid grid form #t)
|
(when allow-delete?
|
||||||
(make-wrapped-grid-window grid title)
|
(form-add-hotkey form KEY-DELETE))
|
||||||
|
|
||||||
(receive (exit-reason argument)
|
(add-form-to-grid grid form #t)
|
||||||
(run-form form)
|
(make-wrapped-grid-window grid title)
|
||||||
(dynamic-wind
|
|
||||||
(const #t)
|
(receive (exit-reason argument)
|
||||||
(lambda ()
|
(run-form-with-clients form
|
||||||
(case exit-reason
|
`(list-selection (title ,title)
|
||||||
((exit-component)
|
(multiple-choices?
|
||||||
(cond
|
,listbox-allow-multiple?)
|
||||||
((components=? argument button)
|
(items
|
||||||
(button-callback-procedure))
|
,(map listbox-item->text
|
||||||
((and button2
|
listbox-items))))
|
||||||
(components=? argument button2))
|
(dynamic-wind
|
||||||
(button2-callback-procedure))
|
(const #t)
|
||||||
((components=? argument listbox)
|
(lambda ()
|
||||||
(if listbox-allow-multiple?
|
(match exit-reason
|
||||||
(let* ((entries (listbox-selection listbox))
|
('exit-component
|
||||||
(items (map (lambda (entry)
|
(cond
|
||||||
(assoc-ref keys entry))
|
((components=? argument button)
|
||||||
entries)))
|
(button-callback-procedure))
|
||||||
(listbox-callback-procedure items))
|
((and button2
|
||||||
(let* ((entry (current-listbox-entry listbox))
|
(components=? argument button2))
|
||||||
(item (assoc-ref keys entry)))
|
(button2-callback-procedure))
|
||||||
(listbox-callback-procedure item))))))
|
((components=? argument listbox)
|
||||||
((exit-hotkey)
|
(if listbox-allow-multiple?
|
||||||
(let* ((entry (current-listbox-entry listbox))
|
(let* ((entries (listbox-selection listbox))
|
||||||
(item (assoc-ref keys entry)))
|
(items (map (lambda (entry)
|
||||||
(hotkey-callback-procedure argument item)))))
|
(assoc-ref keys entry))
|
||||||
(lambda ()
|
entries)))
|
||||||
(destroy-form-and-pop form))))))
|
(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
|
(define* (run-scale-page #:key
|
||||||
title
|
title
|
||||||
|
@ -498,48 +653,65 @@ (define (fill-checkbox-tree checkbox-tree items)
|
||||||
items
|
items
|
||||||
selection))
|
selection))
|
||||||
|
|
||||||
(let* ((checkbox-tree
|
(let loop ()
|
||||||
(make-checkboxtree -1 -1
|
(let* ((checkbox-tree
|
||||||
checkbox-tree-height
|
(make-checkboxtree -1 -1
|
||||||
FLAG-BORDER))
|
checkbox-tree-height
|
||||||
(info-textbox
|
FLAG-BORDER))
|
||||||
(make-reflowed-textbox -1 -1 info-text
|
(info-textbox
|
||||||
info-textbox-width
|
(make-reflowed-textbox -1 -1 info-text
|
||||||
#:flags FLAG-BORDER))
|
info-textbox-width
|
||||||
(ok-button (make-button -1 -1 (G_ "OK")))
|
#:flags FLAG-BORDER))
|
||||||
(exit-button (make-button -1 -1 (G_ "Exit")))
|
(ok-button (make-button -1 -1 (G_ "OK")))
|
||||||
(grid (vertically-stacked-grid
|
(exit-button (make-button -1 -1 (G_ "Exit")))
|
||||||
GRID-ELEMENT-COMPONENT info-textbox
|
(grid (vertically-stacked-grid
|
||||||
GRID-ELEMENT-COMPONENT checkbox-tree
|
GRID-ELEMENT-COMPONENT info-textbox
|
||||||
GRID-ELEMENT-SUBGRID
|
GRID-ELEMENT-COMPONENT checkbox-tree
|
||||||
(horizontal-stacked-grid
|
GRID-ELEMENT-SUBGRID
|
||||||
GRID-ELEMENT-COMPONENT ok-button
|
(horizontal-stacked-grid
|
||||||
GRID-ELEMENT-COMPONENT exit-button)))
|
GRID-ELEMENT-COMPONENT ok-button
|
||||||
(keys (fill-checkbox-tree checkbox-tree items))
|
GRID-ELEMENT-COMPONENT exit-button)))
|
||||||
(form (make-form #:flags FLAG-NOF12)))
|
(keys (fill-checkbox-tree checkbox-tree items))
|
||||||
|
(form (make-form #:flags FLAG-NOF12)))
|
||||||
|
|
||||||
(add-form-to-grid grid form #t)
|
(define (choice->item str)
|
||||||
(make-wrapped-grid-window grid title)
|
;; 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)
|
(add-form-to-grid grid form #t)
|
||||||
(run-form form)
|
(make-wrapped-grid-window grid title)
|
||||||
(dynamic-wind
|
|
||||||
(const #t)
|
(receive (exit-reason argument)
|
||||||
(lambda ()
|
(run-form-with-clients form
|
||||||
(case exit-reason
|
`(checkbox-list (title ,title)
|
||||||
((exit-component)
|
(text ,info-text)
|
||||||
(cond
|
(items
|
||||||
((components=? argument ok-button)
|
,(map item->text items))))
|
||||||
(let* ((entries (current-checkbox-selection checkbox-tree))
|
(dynamic-wind
|
||||||
(current-items (map (lambda (entry)
|
(const #t)
|
||||||
(assoc-ref keys entry))
|
|
||||||
entries)))
|
(lambda ()
|
||||||
(ok-button-callback-procedure)
|
(match exit-reason
|
||||||
current-items))
|
('exit-component
|
||||||
((components=? argument exit-button)
|
(cond
|
||||||
(exit-button-callback-procedure))))))
|
((components=? argument ok-button)
|
||||||
(lambda ()
|
(let* ((entries (current-checkbox-selection checkbox-tree))
|
||||||
(destroy-form-and-pop form))))))
|
(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)
|
(define* (edit-file file #:key locale)
|
||||||
"Spawn an editor for FILE."
|
"Spawn an editor for FILE."
|
||||||
|
@ -606,13 +778,16 @@ (define* (run-file-textbox-page #:key
|
||||||
text))
|
text))
|
||||||
|
|
||||||
(receive (exit-reason argument)
|
(receive (exit-reason argument)
|
||||||
(run-form form)
|
(run-form-with-clients form
|
||||||
|
`(file-dialog (title ,title)
|
||||||
|
(text ,info-text)
|
||||||
|
(file ,file)))
|
||||||
(define result
|
(define result
|
||||||
(dynamic-wind
|
(dynamic-wind
|
||||||
(const #t)
|
(const #t)
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(case exit-reason
|
(match exit-reason
|
||||||
((exit-component)
|
('exit-component
|
||||||
(cond
|
(cond
|
||||||
((components=? argument ok-button)
|
((components=? argument ok-button)
|
||||||
(ok-button-callback-procedure))
|
(ok-button-callback-procedure))
|
||||||
|
@ -621,10 +796,15 @@ (define result
|
||||||
(exit-button-callback-procedure))
|
(exit-button-callback-procedure))
|
||||||
((and edit-button?
|
((and edit-button?
|
||||||
(components=? argument 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 ()
|
(lambda ()
|
||||||
(destroy-form-and-pop form))))
|
(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
|
(loop) ;recurse in tail position
|
||||||
result)))))
|
result)))))
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
|
;;; 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>
|
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
|
@ -682,6 +682,12 @@ (define (hotkey-action key listbox-item)
|
||||||
#:allow-delete? #t
|
#:allow-delete? #t
|
||||||
#:button-text (G_ "OK")
|
#:button-text (G_ "OK")
|
||||||
#:button-callback-procedure button-ok-action
|
#: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-text (G_ "Exit")
|
||||||
#:button2-callback-procedure button-exit-action
|
#:button2-callback-procedure button-exit-action
|
||||||
#:listbox-callback-procedure listbox-action
|
#:listbox-callback-procedure listbox-action
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
|
;;; 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>
|
;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
|
@ -23,6 +23,7 @@ (define-module (gnu installer newt user)
|
||||||
#:use-module ((gnu installer steps) #:select (&installer-step-abort))
|
#:use-module ((gnu installer steps) #:select (&installer-step-abort))
|
||||||
#:use-module (gnu installer newt page)
|
#:use-module (gnu installer newt page)
|
||||||
#:use-module (gnu installer newt utils)
|
#:use-module (gnu installer newt utils)
|
||||||
|
#:use-module (gnu installer utils)
|
||||||
#:use-module (guix i18n)
|
#:use-module (guix i18n)
|
||||||
#:use-module (newt)
|
#:use-module (newt)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
|
@ -115,6 +116,7 @@ (define (pad-label label)
|
||||||
GRID-ELEMENT-SUBGRID entry-grid
|
GRID-ELEMENT-SUBGRID entry-grid
|
||||||
GRID-ELEMENT-SUBGRID button-grid)
|
GRID-ELEMENT-SUBGRID button-grid)
|
||||||
title)
|
title)
|
||||||
|
|
||||||
(let ((error-page
|
(let ((error-page
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(run-error-page (G_ "Empty inputs are not allowed.")
|
(run-error-page (G_ "Empty inputs are not allowed.")
|
||||||
|
@ -230,33 +232,45 @@ (define (run users)
|
||||||
(set-current-component form ok-button))
|
(set-current-component form ok-button))
|
||||||
|
|
||||||
(receive (exit-reason argument)
|
(receive (exit-reason argument)
|
||||||
(run-form form)
|
(run-form-with-clients form '(add-users))
|
||||||
(dynamic-wind
|
(dynamic-wind
|
||||||
(const #t)
|
(const #t)
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(when (eq? exit-reason 'exit-component)
|
(match exit-reason
|
||||||
(cond
|
('exit-component
|
||||||
((components=? argument add-button)
|
(cond
|
||||||
(run (cons (run-user-add-page) users)))
|
((components=? argument add-button)
|
||||||
((components=? argument del-button)
|
(run (cons (run-user-add-page) users)))
|
||||||
(let* ((current-user-key (current-listbox-entry listbox))
|
((components=? argument del-button)
|
||||||
(users
|
(let* ((current-user-key (current-listbox-entry listbox))
|
||||||
(map (cut assoc-ref <> 'user)
|
(users
|
||||||
(remove (lambda (element)
|
(map (cut assoc-ref <> 'user)
|
||||||
(equal? (assoc-ref element 'key)
|
(remove (lambda (element)
|
||||||
current-user-key))
|
(equal? (assoc-ref element 'key)
|
||||||
listbox-elements))))
|
current-user-key))
|
||||||
(run users)))
|
listbox-elements))))
|
||||||
((components=? argument ok-button)
|
(run users)))
|
||||||
(when (null? users)
|
((components=? argument ok-button)
|
||||||
(run-error-page (G_ "Please create at least one user.")
|
(when (null? users)
|
||||||
(G_ "No user"))
|
(run-error-page (G_ "Please create at least one user.")
|
||||||
(run users))
|
(G_ "No user"))
|
||||||
(reverse users))
|
(run users))
|
||||||
((components=? argument exit-button)
|
(reverse users))
|
||||||
(raise
|
((components=? argument exit-button)
|
||||||
(condition
|
(raise
|
||||||
(&installer-step-abort)))))))
|
(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 ()
|
(lambda ()
|
||||||
(destroy-form-and-pop form))))))
|
(destroy-form-and-pop form))))))
|
||||||
|
|
||||||
|
|
|
@ -1,5 +1,6 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
|
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||||
|
;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -11,16 +12,20 @@
|
||||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; You should have received a copy of the GNU General Public License
|
;;; You should have received a copy of the GNU General Public License
|
||||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
(define-module (gnu installer newt welcome)
|
(define-module (gnu installer newt welcome)
|
||||||
|
#:use-module (gnu installer steps)
|
||||||
#:use-module (gnu installer utils)
|
#:use-module (gnu installer utils)
|
||||||
|
#:use-module (gnu installer newt page)
|
||||||
#:use-module (gnu installer newt utils)
|
#:use-module (gnu installer newt utils)
|
||||||
#:use-module (guix build syscalls)
|
#:use-module (guix build syscalls)
|
||||||
#:use-module (guix i18n)
|
#: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 match)
|
||||||
#:use-module (ice-9 receive)
|
#:use-module (ice-9 receive)
|
||||||
#:use-module (newt)
|
#:use-module (newt)
|
||||||
|
@ -66,24 +71,43 @@ (define (fill-listbox listbox items)
|
||||||
GRID-ELEMENT-COMPONENT options-listbox))
|
GRID-ELEMENT-COMPONENT options-listbox))
|
||||||
(form (make-form)))
|
(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))
|
(set-textbox-text logo-textbox (read-all logo))
|
||||||
|
|
||||||
(add-form-to-grid grid form #t)
|
(add-form-to-grid grid form #t)
|
||||||
(make-wrapped-grid-window grid title)
|
(make-wrapped-grid-window grid title)
|
||||||
|
|
||||||
(receive (exit-reason argument)
|
(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
|
(dynamic-wind
|
||||||
(const #t)
|
(const #t)
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(when (eq? exit-reason 'exit-component)
|
(match exit-reason
|
||||||
(cond
|
('exit-component
|
||||||
((components=? argument options-listbox)
|
(let* ((entry (current-listbox-entry options-listbox))
|
||||||
(let* ((entry (current-listbox-entry options-listbox))
|
(item (assoc-ref keys entry)))
|
||||||
(item (assoc-ref keys entry)))
|
(match item
|
||||||
(match item
|
((text . proc)
|
||||||
((text . proc)
|
(proc)))))
|
||||||
(proc))))))))
|
('exit-fd-ready
|
||||||
|
(let* ((choice argument)
|
||||||
|
(item (choice->item choice)))
|
||||||
|
(match item
|
||||||
|
((text . proc)
|
||||||
|
(proc)))))))
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(destroy-form-and-pop form))))))
|
(destroy-form-and-pop form))))))
|
||||||
|
|
||||||
|
|
|
@ -1,5 +1,6 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
|
;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||||
|
;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -19,6 +20,7 @@
|
||||||
(define-module (gnu installer steps)
|
(define-module (gnu installer steps)
|
||||||
#:use-module (guix records)
|
#:use-module (guix records)
|
||||||
#:use-module (guix build utils)
|
#:use-module (guix build utils)
|
||||||
|
#:use-module (gnu installer utils)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:use-module (ice-9 pretty-print)
|
#:use-module (ice-9 pretty-print)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
|
@ -185,13 +187,18 @@ (define* (run result #:key todo-steps done-steps)
|
||||||
#:todo-steps rest-steps
|
#:todo-steps rest-steps
|
||||||
#:done-steps (append done-steps (list step))))))))
|
#:done-steps (append done-steps (list step))))))))
|
||||||
|
|
||||||
(call-with-prompt 'raise-above
|
;; Ignore SIGPIPE so that we don't die if a client closes the connection
|
||||||
(lambda ()
|
;; prematurely.
|
||||||
(run '()
|
(sigaction SIGPIPE SIG_IGN)
|
||||||
#:todo-steps steps
|
|
||||||
#:done-steps '()))
|
(with-server-socket
|
||||||
(lambda (k condition)
|
(call-with-prompt 'raise-above
|
||||||
(raise condition))))
|
(lambda ()
|
||||||
|
(run '()
|
||||||
|
#:todo-steps steps
|
||||||
|
#:done-steps '()))
|
||||||
|
(lambda (k condition)
|
||||||
|
(raise condition)))))
|
||||||
|
|
||||||
(define (find-step-by-id steps id)
|
(define (find-step-by-id steps id)
|
||||||
"Find and return the step in STEPS whose id is equal to ID."
|
"Find and return the step in STEPS whose id is equal to ID."
|
||||||
|
@ -249,3 +256,7 @@ (define* (configuration->file configuration
|
||||||
(pretty-print part port)))
|
(pretty-print part port)))
|
||||||
configuration)
|
configuration)
|
||||||
(flush-output-port port))))
|
(flush-output-port port))))
|
||||||
|
|
||||||
|
;;; Local Variables:
|
||||||
|
;;; eval: (put 'with-server-socket 'scheme-indent-function 0)
|
||||||
|
;;; End:
|
||||||
|
|
|
@ -21,7 +21,9 @@ (define-module (gnu installer utils)
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
#:use-module (guix build utils)
|
#:use-module (guix build utils)
|
||||||
#:use-module (guix i18n)
|
#:use-module (guix i18n)
|
||||||
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-34)
|
#:use-module (srfi srfi-34)
|
||||||
|
#:use-module (ice-9 match)
|
||||||
#:use-module (ice-9 rdelim)
|
#:use-module (ice-9 rdelim)
|
||||||
#:use-module (ice-9 regex)
|
#:use-module (ice-9 regex)
|
||||||
#:use-module (ice-9 format)
|
#:use-module (ice-9 format)
|
||||||
|
@ -33,7 +35,12 @@ (define-module (gnu installer utils)
|
||||||
run-shell-command
|
run-shell-command
|
||||||
|
|
||||||
syslog-port
|
syslog-port
|
||||||
syslog))
|
syslog
|
||||||
|
|
||||||
|
with-server-socket
|
||||||
|
current-server-socket
|
||||||
|
current-clients
|
||||||
|
send-to-clients))
|
||||||
|
|
||||||
(define* (read-lines #:optional (port (current-input-port)))
|
(define* (read-lines #:optional (port (current-input-port)))
|
||||||
"Read lines from PORT and return them as a list."
|
"Read lines from PORT and return them as a list."
|
||||||
|
@ -66,7 +73,11 @@ (define* (run-shell-command command #:key locale)
|
||||||
COMMAND exited successfully, #f otherwise."
|
COMMAND exited successfully, #f otherwise."
|
||||||
(define (pause)
|
(define (pause)
|
||||||
(format #t (G_ "Press Enter to continue.~%"))
|
(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
|
(call-with-temporary-output-file
|
||||||
(lambda (file port)
|
(lambda (file port)
|
||||||
|
@ -134,3 +145,76 @@ (define-syntax syslog
|
||||||
(with-syntax ((fmt (string-append "installer[~d]: "
|
(with-syntax ((fmt (string-append "installer[~d]: "
|
||||||
(syntax->datum #'fmt))))
|
(syntax->datum #'fmt))))
|
||||||
#'(format (syslog-port) fmt (getpid) args ...))))))
|
#'(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 a new issue