me
/
guix
Archived
1
0
Fork 0
Code

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.
master
Ludovic Courtès 2020-01-22 22:57:14 +01:00
parent 5ce84b1713
commit 63b8c089c1
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
7 changed files with 581 additions and 252 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
gnu/installer/newt/final.scm
View File

@ -63,28 +63,38 @@ This will take a few minutes.")
(&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

564
gnu/installer/newt/page.scm
View File

@ -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 @@
#: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 @@
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 @@
;;; ;;;
;;; 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 @@ input box, such as FLAG-PASSWORD."
(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 @@ of the page is set to 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 @@ of the page is set to 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 @@ of the page is set to TITLE."
(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 @@ 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 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 @@ 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 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 @@ ITEMS when 'Ok' is pressed."
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 @@ ITEMS when 'Ok' is pressed."
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 @@ ITEMS when 'Ok' is pressed."
(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)))))

8
gnu/installer/newt/partition.scm
View File

@ -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 @@ by pressing the Exit button.~%~%")))
#: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

64
gnu/installer/newt/user.scm
View File

@ -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 @@
#: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 @@ REAL-NAME, and HOME-DIRECTORY as the initial values in the form."
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 @@ administrator (\"root\").")
(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))))))

44
gnu/installer/newt/welcome.scm
View File

@ -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 @@ we want this page to occupy all the screen space available."
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))))))

25
gnu/installer/steps.scm
View File

@ -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 @@ return the accumalated result so far."
#: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 @@ found in RESULTS."
(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:

88
gnu/installer/utils.scm
View File

@ -21,7 +21,9 @@
#: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 @@
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 @@ number. If no percentage is found, return #f"
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 @@ COMMAND exited successfully, #f otherwise."
(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)