diff options
| -rw-r--r-- | gnu/installer.scm | 43 | ||||
| -rw-r--r-- | gnu/installer/dump.scm | 67 | ||||
| -rw-r--r-- | gnu/installer/newt.scm | 76 | ||||
| -rw-r--r-- | gnu/installer/newt/dump.scm | 36 | ||||
| -rw-r--r-- | gnu/installer/newt/page.scm | 65 | ||||
| -rw-r--r-- | gnu/installer/record.scm | 9 | ||||
| -rw-r--r-- | 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 9510c79671..dddda78efa 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -775,7 +775,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 \ |