[bug#73927] [PATCH v3 14/17] installer: Add dry-run?

[Janneke Nieuwenhuizen <janneke@gnu.org>]

This allows running the installer without root privileges.  Do something like

    ./pre-inst-env guix repl
    ,use (guix)
    ,use (gnu installer)
    (installer-program #:dry-run? #t)
    ,build $1
    =>
    "/gnu/store/...-installer-program"

and run

    /gnu/store/...-installer-program

* gnu/installer/newt.scm (locale-page): Add #:dry-run? parameter.
(keymap-page): Likewise.
* gnu/installer/newt/keymap.scm (run-keymap-page): Likewise.
* gnu/installer/steps.scm (run-installer-steps): Likewise.  Use it to skip
writing to socket.
* gnu/installer/newt/final.scm (run-final-page): Rename to...
(run-final-page-install): ...this.
(dry-run-final-page, run-final-page): New procedures.
* gnu/installer/parted.scm (bootloader-configuration): Cater for empty user
partitions.
* gnu/installer/utils.scm (dry-run-command): New procedure.
* gnu/installer.scm (compute-locale-step): Add #:dry-run? parameter.  Use it
to avoid actually applying locale.
(compute-keymap-step): Add dry-run? parameter.  Pass it to
keymap-page.
(installer-program): Add #:dry-run? parameter.  If #:true
avoid writing to /proc, use dry-run-command, skip sync and reboot, and pass
dry-run? to...
(installer-steps): ...here.  Add #:dry-run? parameter.  Use it to disable
skip network, substitutes, partitioning pages, and pass it to...
compute-locale-step, compute-keymap-step, and final-page.

Change-Id: I0ff4c3b0a0c69539af617c27ba37654beed44619
---
 gnu/installer.scm                | 81 ++++++++++++++++++++------------
 gnu/installer/newt.scm           | 14 +++---
 gnu/installer/newt/final.scm     | 20 +++++++-
 gnu/installer/newt/keymap.scm    |  5 +-
 gnu/installer/newt/locale.scm    |  6 ++-
 gnu/installer/newt/partition.scm |  1 +
 gnu/installer/parted.scm         | 29 +++++++-----
 gnu/installer/steps.scm          | 16 +++++--
 gnu/installer/utils.scm          |  4 ++
 9 files changed, 116 insertions(+), 60 deletions(-)

diff --git a/gnu/installer.scm b/gnu/installer.scm
index 21809e4259..39a83c4455 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -134,7 +134,8 @@ (define apply-locale
 (define* (compute-locale-step #:key
                               locales-name
                               iso639-languages-name
-                              iso3166-territories-name)
+                              iso3166-territories-name
+                              dry-run?)
   "Return a gexp that run the locale-page of INSTALLER, and install the
 selected locale. The list of locales, languages and territories passed to
 locale-page are computed in derivations named respectively LOCALES-NAME,
@@ -177,8 +178,11 @@ (define (compiled-file-loader file name)
                ((installer-locale-page current-installer)
                 #:supported-locales #$locales-loader
                 #:iso639-languages #$iso639-loader
-                #:iso3166-territories #$iso3166-loader)))
-          (#$apply-locale result)
+                #:iso3166-territories #$iso3166-loader
+                #:dry-run? #$dry-run?)))
+          (if #$dry-run?
+              '()
+              (#$apply-locale result))
           result))))
 
 (define apply-keymap
@@ -188,7 +192,7 @@ (define apply-keymap
        (kmscon-update-keymap (default-keyboard-model)
                              layout variant options))))
 
-(define* (compute-keymap-step context)
+(define (compute-keymap-step context dry-run?)
   "Return a gexp that runs the keymap-page of INSTALLER and install the
 selected keymap."
   #~(lambda (current-installer)
@@ -200,15 +204,16 @@ (define* (compute-keymap-step context)
                                    "/share/X11/xkb/rules/base.xml")))
                (lambda (models layouts)
                  ((installer-keymap-page current-installer)
-                  layouts '#$context)))))
+                  layouts '#$context #$dry-run?)))))
         (and result (#$apply-keymap result))
         result)))
 
-(define (installer-steps)
+(define* (installer-steps #:key dry-run?)
   (let ((locale-step (compute-locale-step
                       #:locales-name "locales"
                       #:iso639-languages-name "iso639-languages"
-                      #:iso3166-territories-name "iso3166-territories"))
+                      #:iso3166-territories-name "iso3166-territories"
+                      #:dry-run? dry-run?))
         (timezone-data #~(string-append #$tzdata
                                         "/share/zoneinfo/zone.tab")))
     #~(lambda (current-installer)
@@ -216,7 +221,7 @@ (define (installer-steps)
          (lambda ()
            ((installer-parameters-page current-installer)
             (lambda _
-              (#$(compute-keymap-step 'param)
+              (#$(compute-keymap-step 'param dry-run?)
                current-installer)))))
         (list
          ;; Ask the user to choose a locale among those supported by
@@ -262,8 +267,10 @@ (define (installer-steps)
           (id 'keymap)
           (description (G_ "Keyboard mapping selection"))
           (compute (lambda _
-                     (#$(compute-keymap-step 'default)
-                      current-installer)))
+                     (if #$dry-run?
+                         '("en" "US" #f)
+                         (#$(compute-keymap-step 'default dry-run?)
+                       current-installer))))
           (configuration-formatter keyboard-layout->configuration))
 
          ;; Ask the user to input a hostname for the system.
@@ -280,14 +287,18 @@ (define (installer-steps)
           (id 'network)
           (description (G_ "Network selection"))
           (compute (lambda _
-                     ((installer-network-page current-installer)))))
+                     (if #$dry-run?
+                         '()
+                         ((installer-network-page current-installer))))))
 
          ;; Ask whether to enable substitute server discovery.
          (installer-step
           (id 'substitutes)
           (description (G_ "Substitute server discovery"))
           (compute (lambda _
-                     ((installer-substitutes-page current-installer)))))
+                     (if #$dry-run?
+                         '()
+                         ((installer-substitutes-page current-installer))))))
 
          ;; Prompt for users (name, group and home directory).
          (installer-step
@@ -313,7 +324,9 @@ (define (installer-steps)
           (id 'partition)
           (description (G_ "Partitioning"))
           (compute (lambda _
-                     ((installer-partitioning-page current-installer))))
+                     (if #$dry-run?
+                         '()
+                         ((installer-partitioning-page current-installer)))))
           (configuration-formatter user-partitions->configuration))
 
          (installer-step
@@ -322,7 +335,7 @@ (define (installer-steps)
           (compute
            (lambda (result prev-steps)
              ((installer-final-page current-installer)
-              result prev-steps))))))))
+              result prev-steps #$dry-run?))))))))
 
 (define (provenance-sexp)
   "Return an sexp representing the currently-used channels, for logging
@@ -343,7 +356,7 @@ (define (provenance-sexp)
              `(channel ,(channel-name channel) ,url ,(channel-commit channel))))
           channels))))
 
-(define (installer-program)
+(define* (installer-program #:key dry-run?)
   "Return a file-like object that runs the given INSTALLER."
   (define init-gettext
     ;; Initialize gettext support, so that installer messages can be
@@ -377,7 +390,7 @@ (define set-installer-path
           (lambda ()
             (set-path-environment-variable "PATH" '("bin" "sbin") inputs)))))
 
-  (define steps (installer-steps))
+  (define steps (installer-steps #:dry-run? dry-run?))
   (define modules
     (scheme-modules*
      (string-append (current-source-directory) "/..")
@@ -425,9 +438,10 @@ (define installer-builder
 
             ;; Enable core dump generation.
             (setrlimit 'core #f #f)
-            (call-with-output-file "/proc/sys/kernel/core_pattern"
-              (lambda (port)
-                (format port %core-dump)))
+            (unless #$dry-run?
+              (call-with-output-file "/proc/sys/kernel/core_pattern"
+                (lambda (port)
+                  (format port %core-dump))))
 
             ;; Initialize gettext support so that installers can use
             ;; (guix i18n) module.
@@ -466,24 +480,29 @@ (define steps (#$steps current-installer))
               (lambda ()
                 (parameterize
                     ((%run-command-in-installer
-                      (installer-run-command current-installer)))
+                      (if #$dry-run?
+                          dry-run-command
+                          (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)))
+                         #:steps steps
+                         #:dry-run? #$dry-run?))
+
+                      (let ((result (result-step results 'final)))
+                        (unless #$dry-run?
+                         (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"
diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm
index 6d8ea35fff..d53bc058b3 100644
--- a/gnu/installer/newt.scm
+++ b/gnu/installer/newt.scm
@@ -158,17 +158,19 @@ (define stop-sig (status:stop-sig result))
                                       (term-signal term-sig)
                                       (stop-signal stop-sig)))))))))))
 
-(define (final-page result prev-steps)
-  (run-final-page result prev-steps))
+(define (final-page result prev-steps dry-run?)
+  (run-final-page result prev-steps dry-run?))
 
 (define* (locale-page #:key
                       supported-locales
                       iso639-languages
-                      iso3166-territories)
+                      iso3166-territories
+                      dry-run?)
   (run-locale-page
    #:supported-locales supported-locales
    #:iso639-languages iso639-languages
-   #:iso3166-territories iso3166-territories))
+   #:iso3166-territories iso3166-territories
+   #:dry-run? dry-run?))
 
 (define (timezone-page zonetab)
   (run-timezone-page zonetab))
@@ -179,8 +181,8 @@ (define* (welcome-page logo #:key pci-database)
 (define (menu-page steps)
   (run-menu-page steps))
 
-(define* (keymap-page layouts context)
-  (run-keymap-page layouts #:context context))
+(define (keymap-page layouts context dry-run?)
+  (run-keymap-page layouts #:context context #:dry-run? dry-run?))
 
 (define (network-page)
   (run-network-page))
diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm
index 9f950a0551..c4e53f6d79 100644
--- a/gnu/installer/newt/final.scm
+++ b/gnu/installer/newt/final.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -106,7 +107,7 @@ (define* (run-install-shell locale
     (newt-resume)
     install-ok?))
 
-(define (run-final-page result prev-steps)
+(define (run-final-page-install result prev-steps)
   (define (wait-for-clients)
     (unless (null? (current-clients))
       (installer-log-line "waiting with clients before starting final step")
@@ -133,3 +134,20 @@ (define (wait-for-clients)
     (if install-ok?
         (run-install-success-page)
         (run-install-failed-page))))
+
+(define (dry-run-final-page result prev-steps)
+  (installer-log-line "proceeding with final step -- dry-run")
+  (let* ((configuration   (format-configuration prev-steps result))
+         (user-partitions (result-step result 'partition))
+         (locale          (result-step result 'locale))
+         (users           (result-step result 'user))
+         (file            (configuration->file configuration))
+         (install-ok?     (run-config-display-page #:locale locale)))
+    (if install-ok?
+        (run-install-success-page)
+        (run-install-failed-page))))
+
+(define (run-final-page result prev-steps dry-run?)
+  (if dry-run?
+      (dry-run-final-page result prev-steps)
+      (run-final-page-install result prev-steps)))
diff --git a/gnu/installer/newt/keymap.scm b/gnu/installer/newt/keymap.scm
index 109ec55e0a..57f6d6530c 100644
--- a/gnu/installer/newt/keymap.scm
+++ b/gnu/installer/newt/keymap.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
+;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -153,7 +154,7 @@ (define (toggleable-latin-layout layout variant)
          "grp:alt_shift_toggle"))
       (list layout variant #f)))
 
-(define* (run-keymap-page layouts #:key (context #f))
+(define* (run-keymap-page layouts #:key context dry-run?)
   "Run a page asking the user to select a keyboard layout and variant. LAYOUTS
 is a list of supported X11-KEYMAP-LAYOUT.  For non-Latin keyboard layouts, a
 second layout and toggle options will be added automatically.  Return a list
@@ -201,7 +202,7 @@ (define (format-result layout variant)
                                      "xkeyboard-config")))))
       (toggleable-latin-layout layout variant)))
 
-  (let* ((result (run-installer-steps #:steps keymap-steps))
+  (let* ((result (run-installer-steps #:steps keymap-steps #:dry-run? dry-run?))
          (layout (result-step result 'layout))
          (variant (result-step result 'variant)))
     (and layout
diff --git a/gnu/installer/newt/locale.scm b/gnu/installer/newt/locale.scm
index a226b39ba6..0be9db449e 100644
--- a/gnu/installer/newt/locale.scm
+++ b/gnu/installer/newt/locale.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -92,7 +93,8 @@ (define (run-modifier-page modifiers modifier->text)
 (define* (run-locale-page #:key
                           supported-locales
                           iso639-languages
-                          iso3166-territories)
+                          iso3166-territories
+                          dry-run?)
   "Run a page asking the user to select a locale language and possibly
 territory, codeset and modifier. Use SUPPORTED-LOCALES as the list of glibc
 available locales. ISO639-LANGUAGES is an association list associating a
@@ -212,4 +214,4 @@ (define locale-steps
   ;; step, turn the result into a glibc locale string and return it.
   (result->locale-string
    supported-locales
-   (run-installer-steps #:steps locale-steps)))
+   (run-installer-steps #:steps locale-steps #:dry-run? dry-run?)))
diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm
index 37656696c1..48dd306080 100644
--- a/gnu/installer/newt/partition.scm
+++ b/gnu/installer/newt/partition.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2018, 2019, 2022 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm
index e59df3d8e6..b36b238d8b 100644
--- a/gnu/installer/parted.scm
+++ b/gnu/installer/parted.scm
@@ -1461,19 +1461,22 @@ (define (root-user-partition? partition)
 
 (define (bootloader-configuration user-partitions)
   "Return the bootloader configuration field for USER-PARTITIONS."
-  (let* ((root-partition (find root-user-partition?
-                               user-partitions))
-         (root-partition-disk (user-partition-disk-file-name root-partition)))
-    `((bootloader-configuration
-       ,@(if (efi-installation?)
-             `((bootloader grub-efi-bootloader)
-               (targets (list ,(default-esp-mount-point))))
-             `((bootloader grub-bootloader)
-               (targets (list ,root-partition-disk))))
-
-       ;; XXX: Assume we defined the 'keyboard-layout' field of
-       ;; <operating-system> right above.
-       (keyboard-layout keyboard-layout)))))
+  (let ((root-partition (find root-user-partition? user-partitions)))
+    (match user-partitions
+      (() '())
+      (_
+       (let ((root-partition-disk (user-partition-disk-file-name
+                                   root-partition)))
+         `((bootloader-configuration
+            ,@(if (efi-installation?)
+                  `((bootloader grub-efi-bootloader)
+                    (targets (list ,(default-esp-mount-point))))
+                  `((bootloader grub-bootloader)
+                    (targets (list ,root-partition-disk))))
+
+            ;; XXX: Assume we defined the 'keyboard-layout' field of
+            ;; <operating-system> right above.
+            (keyboard-layout keyboard-layout))))))))
 
 (define (user-partition-missing-modules user-partitions)
   "Return the list of kernel modules missing from the default set of kernel
diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm
index 0c505e40e4..de0a852f02 100644
--- a/gnu/installer/steps.scm
+++ b/gnu/installer/steps.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -84,7 +85,8 @@ (define-record-type* <installer-step>
 (define* (run-installer-steps #:key
                               steps
                               (rewind-strategy 'previous)
-                              (menu-proc (const #f)))
+                              (menu-proc (const #f))
+                              dry-run?)
   "Run the COMPUTE procedure of all <installer-step> records in STEPS
 sequentially, inside a the 'installer-step prompt.  When aborted to with a
 parameter of 'abort, fallback to a previous install-step, accordingly to the
@@ -191,10 +193,14 @@ (define* (run result #:key todo-steps done-steps)
   ;; prematurely.
   (sigaction SIGPIPE SIG_IGN)
 
-  (with-server-socket
-    (run '()
-         #:todo-steps steps
-         #:done-steps '())))
+  (if dry-run?
+      (run '()
+           #:todo-steps steps
+           #:done-steps '())
+      (with-server-socket
+        (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."
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 170f036537..a8eb6cee83 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -49,6 +49,7 @@ (define-module (gnu installer utils)
             run-external-command-with-handler
             run-external-command-with-handler/tty
             run-external-command-with-line-hooks
+            dry-run-command
             run-command
             %run-command-in-installer
 
@@ -222,6 +223,9 @@ (define succeeded?
   (pause)
   succeeded?)
 
+(define (dry-run-command . args)
+  (format #t "dry-run-command: skipping: ~a\n" args))
+
 (define %run-command-in-installer
   (make-parameter
    (lambda (. args)
-- 
2.46.0