* [bug#39729] [PATCH 2/7] installer: Use a Guile-Newt snapshot that supports 'form-watch-fd'.
2020-02-21 23:20 ` [bug#39729] [PATCH 1/7] tests: 'run-basic-test' can enter a root password Ludovic Courtès
@ 2020-02-21 23:20 ` Ludovic Courtès
2020-02-21 23:20 ` [bug#39729] [PATCH 3/7] installer: Implement a dialog on /var/guix/installer-socket Ludovic Courtès
` (4 subsequent siblings)
5 siblings, 0 replies; 10+ messages in thread
From: Ludovic Courtès @ 2020-02-21 23:20 UTC (permalink / raw)
To: 39729; +Cc: Ludovic Courtès
* gnu/installer.scm (guile-newt): New variable.
---
gnu/installer.scm | 21 +++++++++++++++++++++
1 file changed, 21 insertions(+)
diff --git a/gnu/installer.scm b/gnu/installer.scm
index edef3fde62..6c11fa6198 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -26,6 +26,8 @@
#:use-module (guix utils)
#:use-module (guix ui)
#:use-module ((guix self) #:select (make-config.scm))
+ #:use-module (guix packages)
+ #:use-module (guix git-download)
#:use-module (gnu installer utils)
#:use-module (gnu packages admin)
#:use-module (gnu packages base)
@@ -280,6 +282,25 @@ selected keymap."
((installer-final-page current-installer)
result prev-steps))))))))
+(define guile-newt
+ ;; Guile-Newt with 'form-watch-fd'.
+ ;; TODO: Remove once a new release is out.
+ (let ((commit "b3c885d42cfac327d3531c9d064939514ce6bf12")
+ (revision "1"))
+ (package
+ (inherit (@ (gnu packages guile-xyz) guile-newt))
+ (name "guile-newt")
+ (version (git-version "0.0.1" revision commit))
+ (source (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "https://gitlab.com/mothacehe/guile-newt")
+ (commit commit)))
+ (file-name (git-file-name name version))
+ (sha256
+ (base32
+ "02p0bi6c05699idgx6gfkljhqgi8zf09clhzx81i8wa064s70r1y")))))))
+
(define (installer-program)
"Return a file-like object that runs the given INSTALLER."
(define init-gettext
--
2.25.1
^ permalink raw reply related [flat|nested] 10+ messages in thread* [bug#39729] [PATCH 3/7] installer: Implement a dialog on /var/guix/installer-socket.
2020-02-21 23:20 ` [bug#39729] [PATCH 1/7] tests: 'run-basic-test' can enter a root password Ludovic Courtès
2020-02-21 23:20 ` [bug#39729] [PATCH 2/7] installer: Use a Guile-Newt snapshot that supports 'form-watch-fd' Ludovic Courtès
@ 2020-02-21 23:20 ` Ludovic Courtès
2020-02-21 23:20 ` [bug#39729] [PATCH 4/7] installer: Bypass connectivity check when /tmp/installer-assume-online exists Ludovic Courtès
` (3 subsequent siblings)
5 siblings, 0 replies; 10+ messages in thread
From: Ludovic Courtès @ 2020-02-21 23:20 UTC (permalink / raw)
To: 39729; +Cc: Ludovic Courtès
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.
---
gnu/installer/newt/final.scm | 40 ++-
gnu/installer/newt/page.scm | 564 ++++++++++++++++++++-----------
gnu/installer/newt/partition.scm | 8 +-
gnu/installer/newt/user.scm | 64 ++--
gnu/installer/newt/welcome.scm | 44 ++-
gnu/installer/steps.scm | 25 +-
gnu/installer/utils.scm | 88 ++++-
7 files changed, 581 insertions(+), 252 deletions(-)
diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm
index 405eee2540..5cb4f6816d 100644
--- a/gnu/installer/newt/final.scm
+++ b/gnu/installer/newt/final.scm
@@ -63,28 +63,38 @@ This will take a few minutes.")
(&installer-step-abort)))))))
(define (run-install-success-page)
- (message-window
- (G_ "Installation complete")
- (G_ "Reboot")
- (G_ "Congratulations! Installation is now complete. \
+ (match (current-clients)
+ (()
+ (message-window
+ (G_ "Installation complete")
+ (G_ "Reboot")
+ (G_ "Congratulations! Installation is now complete. \
You may remove the device containing the installation image and \
-press the button to reboot."))
+press the button to reboot.")))
+ (_
+ ;; When there are clients connected, send them a message and keep going.
+ (send-to-clients '(installation-complete))))
;; Return success so that the installer happily reboots.
'success)
(define (run-install-failed-page)
- (match (choice-window
- (G_ "Installation failed")
- (G_ "Resume")
- (G_ "Restart the installer")
- (G_ "The final system installation step failed. You can resume from \
+ (match (current-clients)
+ (()
+ (match (choice-window
+ (G_ "Installation failed")
+ (G_ "Resume")
+ (G_ "Restart the installer")
+ (G_ "The final system installation step failed. You can resume from \
a specific step, or restart the installer."))
- (1 (raise
- (condition
- (&installer-step-abort))))
- (2
- ;; Keep going, the installer will be restarted later on.
+ (1 (raise
+ (condition
+ (&installer-step-abort))))
+ (2
+ ;; Keep going, the installer will be restarted later on.
+ #t)))
+ (_
+ (send-to-clients '(installation-failure))
#t)))
(define* (run-install-shell locale
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index 8aea5a1109..c01124aa0d 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -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)))))
diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm
index 3cba7f77dd..c925e410a9 100644
--- a/gnu/installer/newt/partition.scm
+++ b/gnu/installer/newt/partition.scm
@@ -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
diff --git a/gnu/installer/newt/user.scm b/gnu/installer/newt/user.scm
index b01d52172b..ad711d665a 100644
--- a/gnu/installer/newt/user.scm
+++ b/gnu/installer/newt/user.scm
@@ -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))))))
diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm
index aec3e7a612..1b4b2df816 100644
--- a/gnu/installer/newt/welcome.scm
+++ b/gnu/installer/newt/welcome.scm
@@ -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))))))
diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm
index b2fc819d89..0b6d8e4649 100644
--- a/gnu/installer/steps.scm
+++ b/gnu/installer/steps.scm
@@ -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:
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 842bd02ced..4dc26374b1 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -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 ...))))))
+
+\f
+;;;
+;;; 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)
--
2.25.1
^ permalink raw reply related [flat|nested] 10+ messages in thread* [bug#39729] [PATCH 4/7] installer: Bypass connectivity check when /tmp/installer-assume-online exists.
2020-02-21 23:20 ` [bug#39729] [PATCH 1/7] tests: 'run-basic-test' can enter a root password Ludovic Courtès
2020-02-21 23:20 ` [bug#39729] [PATCH 2/7] installer: Use a Guile-Newt snapshot that supports 'form-watch-fd' Ludovic Courtès
2020-02-21 23:20 ` [bug#39729] [PATCH 3/7] installer: Implement a dialog on /var/guix/installer-socket Ludovic Courtès
@ 2020-02-21 23:20 ` Ludovic Courtès
2020-02-21 23:20 ` [bug#39729] [PATCH 5/7] installer: Run commands without hopping through the shell Ludovic Courtès
` (2 subsequent siblings)
5 siblings, 0 replies; 10+ messages in thread
From: Ludovic Courtès @ 2020-02-21 23:20 UTC (permalink / raw)
To: 39729; +Cc: Ludovic Courtès
This is useful for automated tests.
* gnu/installer/newt/network.scm (wait-service-online)[online?]: New
procedure. Check for /tmp/installer-assume-online.
Use it instead of 'connman-online?'.
---
gnu/installer/newt/network.scm | 10 +++++++---
1 file changed, 7 insertions(+), 3 deletions(-)
diff --git a/gnu/installer/newt/network.scm b/gnu/installer/newt/network.scm
index 40d85817b6..461d5d99c0 100644
--- a/gnu/installer/newt/network.scm
+++ b/gnu/installer/newt/network.scm
@@ -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>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -119,6 +119,10 @@ network devices were found. Do you want to continue anyway?"))
(define (wait-service-online)
"Display a newt scale until connman detects an Internet access. Do
FULL-VALUE tentatives, spaced by 1 second."
+ (define (online?)
+ (or (connman-online?)
+ (file-exists? "/tmp/installer-assume-online")))
+
(let* ((full-value 5))
(run-scale-page
#:title (G_ "Checking connectivity")
@@ -127,10 +131,10 @@ FULL-VALUE tentatives, spaced by 1 second."
#:scale-update-proc
(lambda (value)
(sleep 1)
- (if (connman-online?)
+ (if (online?)
full-value
(+ value 1))))
- (unless (connman-online?)
+ (unless (online?)
(run-error-page
(G_ "The selected network does not provide access to the \
Internet, please try again.")
--
2.25.1
^ permalink raw reply related [flat|nested] 10+ messages in thread* [bug#39729] [PATCH 5/7] installer: Run commands without hopping through the shell.
2020-02-21 23:20 ` [bug#39729] [PATCH 1/7] tests: 'run-basic-test' can enter a root password Ludovic Courtès
` (2 preceding siblings ...)
2020-02-21 23:20 ` [bug#39729] [PATCH 4/7] installer: Bypass connectivity check when /tmp/installer-assume-online exists Ludovic Courtès
@ 2020-02-21 23:20 ` Ludovic Courtès
2020-02-21 23:20 ` [bug#39729] [PATCH 6/7] installer: Honor /tmp/installer-system-init-options Ludovic Courtès
2020-02-21 23:20 ` [bug#39729] [PATCH 7/7] tests: install: Add "gui-installed-os" Ludovic Courtès
5 siblings, 0 replies; 10+ messages in thread
From: Ludovic Courtès @ 2020-02-21 23:20 UTC (permalink / raw)
To: 39729; +Cc: Ludovic Courtès
* gnu/installer/utils.scm (run-shell-command): Rename to...
(run-command): Remove call to 'call-with-temporary-output-file' and hop
through Bash. Expect COMMAND to be a list of strings rather than a
string.
* gnu/installer/final.scm (install-system): Turn INSTALL-COMMAND into a
list of strings and pass it to 'run-command'.
* gnu/installer/newt/page.scm (edit-file): Likewise.
---
gnu/installer/final.scm | 11 +++----
gnu/installer/newt/page.scm | 5 ++-
gnu/installer/utils.scm | 64 ++++++++++++++++++-------------------
3 files changed, 39 insertions(+), 41 deletions(-)
diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm
index 8c2185e36f..7193ecb8a4 100644
--- a/gnu/installer/final.scm
+++ b/gnu/installer/final.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -111,10 +111,9 @@ cow-store service."
Start COW-STORE service on target directory and launch guix install command in
a subshell. LOCALE must be the locale name under which that command will run,
or #f. Return #t on success and #f on failure."
- (let ((install-command
- (format #f "guix system init --fallback ~a ~a"
- (%installer-configuration-file)
- (%installer-target-dir))))
+ (let ((install-command (list "guix" "system" "init" "--fallback"
+ (%installer-configuration-file)
+ (%installer-target-dir))))
(mkdir-p (%installer-target-dir))
;; We want to initialize user passwords but we don't want to store them in
@@ -128,7 +127,7 @@ or #f. Return #t on success and #f on failure."
(lambda ()
(start-service 'cow-store (list (%installer-target-dir))))
(lambda ()
- (run-shell-command install-command #:locale locale))
+ (run-command install-command #:locale locale))
(lambda ()
(stop-service 'cow-store)
;; Remove the store overlay created at cow-store service start.
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index c01124aa0d..9031c7d4ba 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -719,9 +719,8 @@ ITEMS when 'Ok' is pressed."
(newt-suspend)
;; Use Nano because it syntax-highlights Scheme by default.
;; TODO: Add a menu to choose an editor?
- (run-shell-command (string-append "/run/current-system/profile/bin/nano "
- file)
- #:locale locale)
+ (run-command (list "/run/current-system/profile/bin/nano" file)
+ #:locale locale)
(newt-resume))
(define* (run-file-textbox-page #:key
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 4dc26374b1..0a91ae1e4a 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -32,7 +32,7 @@
read-all
nearest-exact-integer
read-percentage
- run-shell-command
+ run-command
syslog-port
syslog
@@ -68,48 +68,48 @@ number. If no percentage is found, return #f"
(and result
(string->number (match:substring result 1)))))
-(define* (run-shell-command command #:key locale)
- "Run COMMAND, a string, with Bash, and in the given LOCALE. Return true if
+(define* (run-command command #:key locale)
+ "Run COMMAND, a list of strings, in the given LOCALE. Return true if
COMMAND exited successfully, #f otherwise."
+ (define env (environ))
+
(define (pause)
(format #t (G_ "Press Enter to continue.~%"))
(send-to-clients '(pause))
+ (environ env) ;restore environment variables
(match (select (cons (current-input-port) (current-clients))
'() '())
(((port _ ...) _ _)
(read-line port))))
- (call-with-temporary-output-file
- (lambda (file port)
- (when locale
- (let ((supported? (false-if-exception
- (setlocale LC_ALL locale))))
- ;; If LOCALE is not supported, then set LANGUAGE, which might at
- ;; least give us translated messages.
- (if supported?
- (format port "export LC_ALL=\"~a\"~%" locale)
- (format port "export LANGUAGE=\"~a\"~%"
- (string-take locale
- (string-index locale #\_))))))
+ (setenv "PATH" "/run/current-system/profile/bin")
- (format port "exec ~a~%" command)
- (close port)
+ (when locale
+ (let ((supported? (false-if-exception
+ (setlocale LC_ALL locale))))
+ ;; If LOCALE is not supported, then set LANGUAGE, which might at
+ ;; least give us translated messages.
+ (if supported?
+ (setenv "LC_ALL" locale)
+ (setenv "LANGUAGE"
+ (string-take locale
+ (string-index locale #\_))))))
- (guard (c ((invoke-error? c)
- (newline)
- (format (current-error-port)
- (G_ "Command failed with exit code ~a.~%")
- (invoke-error-exit-status c))
- (syslog "command ~s failed with exit code ~a"
- command (invoke-error-exit-status c))
- (pause)
- #f))
- (syslog "running command ~s~%" command)
- (invoke "bash" "--init-file" file)
- (syslog "command ~s succeeded~%" command)
- (newline)
- (pause)
- #t))))
+ (guard (c ((invoke-error? c)
+ (newline)
+ (format (current-error-port)
+ (G_ "Command failed with exit code ~a.~%")
+ (invoke-error-exit-status c))
+ (syslog "command ~s failed with exit code ~a"
+ command (invoke-error-exit-status c))
+ (pause)
+ #f))
+ (syslog "running command ~s~%" command)
+ (apply invoke command)
+ (syslog "command ~s succeeded~%" command)
+ (newline)
+ (pause)
+ #t))
\f
;;;
--
2.25.1
^ permalink raw reply related [flat|nested] 10+ messages in thread* [bug#39729] [PATCH 6/7] installer: Honor /tmp/installer-system-init-options.
2020-02-21 23:20 ` [bug#39729] [PATCH 1/7] tests: 'run-basic-test' can enter a root password Ludovic Courtès
` (3 preceding siblings ...)
2020-02-21 23:20 ` [bug#39729] [PATCH 5/7] installer: Run commands without hopping through the shell Ludovic Courtès
@ 2020-02-21 23:20 ` Ludovic Courtès
2020-02-21 23:20 ` [bug#39729] [PATCH 7/7] tests: install: Add "gui-installed-os" Ludovic Courtès
5 siblings, 0 replies; 10+ messages in thread
From: Ludovic Courtès @ 2020-02-21 23:20 UTC (permalink / raw)
To: 39729; +Cc: Ludovic Courtès
* gnu/installer/final.scm (install-system): Honor
"/tmp/installer-system-init-options".
---
gnu/installer/final.scm | 16 +++++++++++++---
1 file changed, 13 insertions(+), 3 deletions(-)
diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm
index 7193ecb8a4..869be8814b 100644
--- a/gnu/installer/final.scm
+++ b/gnu/installer/final.scm
@@ -111,9 +111,19 @@ cow-store service."
Start COW-STORE service on target directory and launch guix install command in
a subshell. LOCALE must be the locale name under which that command will run,
or #f. Return #t on success and #f on failure."
- (let ((install-command (list "guix" "system" "init" "--fallback"
- (%installer-configuration-file)
- (%installer-target-dir))))
+ (let* ((options (catch 'system-error
+ (lambda ()
+ ;; If this file exists, it can provide
+ ;; additional command-line options.
+ (call-with-input-file
+ "/tmp/installer-system-init-options"
+ read))
+ (const '())))
+ (install-command (append (list "guix" "system" "init"
+ "--fallback")
+ options
+ (list (%installer-configuration-file)
+ (%installer-target-dir)))))
(mkdir-p (%installer-target-dir))
;; We want to initialize user passwords but we don't want to store them in
--
2.25.1
^ permalink raw reply related [flat|nested] 10+ messages in thread* [bug#39729] [PATCH 7/7] tests: install: Add "gui-installed-os".
2020-02-21 23:20 ` [bug#39729] [PATCH 1/7] tests: 'run-basic-test' can enter a root password Ludovic Courtès
` (4 preceding siblings ...)
2020-02-21 23:20 ` [bug#39729] [PATCH 6/7] installer: Honor /tmp/installer-system-init-options Ludovic Courtès
@ 2020-02-21 23:20 ` Ludovic Courtès
5 siblings, 0 replies; 10+ messages in thread
From: Ludovic Courtès @ 2020-02-21 23:20 UTC (permalink / raw)
To: 39729; +Cc: Ludovic Courtès
* gnu/installer/tests.scm: New file.
* gnu/local.mk (INSTALLER_MODULES): Add it.
* gnu/tests/install.scm (run-install): Add #:gui-test. Add (gnu
installer tests) to the marionette imported modules. Honor GUI-TEST.
Check whether SCRIPT is true.
(%root-password, %syslog-conf): New variable.
(operating-system-with-console-syslog, gui-test-program)
(guided-installation-test): New procedures.
(%extra-packages, installation-os-for-gui-tests)
(%test-gui-installed-os): New variable.
---
gnu/installer/tests.scm | 340 ++++++++++++++++++++++++++++++++++++++++
gnu/local.mk | 3 +-
gnu/tests/install.scm | 200 ++++++++++++++++++++++-
3 files changed, 535 insertions(+), 8 deletions(-)
create mode 100644 gnu/installer/tests.scm
diff --git a/gnu/installer/tests.scm b/gnu/installer/tests.scm
new file mode 100644
index 0000000000..6f5393e3ab
--- /dev/null
+++ b/gnu/installer/tests.scm
@@ -0,0 +1,340 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; 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
+;;; GNU General Public License for more details.
+;;;
+;;; 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 tests)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 pretty-print)
+ #:export (&pattern-not-matched
+ pattern-not-matched?
+
+ %installer-socket-file
+ open-installer-socket
+
+ converse
+ conversation-log-port
+
+ choose-locale+keyboard
+ enter-host-name+passwords
+ choose-services
+ choose-partitioning
+ conclude-installation
+
+ edit-configuration-file))
+
+;;; Commentary:
+;;;
+;;; This module provides tools to test the guided "graphical" installer in a
+;;; non-interactive fashion. The core of it is 'converse': it allows you to
+;;; state Expect-style dialogues, which happen over the Unix-domain socket the
+;;; installer listens to. Higher-level procedures such as
+;;; 'choose-locale+keyboard' are provided to perform specific parts of the
+;;; dialogue.
+;;;
+;;; Code:
+
+(define %installer-socket-file
+ ;; Socket the installer listens to.
+ "/var/guix/installer-socket")
+
+(define* (open-installer-socket #:optional (file %installer-socket-file))
+ "Return a socket connected to the installer."
+ (let ((sock (socket AF_UNIX SOCK_STREAM 0)))
+ (connect sock AF_UNIX file)
+ sock))
+
+(define-condition-type &pattern-not-matched &error
+ pattern-not-matched?
+ (pattern pattern-not-matched-pattern)
+ (sexp pattern-not-matched-sexp))
+
+(define (pattern-error pattern sexp)
+ (raise (condition
+ (&pattern-not-matched
+ (pattern pattern) (sexp sexp)))))
+
+(define conversation-log-port
+ ;; Port where debugging info is logged
+ (make-parameter (current-error-port)))
+
+(define (converse-debug pattern)
+ (format (conversation-log-port)
+ "conversation expecting pattern ~s~%"
+ pattern))
+
+(define-syntax converse
+ (lambda (s)
+ "Convert over PORT: read sexps from there, match them against each
+PATTERN, and send the corresponding REPLY. Raise to '&pattern-not-matched'
+when one of the PATTERNs is not matched."
+
+ ;; XXX: Strings that appear in PATTERNs must be in the language the
+ ;; installer is running in. In the future, we should add support to allow
+ ;; writing English strings in PATTERNs and have the pattern matcher
+ ;; automatically translate them.
+
+ ;; Here we emulate 'pmatch' syntax on top of 'match'. This is ridiculous
+ ;; but that's because 'pmatch' compares objects with 'eq?', making it
+ ;; pretty useless, and it doesn't support ellipses and such.
+
+ (define (quote-pattern s)
+ ;; Rewrite the pattern S from pmatch style (a ,b) to match style like
+ ;; ('a b).
+ (with-ellipsis :::
+ (syntax-case s (unquote _ ...)
+ ((unquote id) #'id)
+ (_ #'_)
+ (... #'...)
+ (id
+ (identifier? #'id)
+ #''id)
+ ((lst :::) (map quote-pattern #'(lst :::)))
+ (pattern #'pattern))))
+
+ (define (match-pattern s)
+ ;; Match one pattern without a guard.
+ (syntax-case s ()
+ ((port (pattern reply) continuation)
+ (with-syntax ((pattern (quote-pattern #'pattern)))
+ #'(let ((pat 'pattern))
+ (converse-debug pat)
+ (match (read port)
+ (pattern
+ (let ((data (call-with-values (lambda () reply)
+ list)))
+ (for-each (lambda (obj)
+ (write obj port)
+ (newline port))
+ data)
+ (force-output port)
+ (continuation port)))
+ (sexp
+ (pattern-error pat sexp))))))))
+
+ (syntax-case s ()
+ ((_ port (pattern reply) rest ...)
+ (match-pattern #'(port (pattern reply)
+ (lambda (port)
+ (converse port rest ...)))))
+ ((_ port (pattern guard reply) rest ...)
+ #`(let ((skip? (not guard))
+ (next (lambda (p)
+ (converse p rest ...))))
+ (if skip?
+ (next port)
+ #,(match-pattern #'(port (pattern reply) next)))))
+ ((_ port)
+ #t))))
+
+(define* (choose-locale+keyboard port
+ #:key
+ (language "English")
+ (location "Hong Kong")
+ (timezone '("Europe" "Zagreb"))
+ (keyboard
+ '("English (US)"
+ "English (intl., with AltGr dead keys)")))
+ "Converse over PORT with the guided installer to choose the specified
+LANGUAGE, LOCATION, TIMEZONE, and KEYBOARD."
+ (converse port
+ ((list-selection (title "Locale language")
+ (multiple-choices? #f)
+ (items _))
+ language)
+ ((list-selection (title "Locale location")
+ (multiple-choices? #f)
+ (items _))
+ location)
+ ((menu (title "GNU Guix install")
+ (text _)
+ (items (,guided _ ...))) ;"Guided graphical installation"
+ guided)
+ ((list-selection (title "Timezone")
+ (multiple-choices? #f)
+ (items _))
+ (first timezone))
+ ((list-selection (title "Timezone")
+ (multiple-choices? #f)
+ (items _))
+ (second timezone))
+ ((list-selection (title "Layout")
+ (multiple-choices? #f)
+ (items _))
+ (first keyboard))
+ ((list-selection (title "Variant")
+ (multiple-choices? #f)
+ (items _))
+ (second keyboard))))
+
+(define* (enter-host-name+passwords port
+ #:key
+ (host-name "guix")
+ (root-password "foo")
+ (users '(("alice" "pass1")
+ ("bob" "pass2")
+ ("charlie" "pass3"))))
+ "Converse over PORT with the guided installer to choose HOST-NAME,
+ROOT-PASSWORD, and USERS."
+ (converse port
+ ((input (title "Hostname") (text _) (default _))
+ host-name)
+ ((input (title "System administrator password") (text _) (default _))
+ root-password)
+ ((input (title "Password confirmation required") (text _) (default _))
+ root-password)
+ ((add-users)
+ (match users
+ (((names passwords) ...)
+ (map (lambda (name password)
+ `(user (name ,name) (real-name ,(string-titlecase name))
+ (home-directory ,(string-append "/home/" name))
+ (password ,password)))
+ names passwords))))))
+
+(define* (choose-services port
+ #:key
+ (desktop-environments '("GNOME"))
+ (choose-network-service?
+ (lambda (service)
+ (or (string-contains service "SSH")
+ (string-contains service "NSS"))))
+ (choose-network-management-tool?
+ (lambda (service)
+ (string-contains service "DHCP"))))
+ "Converse over PORT to choose networking services."
+ (converse port
+ ((checkbox-list (title "Desktop environment") (text _)
+ (items _))
+ desktop-environments)
+ ((checkbox-list (title "Network service") (text _)
+ (items ,services))
+ (filter choose-network-service? services))
+
+ ;; The "Network management" dialog shows up only when no desktop
+ ;; environments have been selected, hence the guard.
+ ((list-selection (title "Network management")
+ (multiple-choices? #f)
+ (items ,services))
+ (null? desktop-environments)
+ (find choose-network-management-tool? services))))
+
+(define (edit-configuration-file file)
+ "Edit FILE, an operating system configuration file generated by the
+installer, by adding a marionette service such that the installed OS is
+instrumented for further testing."
+ (define (read-expressions port)
+ (let loop ((result '()))
+ (match (read port)
+ ((? eof-object?)
+ (reverse result))
+ (exp
+ (loop (cons exp result))))))
+
+ (define (edit exp)
+ (match exp
+ (('operating-system _ ...)
+ `(marionette-operating-system ,exp
+ #:imported-modules
+ '((gnu services herd)
+ (guix build utils)
+ (guix combinators))))
+ (_
+ exp)))
+
+ (let ((content (call-with-input-file file read-expressions)))
+ (call-with-output-file file
+ (lambda (port)
+ (format port "\
+;; Operating system configuration edited for automated testing.~%~%")
+
+ (pretty-print '(use-modules (gnu tests)) port)
+ (for-each (lambda (exp)
+ (pretty-print (edit exp) port)
+ (newline port))
+ content)))
+
+ #t))
+
+(define* (choose-partitioning port
+ #:key
+ (encrypted? #t)
+ (passphrase "thepassphrase")
+ (edit-configuration-file
+ edit-configuration-file))
+ "Converse over PORT to choose the partitioning method. When ENCRYPTED? is
+true, choose full-disk encryption with PASSPHRASE as the LUKS passphrase.
+This conversation goes past the final dialog box that shows the configuration
+file, actually starting the installation process."
+ (converse port
+ ((list-selection (title "Partitioning method")
+ (multiple-choices? #f)
+ (items (,not-encrypted ,encrypted _ ...)))
+ (if encrypted?
+ encrypted
+ not-encrypted))
+ ((list-selection (title "Disk") (multiple-choices? #f)
+ (items (,disk _ ...)))
+ disk)
+
+ ;; The "Partition table" dialog pops up only if there's not already a
+ ;; partition table.
+ ((list-selection (title "Partition table")
+ (multiple-choices? #f)
+ (items _))
+ "gpt")
+ ((list-selection (title "Partition scheme")
+ (multiple-choices? #f)
+ (items (,one-partition _ ...)))
+ one-partition)
+ ((list-selection (title "Guided partitioning")
+ (multiple-choices? #f)
+ (items (,disk _ ...)))
+ disk)
+ ((input (title "Password required")
+ (text _) (default #f))
+ encrypted? ;only when ENCRYPTED?
+ passphrase)
+ ((input (title "Password confirmation required")
+ (text _) (default #f))
+ encrypted?
+ passphrase)
+ ((confirmation (title "Format disk?") (text _))
+ #t)
+ ((info (title "Preparing partitions") _ ...)
+ (values)) ;nothing to return
+ ((file-dialog (title "Configuration file")
+ (text _)
+ (file ,configuration-file))
+ (edit-configuration-file configuration-file))))
+
+(define (conclude-installation port)
+ "Conclude the installation by checking over PORT that we get the final
+messages once the 'guix system init' process has completed."
+ (converse port
+ ((pause) ;"Press Enter to continue."
+ #t)
+ ((installation-complete) ;congratulations!
+ (values))))
+
+;;; Local Variables:
+;;; eval: (put 'converse 'scheme-indent-function 1)
+;;; eval: (put 'with-ellipsis 'scheme-indent-function 1)
+;;; End:
diff --git a/gnu/local.mk b/gnu/local.mk
index f2289518e5..702dc59b80 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
-# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Andreas Enge <andreas@enge.fr>
# Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
# Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Mark H Weaver <mhw@netris.org>
@@ -655,6 +655,7 @@ INSTALLER_MODULES = \
%D%/installer/record.scm \
%D%/installer/services.scm \
%D%/installer/steps.scm \
+ %D%/installer/tests.scm \
%D%/installer/timezone.scm \
%D%/installer/user.scm \
%D%/installer/utils.scm \
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index 335efbd468..8480c95fd6 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -26,10 +26,14 @@
#:use-module (gnu system install)
#:use-module (gnu system vm)
#:use-module ((gnu build vm) #:select (qemu-command))
+ #:use-module (gnu packages admin)
#:use-module (gnu packages bootloaders)
+ #:use-module (gnu packages cryptsetup)
+ #:use-module (gnu packages linux)
#:use-module (gnu packages ocr)
#:use-module (gnu packages package-management)
#:use-module (gnu packages virtualization)
+ #:use-module (gnu services networking)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix packages)
@@ -44,7 +48,9 @@
%test-raid-root-os
%test-encrypted-root-os
%test-btrfs-root-os
- %test-jfs-root-os))
+ %test-jfs-root-os
+
+ %test-gui-installed-os))
;;; Commentary:
;;;
@@ -179,6 +185,7 @@ reboot\n")
(define* (run-install target-os target-os-source
#:key
(script %simple-installation-script)
+ (gui-test #f)
(packages '())
(os (marionette-operating-system
(operating-system
@@ -191,6 +198,7 @@ reboot\n")
packages))
(kernel-arguments '("console=ttyS0")))
#:imported-modules '((gnu services herd)
+ (gnu installer tests)
(guix combinators))))
(installation-disk-image-file-system-type "ext4")
(target-size (* 2200 MiB)))
@@ -256,13 +264,21 @@ packages defined in installation-os."
(start 'term-tty1))
marionette)
- (marionette-eval '(call-with-output-file "/etc/target-config.scm"
- (lambda (port)
- (write '#$target-os-source port)))
- marionette)
+ (when #$(->bool script)
+ (marionette-eval '(call-with-output-file "/etc/target-config.scm"
+ (lambda (port)
+ (write '#$target-os-source port)))
+ marionette)
+ (exit (marionette-eval '(zero? (system #$script))
+ marionette)))
- (exit (marionette-eval '(zero? (system #$script))
- marionette)))))
+ (when #$(->bool gui-test)
+ (wait-for-unix-socket "/var/guix/installer-socket"
+ marionette)
+ (format #t "installer socket ready~%")
+ (force-output)
+ (exit #$(and gui-test
+ (gui-test #~marionette)))))))
(gexp->derivation "installation" install)))
@@ -890,4 +906,174 @@ build (current-guix) and then store a couple of full system images.")
(command (qemu-command/writable-image image)))
(run-basic-test %jfs-root-os command "jfs-root-os")))))
+\f
+;;;
+;;; Installation through the graphical interface.
+;;;
+
+(define %syslog-conf
+ ;; Syslog configuration that dumps to /dev/console, so we can see the
+ ;; installer's messages during the test.
+ (computed-file "syslog.conf"
+ #~(begin
+ (copy-file #$%default-syslog.conf #$output)
+ (chmod #$output #o644)
+ (let ((port (open-file #$output "a")))
+ (display "\n*.info /dev/console\n" port)
+ #t))))
+
+(define (operating-system-with-console-syslog os)
+ "Return OS with a syslog service that writes to /dev/console."
+ (operating-system
+ (inherit os)
+ (services (modify-services (operating-system-user-services os)
+ (syslog-service-type config
+ =>
+ (syslog-configuration
+ (inherit config)
+ (config-file %syslog-conf)))))))
+
+(define %root-password "foo")
+
+(define* (gui-test-program marionette #:key (encrypted? #f))
+ #~(let ()
+ (define (screenshot file)
+ (marionette-control (string-append "screendump " file)
+ #$marionette))
+
+ (setvbuf (current-output-port) 'none)
+ (setvbuf (current-error-port) 'none)
+
+ (marionette-eval '(use-modules (gnu installer tests))
+ #$marionette)
+
+ ;; Arrange so that 'converse' prints debugging output to the console.
+ (marionette-eval '(let ((console (open-output-file "/dev/console")))
+ (setvbuf console 'none)
+ (conversation-log-port console))
+ #$marionette)
+
+ ;; Tell the installer to not wait for the Connman "online" status.
+ (marionette-eval '(call-with-output-file "/tmp/installer-assume-online"
+ (const #t))
+ #$marionette)
+
+ ;; Run 'guix system init' with '--no-grafts', to cope with the lack of
+ ;; network access.
+ (marionette-eval '(call-with-output-file
+ "/tmp/installer-system-init-options"
+ (lambda (port)
+ (write '("--no-grafts" "--no-substitutes")
+ port)))
+ #$marionette)
+
+ (marionette-eval '(define installer-socket
+ (open-installer-socket))
+ #$marionette)
+ (screenshot "installer-start.ppm")
+
+ (marionette-eval '(choose-locale+keyboard installer-socket)
+ #$marionette)
+ (screenshot "installer-locale.ppm")
+
+ ;; Choose the host name that the "basic" test expects.
+ (marionette-eval '(enter-host-name+passwords installer-socket
+ #:host-name "liberigilo"
+ #:root-password
+ #$%root-password
+ #:users
+ '(("alice" "pass1")
+ ("bob" "pass2")))
+ #$marionette)
+ (screenshot "installer-services.ppm")
+
+ (marionette-eval '(choose-services installer-socket
+ #:desktop-environments '()
+ #:choose-network-service?
+ (const #f))
+ #$marionette)
+ (screenshot "installer-partitioning.ppm")
+
+ (marionette-eval '(choose-partitioning installer-socket
+ #:encrypted? #$encrypted?
+ #:passphrase #$%luks-passphrase)
+ #$marionette)
+ (screenshot "installer-run.ppm")
+
+ (marionette-eval '(conclude-installation installer-socket)
+ #$marionette)
+
+ (sync)
+ #t))
+
+(define %extra-packages
+ ;; Packages needed when installing with an encrypted root.
+ (list isc-dhcp
+ lvm2-static cryptsetup-static e2fsck/static
+ loadkeys-static))
+
+(define installation-os-for-gui-tests
+ ;; Operating system that contains all of %EXTRA-PACKAGES, needed for the
+ ;; target OS, as well as syslog output redirected to the console so we can
+ ;; see what the installer is up to.
+ (marionette-operating-system
+ (operating-system
+ (inherit (operating-system-with-console-syslog
+ (operating-system-add-packages
+ (operating-system-with-current-guix
+ installation-os)
+ %extra-packages)))
+ (kernel-arguments '("console=ttyS0")))
+ #:imported-modules '((gnu services herd)
+ (gnu installer tests)
+ (guix combinators))))
+
+(define* (guided-installation-test name #:key encrypted?)
+ (define os
+ (operating-system
+ (inherit %minimal-os)
+ (users (append (list (user-account
+ (name "alice")
+ (comment "Bob's sister")
+ (group "users")
+ (supplementary-groups
+ '("wheel" "audio" "video")))
+ (user-account
+ (name "bob")
+ (comment "Alice's brother")
+ (group "users")
+ (supplementary-groups
+ '("wheel" "audio" "video"))))
+ %base-user-accounts))
+ (swap-devices '("/dev/vdb2"))
+ (services (cons (service dhcp-client-service-type)
+ (operating-system-user-services %minimal-os)))))
+
+ (system-test
+ (name name)
+ (description
+ "Install an OS using the graphical installer and test it.")
+ (value
+ (mlet* %store-monad ((image (run-install os '(this is unused)
+ #:script #f
+ #:os installation-os-for-gui-tests
+ #:gui-test
+ (lambda (marionette)
+ (gui-test-program
+ marionette
+ #:encrypted? encrypted?))))
+ (command (qemu-command/writable-image image)))
+ (run-basic-test os command name
+ #:initialization (and encrypted? enter-luks-passphrase)
+ #:root-password %root-password)))))
+
+(define %test-gui-installed-os
+ (guided-installation-test "gui-installed-os"
+ #:encrypted? #f))
+
+;; (define %test-gui-installed-os
+;; ;; FIXME: Fails due to <https://bugs.gnu.org/39712>.
+;; (guided-installation-test "gui-installed-os-encrypted"
+;; #:encrypted? #t))
+
;;; install.scm ends here
--
2.25.1
^ permalink raw reply related [flat|nested] 10+ messages in thread