08/18: installer: Add installer-specific run command process.

[guix-commits]

mothacehe pushed a commit to branch wip-harden-installer
in repository guix.

commit 917e94b29f84434e879f0b5ae8f8cd209f7ef114
Author: Josselin Poiret <dev@jpoiret.xyz>
AuthorDate: Sat Jan 15 14:50:01 2022 +0100

    installer: Add installer-specific run command process.
    
    * gnu/installer/record.scm (installer)[run-command]: Add field.
    * gnu/installer/utils.scm (run-command-in-installer): Add parameter.
    * gnu/installer.scm (installer-program): Parameterize
    run-command-in-installer with current installer's run-command.
    * gnu/installer/newt.scm (newt-run-command): New variable.
    (newt-installer): Use it.
    
    Signed-off-by: Mathieu Othacehe <othacehe@gnu.org>
---
 gnu/installer.scm        | 79 +++++++++++++++++++++++++-----------------------
 gnu/installer/newt.scm   | 10 +++++-
 gnu/installer/record.scm |  7 +++--
 gnu/installer/utils.scm  | 10 ++++++
 4 files changed, 65 insertions(+), 41 deletions(-)

diff --git a/gnu/installer.scm b/gnu/installer.scm
index d0d012f04b..3cc5c79d4e 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -416,44 +416,47 @@ selected keymap."
             (define steps (#$steps current-installer))
             ((installer-init current-installer))
 
-            (catch #t
-              (lambda ()
-                (define results
-                  (run-installer-steps
-                   #:rewind-strategy 'menu
-                   #:menu-proc (installer-menu-page current-installer)
-                   #:steps steps))
-
-                (match (result-step results 'final)
-                  ('success
-                   ;; We did it!  Let's reboot!
-                   (sync)
-                   (stop-service 'root))
-                  (_
-                   ;; 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)))
+            (parameterize
+                ((run-command-in-installer
+                  (installer-run-command current-installer)))
+              (catch #t
+                (lambda ()
+                  (define results
+                    (run-installer-steps
+                     #:rewind-strategy 'menu
+                     #:menu-proc (installer-menu-page current-installer)
+                     #:steps steps))
+
+                  (match (result-step results 'final)
+                    ('success
+                     ;; We did it!  Let's reboot!
+                     (sync)
+                     (stop-service 'root))
+                    (_
+                     ;; 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))))
 
             ((installer-exit current-installer))))))
 
diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm
index 61fb9cf2ca..fc851339d1 100644
--- a/gnu/installer/newt.scm
+++ b/gnu/installer/newt.scm
@@ -79,6 +79,13 @@ problem. The backtrace is displayed below~a. Please report 
it by email to \
   (newt-finish)
   (clear-screen))
 
+(define (newt-run-command . args)
+  (newt-suspend)
+  (clear-screen)
+  (define result (run-command args))
+  (newt-resume)
+  result)
+
 (define (final-page result prev-steps)
   (run-final-page result prev-steps))
 
@@ -150,4 +157,5 @@ problem. The backtrace is displayed below~a. Please report 
it by email to \
    (welcome-page welcome-page)
    (parameters-menu parameters-menu)
    (parameters-page parameters-page)
-   (dump-page dump-page)))
+   (dump-page dump-page)
+   (run-command newt-run-command)))
diff --git a/gnu/installer/record.scm b/gnu/installer/record.scm
index e7cd45ee83..23db3edd70 100644
--- a/gnu/installer/record.scm
+++ b/gnu/installer/record.scm
@@ -42,7 +42,8 @@
             installer-welcome-page
             installer-parameters-menu
             installer-parameters-page
-            installer-dump-page))
+            installer-dump-page
+            installer-run-command))
 
 
 ;;;
@@ -94,4 +95,6 @@
   ;; procedure (keyboard-layout-selection) -> void
   (parameters-page installer-parameters-page)
   ;; procedure (dump) -> void
-  (dump-page installer-dump-page))
+  (dump-page installer-dump-page)
+  ;; procedure command -> bool
+  (run-command installer-run-command))
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 66c41ac2a1..fb62fb8896 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -25,6 +25,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (ice-9 control)
   #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
@@ -39,6 +40,7 @@
             run-external-command-with-handler
             run-external-command-with-line-hooks
             run-command
+            run-command-in-installer
 
             syslog-port
             %syslog-line-hook
@@ -168,6 +170,14 @@ successfully, #f otherwise."
   (pause)
   succeeded?)
 
+(define run-command-in-installer
+  (make-parameter
+   (lambda (. args)
+     (raise
+      (condition
+       (&serious)
+       (&message (message "run-command-in-installer not set")))))))
+
 
 ;;;
 ;;; Logging.