installer: Add crash dump upload support.

Suggested-by: Josselin Poiret <dev@jpoiret.xyz>

* gnu/installer/dump.scm: New file.
* gnu/installer/newt/dump.scm: New file.
* gnu/local.mk (INSTALLER_MODULES): Add them.
* gnu/installer/record.scm (<installer>)[dump-page]: New field.
* gnu/installer/steps.scm (%current-result): New variable.
(run-installer-steps): Update it.
* gnu/installer.scm (installer-program): Add tar and gip to the installer
path. Add guile-webutils and gnutls to the Guile extensions. Generate and send
the crash dump report.
* gnu/installer/newt.scm (exit-error): Add a report argument. Display the
report id.
(dump-page): New procedure.
(newt-installer): Update it.

7 files changed, 183 insertions, 12 deletions

diff --git a/gnu/installer.scm b/gnu/installer.scm
index c8b7a66cfc8..d57b1d673a5 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -33,6 +33,7 @@
   #:use-module (gnu packages admin)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
+  #:use-module (gnu packages compression)
   #:use-module (gnu packages connman)
   #:use-module (gnu packages cryptsetup)
   #:use-module (gnu packages disk)
@@ -336,6 +337,8 @@ selected keymap."
                        guix ;guix system init call
                        util-linux ;mkwap
                        shadow
+                       tar ;dump
+                       gzip ;dump
                        coreutils)))
         (with-output-to-port (%make-void-port "w")
           (lambda ()
@@ -352,7 +355,8 @@ selected keymap."
     ;; packages …), etc. modules.
     (with-extensions (list guile-gcrypt guile-newt
                            guile-parted guile-bytestructures
-                           guile-json-3 guile-git guix gnutls)
+                           guile-json-3 guile-git guile-webutils
+                           guix gnutls)
       (with-imported-modules `(,@(source-module-closure
                                   `(,@modules
                                     (gnu services herd)
@@ -363,6 +367,7 @@ selected keymap."
             (use-modules (gnu installer record)
                          (gnu installer keymap)
                          (gnu installer steps)
+                         (gnu installer dump)
                          (gnu installer final)
                          (gnu installer hostname)
                          (gnu installer locale)
@@ -432,15 +437,22 @@ selected keymap."
                 (lambda (key . args)
                   (syslog "crashing due to uncaught exception: ~s ~s~%"
                           key args)
-                  (let ((error-file "/tmp/last-installer-error"))
+                  (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)))
-                    ((installer-exit-error current-installer)
-                     error-file 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)))
 
               ((installer-exit current-installer)))))))
diff --git a/gnu/installer/dump.scm b/gnu/installer/dump.scm
new file mode 100644
index 00000000000..49c40a26afd
--- /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 4f7fc6f4dcc..d48e2c01298 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 00000000000..64f0d582377
--- /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 0b34318c457..e7cd45ee83e 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 c05dfa567a8..55433cff31a 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))))))))
diff --git a/gnu/local.mk b/gnu/local.mk
index 9969bc67cb3..9510c796717 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -758,6 +758,7 @@ GNU_SYSTEM_MODULES =				\
 INSTALLER_MODULES =                             \
   %D%/installer.scm                             \
   %D%/installer/connman.scm                     \
+  %D%/installer/dump.scm                        \
   %D%/installer/final.scm                       \
   %D%/installer/hostname.scm                    \
   %D%/installer/keymap.scm                      \
@@ -774,6 +775,7 @@ 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             \