From patchwork Sat Jan 15 13:50:11 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Josselin Poiret X-Patchwork-Id: 36380 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 170CD27BBEA; Sat, 15 Jan 2022 13:53:24 +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 0EDB027BBE9 for ; Sat, 15 Jan 2022 13:53:23 +0000 (GMT) Received: from localhost ([::1]:42910 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1n8jUg-0008OQ-8H for patchwork@mira.cbaines.net; Sat, 15 Jan 2022 08:53:22 -0500 Received: from eggs.gnu.org ([209.51.188.92]:38008) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1n8jTc-00067e-Jr for guix-patches@gnu.org; Sat, 15 Jan 2022 08:52:16 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:46647) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1n8jTP-0004RX-MJ for guix-patches@gnu.org; Sat, 15 Jan 2022 08:52:14 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1n8jTP-0001un-MA for guix-patches@gnu.org; Sat, 15 Jan 2022 08:52:03 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#53063] [PATCH v2 wip-harden-installer 18/18] installer: Make dump archive creation optional and selective. Resent-From: Josselin Poiret Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sat, 15 Jan 2022 13:52:03 +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.16422546767258 (code B ref 53063); Sat, 15 Jan 2022 13:52:03 +0000 Received: (at 53063) by debbugs.gnu.org; 15 Jan 2022 13:51:16 +0000 Received: from localhost ([127.0.0.1]:39545 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1n8jSd-0001so-Kh for submit@debbugs.gnu.org; Sat, 15 Jan 2022 08:51:16 -0500 Received: from jpoiret.xyz ([206.189.101.64]:50078) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1n8jS5-0001ow-K0 for 53063@debbugs.gnu.org; Sat, 15 Jan 2022 08:50:43 -0500 Received: from authenticated-user (jpoiret.xyz [206.189.101.64]) by jpoiret.xyz (Postfix) with ESMTPA id B42DA185149; Sat, 15 Jan 2022 13:50:39 +0000 (UTC) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=jpoiret.xyz; s=dkim; t=1642254640; h=from:from:reply-to:subject:subject:date:date:message-id:message-id: to:to:cc:cc:mime-version:mime-version:content-type:content-type: content-transfer-encoding:content-transfer-encoding: in-reply-to:in-reply-to:references:references; bh=nqmDo2lJ1u3KBUKSB65efrKXRVa+rWRUcON7Sq0ljGc=; b=c1qGoNBHB757Jzyl0qNMVpKRrWo6ewrpZUxYoX9kFhMr9J5fZ0YswwTTJ6ouvkatV+AybI MPXvBAuujA6ThnNbZHmyAtXuRjNaBn7PbRMW7jGf82HdGGk6S1Ex1mct/7f5csX5B1ZSTO emv9E/Lbx8fqYP0unyiYJQJ+rGUhGO7uG4gZG+B0AJJev9Gm1VWvIxz3MqutPnluUOwvIW BtwLPrYzvF+SPcG5aboHL3t8TcYPO+V4e8lymEVSMuk0HNReMlhrhg4V840KwGDj2voR0X bmV7LeRWHFP0pLzTkzQliZGTJ5HY76wmFCm1Yk/HPTkd2RjPOrLF937SxPpZuQ== Date: Sat, 15 Jan 2022 14:50:11 +0100 Message-Id: <20220115135011.5817-19-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.scm (installer-program): Let the installer customize the dump archive. * gnu/installer/dump.scm (prepare-dump, make-dump): Split make-dump in prepare-dump, which copies the files necessary for the dump, and make-dump which creates the archive. * gnu/installer/record.scm (installer): Add report-page field. Change documented return value of exit-error. * gnu/installer/newt.scm (exit-error): Change arguments to be a string containing the error. Let the user choose between exiting and initiating a dump. (report-page): Add new variable. * gnu/installer/newt/page.scm (run-dump-page): New variable. * gnu/installer/newt/dump.scm: Delete it. --- gnu/installer.scm | 38 ++++++++++---------- gnu/installer/dump.scm | 67 ++++++++++++++++++++-------------- gnu/installer/newt.scm | 72 ++++++++++++++++++++++++------------- gnu/installer/newt/dump.scm | 36 ------------------- gnu/installer/newt/page.scm | 58 ++++++++++++++++++++++++++++++ gnu/installer/record.scm | 9 +++-- gnu/local.mk | 1 - 7 files changed, 173 insertions(+), 108 deletions(-) delete mode 100644 gnu/installer/newt/dump.scm diff --git a/gnu/installer.scm b/gnu/installer.scm index 86495a067b..01eda04774 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -386,7 +386,8 @@ (define installer-builder (guix build utils) ((system repl debug) #:select (terminal-width)) - (ice-9 match)) + (ice-9 match) + (ice-9 textual-ports)) ;; Initialize gettext support so that installers can use ;; (guix i18n) module. @@ -416,6 +417,7 @@ (define installer-builder (define current-installer newt-installer) (define steps (#$steps current-installer)) + (dynamic-wind (installer-init current-installer) @@ -444,23 +446,23 @@ (define results (lambda (key . args) (installer-log-line "crashing due to uncaught exception: ~s ~s" key args) - (let ((error-file "/tmp/last-installer-error") - (dump-archive "/tmp/dump.tgz")) - (call-with-output-file error-file - (lambda (port) - (display-backtrace (make-stack #t) port) - (print-exception port - (stack-ref (make-stack #t) 1) - key args))) - (make-dump dump-archive - #:result %current-result - #:backtrace error-file) - (let ((report - ((installer-dump-page current-installer) - dump-archive))) - ((installer-exit-error current-installer) - error-file report key args))) - (primitive-exit 1))))) + (define dump-dir (prepare-dump key args + #:result %current-result)) + (define action + ((installer-exit-error current-installer) + (get-string-all + (open-input-file + (string-append dump-dir "/installer-backtrace"))))) + (match action + ('dump + (let* ((dump-files + ((installer-dump-page current-installer) + dump-dir)) + (dump-archive (make-dump dump-dir dump-files))) + ((installer-report-page current-installer) + dump-archive))) + (_ #f)) + (exit 1))))) (installer-exit current-installer)))))) diff --git a/gnu/installer/dump.scm b/gnu/installer/dump.scm index 49c40a26af..daa02f205a 100644 --- a/gnu/installer/dump.scm +++ b/gnu/installer/dump.scm @@ -28,7 +28,8 @@ (define-module (gnu installer dump) #:use-module (web http) #:use-module (web response) #:use-module (webutils multipart) - #:export (make-dump + #:export (prepare-dump + make-dump send-dump-report)) ;; The installer crash dump type. @@ -40,35 +41,49 @@ (define (result->list result) (cons k v)) result)) -(define* (make-dump output - #:key - result - backtrace) - "Create a crash dump archive in OUTPUT. RESULT is the installer result hash -table. BACKTRACE is the installer Guile backtrace." - (let ((dump-dir "/tmp/dump")) - (mkdir-p dump-dir) - (with-directory-excursion dump-dir - ;; backtrace - (copy-file backtrace "installer-backtrace") +(define* (prepare-dump key args #:key result) + "Create a crash dump directory. KEY and ARGS represent the thrown error. +RESULT is the installer result hash table. Returns the created directory path." + (define now (localtime (current-time))) + (define dump-dir + (format #f "/tmp/dump.~a" + (strftime "%F.%H.%M.%S" now))) + (mkdir-p dump-dir) + (with-directory-excursion dump-dir + ;; backtrace + (call-with-output-file "installer-backtrace" + (lambda (port) + (display-backtrace (make-stack #t) port) + (print-exception port + (stack-ref (make-stack #t) 1) + key args))) - ;; installer result - (call-with-output-file "installer-result" - (lambda (port) - (write (result->list result) port))) + ;; installer result + (call-with-output-file "installer-result" + (lambda (port) + (write (result->list result) port))) - ;; syslog - (copy-file "/var/log/messages" "syslog") + ;; syslog + (copy-file "/var/log/messages" "syslog") - ;; dmesg - (let ((pipe (open-pipe* OPEN_READ "dmesg"))) - (call-with-output-file "dmesg" - (lambda (port) - (dump-port pipe port) - (close-pipe pipe))))) + ;; dmesg + (let ((pipe (open-pipe* OPEN_READ "dmesg"))) + (call-with-output-file "dmesg" + (lambda (port) + (dump-port pipe port) + (close-pipe pipe))))) + dump-dir) - (with-directory-excursion (dirname dump-dir) - (system* "tar" "-zcf" output (basename dump-dir))))) +(define* (make-dump dump-dir file-choices) + "Create a crash dump archive from DUMP-DIR containing FILE-CHOICES. +Returns the archive path." + (define output (string-append (basename dump-dir) ".tar.gz")) + (with-directory-excursion (dirname dump-dir) + (apply system* "tar" "-zcf" output + (map (lambda (f) + (string-append (basename dump-dir) "/" f)) + file-choices))) + (canonicalize-path (string-append (dirname dump-dir) "/" output))) (define* (send-dump-report dump #:key diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index 352d2997bd..2646b5d369 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -19,7 +19,7 @@ (define-module (gnu installer newt) #:use-module (gnu installer record) #:use-module (gnu installer utils) - #:use-module (gnu installer newt dump) + #:use-module (gnu installer dump) #:use-module (gnu installer newt ethernet) #:use-module (gnu installer newt final) #:use-module (gnu installer newt parameters) @@ -40,9 +40,11 @@ (define-module (gnu installer newt) #:use-module (guix config) #:use-module (guix discovery) #:use-module (guix i18n) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (ice-9 ftw) #:use-module (newt) #:export (newt-installer)) @@ -58,28 +60,52 @@ (define (exit) (newt-finish) (clear-screen)) -(define (exit-error file report key args) +(define (exit-error error) (newt-set-color COLORSET-ROOT "white" "red") - (let ((width (nearest-exact-integer - (* (screen-columns) 0.8))) - (height (nearest-exact-integer - (* (screen-rows) 0.7))) - (report (if report - (format #f ". It has been uploaded as ~a" report) - ""))) - (run-file-textbox-page - #:info-text (format #f (G_ "The installer has encountered an unexpected \ -problem. The backtrace is displayed below~a. Please report it by email to \ -<~a>.") report %guix-bug-report-address) + (define action + (run-textbox-page + #:info-text (G_ "The installer has encountered an unexpected problem. \ +The backtrace is displayed below. You may choose to exit or create a dump \ +archive.") #:title (G_ "Unexpected problem") - #:file file - #:exit-button? #f - #:info-textbox-width width - #:file-textbox-width width - #:file-textbox-height height)) + #:content error + #:buttons-spec + (list + (cons (G_ "Exit") (const 'exit)) + (cons (G_ "Dump") (const 'dump))))) (newt-set-color COLORSET-ROOT "white" "blue") - (newt-finish) - (clear-screen)) + action) + +(define (report-page dump-archive) + (define text + (format #f (G_ "The dump archive was created as ~a. Would you like to \ +send this archive to the Guix servers?") dump-archive)) + (define title (G_ "Dump archive created")) + (when (run-confirmation-page text title) + (let* ((uploaded-name (send-dump-report dump-archive)) + (text (if uploaded-name + (format #f (G_ "The dump was uploaded as ~a. Please \ +report it by email to ~a.") uploaded-name %guix-bug-report-address) + (G_ "The dump could not be uploaded.")))) + (run-error-page + text + (G_ "Dump upload result"))))) + +(define (dump-page dump-dir) + (define files + (scandir dump-dir (lambda (x) + (not (or (string=? x ".") + (string=? x "..")))))) + (fold (lambda (file-choice acc) + (if (cdr file-choice) + (cons (car file-choice) acc) + acc)) + '() + (run-dump-page + dump-dir + (map (lambda (x) + (cons x #f)) + files)))) (define (newt-run-command . args) (define command-output "") @@ -178,9 +204,6 @@ (define (parameters-menu menu-proc) (define (parameters-page keyboard-layout-selection) (run-parameters-page keyboard-layout-selection)) -(define (dump-page steps) - (run-dump-page steps)) - (define newt-installer (installer (name 'newt) @@ -202,4 +225,5 @@ (define newt-installer (parameters-menu parameters-menu) (parameters-page parameters-page) (dump-page dump-page) - (run-command newt-run-command))) + (run-command newt-run-command) + (report-page report-page))) diff --git a/gnu/installer/newt/dump.scm b/gnu/installer/newt/dump.scm deleted file mode 100644 index 64f0d58237..0000000000 --- a/gnu/installer/newt/dump.scm +++ /dev/null @@ -1,36 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021 Mathieu Othacehe -;;; -;;; 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 newt dump) - #:use-module (gnu installer dump) - #:use-module (gnu installer newt page) - #:use-module (guix i18n) - #:use-module (newt) - #:export (run-dump-page)) - -(define (run-dump-page dump) - "Run a dump page, proposing the user to upload the crash dump to Guix -servers." - (case (choice-window - (G_ "Crash dump upload") - (G_ "Yes") - (G_ "No") - (G_ "The installer failed. Do you accept to upload the crash dump \ -to Guix servers, so that we can investigate the issue?")) - ((1) (send-dump-report dump)) - ((2) #f))) diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm index b5d7c98094..060e633254 100644 --- a/gnu/installer/newt/page.scm +++ b/gnu/installer/newt/page.scm @@ -47,6 +47,7 @@ (define-module (gnu installer newt page) %ok-button %exit-button run-textbox-page + run-dump-page run-form-with-clients)) @@ -899,3 +900,60 @@ (define form (make-form #:flags FLAG-NOF12)) ;; TODO ('exit-fd-ready (raise (condition (&serious))))))) + +(define* (run-dump-page base-dir file-choices) + (define info-textbox + (make-reflowed-textbox -1 -1 "Please select files you wish to include in \ +the dump." + 50 + #:flags FLAG-BORDER)) + (define components + (map (match-lambda ((file . enabled) + (list + (make-button -1 -1 "Edit") + (make-checkbox -1 -1 file (if enabled #\x #\ ) " x") + file))) + file-choices)) + (define grid + (apply vertically-stacked-grid + GRID-ELEMENT-COMPONENT info-textbox + (append + (append-map + (match-lambda ((button checkbox _) + (list GRID-ELEMENT-SUBGRID + (horizontal-stacked-grid + GRID-ELEMENT-COMPONENT checkbox + GRID-ELEMENT-COMPONENT button)))) + components) + (list GRID-ELEMENT-COMPONENT (make-button -1 -1 "Create"))))) + (define form (make-form #:flags FLAG-NOF12)) + + (add-form-to-grid grid form #t) + (make-wrapped-grid-window grid "Installer dump") + + (define prompt-tag (make-prompt-tag)) + + (let loop () + (call-with-prompt prompt-tag + (lambda () + (receive (exit-reason argument) + (run-form-with-clients form + `(dump-page)) + (match exit-reason + ('exit-component + (let ((result + (map (match-lambda + ((edit checkbox filename) + (if (components=? edit argument) + (abort-to-prompt prompt-tag filename) + (cons filename (eq? #\x + (checkbox-value checkbox)))))) + components))) + (destroy-form-and-pop form) + result)) + ;; TODO + ('exit-fd-ready + (raise (condition (&serious))))))) + (lambda (k file) + (edit-file (string-append base-dir "/" file)) + (loop))))) diff --git a/gnu/installer/record.scm b/gnu/installer/record.scm index 23db3edd70..20519a26c3 100644 --- a/gnu/installer/record.scm +++ b/gnu/installer/record.scm @@ -43,7 +43,8 @@ (define-module (gnu installer record) installer-parameters-menu installer-parameters-page installer-dump-page - installer-run-command)) + installer-run-command + installer-report-page)) ;;; @@ -63,7 +64,7 @@ (define-record-type* (init installer-init) ;; procedure: void -> void (exit installer-exit) - ;; procedure (key arguments) -> void + ;; procedure (key arguments) -> (action) (exit-error installer-exit-error) ;; procedure void -> void (final-page installer-final-page) @@ -97,4 +98,6 @@ (define-record-type* ;; procedure (dump) -> void (dump-page installer-dump-page) ;; procedure command -> bool - (run-command installer-run-command)) + (run-command installer-run-command) + ;; procedure (report) -> void + (report-page installer-report-page)) diff --git a/gnu/local.mk b/gnu/local.mk index a3818cdcbf..adb3d64e29 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -773,7 +773,6 @@ INSTALLER_MODULES = \ %D%/installer/user.scm \ %D%/installer/utils.scm \ \ - %D%/installer/newt/dump.scm \ %D%/installer/newt/ethernet.scm \ %D%/installer/newt/final.scm \ %D%/installer/newt/parameters.scm \