diff options
Diffstat (limited to 'gnu/installer')
| -rw-r--r-- | gnu/installer/dump.scm | 103 | ||||
| -rw-r--r-- | gnu/installer/newt.scm | 18 | ||||
| -rw-r--r-- | gnu/installer/newt/dump.scm | 36 | ||||
| -rw-r--r-- | gnu/installer/record.scm | 7 | ||||
| -rw-r--r-- | gnu/installer/steps.scm | 9 |
5 files changed, 165 insertions, 8 deletions
diff --git a/gnu/installer/dump.scm b/gnu/installer/dump.scm new file mode 100644 index 0000000000..49c40a26af --- /dev/null +++ b/gnu/installer/dump.scm @@ -0,0 +1,103 @@ +;;; 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 dump) + #:use-module (gnu installer utils) + #:use-module (guix build utils) + #:use-module (srfi srfi-11) + #:use-module (ice-9 iconv) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module (ice-9 textual-ports) + #:use-module (web client) + #:use-module (web http) + #:use-module (web response) + #:use-module (webutils multipart) + #:export (make-dump + send-dump-report)) + +;; The installer crash dump type. +(define %dump-type "installer-dump") + +(define (result->list result) + "Return the alist for the given RESULT." + (hash-map->list (lambda (k v) + (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") + + ;; installer result + (call-with-output-file "installer-result" + (lambda (port) + (write (result->list result) port))) + + ;; 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))))) + + (with-directory-excursion (dirname dump-dir) + (system* "tar" "-zcf" output (basename dump-dir))))) + +(define* (send-dump-report dump + #:key + (url "https://dump.guix.gnu.org")) + "Turn the DUMP archive into a multipart body and send it to the Guix crash +dump server at URL." + (define (match-boundary kont) + (match-lambda + (('boundary . (? string? b)) + (kont b)) + (x #f))) + + (define (response->string response) + (bytevector->string + (read-response-body response) + "UTF-8")) + + (let-values (((body boundary) + (call-with-input-file dump + (lambda (port) + (format-multipart-body + `((,%dump-type . ,port))))))) + (false-if-exception + (response->string + (http-post + (string-append url "/upload") + #:keep-alive? #t + #:streaming? #t + #:headers `((content-type + . (multipart/form-data + (boundary . ,boundary)))) + #:body body))))) diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index 4f7fc6f4dc..d48e2c0129 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -19,6 +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 newt ethernet) #:use-module (gnu installer newt final) #:use-module (gnu installer newt parameters) @@ -55,16 +56,19 @@ (newt-finish) (clear-screen)) -(define (exit-error file key args) +(define (exit-error file report key args) (newt-set-color COLORSET-ROOT "white" "red") (let ((width (nearest-exact-integer (* (screen-columns) 0.8))) (height (nearest-exact-integer - (* (screen-rows) 0.7)))) + (* (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. Please report it by email to \ -<~a>.") %guix-bug-report-address) +problem. The backtrace is displayed below~a. Please report it by email to \ +<~a>.") report %guix-bug-report-address) #:title (G_ "Unexpected problem") #:file file #:exit-button? #f @@ -123,6 +127,9 @@ problem. The backtrace is displayed below. 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) @@ -142,4 +149,5 @@ problem. The backtrace is displayed below. Please report it by email to \ (services-page services-page) (welcome-page welcome-page) (parameters-menu parameters-menu) - (parameters-page parameters-page))) + (parameters-page parameters-page) + (dump-page dump-page))) diff --git a/gnu/installer/newt/dump.scm b/gnu/installer/newt/dump.scm new file mode 100644 index 0000000000..64f0d58237 --- /dev/null +++ b/gnu/installer/newt/dump.scm @@ -0,0 +1,36 @@ +;;; 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/record.scm b/gnu/installer/record.scm index 0b34318c45..e7cd45ee83 100644 --- a/gnu/installer/record.scm +++ b/gnu/installer/record.scm @@ -41,7 +41,8 @@ installer-services-page installer-welcome-page installer-parameters-menu - installer-parameters-page)) + installer-parameters-page + installer-dump-page)) ;;; @@ -91,4 +92,6 @@ ;; procedure (menu-proc) -> void (parameters-menu installer-parameters-menu) ;; procedure (keyboard-layout-selection) -> void - (parameters-page installer-parameters-page)) + (parameters-page installer-parameters-page) + ;; procedure (dump) -> void + (dump-page installer-dump-page)) diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm index c05dfa567a..55433cff31 100644 --- a/gnu/installer/steps.scm +++ b/gnu/installer/steps.scm @@ -52,7 +52,13 @@ %installer-configuration-file %installer-target-dir format-configuration - configuration->file)) + configuration->file + + %current-result)) + +;; Hash table storing the step results. Use it only for logging and debug +;; purposes. +(define %current-result (make-hash-table)) ;; This condition may be raised to abort the current step. (define-condition-type &installer-step-abort &condition @@ -183,6 +189,7 @@ return the accumalated result so far." (let* ((id (installer-step-id step)) (compute (installer-step-compute step)) (res (compute result done-steps))) + (hash-set! %current-result id res) (run (alist-cons id res result) #:todo-steps rest-steps #:done-steps (append done-steps (list step)))))))) |