[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
18/18: installer: Make dump archive creation optional and selective.
|
From: |
guix-commits |
|
Subject: |
18/18: installer: Make dump archive creation optional and selective. |
|
Date: |
Mon, 17 Jan 2022 05:04:54 -0500 (EST) |
mothacehe pushed a commit to branch wip-harden-installer
in repository guix.
commit 1e2f0cca1ae6bf10bec0f746799447cc6336655a
Author: Josselin Poiret <dev@jpoiret.xyz>
AuthorDate: Sat Jan 15 14:50:11 2022 +0100
installer: Make dump archive creation optional and selective.
* 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.
Signed-off-by: Mathieu Othacehe <othacehe@gnu.org>
---
gnu/installer.scm | 43 +++++++++++++------------
gnu/installer/dump.scm | 67 +++++++++++++++++++++++----------------
gnu/installer/newt.scm | 76 ++++++++++++++++++++++++++++++---------------
gnu/installer/newt/dump.scm | 36 ---------------------
gnu/installer/newt/page.scm | 65 ++++++++++++++++++++++++++++++++++++++
gnu/installer/record.scm | 9 ++++--
gnu/local.mk | 1 -
7 files changed, 186 insertions(+), 111 deletions(-)
diff --git a/gnu/installer.scm b/gnu/installer.scm
index 1cfd9d1bc9..7b2914be98 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -386,7 +386,8 @@ selected keymap."
(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 @@ selected keymap."
(define current-installer newt-installer)
(define steps (#$steps current-installer))
+
(dynamic-wind
(installer-init current-installer)
(lambda ()
@@ -436,30 +438,31 @@ selected keymap."
(sync)
(stop-service 'root))
(_
- ;; The installation failed, exit so that it is
restarted
- ;; by login.
+ ;; The installation failed, exit so that it is
+ ;; restarted by login.
#f)))
(const #f)
(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 @@
#: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 @@
(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..1db78e6f0d 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,12 @@
#: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 (ice-9 match)
#:use-module (newt)
#:export (newt-installer))
@@ -58,28 +61,53 @@
(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_ "Dump") (const 'dump))
+ (cons (G_ "Exit") (const 'exit)))))
(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 (match-lambda*
+ (((file . enable?) acc)
+ (if enable?
+ (cons file acc)
+ acc)))
+ '()
+ (run-dump-page
+ dump-dir
+ (map (lambda (x)
+ (cons x #f))
+ files))))
(define (newt-run-command . args)
(define command-output "")
@@ -118,7 +146,7 @@ problem. The backtrace is displayed below~a. Please report
it by email to \
(cons "Abort"
(lambda ()
(abort-to-prompt 'installer-step 'abort)))
- (cons "Dump"
+ (cons "Report"
(lambda ()
(raise
(condition
@@ -178,9 +206,6 @@ problem. The backtrace is displayed below~a. Please report
it by email to \
(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 +227,5 @@ problem. The backtrace is displayed below~a. Please report
it by email to \
(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 <othacehe@gnu.org>
-;;;
-;;; 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 <http://www.gnu.org/licenses/>.
-
-(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..0f508a31c0 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -47,6 +47,7 @@
%ok-button
%exit-button
run-textbox-page
+ run-dump-page
run-form-with-clients))
@@ -899,3 +900,67 @@ component ~a." argument))))))))
;; 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-compact-button -1 -1 "Edit")
+ (make-checkbox -1 -1 file (if enabled #\x #\ ) " x")
+ file)))
+ file-choices))
+
+ (define sub-grid (make-grid 2 (length components)))
+
+ (for-each
+ (match-lambda* (((button checkbox _) index)
+ (set-grid-field sub-grid 0 index
+ GRID-ELEMENT-COMPONENT checkbox
+ #:anchor ANCHOR-LEFT)
+ (set-grid-field sub-grid 1 index
+ GRID-ELEMENT-COMPONENT button
+ #:anchor ANCHOR-LEFT)))
+ components (iota (length components)))
+
+ (define grid
+ (vertically-stacked-grid
+ GRID-ELEMENT-COMPONENT info-textbox
+ GRID-ELEMENT-SUBGRID sub-grid
+ 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 @@
installer-parameters-menu
installer-parameters-page
installer-dump-page
- installer-run-command))
+ installer-run-command
+ installer-report-page))
;;;
@@ -63,7 +64,7 @@
(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 @@
;; 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 \
- branch wip-harden-installer updated (84d0d8ad3d -> 1e2f0cca1a), guix-commits, 2022/01/17
- 01/18: installer: Use define instead of let at top-level., guix-commits, 2022/01/17
- 07/18: installer: Capture external commands output., guix-commits, 2022/01/17
- 05/18: installer: Keep PATH inside the install container., guix-commits, 2022/01/17
- 18/18: installer: Make dump archive creation optional and selective.,
guix-commits <=
- 06/18: installer: Remove specific logging code., guix-commits, 2022/01/17
- 03/18: installer: Use new installer-log-line everywhere., guix-commits, 2022/01/17
- 04/18: installer: Un-export syslog syntax., guix-commits, 2022/01/17
- 08/18: installer: Add installer-specific run command process., guix-commits, 2022/01/17
- 09/18: installer: Use run-command-in-installer in (gnu installer parted)., guix-commits, 2022/01/17
- 10/18: installer: Raise condition when mklabel fails., guix-commits, 2022/01/17
- 14/18: installer: Use named prompt to abort or break installer steps., guix-commits, 2022/01/17
- 15/18: installer: Add error page when running external commands., guix-commits, 2022/01/17
- 17/18: installer: Turn passwords into opaque records., guix-commits, 2022/01/17
- 02/18: installer: Generalize logging facility., guix-commits, 2022/01/17