[bug#53063] [PATCH v2 wip-harden-installer 14/18] installer: Use named prompt to abort or break installer steps.

[Josselin Poiret]

* gnu/installer/steps.scm (run-installer-steps): Set up
'installer-step prompt.
* gnu/installer/newt/ethernet.scm (run-ethernet-page)
* gnu/installer/newt/final.scm (run-config-display-page,
run-install-failed-page)
* gnu/installer/newt/keymap.scm (run-layout-page, run-variant-page)
* gnu/installer/newt/locale.scm (run-language-page,
run-territory-page, run-codeset-page, run-modifier-page,
run-locale-page)
* gnu/installer/newt/network.scm (run-technology-page,
wait-service-online)
* gnu/installer/newt/page.scm (run-listbox-selection-page,
run-checkbox-tree-page)
* gnu/installer/newt/partition.scm (button-exit-action)
* gnu/installer/newt/services.scm (run-desktop-environments-cbt-page,
run-networking-cbt-page, run-other-services-cbt-page,
run-network-management-page)
* gnu/installer/newt/timezone.scm (run-timezone-page)
* gnu/installer/newt/user.scm (run-user-page)
* gnu/installer/newt/welcome.scm (run-menu-page)
* gnu/installer/newt/wifi.scm (run-wifi-page): Use the 'installer-step
prompt to abort.
---
 gnu/installer/newt/ethernet.scm  |   8 +-
 gnu/installer/newt/final.scm     |   8 +-
 gnu/installer/newt/keymap.scm    |   8 +-
 gnu/installer/newt/locale.scm    |  25 ++----
 gnu/installer/newt/network.scm   |  16 +---
 gnu/installer/newt/page.scm      |   4 +-
 gnu/installer/newt/partition.scm |   6 +-
 gnu/installer/newt/services.scm  |  16 +---
 gnu/installer/newt/timezone.scm  |   4 +-
 gnu/installer/newt/user.scm      |   5 +-
 gnu/installer/newt/welcome.scm   |   2 +-
 gnu/installer/newt/wifi.scm      |   4 +-
 gnu/installer/steps.scm          | 127 +++++++++++++------------------
 13 files changed, 85 insertions(+), 148 deletions(-)

diff --git a/gnu/installer/newt/ethernet.scm b/gnu/installer/newt/ethernet.scm
index ecd22efbb2..d75a640519 100644
--- a/gnu/installer/newt/ethernet.scm
+++ b/gnu/installer/newt/ethernet.scm
@@ -65,9 +65,7 @@ (define (run-ethernet-page)
      (run-error-page
       (G_ "No ethernet service available, please try again.")
       (G_ "No service"))
-     (raise
-      (condition
-       (&installer-step-abort))))
+     (abort-to-prompt 'installer-step 'abort))
     ((service)
      ;; Only one service is available so return it directly.
      service)
@@ -81,7 +79,5 @@ (define (run-ethernet-page)
       #:button-text (G_ "Exit")
       #:button-callback-procedure
       (lambda _
-        (raise
-         (condition
-          (&installer-step-abort))))
+        (abort-to-prompt 'installer-step 'abort))
       #:listbox-callback-procedure connect-ethernet-service))))
diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm
index efe422f4f4..7c3f73ee82 100644
--- a/gnu/installer/newt/final.scm
+++ b/gnu/installer/newt/final.scm
@@ -59,9 +59,7 @@ (define* (run-config-display-page #:key locale)
      #:file-textbox-height height
      #:exit-button-callback-procedure
      (lambda ()
-       (raise
-        (condition
-         (&installer-step-abort)))))))
+       (abort-to-prompt 'installer-step 'abort)))))
 
 (define (run-install-success-page)
   (match (current-clients)
@@ -88,9 +86,7 @@ (define (run-install-failed-page)
              (G_ "Restart the installer")
              (G_ "The final system installation step failed.  You can resume 
from \
 a specific step, or restart the installer."))
-       (1 (raise
-           (condition
-            (&installer-step-abort))))
+       (1 (abort-to-prompt 'installer-step 'abort))
        (2
         ;; Keep going, the installer will be restarted later on.
         #t)))
diff --git a/gnu/installer/newt/keymap.scm b/gnu/installer/newt/keymap.scm
index 92f7f46f34..c5d4be6792 100644
--- a/gnu/installer/newt/keymap.scm
+++ b/gnu/installer/newt/keymap.scm
@@ -59,9 +59,7 @@ (define (run-layout-page layouts layout->text context)
        ((param) (const #f))
        (else
         (lambda _
-          (raise
-           (condition
-            (&installer-step-abort)))))))))
+          (abort-to-prompt 'installer-step 'abort)))))))
 
 (define (run-variant-page variants variant->text)
   (let ((title (G_ "Variant")))
@@ -74,9 +72,7 @@ (define (run-variant-page variants variant->text)
      #:button-text (G_ "Back")
      #:button-callback-procedure
      (lambda _
-       (raise
-        (condition
-         (&installer-step-abort)))))))
+       (abort-to-prompt 'installer-step 'abort)))))
 
 (define (sort-layouts layouts)
   "Sort LAYOUTS list by putting the US layout ahead and return it."
diff --git a/gnu/installer/newt/locale.scm b/gnu/installer/newt/locale.scm
index bfd89aca2c..01171e253f 100644
--- a/gnu/installer/newt/locale.scm
+++ b/gnu/installer/newt/locale.scm
@@ -43,9 +43,7 @@ (define result
      #:button-text (G_ "Exit")
      #:button-callback-procedure
      (lambda _
-       (raise
-        (condition
-         (&installer-step-abort))))))
+       (abort-to-prompt 'installer-step 'abort))))
 
   ;; Immediately install the chosen language so that the territory page that
   ;; comes after (optionally) is displayed in the chosen language.
@@ -63,9 +61,7 @@ (define (run-territory-page territories territory->text)
      #:button-text (G_ "Back")
      #:button-callback-procedure
      (lambda _
-       (raise
-        (condition
-         (&installer-step-abort)))))))
+       (abort-to-prompt 'installer-step 'abort)))))
 
 (define (run-codeset-page codesets)
   (let ((title (G_ "Locale codeset")))
@@ -78,9 +74,7 @@ (define (run-codeset-page codesets)
      #:button-text (G_ "Back")
      #:button-callback-procedure
      (lambda _
-       (raise
-        (condition
-         (&installer-step-abort)))))))
+       (abort-to-prompt 'installer-step 'abort)))))
 
 (define (run-modifier-page modifiers modifier->text)
   (let ((title (G_ "Locale modifier")))
@@ -94,9 +88,7 @@ (define (run-modifier-page modifiers modifier->text)
      #:button-text (G_ "Back")
      #:button-callback-procedure
      (lambda _
-       (raise
-        (condition
-         (&installer-step-abort)))))))
+       (abort-to-prompt 'installer-step 'abort)))))
 
 (define* (run-locale-page #:key
                           supported-locales
@@ -110,11 +102,10 @@ (define* (run-locale-page #:key
 glibc format is returned."
 
   (define (break-on-locale-found locales)
-    "Raise the &installer-step-break condition if LOCALES contains exactly one
+    "Break to the installer step if LOCALES contains exactly one
 element."
     (and (= (length locales) 1)
-         (raise
-          (condition (&installer-step-break)))))
+         (abort-to-prompt 'installer-step 'break)))
 
   (define (filter-locales locales result)
     "Filter the list of locale records LOCALES using the RESULT returned by
@@ -218,8 +209,8 @@ (define locale-steps
 
   ;; If run-installer-steps returns locally, it means that the user had to go
   ;; through all steps (language, territory, codeset and modifier) to select a
-  ;; locale. In that case, like if we exited by raising &installer-step-break
-  ;; condition, turn the result into a glibc locale string and return it.
+  ;; locale. In that case, like if we exited by breaking to the installer
+  ;; step, turn the result into a glibc locale string and return it.
   (result->locale-string
    supported-locales
    (run-installer-steps #:steps locale-steps)))
diff --git a/gnu/installer/newt/network.scm b/gnu/installer/newt/network.scm
index fb221483c3..0477a489be 100644
--- a/gnu/installer/newt/network.scm
+++ b/gnu/installer/newt/network.scm
@@ -65,12 +65,8 @@ (define (technology-items)
             (G_ "Exit")
             (G_ "The install process requires Internet access but no \
 network devices were found. Do you want to continue anyway?"))
-       ((1) (raise
-             (condition
-              (&installer-step-break))))
-       ((2) (raise
-             (condition
-              (&installer-step-abort))))))
+       ((1) (abort-to-prompt 'installer-step 'break))
+       ((2) (abort-to-prompt 'installer-step 'abort))))
     ((technology)
      ;; Since there's only one technology available, skip the selection
      ;; screen.
@@ -86,9 +82,7 @@ (define (technology-items)
       #:button-text (G_ "Exit")
       #:button-callback-procedure
       (lambda _
-        (raise
-         (condition
-          (&installer-step-abort))))))))
+        (abort-to-prompt 'installer-step 'abort))))))
 
 (define (find-technology-by-type technologies type)
   "Find and return a technology with the given TYPE in TECHNOLOGIES list."
@@ -156,9 +150,7 @@ (define (online?)
        (G_ "The selected network does not provide access to the \
 Internet and the Guix substitute server, please try again.")
        (G_ "Connection error"))
-      (raise
-       (condition
-        (&installer-step-abort))))))
+      (abort-to-prompt 'installer-step 'abort))))
 
 (define (run-network-page)
   "Run a page to allow the user to configure connman so that it can access the
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index 695c7d875f..8c675fa837 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -488,7 +488,7 @@ (define (choice->item str)
                         (string=? str (listbox-item->text item))))
                      keys)
           ((key . item) item)
-          (#f (raise (condition (&installer-step-abort))))))
+          (#f (abort-to-prompt 'installer-step 'abort))))
 
       ;; On every listbox element change, check if we need to skip it. If yes,
       ;; depending on the 'last-listbox-key', jump forward or backward. If no,
@@ -690,7 +690,7 @@ (define (choice->item str)
                         (string=? str (item->text item))))
                      keys)
           ((key . item) item)
-          (#f (raise (condition (&installer-step-abort))))))
+          (#f (abort-to-prompt 'installer-step 'abort))))
 
       (add-form-to-grid grid form #t)
       (make-wrapped-grid-window grid title)
diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm
index 6a3aa3daff..e7a97810ac 100644
--- a/gnu/installer/newt/partition.scm
+++ b/gnu/installer/newt/partition.scm
@@ -36,10 +36,8 @@ (define-module (gnu installer newt partition)
   #:export (run-partitioning-page))
 
 (define (button-exit-action)
-  "Raise the &installer-step-abort condition."
-  (raise
-   (condition
-    (&installer-step-abort))))
+  "Abort the installer step."
+  (abort-to-prompt 'installer-step 'abort))
 
 (define (run-scheme-page)
   "Run a page asking the user for a partitioning scheme."
diff --git a/gnu/installer/newt/services.scm b/gnu/installer/newt/services.scm
index c218825813..9951ad2212 100644
--- a/gnu/installer/newt/services.scm
+++ b/gnu/installer/newt/services.scm
@@ -46,9 +46,7 @@ (define (run-desktop-environments-cbt-page)
      #:checkbox-tree-height 9
      #:exit-button-callback-procedure
      (lambda ()
-       (raise
-        (condition
-         (&installer-step-abort)))))))
+       (abort-to-prompt 'installer-step 'abort)))))
 
 (define (run-networking-cbt-page)
   "Run a page allowing the user to select networking services."
@@ -65,9 +63,7 @@ (define (run-networking-cbt-page)
      #:checkbox-tree-height 5
      #:exit-button-callback-procedure
      (lambda ()
-       (raise
-        (condition
-         (&installer-step-abort)))))))
+       (abort-to-prompt 'installer-step 'abort)))))
 
 (define (run-printing-services-cbt-page)
   "Run a page allowing the user to select document services such as CUPS."
@@ -85,9 +81,7 @@ (define (run-printing-services-cbt-page)
      #:checkbox-tree-height 9
      #:exit-button-callback-procedure
      (lambda ()
-       (raise
-        (condition
-         (&installer-step-abort)))))))
+       (abort-to-prompt 'installer-step 'abort)))))
 
 (define (run-console-services-cbt-page)
   "Run a page to select various system adminstration services for non-graphical
@@ -130,9 +124,7 @@ (define (run-network-management-page)
      #:button-text (G_ "Exit")
      #:button-callback-procedure
      (lambda _
-       (raise
-        (condition
-         (&installer-step-abort)))))))
+       (abort-to-prompt 'installer-step 'abort)))))
 
 (define (run-services-page)
   (let ((desktop (run-desktop-environments-cbt-page)))
diff --git a/gnu/installer/newt/timezone.scm b/gnu/installer/newt/timezone.scm
index 67bf41ff84..bed9f9d5cb 100644
--- a/gnu/installer/newt/timezone.scm
+++ b/gnu/installer/newt/timezone.scm
@@ -65,9 +65,7 @@ (define (loop path)
          #:button-callback-procedure
          (if (null? path)
              (lambda _
-               (raise
-                (condition
-                 (&installer-step-abort))))
+               (abort-to-prompt 'installer-step 'abort))
              (lambda _
                (loop (all-but-last path))))
          #:listbox-callback-procedure
diff --git a/gnu/installer/newt/user.scm b/gnu/installer/newt/user.scm
index 58bb86bf96..97141cfe64 100644
--- a/gnu/installer/newt/user.scm
+++ b/gnu/installer/newt/user.scm
@@ -20,7 +20,6 @@
 
 (define-module (gnu installer newt user)
   #:use-module (gnu installer user)
-  #:use-module ((gnu installer steps) #:select (&installer-step-abort))
   #:use-module (gnu installer newt page)
   #:use-module (gnu installer newt utils)
   #:use-module (gnu installer utils)
@@ -257,9 +256,7 @@ (define (run users)
                    (run users))
                  (reverse users))
                 ((components=? argument exit-button)
-                 (raise
-                  (condition
-                   (&installer-step-abort))))))
+                 (abort-to-prompt 'installer-step 'abort))))
               ('exit-fd-ready
                ;; Read the complete user list at once.
                (match argument
diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm
index 5f461279e2..7a7ddfb7bd 100644
--- a/gnu/installer/newt/welcome.scm
+++ b/gnu/installer/newt/welcome.scm
@@ -84,7 +84,7 @@ (define (choice->item str)
                       (string=? str (listbox-item->text item))))
                    keys)
         ((key . item) item)
-        (#f (raise (condition (&installer-step-abort))))))
+        (#f (abort-to-prompt 'installer-step 'abort))))
 
     (set-textbox-text logo-textbox (read-all logo))
 
diff --git a/gnu/installer/newt/wifi.scm b/gnu/installer/newt/wifi.scm
index f5d8f1fdbf..8a87cbdf4b 100644
--- a/gnu/installer/newt/wifi.scm
+++ b/gnu/installer/newt/wifi.scm
@@ -237,9 +237,7 @@ (define (run-wifi-page)
               (run-wifi-scan-page)
               (run-wifi-page))
              ((components=? argument exit-button)
-              (raise
-               (condition
-                (&installer-step-abort))))
+              (abort-to-prompt 'installer-step 'abort))
              ((components=? argument listbox)
               (let ((result (connect-wifi-service listbox service-items)))
                 (unless result
diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm
index d9b3d6d07e..8bc38181a7 100644
--- a/gnu/installer/steps.scm
+++ b/gnu/installer/steps.scm
@@ -28,13 +28,7 @@ (define-module (gnu installer steps)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (rnrs io ports)
-  #:export (&installer-step-abort
-            installer-step-abort?
-
-            &installer-step-break
-            installer-step-break?
-
-            <installer-step>
+  #:export (<installer-step>
             installer-step
             make-installer-step
             installer-step?
@@ -60,14 +54,6 @@ (define-module (gnu installer steps)
 ;; purposes.
 (define %current-result (make-hash-table))
 
-;; This condition may be raised to abort the current step.
-(define-condition-type &installer-step-abort &condition
-  installer-step-abort?)
-
-;; This condition may be raised to break out from the steps execution.
-(define-condition-type &installer-step-break &condition
-  installer-step-break?)
-
 ;; An installer-step record is basically an id associated to a compute
 ;; procedure. The COMPUTE procedure takes exactly one argument, an association
 ;; list containing the results of previously executed installer-steps (see
@@ -94,8 +80,10 @@ (define* (run-installer-steps #:key
                               (rewind-strategy 'previous)
                               (menu-proc (const #f)))
   "Run the COMPUTE procedure of all <installer-step> records in STEPS
-sequentially.  If the &installer-step-abort condition is raised, fallback to a
-previous install-step, accordingly to the specified REWIND-STRATEGY.
+sequentially, inside a the 'installer-step prompt.  When aborted to with a
+parameter of 'abort, fallback to a previous install-step, accordingly to the
+specified REWIND-STRATEGY.  When aborted to with a parameter of 'break, stop
+the computation and return the accumalated result so far.
 
 REWIND-STRATEGY possible values are 'previous, 'menu and 'start.  If 'previous
 is selected, the execution will resume at the previous installer-step. If
@@ -112,10 +100,7 @@ (define* (run-installer-steps #:key
 where STEP-ID is the ID field of the installer-step and COMPUTE-RESULT the
 result of the associated COMPUTE procedure. This result association list is
 passed as argument of every COMPUTE procedure. It is finally returned when the
-computation is over.
-
-If the &installer-step-break condition is raised, stop the computation and
-return the accumalated result so far."
+computation is over."
   (define (pop-result list)
     (cdr list))
 
@@ -149,63 +134,61 @@ (define* (run result #:key todo-steps done-steps)
     (match todo-steps
       (() (reverse result))
       ((step . rest-steps)
-       (guard (c ((installer-step-abort? c)
-                  (case rewind-strategy
-                    ((previous)
-                     (match done-steps
-                       (()
-                        ;; We cannot go previous the first step. So re-raise
-                        ;; the exception. It might be useful in the case of
-                        ;; nested run-installer-steps. Abort to 'raise-above
-                        ;; prompt to prevent the condition from being catched
-                        ;; by one of the previously installed guard.
-                        (abort-to-prompt 'raise-above c))
-                       ((prev-done ... last-done)
-                        (run (pop-result result)
-                             #:todo-steps (cons last-done todo-steps)
-                             #:done-steps prev-done))))
-                    ((menu)
-                     (let ((goto-step (menu-proc
-                                       (append done-steps (list step)))))
-                       (if (eq? goto-step step)
-                           (run result
-                                #:todo-steps todo-steps
-                                #:done-steps done-steps)
-                           (skip-to-step goto-step result
-                                         #:todo-steps todo-steps
-                                         #:done-steps done-steps))))
-                    ((start)
-                     (if (null? done-steps)
-                         ;; Same as above, it makes no sense to jump to start
-                         ;; when we are at the first installer-step. Abort to
-                         ;; 'raise-above prompt to re-raise the condition.
-                         (abort-to-prompt 'raise-above c)
-                         (run '()
-                              #:todo-steps steps
-                              #:done-steps '())))))
-                 ((installer-step-break? c)
-                  (reverse result)))
-         (installer-log-line "running step '~a'" (installer-step-id step))
-         (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))))))))
+       (call-with-prompt 'installer-step
+         (lambda ()
+           (installer-log-line "running step '~a'" (installer-step-id step))
+           (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)))))
+         (lambda (k action)
+           (match action
+             ('abort
+              (case rewind-strategy
+                ((previous)
+                 (match done-steps
+                   (()
+                    ;; We cannot go previous the first step. Abort again to
+                    ;; 'installer-step prompt. It might be useful in the case
+                    ;; of nested run-installer-steps.
+                    (abort-to-prompt 'installer-step action))
+                   ((prev-done ... last-done)
+                    (run (pop-result result)
+                         #:todo-steps (cons last-done todo-steps)
+                         #:done-steps prev-done))))
+                ((menu)
+                 (let ((goto-step (menu-proc
+                                   (append done-steps (list step)))))
+                   (if (eq? goto-step step)
+                       (run result
+                            #:todo-steps todo-steps
+                            #:done-steps done-steps)
+                       (skip-to-step goto-step result
+                                     #:todo-steps todo-steps
+                                     #:done-steps done-steps))))
+                ((start)
+                 (if (null? done-steps)
+                     ;; Same as above, it makes no sense to jump to start
+                     ;; when we are at the first installer-step. Abort to
+                     ;; 'installer-step prompt again.
+                     (abort-to-prompt 'installer-step action)
+                     (run '()
+                          #:todo-steps steps
+                          #:done-steps '())))))
+             ('break
+              (reverse result))))))))
 
   ;; Ignore SIGPIPE so that we don't die if a client closes the connection
   ;; prematurely.
   (sigaction SIGPIPE SIG_IGN)
 
   (with-server-socket
-    (call-with-prompt 'raise-above
-      (lambda ()
-        (run '()
-             #:todo-steps steps
-             #:done-steps '()))
-      (lambda (k condition)
-        (raise condition)))))
+    (run '()
+         #:todo-steps steps
+         #:done-steps '())))
 
 (define (find-step-by-id steps id)
   "Find and return the step in STEPS whose id is equal to ID."
-- 
2.34.0