[bug#53063] [PATCH v2 wip-harden-installer 15/18] installer: Add error page when running external commands.

[Josselin Poiret via Guix-patches via <guix-patches@gnu.org>]

* gnu/installer/newt.scm (newt-run-command): Add it.
* gnu/installer/newt/page.scm (%ok-button, %exit-button,
%default-buttons, make-newt-buttons, run-textbox-page): Add them.
---
 gnu/installer/newt.scm      | 54 +++++++++++++++++++++---
 gnu/installer/newt/page.scm | 83 +++++++++++++++++++++++++++++++++++++
 2 files changed, 132 insertions(+), 5 deletions(-)

diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm
index fc851339d1..352d2997bd 100644
--- a/gnu/installer/newt.scm
+++ b/gnu/installer/newt.scm
@@ -41,6 +41,8 @@ (define-module (gnu installer newt)
   #:use-module (guix discovery)
   #:use-module (guix i18n)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (newt)
   #:export (newt-installer))
 
@@ -80,11 +82,53 @@ (define (exit-error file report key args)
   (clear-screen))
 
 (define (newt-run-command . args)
-  (newt-suspend)
-  (clear-screen)
-  (define result (run-command args))
-  (newt-resume)
-  result)
+  (define command-output "")
+  (define (line-accumulator line)
+    (set! command-output
+          (string-append/shared command-output line "\n")))
+  (define displayed-command
+    (string-join
+     (map (lambda (s) (string-append "\"" s "\"")) args)
+     " "))
+  (define result (run-external-command-with-line-hooks (list line-accumulator)
+                                                       args))
+  (define exit-val (status:exit-val result))
+  (define term-sig (status:term-sig result))
+  (define stop-sig (status:stop-sig result))
+
+  (if (and exit-val (zero? exit-val))
+      #t
+      (let ((info-text
+             (cond
+              (exit-val
+               (format #f (G_ "External command ~s exited with code ~a")
+                       args exit-val))
+              (term-sig
+               (format #f (G_ "External command ~s terminated by signal ~a")
+                       args term-sig))
+              (stop-sig
+               (format #f (G_ "External command ~s stopped by signal ~a")
+                       args stop-sig)))))
+        (run-textbox-page #:title (G_ "External command error")
+                          #:info-text info-text
+                          #:content command-output
+                          #:buttons-spec
+                          (list
+                           (cons "Ignore" (const #t))
+                           (cons "Abort"
+                                 (lambda ()
+                                   (abort-to-prompt 'installer-step 'abort)))
+                           (cons "Dump"
+                                 (lambda ()
+                                   (raise
+                                    (condition
+                                     ((@@ (guix build utils)
+                                          &invoke-error)
+                                      (program (car args))
+                                      (arguments (cdr args))
+                                      (exit-status exit-val)
+                                      (term-signal term-sig)
+                                      (stop-signal stop-sig)))))))))))
 
 (define (final-page result prev-steps)
   (run-final-page result prev-steps))
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index 8c675fa837..b5d7c98094 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -44,6 +44,9 @@ (define-module (gnu installer newt page)
             run-scale-page
             run-checkbox-tree-page
             run-file-textbox-page
+            %ok-button
+            %exit-button
+            run-textbox-page
 
             run-form-with-clients))
 
@@ -816,3 +819,83 @@ (define result
                  (components=? argument edit-button))
             (loop)                                ;recurse in tail position
             result)))))
+
+(define %ok-button
+  (cons (G_ "Ok")  (lambda () #t)))
+
+(define %exit-button
+  (cons (G_ "Exit") (lambda () (abort-to-prompt 'installer-step 'abort))))
+
+(define %default-buttons
+  (list %ok-button %exit-button))
+
+(define (make-newt-buttons buttons-spec)
+  (map
+   (match-lambda ((title . proc)
+                  (cons (make-button -1 -1 title) proc)))
+   buttons-spec))
+
+(define* (run-textbox-page #:key
+                           title
+                           info-text
+                           content
+                           (buttons-spec %default-buttons))
+  "Run a page to display INFO-TEXT followed by CONTENT to the user, who has to
+choose an action among the buttons specified by BUTTONS-SPEC.
+
+BUTTONS-SPEC is an association list with button labels as keys, and callback
+procedures as values.
+
+This procedure returns the result of the callback procedure of the button
+chosen by the user."
+  (define info-textbox
+    (make-reflowed-textbox -1 -1 info-text
+                           50
+                           #:flags FLAG-BORDER))
+  (define content-textbox
+    (make-textbox -1 -1
+                  50
+                  30
+                  (logior FLAG-SCROLL FLAG-BORDER)))
+  (define buttons
+    (make-newt-buttons buttons-spec))
+  (define grid
+    (vertically-stacked-grid
+     GRID-ELEMENT-COMPONENT info-textbox
+     GRID-ELEMENT-COMPONENT content-textbox
+     GRID-ELEMENT-SUBGRID
+     (apply
+      horizontal-stacked-grid
+      (append-map (match-lambda ((button . proc)
+                                 (list GRID-ELEMENT-COMPONENT button)))
+                  buttons))))
+  (define form (make-form #:flags FLAG-NOF12))
+  (add-form-to-grid grid form #t)
+  (make-wrapped-grid-window grid title)
+  (set-textbox-text content-textbox
+                    (receive (_w _h text)
+                        (reflow-text content
+                                     50
+                                     0 0)
+                      text))
+
+  (receive (exit-reason argument)
+      (run-form-with-clients form
+                             `(contents-dialog (title ,title)
+                                               (text ,info-text)
+                                               (content ,content)))
+    (destroy-form-and-pop form)
+    (match exit-reason
+      ('exit-component
+       (let ((proc (assq-ref buttons argument)))
+         (if proc
+             (proc)
+             (raise
+              (condition
+               (&serious)
+               (&message
+                (message (format #f "Unable to find corresponding PROC for \
+component ~a." argument))))))))
+      ;; TODO
+      ('exit-fd-ready
+       (raise (condition (&serious)))))))
-- 
2.34.0