From 63b8c089c1596cd3e814ac13e1a8b3fa45bb2b54 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Jan 2020 22:57:14 +0100 Subject: 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. --- gnu/installer/newt/user.scm | 64 +++++++++++++++++++++++++++------------------ 1 file changed, 39 insertions(+), 25 deletions(-) (limited to 'gnu/installer/newt/user.scm') 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 -;;; Copyright © 2019 Ludovic Courtès +;;; Copyright © 2019, 2020 Ludovic Courtès ;;; Copyright © 2019 Tobias Geerinckx-Rice ;;; ;;; 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)))))) -- cgit 1.4.1