From patchwork Sat Jan 15 13:50:08 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Josselin Poiret X-Patchwork-Id: 36377 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 0C16B27BBEB; Sat, 15 Jan 2022 13:53:08 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-0.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,FROM_SUSPICIOUS_NTLD,MAILING_LIST_MULTI,PDS_OTHER_BAD_TLD, RCVD_IN_MSPIKE_H3,RCVD_IN_MSPIKE_WL,SPF_HELO_PASS,URIBL_BLOCKED autolearn=no autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 1D0AB27BBEA for ; Sat, 15 Jan 2022 13:53:07 +0000 (GMT) Received: from localhost ([::1]:41810 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1n8jUQ-0007g2-8J for patchwork@mira.cbaines.net; Sat, 15 Jan 2022 08:53:06 -0500 Received: from eggs.gnu.org ([209.51.188.92]:37974) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1n8jTO-0005s7-Od for guix-patches@gnu.org; Sat, 15 Jan 2022 08:52:02 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:46643) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1n8jTO-0004R2-4V for guix-patches@gnu.org; Sat, 15 Jan 2022 08:52:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1n8jTO-0001uG-3z for guix-patches@gnu.org; Sat, 15 Jan 2022 08:52:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#53063] [PATCH v2 wip-harden-installer 15/18] installer: Add error page when running external commands. Resent-From: Josselin Poiret Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sat, 15 Jan 2022 13:52:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 53063 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: Mathieu Othacehe Cc: 53063@debbugs.gnu.org, ludo@gnu.org, Josselin Poiret Received: via spool by 53063-submit@debbugs.gnu.org id=B53063.16422546747223 (code B ref 53063); Sat, 15 Jan 2022 13:52:02 +0000 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== 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 X-Spamd-Bar: / Authentication-Results: jpoiret.xyz; auth=pass smtp.auth=jpoiret@jpoiret.xyz smtp.mailfrom=dev@jpoiret.xyz X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" Reply-to: Josselin Poiret X-ACL-Warn: , Josselin Poiret via Guix-patches X-Patchwork-Original-From: Josselin Poiret via Guix-patches via From: Josselin Poiret X-getmail-retrieved-from-mailbox: Patches * 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)))))))