From unknown Tue Sep 09 21:33:03 2025 X-Loop: help-debbugs@gnu.org Subject: [bug#39729] [PATCH 0/7] Testing the graphical installer Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: m.othacehe@gmail.com, guix-patches@gnu.org Resent-Date: Fri, 21 Feb 2020 23:18:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 39729 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 39729@debbugs.gnu.org Cc: Ludovic =?UTF-8?Q?Court=C3=A8s?= , Mathieu Othacehe X-Debbugs-Original-To: guix-patches@gnu.org X-Debbugs-Original-Xcc: Mathieu Othacehe Received: via spool by submit@debbugs.gnu.org id=B.15823270301530 (code B ref -1); Fri, 21 Feb 2020 23:18:02 +0000 Received: (at submit) by debbugs.gnu.org; 21 Feb 2020 23:17:10 +0000 Received: from localhost ([127.0.0.1]:48381 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j5HXi-0000Oc-2t for submit@debbugs.gnu.org; Fri, 21 Feb 2020 18:17:10 -0500 Received: from lists.gnu.org ([209.51.188.17]:38813) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j5HXf-0000OT-JH for submit@debbugs.gnu.org; Fri, 21 Feb 2020 18:17:09 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:47629) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1j5HXd-0003ZW-5Q for guix-patches@gnu.org; Fri, 21 Feb 2020 18:17:07 -0500 X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org X-Spam-Level: X-Spam-Status: No, score=-1.5 required=5.0 tests=ALL_TRUSTED,BAYES_05, URIBL_BLOCKED autolearn=disabled version=3.3.2 Received: from fencepost.gnu.org ([2001:470:142:3::e]:44440) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1j5HXd-0006fx-1A; Fri, 21 Feb 2020 18:17:05 -0500 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=40966 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1j5HXc-0000dz-3u; Fri, 21 Feb 2020 18:17:04 -0500 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Sat, 22 Feb 2020 00:16:52 +0100 Message-Id: <20200221231652.27632-1-ludo@gnu.org> X-Mailer: git-send-email 2.25.1 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -0.7 (/) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.7 (-) Hello! Here’s a test for the graphical installer, as discussed earlier at: https://lists.gnu.org/archive/html/guix-devel/2020-01/msg00407.html The first part of this patch series implements client support in the installer as discussed above (only more robust to multiple clients, disconnections, etc.). A dirty bit there is the ‘close-port-and-reuse-fd’ hack, which works around the fact that Newt does not provide a ‘form-unwatch-fd’ procedure. Good enough for now! There are also two hacks to (1) skip connectivity checks and (2) to pass ‘--no-grafts’ to ‘guix system init’. The second part implements the actual test. The new (gnu installer tests) module provides tools to implement a dialogue with the installer, and the new “gui-installed-os” test uses it to perform a bare-bones style installation. There’s a commented out variant that does it on an encrypted root, but it currently fails presumably due to . That’s it! Feedback welcome! Ludo’. PS: This patch series is also available as ‘wip-installer-test’. Ludovic Courtès (7): tests: 'run-basic-test' can enter a root password. installer: Use a Guile-Newt snapshot that supports 'form-watch-fd'. installer: Implement a dialog on /var/guix/installer-socket. installer: Bypass connectivity check when /tmp/installer-assume-online exists. installer: Run commands without hopping through the shell. installer: Honor /tmp/installer-system-init-options. tests: install: Add "gui-installed-os". gnu/installer.scm | 21 ++ gnu/installer/final.scm | 21 +- gnu/installer/newt/final.scm | 40 ++- gnu/installer/newt/network.scm | 10 +- gnu/installer/newt/page.scm | 569 ++++++++++++++++++++----------- 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/tests.scm | 340 ++++++++++++++++++ gnu/installer/utils.scm | 152 +++++++-- gnu/local.mk | 3 +- gnu/tests/base.scm | 23 +- gnu/tests/install.scm | 200 ++++++++++- 14 files changed, 1212 insertions(+), 308 deletions(-) create mode 100644 gnu/installer/tests.scm -- 2.25.1 From unknown Tue Sep 09 21:33:03 2025 X-Loop: help-debbugs@gnu.org Subject: [bug#39729] [PATCH 1/7] tests: 'run-basic-test' can enter a root password. References: <20200221231652.27632-1-ludo@gnu.org> In-Reply-To: <20200221231652.27632-1-ludo@gnu.org> Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 21 Feb 2020 23:21:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 39729 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 39729@debbugs.gnu.org Cc: Ludovic =?UTF-8?Q?Court=C3=A8s?= Received: via spool by 39729-submit@debbugs.gnu.org id=B39729.15823272511923 (code B ref 39729); Fri, 21 Feb 2020 23:21:02 +0000 Received: (at 39729) by debbugs.gnu.org; 21 Feb 2020 23:20:51 +0000 Received: from localhost ([127.0.0.1]:48388 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j5HbG-0000Ux-Mr for submit@debbugs.gnu.org; Fri, 21 Feb 2020 18:20:50 -0500 Received: from eggs.gnu.org ([209.51.188.92]:32920) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j5HbE-0000UY-TT for 39729@debbugs.gnu.org; Fri, 21 Feb 2020 18:20:49 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]:44531) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1j5Hb9-0008Al-OM; Fri, 21 Feb 2020 18:20:43 -0500 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=40974 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1j5Hb9-0000vc-8D; Fri, 21 Feb 2020 18:20:43 -0500 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Sat, 22 Feb 2020 00:20:24 +0100 Message-Id: <20200221232030.27752-1-ludo@gnu.org> X-Mailer: git-send-email 2.25.1 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -0.7 (/) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.7 (-) * gnu/tests/base.scm (run-basic-test): Add #:root-password and honor it. --- gnu/tests/base.scm | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index a891711844..37b83dc7ec 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2018 Clément Lassieur ;;; ;;; This file is part of GNU Guix. @@ -55,7 +55,7 @@ (define* (run-basic-test os command #:optional (name "basic") - #:key initialization) + #:key initialization root-password) "Return a derivation called NAME that tests basic features of the OS started using COMMAND, a gexp that evaluates to a list of strings. Compare some properties of running system to what's declared in OS, an . @@ -63,7 +63,10 @@ properties of running system to what's declared in OS, an . When INITIALIZATION is true, it must be a one-argument procedure that is passed a gexp denoting the marionette, and it must return gexp that is inserted before the first test. This is used to introduce an extra -initialization step, such as entering a LUKS passphrase." +initialization step, such as entering a LUKS passphrase. + +When ROOT-PASSWORD is true, enter it as the root password when logging in. +Otherwise assume that there is no password for root." (define special-files (service-value (fold-services (operating-system-services os) @@ -300,7 +303,19 @@ info --version") marionette) ;; Now we can type. - (marionette-type "root\n\nid -un > logged-in\n" marionette) + (let ((password #$root-password)) + (if password + (begin + (marionette-type "root\n" marionette) + (wait-for-screen-text marionette + (lambda (text) + (string-contains text "Password")) + #:ocrad + #$(file-append ocrad "/bin/ocrad")) + (marionette-type (string-append password "\n\n") + marionette)) + (marionette-type "root\n\n" marionette))) + (marionette-type "id -un > logged-in\n" marionette) ;; It can take a while before the shell commands are executed. (marionette-eval '(use-modules (rnrs io ports)) marionette) -- 2.25.1 From unknown Tue Sep 09 21:33:03 2025 X-Loop: help-debbugs@gnu.org Subject: [bug#39729] [PATCH 2/7] installer: Use a Guile-Newt snapshot that supports 'form-watch-fd'. Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 21 Feb 2020 23:21:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 39729 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 39729@debbugs.gnu.org Cc: Ludovic =?UTF-8?Q?Court=C3=A8s?= Received: via spool by 39729-submit@debbugs.gnu.org id=B39729.15823272541949 (code B ref 39729); Fri, 21 Feb 2020 23:21:02 +0000 Received: (at 39729) by debbugs.gnu.org; 21 Feb 2020 23:20:54 +0000 Received: from localhost ([127.0.0.1]:48393 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j5HbK-0000VM-18 for submit@debbugs.gnu.org; Fri, 21 Feb 2020 18:20:54 -0500 Received: from eggs.gnu.org ([209.51.188.92]:32923) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j5HbG-0000Ua-0R for 39729@debbugs.gnu.org; Fri, 21 Feb 2020 18:20:50 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]:44532) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1j5HbA-0008BM-Tp; Fri, 21 Feb 2020 18:20:44 -0500 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=40974 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1j5HbA-0000vc-3x; Fri, 21 Feb 2020 18:20:44 -0500 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Sat, 22 Feb 2020 00:20:25 +0100 Message-Id: <20200221232030.27752-2-ludo@gnu.org> X-Mailer: git-send-email 2.25.1 In-Reply-To: <20200221232030.27752-1-ludo@gnu.org> References: <20200221232030.27752-1-ludo@gnu.org> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -0.7 (/) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.7 (-) * 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 From unknown Tue Sep 09 21:33:03 2025 X-Loop: help-debbugs@gnu.org Subject: [bug#39729] [PATCH 4/7] installer: Bypass connectivity check when /tmp/installer-assume-online exists. Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 21 Feb 2020 23:21:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 39729 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 39729@debbugs.gnu.org Cc: Ludovic =?UTF-8?Q?Court=C3=A8s?= Received: via spool by 39729-submit@debbugs.gnu.org id=B39729.15823272541956 (code B ref 39729); Fri, 21 Feb 2020 23:21:02 +0000 Received: (at 39729) by debbugs.gnu.org; 21 Feb 2020 23:20:54 +0000 Received: from localhost ([127.0.0.1]:48395 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j5HbK-0000VO-Ad for submit@debbugs.gnu.org; Fri, 21 Feb 2020 18:20:54 -0500 Received: from eggs.gnu.org ([209.51.188.92]:32929) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j5HbI-0000Ue-Gt for 39729@debbugs.gnu.org; Fri, 21 Feb 2020 18:20:52 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]:44534) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1j5HbD-0008Fb-Dd; Fri, 21 Feb 2020 18:20:47 -0500 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=40974 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1j5HbC-0000vc-U7; Fri, 21 Feb 2020 18:20:47 -0500 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Sat, 22 Feb 2020 00:20:27 +0100 Message-Id: <20200221232030.27752-4-ludo@gnu.org> X-Mailer: git-send-email 2.25.1 In-Reply-To: <20200221232030.27752-1-ludo@gnu.org> References: <20200221232030.27752-1-ludo@gnu.org> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -0.7 (/) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.7 (-) 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 -;;; Copyright © 2019 Ludovic Courtès +;;; Copyright © 2019, 2020 Ludovic Courtès ;;; ;;; 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 From unknown Tue Sep 09 21:33:03 2025 X-Loop: help-debbugs@gnu.org Subject: [bug#39729] [PATCH 3/7] installer: Implement a dialog on /var/guix/installer-socket. Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 21 Feb 2020 23:21:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 39729 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 39729@debbugs.gnu.org Cc: Ludovic =?UTF-8?Q?Court=C3=A8s?= Received: via spool by 39729-submit@debbugs.gnu.org id=B39729.15823272561971 (code B ref 39729); Fri, 21 Feb 2020 23:21:03 +0000 Received: (at 39729) by debbugs.gnu.org; 21 Feb 2020 23:20:56 +0000 Received: from localhost ([127.0.0.1]:48398 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j5HbK-0000VX-KW for submit@debbugs.gnu.org; Fri, 21 Feb 2020 18:20:56 -0500 Received: from eggs.gnu.org ([209.51.188.92]:32926) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j5HbH-0000Uc-NV for 39729@debbugs.gnu.org; Fri, 21 Feb 2020 18:20:53 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]:44533) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1j5HbC-0008DI-I7; Fri, 21 Feb 2020 18:20:46 -0500 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=40974 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1j5HbB-0000vc-9o; Fri, 21 Feb 2020 18:20:46 -0500 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Sat, 22 Feb 2020 00:20:26 +0100 Message-Id: <20200221232030.27752-3-ludo@gnu.org> X-Mailer: git-send-email 2.25.1 In-Reply-To: <20200221232030.27752-1-ludo@gnu.org> References: <20200221232030.27752-1-ludo@gnu.org> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -0.7 (/) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.7 (-) 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 . (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-localetext item))) - listbox-items)) - (sorted-items - (sort items (lambda (a b) - (let ((text-a (cdr a)) - (text-b (cdr b))) - (string-localetext item))) + listbox-items)) + (sorted-items + (sort items (lambda (a b) + (let ((text-a (cdr a)) + (text-b (cdr b))) + (string-locale) 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 -;;; Copyright © 2019 Ludovic Courtès +;;; Copyright © 2019, 2020 Ludovic Courtès ;;; Copyright © 2020 Tobias Geerinckx-Rice ;;; ;;; 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 -;;; 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)))))) 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 +;;; Copyright © 2020 Ludovic Courtès ;;; ;;; 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 . (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 +;;; Copyright © 2020 Ludovic Courtès ;;; ;;; 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 ...)))))) + + +;;; +;;; 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 From unknown Tue Sep 09 21:33:03 2025 X-Loop: help-debbugs@gnu.org Subject: [bug#39729] [PATCH 5/7] installer: Run commands without hopping through the shell. Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 21 Feb 2020 23:21:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 39729 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 39729@debbugs.gnu.org Cc: Ludovic =?UTF-8?Q?Court=C3=A8s?= Received: via spool by 39729-submit@debbugs.gnu.org id=B39729.15823272571979 (code B ref 39729); Fri, 21 Feb 2020 23:21:03 +0000 Received: (at 39729) by debbugs.gnu.org; 21 Feb 2020 23:20:57 +0000 Received: from localhost ([127.0.0.1]:48401 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j5HbM-0000Vk-CP for submit@debbugs.gnu.org; Fri, 21 Feb 2020 18:20:57 -0500 Received: from eggs.gnu.org ([209.51.188.92]:32936) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j5HbJ-0000Uh-Cc for 39729@debbugs.gnu.org; Fri, 21 Feb 2020 18:20:53 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]:44535) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1j5HbE-0008G5-8t; Fri, 21 Feb 2020 18:20:48 -0500 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=40974 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1j5HbD-0000vc-PW; Fri, 21 Feb 2020 18:20:48 -0500 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Sat, 22 Feb 2020 00:20:28 +0100 Message-Id: <20200221232030.27752-5-ludo@gnu.org> X-Mailer: git-send-email 2.25.1 In-Reply-To: <20200221232030.27752-1-ludo@gnu.org> References: <20200221232030.27752-1-ludo@gnu.org> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -0.7 (/) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.7 (-) * 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 -;;; Copyright © 2019 Ludovic Courtès +;;; Copyright © 2019, 2020 Ludovic Courtès ;;; ;;; 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)) ;;; -- 2.25.1 From unknown Tue Sep 09 21:33:03 2025 X-Loop: help-debbugs@gnu.org Subject: [bug#39729] [PATCH 6/7] installer: Honor /tmp/installer-system-init-options. Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 21 Feb 2020 23:21:04 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 39729 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 39729@debbugs.gnu.org Cc: Ludovic =?UTF-8?Q?Court=C3=A8s?= Received: via spool by 39729-submit@debbugs.gnu.org id=B39729.15823272622031 (code B ref 39729); Fri, 21 Feb 2020 23:21:04 +0000 Received: (at 39729) by debbugs.gnu.org; 21 Feb 2020 23:21:02 +0000 Received: from localhost ([127.0.0.1]:48403 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j5HbS-0000Wa-3Y for submit@debbugs.gnu.org; Fri, 21 Feb 2020 18:21:02 -0500 Received: from eggs.gnu.org ([209.51.188.92]:32940) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j5HbK-0000Um-Bv for 39729@debbugs.gnu.org; Fri, 21 Feb 2020 18:20:54 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]:44537) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1j5HbF-0008GX-9E; Fri, 21 Feb 2020 18:20:49 -0500 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=40974 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1j5HbE-0000vc-Ky; Fri, 21 Feb 2020 18:20:48 -0500 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Sat, 22 Feb 2020 00:20:29 +0100 Message-Id: <20200221232030.27752-6-ludo@gnu.org> X-Mailer: git-send-email 2.25.1 In-Reply-To: <20200221232030.27752-1-ludo@gnu.org> References: <20200221232030.27752-1-ludo@gnu.org> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -0.7 (/) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.7 (-) * 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 From unknown Tue Sep 09 21:33:03 2025 X-Loop: help-debbugs@gnu.org Subject: [bug#39729] [PATCH 7/7] tests: install: Add "gui-installed-os". Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 21 Feb 2020 23:21:04 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 39729 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 39729@debbugs.gnu.org Cc: Ludovic =?UTF-8?Q?Court=C3=A8s?= Received: via spool by 39729-submit@debbugs.gnu.org id=B39729.15823272632056 (code B ref 39729); Fri, 21 Feb 2020 23:21:04 +0000 Received: (at 39729) by debbugs.gnu.org; 21 Feb 2020 23:21:03 +0000 Received: from localhost ([127.0.0.1]:48406 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j5HbS-0000Wi-Ee for submit@debbugs.gnu.org; Fri, 21 Feb 2020 18:21:03 -0500 Received: from eggs.gnu.org ([209.51.188.92]:32942) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j5HbL-0000Uw-Eu for 39729@debbugs.gnu.org; Fri, 21 Feb 2020 18:20:57 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]:44538) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1j5HbG-0008H4-Ad; Fri, 21 Feb 2020 18:20:50 -0500 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=40974 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1j5HbF-0000vc-L9; Fri, 21 Feb 2020 18:20:50 -0500 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Sat, 22 Feb 2020 00:20:30 +0100 Message-Id: <20200221232030.27752-7-ludo@gnu.org> X-Mailer: git-send-email 2.25.1 In-Reply-To: <20200221232030.27752-1-ludo@gnu.org> References: <20200221232030.27752-1-ludo@gnu.org> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -0.7 (/) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.7 (-) * 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 +;;; +;;; 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 . + +(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 +# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès # Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Andreas Enge # Copyright © 2016 Mathieu Lirzin # Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Mark H Weaver @@ -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"))))) + +;;; +;;; 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 . +;; (guided-installation-test "gui-installed-os-encrypted" +;; #:encrypted? #t)) + ;;; install.scm ends here -- 2.25.1 From unknown Tue Sep 09 21:33:03 2025 X-Loop: help-debbugs@gnu.org Subject: [bug#39729] [PATCH 0/7] Testing the graphical installer Resent-From: Mathieu Othacehe Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 27 Feb 2020 16:11:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 39729 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 39729@debbugs.gnu.org, Cc: Ludovic =?UTF-8?Q?Court=C3=A8s?= Received: via spool by 39729-submit@debbugs.gnu.org id=B39729.1582819853440 (code B ref 39729); Thu, 27 Feb 2020 16:11:01 +0000 Received: (at 39729) by debbugs.gnu.org; 27 Feb 2020 16:10:53 +0000 Received: from localhost ([127.0.0.1]:60152 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j7LkT-000072-16 for submit@debbugs.gnu.org; Thu, 27 Feb 2020 11:10:53 -0500 Received: from mail-wm1-f68.google.com ([209.85.128.68]:39481) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j7LkR-00006h-7J for 39729@debbugs.gnu.org; Thu, 27 Feb 2020 11:10:51 -0500 Received: by mail-wm1-f68.google.com with SMTP id c84so4136287wme.4 for <39729@debbugs.gnu.org>; Thu, 27 Feb 2020 08:10:51 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=references:user-agent:from:to:cc:subject:in-reply-to:date :message-id:mime-version:content-transfer-encoding; bh=0cS0xvauuZfiiCVcZY0Im62RCaUvR6BElRWKH0NvnR0=; b=Jt2mimo040B6ieCtgGlccaFDa9FuFEc5UCjifSJlEAQ1wBiEJo1oRUKlgMH91dxsOw GMc14BrkfNrKubqc1rHOJlhm3jwNSDgQvsVPsfFpAneLzdA1k1bm6iyE0KpAwfUZxhI8 4G2e+2BBiw7LIlolvKA01x7AWi1jPc+jcM7jXp8L90+LoliEOdXKStogr1EPX7fK85qL ctdnOaje8TEMTU52t4MLBQZHPwruyWhprrBjY04twJR/itIKWbIOqioy7GwsjHm2+Tm0 vEjzC+BClC5uMGYXAj+x1+RU6zLXMx9NmF5t1ajOi5WLMv6SZEOWvgUMZiBrNMNQirth 0s1Q== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:references:user-agent:from:to:cc:subject :in-reply-to:date:message-id:mime-version:content-transfer-encoding; bh=0cS0xvauuZfiiCVcZY0Im62RCaUvR6BElRWKH0NvnR0=; b=eJ1nTw4kpoxI+oMIpJ8DPTrtuzMlWbTgAnDMxdk6E1UOewsy+O/spIw1vn77mdk5jd 82b9CVb5It2MNWZICcTvYTu5CQUtnGBtY/ikO85admum9yJj+etAncb8yrF2rpsnNcSX YxCJIfKKRL7FsLb/IVjnR+XMrPgtxlRU1T0cXP8yr9XePl6rTrNiCVPFoR9Z+Wul4u2O PPGgk0g5lVz6DPcv6vKbw5zkKD9mniknW2BYbFufMOV4fboh3DxCW3c3EAY7oH9UOU2G 9K3NtQhj8jz44ZDpxzO/hyWYQc1cNRLPIwX3lVaaORVtqwKXnjbrWRIpmPwjEzosw09g Pieg== X-Gm-Message-State: APjAAAVQy6R7Kev/YFm1V8Hk9BPWdFnKMMPke/kd5wETEu3Gn1ZJ+z1Y fKQ6ftzQ3NvSXkqhd5moaZJsu5hb X-Google-Smtp-Source: APXvYqxdnF5A1sdEOHVUdy0+RJ0X5O9DoGro3sHJCBMpKPMiaIsP2IZ7038Ir9XPyTnsq9MxcBpziw== X-Received: by 2002:a7b:c7d4:: with SMTP id z20mr262061wmk.48.1582819844276; Thu, 27 Feb 2020 08:10:44 -0800 (PST) Received: from meru (lfbn-ann-1-292-23.w86-200.abo.wanadoo.fr. [86.200.245.23]) by smtp.gmail.com with ESMTPSA id o15sm8824899wra.83.2020.02.27.08.10.43 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 27 Feb 2020 08:10:43 -0800 (PST) References: <20200221231652.27632-1-ludo@gnu.org> User-agent: mu4e 1.2.0; emacs 26.3 From: Mathieu Othacehe In-reply-to: <20200221231652.27632-1-ludo@gnu.org> Date: Thu, 27 Feb 2020 17:10:42 +0100 Message-ID: <87mu946mf1.fsf@gmail.com> MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-Spam-Score: 0.0 (/) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) Hey! > The second part implements the actual test. The new (gnu installer > tests) module provides tools to implement a dialogue with the installer, > and the new =E2=80=9Cgui-installed-os=E2=80=9D test uses it to perform a = bare-bones > style installation. There=E2=80=99s a commented out variant that does it= on > an encrypted root, but it currently fails presumably due to > . > > That=E2=80=99s it! > > Feedback welcome! This serie LGTM, this is really impressive :) About the umounting issue, you were right. Umounting failed for both %test-gui-installed-os and %test-gui-installed-os-encrypted. The issue was that guix-daemon was keeping open files inside the cow-store, preventing the umount. I discovered then a second issue, some udevd workers, started while the cow-store was active were also preventing the umounting. I published a few patches on top of yours on wip-installer-test to fix those issues. Thanks, Mathieu PS: I had a hard time debugging the marionette, couldn't find better to add some syslog, wait an hour to test & repeat. Do you have a better approach? Would it be possible to have a debug ssh in the marionette? From unknown Tue Sep 09 21:33:03 2025 X-Loop: help-debbugs@gnu.org Subject: [bug#39729] [PATCH 0/7] Testing the graphical installer Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 05 Mar 2020 22:47:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 39729 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: Mathieu Othacehe Cc: 39729@debbugs.gnu.org Received: via spool by 39729-submit@debbugs.gnu.org id=B39729.158344840112031 (code B ref 39729); Thu, 05 Mar 2020 22:47:02 +0000 Received: (at 39729) by debbugs.gnu.org; 5 Mar 2020 22:46:41 +0000 Received: from localhost ([127.0.0.1]:43856 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j9zGK-00037z-Rg for submit@debbugs.gnu.org; Thu, 05 Mar 2020 17:46:41 -0500 Received: from eggs.gnu.org ([209.51.188.92]:51214) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j9zGI-00037j-Lr for 39729@debbugs.gnu.org; Thu, 05 Mar 2020 17:46:38 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]:53496) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1j9zGC-0003Wr-Ha; Thu, 05 Mar 2020 17:46:33 -0500 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=33502 helo=ribbon) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1j9zGC-00039T-0C; Thu, 05 Mar 2020 17:46:32 -0500 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= References: <20200221231652.27632-1-ludo@gnu.org> <87mu946mf1.fsf@gmail.com> X-URL: http://www.fdn.fr/~lcourtes/ X-Revolutionary-Date: 16 =?UTF-8?Q?Vent=C3=B4se?= an 228 de la =?UTF-8?Q?R=C3=A9volution?= X-PGP-Key-ID: 0x090B11993D9AEBB5 X-PGP-Key: http://www.fdn.fr/~lcourtes/ludovic.asc X-PGP-Fingerprint: 3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5 X-OS: x86_64-pc-linux-gnu Date: Thu, 05 Mar 2020 23:46:27 +0100 In-Reply-To: <87mu946mf1.fsf@gmail.com> (Mathieu Othacehe's message of "Thu, 27 Feb 2020 17:10:42 +0100") Message-ID: <87o8ta5sjg.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.3 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -0.7 (/) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.7 (-) Hi Mathieu! Mathieu Othacehe skribis: >> The second part implements the actual test. The new (gnu installer >> tests) module provides tools to implement a dialogue with the installer, >> and the new =E2=80=9Cgui-installed-os=E2=80=9D test uses it to perform a= bare-bones >> style installation. There=E2=80=99s a commented out variant that does i= t on >> an encrypted root, but it currently fails presumably due to >> . >> >> That=E2=80=99s it! >> >> Feedback welcome! > > This serie LGTM, this is really impressive :) About the umounting issue, > you were right. Umounting failed for both %test-gui-installed-os and > %test-gui-installed-os-encrypted. > > The issue was that guix-daemon was keeping open files inside the > cow-store, preventing the umount. I discovered then a second issue, some > udevd workers, started while the cow-store was active were also > preventing the umounting. > > I published a few patches on top of yours on wip-installer-test to fix > those issues. Well done, woohoo! I=E2=80=99ve pushed the whole series on =E2=80=98master=E2=80=99, including= your bug fixes. We can think about writing installer tests for other configurations now. That should be the easy part. :-) > PS: I had a hard time debugging the marionette, couldn't find better to > add some syslog, wait an hour to test & repeat. Do you have a better > approach? Would it be possible to have a debug ssh in the marionette? I don=E2=80=99t really have a better approach. If you want to see the outp= ut of =E2=80=98guix system init=E2=80=99, you can redirect its stderr to /dev/con= sole (wrap the =E2=80=98invoke=E2=80=99 call in =E2=80=98with-error-to-file=E2=80=99),= and then you get a better idea of what=E2=80=99s going on. But that=E2=80=99s about it. SSH wouldn=E2=80=99t be very helpful because the test process is non-intera= ctive. Thanks! Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Thu Mar 05 17:46:59 2020 Received: (at control) by debbugs.gnu.org; 5 Mar 2020 22:46:59 +0000 Received: from localhost ([127.0.0.1]:43859 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j9zGd-00038W-4p for submit@debbugs.gnu.org; Thu, 05 Mar 2020 17:46:59 -0500 Received: from eggs.gnu.org ([209.51.188.92]:51248) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j9zGa-00038J-Uq for control@debbugs.gnu.org; Thu, 05 Mar 2020 17:46:57 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]:53500) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1j9zGV-0003m5-QZ for control@debbugs.gnu.org; Thu, 05 Mar 2020 17:46:51 -0500 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=33512 helo=ribbon) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1j9zGV-00039i-9v for control@debbugs.gnu.org; Thu, 05 Mar 2020 17:46:51 -0500 Date: Thu, 05 Mar 2020 23:46:47 +0100 Message-Id: <87mu8u5siw.fsf@gnu.org> To: control@debbugs.gnu.org From: =?utf-8?Q?Ludovic_Court=C3=A8s?= Subject: control message for bug #39729 MIME-version: 1.0 Content-type: text/plain; charset=utf-8 Content-Transfer-Encoding: 8bit X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -0.7 (/) X-Debbugs-Envelope-To: control X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.7 (-) tags 39729 fixed close 39729 quit