From debbugs-submit-bounces@debbugs.gnu.org Sat Jan 15 08:51:14 2022 Received: (at 53063) by debbugs.gnu.org; 15 Jan 2022 13:51:14 +0000 Received: from localhost ([127.0.0.1]:39537 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1n8jSc-0001sK-1a for submit@debbugs.gnu.org; Sat, 15 Jan 2022 08:51:14 -0500 Received: from jpoiret.xyz ([206.189.101.64]:49552) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1n8jS2-0001nt-1l for 53063@debbugs.gnu.org; Sat, 15 Jan 2022 08:50:39 -0500 Received: from authenticated-user (jpoiret.xyz [206.189.101.64]) by jpoiret.xyz (Postfix) with ESMTPA id 4AC9018506C; Sat, 15 Jan 2022 13:50:37 +0000 (UTC) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=jpoiret.xyz; s=dkim; t=1642254637; h=from:from:reply-to:subject:subject:date:date:message-id:message-id: to:to:cc:cc:mime-version:mime-version: content-transfer-encoding:content-transfer-encoding: in-reply-to:in-reply-to:references:references; bh=XoMruz0Kia1JiWglX8fML55Af/g72LAyaRJJM254d7Y=; b=HRMmXNG2EJKWazI/zQBGUrkWt/QX4V6TTPVD/sc1WXbYnIbvznFljvGne2JREPqySBIy0Q Ggu9zYaz1zUZSlWqLPIaLOS3cNl7RdWK0Z/UgDHENytNTdMjyg7JgTK95eyv03gNJn5ppo t9GYoSyWpGOEZ6kv/IGaCED1FaK7/HUoTu4ZFkCoY11rWHNSNYW4BeWEaSH+vQHuVAIf+z ahewc9sUD1xLQYXTnZN2ePDDKjwzrqixUCP0hIZOxdkZWPBWiLu+WU5o5MLNuIIjq7VH9a ZL92PFsP5MBLooLLM5EvEZ7y39W/oOhHjpUM/x/pqiLvdbeGH/TZZ5IH9NB+4g== From: Josselin Poiret To: Mathieu Othacehe Subject: [PATCH v2 wip-harden-installer 15/18] installer: Add error page when running external commands. Date: Sat, 15 Jan 2022 14:50:08 +0100 Message-Id: <20220115135011.5817-16-dev@jpoiret.xyz> In-Reply-To: <20220115135011.5817-1-dev@jpoiret.xyz> References: <8735lz4xsv.fsf@gnu.org> <20220115135011.5817-1-dev@jpoiret.xyz> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spamd-Bar: / Authentication-Results: jpoiret.xyz; auth=pass smtp.auth=jpoiret@jpoiret.xyz smtp.mailfrom=dev@jpoiret.xyz X-Spam-Score: 2.5 (++) X-Spam-Report: Spam detection software, running on the system "debbugs.gnu.org", has NOT identified this incoming email as spam. The original message has been attached to this so you can view it or label similar future email. If you have any questions, see the administrator of that system for details. Content preview: * gnu/installer/newt.scm (newt-run-command): Add it. * gnu/installer/newt/page.scm (%ok-button, %exit-button, %default-buttons, make-newt-buttons, run-textbox-page): Add them. --- gnu/installer/newt.s [...] Content analysis details: (2.5 points, 10.0 required) pts rule name description ---- ---------------------- -------------------------------------------------- -0.0 SPF_HELO_PASS SPF: HELO matches SPF record 2.0 PDS_OTHER_BAD_TLD Untrustworthy TLDs [URI: jpoiret.xyz (xyz)] -0.0 SPF_PASS SPF: sender matches SPF record 0.5 FROM_SUSPICIOUS_NTLD From abused NTLD X-Debbugs-Envelope-To: 53063 Cc: 53063@debbugs.gnu.org, ludo@gnu.org, Josselin Poiret 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.5 (+) X-Spam-Report: Spam detection software, running on the system "debbugs.gnu.org", has NOT identified this incoming email as spam. The original message has been attached to this so you can view it or label similar future email. If you have any questions, see the administrator of that system for details. Content preview: * gnu/installer/newt.scm (newt-run-command): Add it. * gnu/installer/newt/page.scm (%ok-button, %exit-button, %default-buttons, make-newt-buttons, run-textbox-page): Add them. --- gnu/installer/newt.s [...] Content analysis details: (1.5 points, 10.0 required) pts rule name description ---- ---------------------- -------------------------------------------------- -0.0 SPF_HELO_PASS SPF: HELO matches SPF record 2.0 PDS_OTHER_BAD_TLD Untrustworthy TLDs [URI: jpoiret.xyz (xyz)] -0.0 SPF_PASS SPF: sender matches SPF record 0.5 FROM_SUSPICIOUS_NTLD From abused NTLD -1.0 MAILING_LIST_MULTI Multiple indicators imply a widely-seen list manager * gnu/installer/newt.scm (newt-run-command): Add it. * gnu/installer/newt/page.scm (%ok-button, %exit-button, %default-buttons, make-newt-buttons, run-textbox-page): Add them. --- gnu/installer/newt.scm | 54 +++++++++++++++++++++--- gnu/installer/newt/page.scm | 83 +++++++++++++++++++++++++++++++++++++ 2 files changed, 132 insertions(+), 5 deletions(-) diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index fc851339d1..352d2997bd 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -41,6 +41,8 @@ (define-module (gnu installer newt) #:use-module (guix discovery) #:use-module (guix i18n) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (newt) #:export (newt-installer)) @@ -80,11 +82,53 @@ (define (exit-error file report key args) (clear-screen)) (define (newt-run-command . args) - (newt-suspend) - (clear-screen) - (define result (run-command args)) - (newt-resume) - result) + (define command-output "") + (define (line-accumulator line) + (set! command-output + (string-append/shared command-output line "\n"))) + (define displayed-command + (string-join + (map (lambda (s) (string-append "\"" s "\"")) args) + " ")) + (define result (run-external-command-with-line-hooks (list line-accumulator) + args)) + (define exit-val (status:exit-val result)) + (define term-sig (status:term-sig result)) + (define stop-sig (status:stop-sig result)) + + (if (and exit-val (zero? exit-val)) + #t + (let ((info-text + (cond + (exit-val + (format #f (G_ "External command ~s exited with code ~a") + args exit-val)) + (term-sig + (format #f (G_ "External command ~s terminated by signal ~a") + args term-sig)) + (stop-sig + (format #f (G_ "External command ~s stopped by signal ~a") + args stop-sig))))) + (run-textbox-page #:title (G_ "External command error") + #:info-text info-text + #:content command-output + #:buttons-spec + (list + (cons "Ignore" (const #t)) + (cons "Abort" + (lambda () + (abort-to-prompt 'installer-step 'abort))) + (cons "Dump" + (lambda () + (raise + (condition + ((@@ (guix build utils) + &invoke-error) + (program (car args)) + (arguments (cdr args)) + (exit-status exit-val) + (term-signal term-sig) + (stop-signal stop-sig))))))))))) (define (final-page result prev-steps) (run-final-page result prev-steps)) diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm index 8c675fa837..b5d7c98094 100644 --- a/gnu/installer/newt/page.scm +++ b/gnu/installer/newt/page.scm @@ -44,6 +44,9 @@ (define-module (gnu installer newt page) run-scale-page run-checkbox-tree-page run-file-textbox-page + %ok-button + %exit-button + run-textbox-page run-form-with-clients)) @@ -816,3 +819,83 @@ (define result (components=? argument edit-button)) (loop) ;recurse in tail position result))))) + +(define %ok-button + (cons (G_ "Ok") (lambda () #t))) + +(define %exit-button + (cons (G_ "Exit") (lambda () (abort-to-prompt 'installer-step 'abort)))) + +(define %default-buttons + (list %ok-button %exit-button)) + +(define (make-newt-buttons buttons-spec) + (map + (match-lambda ((title . proc) + (cons (make-button -1 -1 title) proc))) + buttons-spec)) + +(define* (run-textbox-page #:key + title + info-text + content + (buttons-spec %default-buttons)) + "Run a page to display INFO-TEXT followed by CONTENT to the user, who has to +choose an action among the buttons specified by BUTTONS-SPEC. + +BUTTONS-SPEC is an association list with button labels as keys, and callback +procedures as values. + +This procedure returns the result of the callback procedure of the button +chosen by the user." + (define info-textbox + (make-reflowed-textbox -1 -1 info-text + 50 + #:flags FLAG-BORDER)) + (define content-textbox + (make-textbox -1 -1 + 50 + 30 + (logior FLAG-SCROLL FLAG-BORDER))) + (define buttons + (make-newt-buttons buttons-spec)) + (define grid + (vertically-stacked-grid + GRID-ELEMENT-COMPONENT info-textbox + GRID-ELEMENT-COMPONENT content-textbox + GRID-ELEMENT-SUBGRID + (apply + horizontal-stacked-grid + (append-map (match-lambda ((button . proc) + (list GRID-ELEMENT-COMPONENT button))) + buttons)))) + (define form (make-form #:flags FLAG-NOF12)) + (add-form-to-grid grid form #t) + (make-wrapped-grid-window grid title) + (set-textbox-text content-textbox + (receive (_w _h text) + (reflow-text content + 50 + 0 0) + text)) + + (receive (exit-reason argument) + (run-form-with-clients form + `(contents-dialog (title ,title) + (text ,info-text) + (content ,content))) + (destroy-form-and-pop form) + (match exit-reason + ('exit-component + (let ((proc (assq-ref buttons argument))) + (if proc + (proc) + (raise + (condition + (&serious) + (&message + (message (format #f "Unable to find corresponding PROC for \ +component ~a." argument)))))))) + ;; TODO + ('exit-fd-ready + (raise (condition (&serious))))))) -- 2.34.0