[bug#53063] [PATCH v2 wip-harden-installer 18/18] installer: Make dump archive creation optional and selective.

[Josselin Poiret]

* 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 <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..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* <installer>
   (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* <installer>
   ;; 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            \
-- 
2.34.0