[PATCH wip-harden-installer 00/14] General improvements to the installer

  • Done
  • quality assurance status badge
Details
3 participants
  • Josselin Poiret
  • Ludovic Courtès
  • Mathieu Othacehe
Owner
unassigned
Submitted by
Josselin Poiret
Severity
normal
J
J
Josselin Poiret wrote on 6 Jan 2022 23:45
(address . guix-patches@gnu.org)(name . Josselin Poiret)(address . dev@jpoiret.xyz)
cover.1641507696.git.dev@jpoiret.xyz
Hello everyone,

Here are some miscellaneous improvements to the installer. Here is a
run down of the bigger changes:

* Patches 2 to 4 move logging from simply putting everything in syslog
to a more flexible approach, logging lines to multiple targets. One
new target is a per-install /tmp/installer.{DATETIME}.log.

* Patches 5 and 6 add a new alternative to invoke (or system*), which
forks to a new child process with a pipe back to the main process,
sets stdout and stderr to that pipe followed by execlp'ing the
command, while the main process reads from the pipe and applies some
configurable procedures to each line of output. This lets us log
all external command output using the same facility as the installer
itself, while displaying everything to the user. Patch 6 is
"optional", as it is there simply to avoid getting "Error in
finalization thread: Success".

* Patches 7 to 9 add a parameter run-command-in-installer, that is an
installer-specific way of running external commands. Here, the Newt
installer one simply suspends newt and runs the command in the
terminal.

* Patch 13 modifies the installer step aborting mechanism to
use general prompts instead of the exception system. This was done
so that a following patchset (which will hopefully be coming soon)
is able to abort an installer step from an exception handling code
that is outside of the run-installer-steps. You could also say that
it is cleaner :).

* Patch 14 adds a new confirmation page before running any external
command, with the possibility to abort the current installer step.

The next step should be moving installer-program in (gnu installer) to
use SRFI-34/35 exception handling over the current throw/catch one, as
the current code doesn't display those properly.

Josselin Poiret (14):
installer: Use define instead of let at top-level.
installer: Generalize logging facility.
installer: Use new installer-log-line everywhere.
installer: Un-export syslog syntax.
installer: Capture external commands output.
installer: Disable automatic finalization for child thread.
installer: Add installer-specific run command process.
installer: Use run-command-in-installer in (gnu installer parted).
installer: Use the command capturing facility for guix init.
installer: Raise condition when mklabel fails.
installer: Fix run-file-textbox-page when edit-button is #f.
installer: Replace run-command by invoke in newt/page.scm.
installer: Use named prompt to abort or break installer steps.
installer: Add confirmation page when running external commands.

gnu/installer.scm | 15 ++-
gnu/installer/final.scm | 23 +---
gnu/installer/newt.scm | 22 ++-
gnu/installer/newt/ethernet.scm | 8 +-
gnu/installer/newt/final.scm | 22 +--
gnu/installer/newt/keymap.scm | 8 +-
gnu/installer/newt/locale.scm | 25 ++--
gnu/installer/newt/network.scm | 16 +--
gnu/installer/newt/page.scm | 22 +--
gnu/installer/newt/partition.scm | 10 +-
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/parted.scm | 104 +++++++-------
gnu/installer/record.scm | 7 +-
gnu/installer/steps.scm | 127 ++++++++---------
gnu/installer/utils.scm | 225 +++++++++++++++++++++++++++----
19 files changed, 389 insertions(+), 276 deletions(-)

--
2.34.0
J
J
Josselin Poiret wrote on 6 Jan 2022 23:47
[PATCH wip-harden-installer 01/14] installer: Use define instead of let at top-level.
(address . 53063@debbugs.gnu.org)(name . Josselin Poiret)(address . dev@jpoiret.xyz)
5eec8987674e650ca14b1b1b3e8a211d10e772fd.1641507696.git.dev@jpoiret.xyz
* gnu/installer.scm (installer-program): Improve readability by using
define at top-level.
---
gnu/installer.scm | 88 +++++++++++++++++++++++------------------------
1 file changed, 44 insertions(+), 44 deletions(-)

Toggle diff (101 lines)
diff --git a/gnu/installer.scm b/gnu/installer.scm
index d57b1d673a..134fa2faaf 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -412,50 +412,50 @@ (define installer-builder
;; verbose.
(terminal-width 200)
- (let* ((current-installer newt-installer)
- (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)
- (syslog "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)))))))
+ (define current-installer newt-installer)
+ (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)
+ (syslog "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))))))
(program-file
"installer"
--
2.34.0
J
J
Josselin Poiret wrote on 6 Jan 2022 23:48
[PATCH wip-harden-installer 02/14] installer: Generalize logging facility.
(address . 53063@debbugs.gnu.org)(name . Josselin Poiret)(address . dev@jpoiret.xyz)
f601ae7801ca81113378db02f2d5b58be3d45226.1641507696.git.dev@jpoiret.xyz
* gnu/installer/utils.scm (%syslog-line-hook, open-new-log-port,
installer-log-port, %installer-log-line-hook, %display-line-hook,
%default-installer-line-hooks, installer-log-line): Add new
variables.
---
gnu/installer/utils.scm | 45 +++++++++++++++++++++++++++++++++++++++++
1 file changed, 45 insertions(+)

Toggle diff (73 lines)
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 9bd41e2ca0..b1b6f8b23f 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -37,7 +37,12 @@ (define-module (gnu installer utils)
run-command
syslog-port
+ %syslog-line-hook
syslog
+ installer-log-port
+ %installer-log-line-hook
+ %default-installer-line-hooks
+ installer-log-line
call-with-time
let/time
@@ -142,6 +147,9 @@ (define syslog-port
(set! port (open-syslog-port)))
(or port (%make-void-port "w")))))
+(define (%syslog-line-hook line)
+ (format (syslog-port) "installer[~d]: ~a~%" (getpid) line))
+
(define-syntax syslog
(lambda (s)
"Like 'format', but write to syslog."
@@ -152,6 +160,43 @@ (define-syntax syslog
(syntax->datum #'fmt))))
#'(format (syslog-port) fmt (getpid) args ...))))))
+(define (open-new-log-port)
+ (define now (localtime (time-second (current-time))))
+ (define filename
+ (format #f "/tmp/installer.~a.log"
+ (strftime "%F.%T" now)))
+ (open filename (logior O_RDWR
+ O_CREAT)))
+
+(define installer-log-port
+ (let ((port #f))
+ (lambda ()
+ "Return an input and output port to the installer log."
+ (unless port
+ (set! port (open-new-log-port)))
+ port)))
+
+(define (%installer-log-line-hook line)
+ (format (installer-log-port) "~a~%" line))
+
+(define (%display-line-hook line)
+ (display line)
+ (newline))
+
+(define %default-installer-line-hooks
+ (list %syslog-line-hook
+ %installer-log-line-hook))
+
+(define-syntax installer-log-line
+ (lambda (s)
+ "Like 'format', but uses the default line hooks, and only formats one line."
+ (syntax-case s ()
+ ((_ fmt args ...)
+ (string? (syntax->datum #'fmt))
+ #'(let ((formatted (format #f fmt args ...)))
+ (for-each (lambda (f) (f formatted))
+ %default-installer-line-hooks))))))
+
;;;
;;; Client protocol.
--
2.34.0
J
J
Josselin Poiret wrote on 6 Jan 2022 23:48
[PATCH wip-harden-installer 03/14] installer: Use new installer-log-line everywhere.
(address . 53063@debbugs.gnu.org)(name . Josselin Poiret)(address . dev@jpoiret.xyz)
bb0c1e37a4916fb6d0767c650b70893d07c943d8.1641507696.git.dev@jpoiret.xyz
* gnu/installer.scm (installer-program)
* gnu/installer/final.scm (install-locale)
* gnu/installer/newt.scm (init)
* gnu/installer/newt/final.scm (run-final-page)
* gnu/installer/newt/page.scm (run-form-with-clients)
* gnu/installer/newt/partition.scm (run-partitioning-page)
* gnu/installer/parted.scm (eligible-devices, mkpart,
luks-format-and-open, luks-close, mount-user-partitions,
umount-user-partitions, free-parted):
* gnu/installer/steps.scm (run-installer-steps):
* gnu/installer/utils.scm (run-command, send-to-clients): Use it.
---
gnu/installer.scm | 2 +-
gnu/installer/final.scm | 6 ++--
gnu/installer/newt.scm | 2 +-
gnu/installer/newt/final.scm | 4 +--
gnu/installer/newt/page.scm | 13 +++++----
gnu/installer/newt/partition.scm | 4 +--
gnu/installer/parted.scm | 50 ++++++++++++++++----------------
gnu/installer/steps.scm | 2 +-
gnu/installer/utils.scm | 13 +++++----
9 files changed, 49 insertions(+), 47 deletions(-)

Toggle diff (291 lines)
diff --git a/gnu/installer.scm b/gnu/installer.scm
index 134fa2faaf..d0d012f04b 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -435,7 +435,7 @@ (define results
#f)))
(const #f)
(lambda (key . args)
- (syslog "crashing due to uncaught exception: ~s ~s~%"
+ (installer-log-line "crashing due to uncaught exception: ~s ~s"
key args)
(let ((error-file "/tmp/last-installer-error")
(dump-archive "/tmp/dump.tgz"))
diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm
index 276af908f7..fbfac1f692 100644
--- a/gnu/installer/final.scm
+++ b/gnu/installer/final.scm
@@ -125,15 +125,15 @@ (define (install-locale locale)
(setlocale LC_ALL locale))))
(if supported?
(begin
- (syslog "install supported locale ~a~%." locale)
+ (installer-log-line "install supported locale ~a." locale)
(setenv "LC_ALL" locale))
(begin
;; If the selected locale is not supported, install a default UTF-8
;; locale. This is required to copy some files with UTF-8
;; characters, in the nss-certs package notably. Set LANGUAGE
;; anyways, to have translated messages if possible.
- (syslog "~a locale is not supported, installating en_US.utf8 \
-locale instead.~%" locale)
+ (installer-log-line "~a locale is not supported, installing \
+en_US.utf8 locale instead." locale)
(setlocale LC_ALL "en_US.utf8")
(setenv "LC_ALL" "en_US.utf8")
(setenv "LANGUAGE"
diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm
index d48e2c0129..61fb9cf2ca 100644
--- a/gnu/installer/newt.scm
+++ b/gnu/installer/newt.scm
@@ -48,7 +48,7 @@ (define (init)
(newt-init)
(clear-screen)
(set-screen-size!)
- (syslog "Display is ~ax~a.~%" (screen-columns) (screen-rows))
+ (installer-log-line "Display is ~ax~a." (screen-columns) (screen-rows))
(push-help-line
(format #f (G_ "Press <F1> for installation parameters."))))
diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm
index 7f6dd9f075..efe422f4f4 100644
--- a/gnu/installer/newt/final.scm
+++ b/gnu/installer/newt/final.scm
@@ -109,7 +109,7 @@ (define* (run-install-shell locale
(define (run-final-page result prev-steps)
(define (wait-for-clients)
(unless (null? (current-clients))
- (syslog "waiting with clients before starting final step~%")
+ (installer-log-line "waiting with clients before starting final step")
(send-to-clients '(starting-final-step))
(match (select (current-clients) '() '())
(((port _ ...) _ _)
@@ -119,7 +119,7 @@ (define (wait-for-clients)
;; things such as changing the swap partition label.
(wait-for-clients)
- (syslog "proceeding with final step~%")
+ (installer-log-line "proceeding with final step")
(let* ((configuration (format-configuration prev-steps result))
(user-partitions (result-step result 'partition))
(locale (result-step result 'locale))
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index 4209674c28..d9901c33a1 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -93,9 +93,9 @@ (define* (run-form-with-clients form exp)
Like 'run-form', return two values: the exit reason, and an \"argument\"."
(define* (discard-client! port #:optional errno)
(if errno
- (syslog "removing client ~d due to ~s~%"
+ (installer-log-line "removing client ~d due to ~s"
(fileno port) (strerror errno))
- (syslog "removing client ~d due to EOF~%"
+ (installer-log-line "removing client ~d due to EOF"
(fileno port)))
;; XXX: Watch out! There's no 'form-unwatch-fd' procedure in Newt so we
@@ -124,7 +124,7 @@ (define title
(send-to-clients exp)
(let loop ()
- (syslog "running form ~s (~s) with ~d clients~%"
+ (installer-log-line "running form ~s (~s) with ~d clients"
form title (length (current-clients)))
;; Call 'watch-clients!' within the loop because there might be new
@@ -146,7 +146,7 @@ (define title
(discard-client! port)
(loop))
(obj
- (syslog "form ~s (~s): client ~d replied ~s~%"
+ (installer-log-line "form ~s (~s): client ~d replied ~s"
form title (fileno port) obj)
(values 'exit-fd-ready obj))))
(lambda args
@@ -156,8 +156,9 @@ (define title
;; Accept a new client and send it EXP.
(match (accept port)
((client . _)
- (syslog "accepting new client ~d while on form ~s~%"
- (fileno client) form)
+ (installer-log-line
+ "accepting new client ~d while on form ~s"
+ (fileno client) form)
(catch 'system-error
(lambda ()
(write exp client)
diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm
index ccc7686906..6a3aa3daff 100644
--- a/gnu/installer/newt/partition.scm
+++ b/gnu/installer/newt/partition.scm
@@ -801,9 +801,9 @@ (define (run-page devices)
;; Make sure the disks are not in use before proceeding to formatting.
(free-parted eligible-devices)
(format-user-partitions user-partitions-with-pass)
- (syslog "formatted ~a user partitions~%"
+ (installer-log-line "formatted ~a user partitions"
(length user-partitions-with-pass))
- (syslog "user-partitions: ~a~%" user-partitions)
+ (installer-log-line "user-partitions: ~a" user-partitions)
(destroy-form-and-pop form)
user-partitions))
diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm
index 66e07574c9..ced7a757d7 100644
--- a/gnu/installer/parted.scm
+++ b/gnu/installer/parted.scm
@@ -371,7 +371,8 @@ (define (small-device? device)
(let ((length (device-length device))
(sector-size (device-sector-size device)))
(and (< (* length sector-size) %min-device-size)
- (syslog "~a is not eligible because it is smaller than ~a.~%"
+ (installer-log-line "~a is not eligible because it is smaller than \
+~a."
(device-path device)
(unit-format-custom-byte device
%min-device-size
@@ -391,7 +392,8 @@ (define (installation-device? device)
(string=? the-installer-root-partition-path
(partition-get-path partition)))
(disk-partitions disk)))))
- (syslog "~a is not eligible because it is the installation device.~%"
+ (installer-log-line "~a is not eligible because it is the \
+installation device."
(device-path device))))
(remove
@@ -817,24 +819,22 @@ (define* (extend-ranges! start-range end-range
(disk-add-partition disk partition no-constraint)))
(partition-ok?
(or partition-constraint-ok? partition-no-contraint-ok?)))
- (syslog "Creating partition:
-~/type: ~a
-~/filesystem-type: ~a
-~/start: ~a
-~/end: ~a
-~/start-range: [~a, ~a]
-~/end-range: [~a, ~a]
-~/constraint: ~a
-~/no-constraint: ~a
-"
- partition-type
- (filesystem-type-name filesystem-type)
- start-sector*
- end-sector
- (geometry-start start-range) (geometry-end start-range)
- (geometry-start end-range) (geometry-end end-range)
- partition-constraint-ok?
- partition-no-contraint-ok?)
+ (installer-log-line "Creating partition:")
+ (installer-log-line "~/type: ~a" partition-type)
+ (installer-log-line "~/filesystem-type: ~a"
+ (filesystem-type-name filesystem-type))
+ (installer-log-line "~/start: ~a" start-sector*)
+ (installer-log-line "~/end: ~a" end-sector)
+ (installer-log-line "~/start-range: [~a, ~a]"
+ (geometry-start start-range)
+ (geometry-end start-range))
+ (installer-log-line "~/end-range: [~a, ~a]"
+ (geometry-start end-range)
+ (geometry-end end-range))
+ (installer-log-line "~/constraint: ~a"
+ partition-constraint-ok?)
+ (installer-log-line "~/no-constraint: ~a"
+ partition-no-contraint-ok?)
;; Set the partition name if supported.
(when (and partition-ok? has-name? name)
(partition-set-name partition name))
@@ -1188,7 +1188,7 @@ (define (luks-format-and-open user-partition)
(call-with-luks-key-file
password
(lambda (key-file)
- (syslog "formatting and opening LUKS entry ~s at ~s~%"
+ (installer-log-line "formatting and opening LUKS entry ~s at ~s"
label file-name)
(system* "cryptsetup" "-q" "luksFormat" file-name key-file)
(system* "cryptsetup" "open" "--type" "luks"
@@ -1197,7 +1197,7 @@ (define (luks-format-and-open user-partition)
(define (luks-close user-partition)
"Close the encrypted partition pointed by USER-PARTITION."
(let ((label (user-partition-crypt-label user-partition)))
- (syslog "closing LUKS entry ~s~%" label)
+ (installer-log-line "closing LUKS entry ~s" label)
(system* "cryptsetup" "close" label)))
(define (format-user-partitions user-partitions)
@@ -1279,7 +1279,7 @@ (define (mount-user-partitions user-partitions)
(file-name
(user-partition-upper-file-name user-partition)))
(mkdir-p target)
- (syslog "mounting ~s on ~s~%" file-name target)
+ (installer-log-line "mounting ~s on ~s" file-name target)
(mount file-name target mount-type)))
sorted-partitions)))
@@ -1295,7 +1295,7 @@ (define (umount-user-partitions user-partitions)
(target
(string-append (%installer-target-dir)
mount-point)))
- (syslog "unmounting ~s~%" target)
+ (installer-log-line "unmounting ~s" target)
(umount target)
(when crypt-label
(luks-close user-partition))))
@@ -1486,6 +1486,6 @@ (define (free-parted devices)
(error
(format #f (G_ "Device ~a is still in use.")
file-name))
- (syslog "Syncing ~a took ~a seconds.~%"
+ (installer-log-line "Syncing ~a took ~a seconds."
file-name (time-second time)))))
device-file-names)))
diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm
index 55433cff31..d9b3d6d07e 100644
--- a/gnu/installer/steps.scm
+++ b/gnu/installer/steps.scm
@@ -185,7 +185,7 @@ (define* (run result #:key todo-steps done-steps)
#:done-steps '())))))
((installer-step-break? c)
(reverse result)))
- (syslog "running step '~a'~%" (installer-step-id step))
+ (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)))
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index b1b6f8b23f..74046c9cab 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -100,13 +100,13 @@ (define (pause)
(format (current-error-port)
(G_ "Command failed with exit code ~a.~%")
(invoke-error-exit-status c))
- (syslog "command ~s failed with exit code ~a"
- command (invoke-error-exit-status c))
+ (installer-log-line "command ~s failed with exit code ~a"
+ command (invoke-error-exit-status c))
(pause)
#f))
- (syslog "running command ~s~%" command)
+ (installer-log-line "running command ~s" command)
(apply invoke command)
- (syslog "command ~s succeeded~%" command)
+ (installer-log-line "command ~s succeeded" command)
(newline)
(pause)
#t))
@@ -259,8 +259,9 @@ (define remainder
(let ((errno (system-error-errno args)))
(if (memv errno (list EPIPE ECONNRESET ECONNABORTED))
(begin
- (syslog "removing client ~s due to ~s while replying~%"
- (fileno client) (strerror errno))
+ (installer-log-line
+ "removing client ~s due to ~s while replying"
+ (fileno client) (strerror errno))
(false-if-exception (close-port client))
remainder)
(cons client remainder))))))
--
2.34.0
J
J
Josselin Poiret wrote on 6 Jan 2022 23:48
[PATCH wip-harden-installer 04/14] installer: Un-export syslog syntax.
(address . 53063@debbugs.gnu.org)(name . Josselin Poiret)(address . dev@jpoiret.xyz)
cfea99887d76107f95e4c8a70144ea2a145bf275.1641507696.git.dev@jpoiret.xyz
* gnu/installer/utils.scm (syslog): Remove export.
---
gnu/installer/utils.scm | 1 -
1 file changed, 1 deletion(-)

Toggle diff (14 lines)
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 74046c9cab..1bff1e1229 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -38,7 +38,6 @@ (define-module (gnu installer utils)
syslog-port
%syslog-line-hook
- syslog
installer-log-port
%installer-log-line-hook
%default-installer-line-hooks
--
2.34.0
J
J
Josselin Poiret wrote on 6 Jan 2022 23:48
[PATCH wip-harden-installer 05/14] installer: Capture external commands output.
(address . 53063@debbugs.gnu.org)(name . Josselin Poiret)(address . dev@jpoiret.xyz)
fb8b136928d2d981eec2f284207b4dc7483077cc.1641507696.git.dev@jpoiret.xyz
* gnu/installer/utils.scm (close-fdes-ignore-badf, reset-fds,
run-external-command-with-handler,
run-external-command-with-line-hooks): New variables.
(run-command): Use run-external-command-with-line-hooks.
---
gnu/installer/utils.scm | 154 ++++++++++++++++++++++++++++++++++------
1 file changed, 134 insertions(+), 20 deletions(-)

Toggle diff (186 lines)
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 1bff1e1229..878434f074 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -25,7 +25,9 @@ (define-module (gnu installer utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-34)
+ #:use-module (ice-9 control)
#:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (ice-9 format)
@@ -78,37 +80,149 @@ (define (read-percentage percentage)
(and result
(string->number (match:substring result 1)))))
+;; This is needed because there are two close procedures in Guile:
+;; * close, which relocates ports that were using the fd to use a
+;; newly dup'd fd;
+;; * vanilla close-fdes, which does not ignore EBADF, making it
+;; impossible to use it to close all ports.
+(define (close-fdes-ignore-badf fd)
+ (let/ec escape
+ (with-exception-handler
+ (lambda (exn)
+ (if (eq? (exception-kind exn) 'system-error)
+ (let ((args (exception-args exn)))
+ (if (eq? (car (car (cdr (cdr (cdr args)))))
+ 9) ;; EBADF
+ (escape)
+ (raise-exception exn)))
+ (raise-exception exn)))
+ (lambda ()
+ (close-fdes fd)))))
+
+(define (reset-fds in out err)
+ "Resets the stdin, stdout and stderr to IN, OUT and ERR
+respectively, while closing all other open file descriptors."
+ ;; getrlimit is undocumented, but defined in
+ ;; libguile/posix.c.
+ (define maxfds (getrlimit 'nofile))
+ (let loop ((fd 0))
+ (and (< fd maxfds)
+ (begin (unless (or (eq? in fd)
+ (eq? out fd)
+ (eq? err fd))
+ (close-fdes-ignore-badf fd))
+ (loop (+ fd 1)))))
+ (define (next-available fd)
+ (and (< fd maxfds)
+ (if (or (eq? in fd)
+ (eq? out fd)
+ (eq? err fd))
+ (next-available (+ fd 1))
+ fd)))
+ (define dupin (next-available 3))
+ (define dupout (next-available (+ dupin 1)))
+ (define duperr (next-available (+ dupout 1)))
+ (dup2 in dupin)
+ (dup2 out dupout)
+ (dup2 err duperr)
+ (for-each close-fdes-ignore-badf (list in out err))
+ (dup2 dupin 0)
+ (dup2 dupout 1)
+ (dup2 duperr 2)
+ (for-each close-fdes (list dupin dupout duperr))
+ (set-current-input-port (fdes->inport 0))
+ (set-current-output-port (fdes->outport 1))
+ (set-current-error-port (fdes->outport 2)))
+
+(define* (run-external-command-with-handler handler command)
+ "Run command specified by the list COMMAND in a child with output handler
+HANDLER. HANDLER is a procedure taking an input port, to which the command
+will write its standard output and error. Returns the integer status value of
+the child process as returned by waitpid."
+ (match-let (((input . output) (pipe)))
+ (match (primitive-fork)
+ (0 ;; We're in the child
+ (close-port input)
+ (reset-fds
+ (open-fdes "/dev/null" O_WRONLY)
+ ;; Avoid port GC'ing closing the fd by increasing its revealed count.
+ (port->fdes output)
+ (fileno output))
+ (with-exception-handler
+ (lambda (exn)
+ ((@@ (ice-9 exceptions) format-exception) (current-error-port)
+ exn)
+ (primitive-_exit 1))
+ (lambda ()
+ (apply execlp (car command) command)
+ (primitive-_exit 1))))
+ (pid
+ (close-port output)
+ (handler input)
+ (close-port input)
+ (cdr (waitpid pid))))))
+
+(define (run-external-command-with-line-hooks line-hooks command)
+ "Run command specified by ARGS in a child, processing each output line with
+the procedures in LINE-HOOKS. Returns the integer status value of
+the child process as returned by waitpid."
+ (define (handler input)
+ (and (and=> (get-line input)
+ (lambda (line)
+ (if (eof-object? line)
+ #f
+ (begin (for-each (lambda (f) (f line))
+ (append line-hooks
+ %default-installer-line-hooks))
+ #t))))
+ (handler input)))
+ (run-external-command-with-handler handler command))
+
(define* (run-command command)
"Run COMMAND, a list of strings. Return true if COMMAND exited
successfully, #f otherwise."
- (define env (environ))
-
(define (pause)
(format #t (G_ "Press Enter to continue.~%"))
(send-to-clients '(pause))
- (environ env) ;restore environment variables
(match (select (cons (current-input-port) (current-clients))
'() '())
(((port _ ...) _ _)
(read-line port))))
- (setenv "PATH" "/run/current-system/profile/bin")
-
- (guard (c ((invoke-error? c)
- (newline)
- (format (current-error-port)
- (G_ "Command failed with exit code ~a.~%")
- (invoke-error-exit-status c))
- (installer-log-line "command ~s failed with exit code ~a"
- command (invoke-error-exit-status c))
- (pause)
- #f))
- (installer-log-line "running command ~s" command)
- (apply invoke command)
- (installer-log-line "command ~s succeeded" command)
- (newline)
- (pause)
- #t))
+ (installer-log-line "running command ~s" command)
+ (define result (run-external-command-with-line-hooks
+ (list %display-line-hook)
+ command))
+ (define exit-val (status:exit-val result))
+ (define term-sig (status:term-sig result))
+ (define stop-sig (status:stop-sig result))
+ (define succeeded?
+ (cond
+ ((and exit-val (not (zero? exit-val)))
+ (installer-log-line "command ~s exited with value ~a"
+ command exit-val)
+ (format #t (G_ "Command ~s exited with value ~a")
+ command exit-val)
+ #f)
+ (term-sig
+ (installer-log-line "command ~s killed by signal ~a"
+ command term-sig)
+ (format #t (G_ "Command ~s killed by signal ~a")
+ command term-sig)
+ #f)
+ (stop-sig
+ (installer-log-line "command ~s stopped by signal ~a"
+ command stop-sig)
+ (format #t (G_ "Command ~s stopped by signal ~a")
+ command stop-sig)
+ #f)
+ (else
+ (installer-log-line "command ~s succeeded" command)
+ (format #t (G_ "Command ~s succeeded") command)
+ #t)))
+ (newline)
+ (pause)
+ succeeded?)
;;;
--
2.34.0
J
J
Josselin Poiret wrote on 6 Jan 2022 23:48
[PATCH wip-harden-installer 06/14] installer: Disable automatic finalization for child thread.
(address . 53063@debbugs.gnu.org)(name . Josselin Poiret)(address . dev@jpoiret.xyz)
17c53526bb7d92f07515a6c2cc165e717aa21346.1641507696.git.dev@jpoiret.xyz
* gnu/installer/utils.scm (run-external-command-with-handler): Disable
finalization manually, to avoid having the finalizer thread spout
"error in finalization thread: Success".
---
gnu/installer/utils.scm | 10 ++++++++++
1 file changed, 10 insertions(+)

Toggle diff (30 lines)
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 878434f074..ad220492d9 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -32,6 +32,8 @@ (define-module (gnu installer utils)
#:use-module (ice-9 regex)
#:use-module (ice-9 format)
#:use-module (ice-9 textual-ports)
+ #:use-module (system foreign)
+ #:use-module (system foreign-library)
#:export (read-lines
read-all
nearest-exact-integer
@@ -143,6 +145,14 @@ (define* (run-external-command-with-handler handler command)
(match (primitive-fork)
(0 ;; We're in the child
(close-port input)
+ ;; XXX: Disable automatic finalization because we're going to exec.
+ ;; Might become unnecessary with newer Guile versions, as the
+ ;; *possible* finalization thread may stop properly when its pipe is
+ ;; closed.
+ ((foreign-library-function (load-foreign-library #f)
+ "scm_set_automatic_finalization_enabled"
+ #:return-type int
+ #:arg-types (list int)) 0)
(reset-fds
(open-fdes "/dev/null" O_WRONLY)
;; Avoid port GC'ing closing the fd by increasing its revealed count.
--
2.34.0
J
J
Josselin Poiret wrote on 6 Jan 2022 23:48
[PATCH wip-harden-installer 07/14] installer: Add installer-specific run command process.
(address . 53063@debbugs.gnu.org)(name . Josselin Poiret)(address . dev@jpoiret.xyz)
90da18d18c8398a5278b4893faa81323b0f3cd23.1641507696.git.dev@jpoiret.xyz
* 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.
---
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(-)

Toggle diff (174 lines)
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 @@ (define current-installer newt-installer)
(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 @@ (define (exit-error file report key args)
(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 @@ (define newt-installer
(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 @@ (define-module (gnu installer record)
installer-welcome-page
installer-parameters-menu
installer-parameters-page
- installer-dump-page))
+ installer-dump-page
+ installer-run-command))
;;;
@@ -94,4 +95,6 @@ (define-record-type* <installer>
;; 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 ad220492d9..b148fc2a81 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -25,6 +25,7 @@ (define-module (gnu installer utils)
#: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 @@ (define-module (gnu installer utils)
nearest-exact-integer
read-percentage
run-command
+ run-command-in-installer
syslog-port
%syslog-line-hook
@@ -234,6 +236,14 @@ (define succeeded?
(pause)
succeeded?)
+(define run-command-in-installer
+ (make-parameter
+ (lambda (. args)
+ (raise
+ (condition
+ (&serious)
+ (&message (message "run-command-in-installer not set")))))))
+
;;;
;;; Logging.
--
2.34.0
J
J
Josselin Poiret wrote on 6 Jan 2022 23:48
[PATCH wip-harden-installer 08/14] installer: Use run-command-in-installer in (gnu installer parted).
(address . 53063@debbugs.gnu.org)(name . Josselin Poiret)(address . dev@jpoiret.xyz)
fd17b5daf4a16b96d5f97841ec50c884dd6616ec.1641507696.git.dev@jpoiret.xyz
* gnu/installer/parted.scm (remove-logical-devices,
create-btrfs-file-system, create-ext4-file-system,
create-fat16-file-system, create-fat32-file-system,
create-jfs-file-system, create-ntfs-file-system,
create-xfs-file-system, create-swap-partition, luks-format-and-open,
luks-close): Use run-command-in-installer.
(with-null-output-ports): Remove.
---
gnu/installer/parted.scm | 44 +++++++++++++---------------------------
1 file changed, 14 insertions(+), 30 deletions(-)

Toggle diff (99 lines)
diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm
index ced7a757d7..c8bb73ee64 100644
--- a/gnu/installer/parted.scm
+++ b/gnu/installer/parted.scm
@@ -343,8 +343,7 @@ (define* (force-device-sync device)
(define (remove-logical-devices)
"Remove all active logical devices."
- (with-null-output-ports
- (invoke "dmsetup" "remove_all")))
+ ((run-command-in-installer) "dmsetup" "remove_all"))
(define (installer-root-partition-path)
"Return the root partition path, or #f if it could not be detected."
@@ -1115,53 +1114,37 @@ (define (set-user-partitions-file-name user-partitions)
(file-name file-name))))
user-partitions))
-(define-syntax-rule (with-null-output-ports exp ...)
- "Evaluate EXP with both the output port and the error port pointing to the
-bit bucket."
- (with-output-to-port (%make-void-port "w")
- (lambda ()
- (with-error-to-port (%make-void-port "w")
- (lambda () exp ...)))))
-
(define (create-btrfs-file-system partition)
"Create a btrfs file-system for PARTITION file-name."
- (with-null-output-ports
- (invoke "mkfs.btrfs" "-f" partition)))
+ ((run-command-in-installer) "mkfs.btrfs" "-f" partition))
(define (create-ext4-file-system partition)
"Create an ext4 file-system for PARTITION file-name."
- (with-null-output-ports
- (invoke "mkfs.ext4" "-F" partition)))
+ ((run-command-in-installer) "mkfs.ext4" "-F" partition))
(define (create-fat16-file-system partition)
"Create a fat16 file-system for PARTITION file-name."
- (with-null-output-ports
- (invoke "mkfs.fat" "-F16" partition)))
+ ((run-command-in-installer) "mkfs.fat" "-F16" partition))
(define (create-fat32-file-system partition)
"Create a fat32 file-system for PARTITION file-name."
- (with-null-output-ports
- (invoke "mkfs.fat" "-F32" partition)))
+ ((run-command-in-installer) "mkfs.fat" "-F32" partition))
(define (create-jfs-file-system partition)
"Create a JFS file-system for PARTITION file-name."
- (with-null-output-ports
- (invoke "jfs_mkfs" "-f" partition)))
+ ((run-command-in-installer) "jfs_mkfs" "-f" partition))
(define (create-ntfs-file-system partition)
"Create a JFS file-system for PARTITION file-name."
- (with-null-output-ports
- (invoke "mkfs.ntfs" "-F" "-f" partition)))
+ ((run-command-in-installer) "mkfs.ntfs" "-F" "-f" partition))
(define (create-xfs-file-system partition)
"Create an XFS file-system for PARTITION file-name."
- (with-null-output-ports
- (invoke "mkfs.xfs" "-f" partition)))
+ ((run-command-in-installer) "mkfs.xfs" "-f" partition))
(define (create-swap-partition partition)
"Set up swap area on PARTITION file-name."
- (with-null-output-ports
- (invoke "mkswap" "-f" partition)))
+ ((run-command-in-installer) "mkswap" "-f" partition))
(define (call-with-luks-key-file password proc)
"Write PASSWORD in a temporary file and pass it to PROC as argument."
@@ -1190,15 +1173,16 @@ (define (luks-format-and-open user-partition)
(lambda (key-file)
(installer-log-line "formatting and opening LUKS entry ~s at ~s"
label file-name)
- (system* "cryptsetup" "-q" "luksFormat" file-name key-file)
- (system* "cryptsetup" "open" "--type" "luks"
- "--key-file" key-file file-name label)))))
+ ((run-command-in-installer) "cryptsetup" "-q" "luksFormat"
+ file-name key-file)
+ ((run-command-in-installer) "cryptsetup" "open" "--type" "luks"
+ "--key-file" key-file file-name label)))))
(define (luks-close user-partition)
"Close the encrypted partition pointed by USER-PARTITION."
(let ((label (user-partition-crypt-label user-partition)))
(installer-log-line "closing LUKS entry ~s" label)
- (system* "cryptsetup" "close" label)))
+ ((run-command-in-installer) "cryptsetup" "close" label)))
(define (format-user-partitions user-partitions)
"Format the <user-partition> records in USER-PARTITIONS list with
--
2.34.0
J
J
Josselin Poiret wrote on 6 Jan 2022 23:48
[PATCH wip-harden-installer 10/14] installer: Raise condition when mklabel fails.
(address . 53063@debbugs.gnu.org)(name . Josselin Poiret)(address . dev@jpoiret.xyz)
6155fe6216aadb42c2f7f67274fb4eb888cb7b4c.1641507696.git.dev@jpoiret.xyz
* gnu/installer/parted.scm (mklabel): Do it.
---
gnu/installer/parted.scm | 10 ++++++++--
1 file changed, 8 insertions(+), 2 deletions(-)

Toggle diff (23 lines)
diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm
index c8bb73ee64..e33ef5f8fd 100644
--- a/gnu/installer/parted.scm
+++ b/gnu/installer/parted.scm
@@ -635,8 +635,14 @@ (define (user-partition-description user-partition)
(define (mklabel device type-name)
"Create a partition table on DEVICE. TYPE-NAME is the type of the partition
table, \"msdos\" or \"gpt\"."
- (let ((type (disk-type-get type-name)))
- (disk-new-fresh device type)))
+ (let* ((type (disk-type-get type-name))
+ (disk (disk-new-fresh device type)))
+ (or disk
+ (raise
+ (condition
+ (&error)
+ (&message (message (format #f "Cannot create partition table of type
+~a on device ~a." type-name (device-path device)))))))))
;;
--
2.34.0
J
J
Josselin Poiret wrote on 6 Jan 2022 23:48
[PATCH wip-harden-installer 09/14] installer: Use the command capturing facility for guix init.
(address . 53063@debbugs.gnu.org)(name . Josselin Poiret)(address . dev@jpoiret.xyz)
c2772f65f47b0c13e84699d13d3bae35353fff6b.1641507696.git.dev@jpoiret.xyz
* gnu/installer/newt/final.scm (run-install-shell): Remove procedure,
as run-command-in-installer now takes care of everything.
(run-final-page): Directly use install-system.
* gnu/installer/final.scm (install-system): Restore PATH inside the
container, and use run-command-in-installer.
---
gnu/installer/final.scm | 17 +++--------------
gnu/installer/newt/final.scm | 10 +---------
2 files changed, 4 insertions(+), 23 deletions(-)

Toggle diff (65 lines)
diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm
index fbfac1f692..ba39dad354 100644
--- a/gnu/installer/final.scm
+++ b/gnu/installer/final.scm
@@ -169,6 +169,7 @@ (define (assert-exit x)
(database-dir "/var/guix/db")
(database-file (string-append database-dir "/db.sqlite"))
(saved-database (string-append database-dir "/db.save"))
+ (path (getenv "PATH"))
(ret #f))
(mkdir-p (%installer-target-dir))
@@ -205,20 +206,8 @@ (define (assert-exit x)
(stop-service 'guix-daemon)
(start-service 'guix-daemon (list (number->string (getpid))))
- (setvbuf (current-output-port) 'none)
- (setvbuf (current-error-port) 'none)
-
- ;; If there are any connected clients, assume that we are running
- ;; installation tests. In that case, dump the standard and error
- ;; outputs to syslog.
- (set! ret
- (if (not (null? (current-clients)))
- (with-output-to-file "/dev/console"
- (lambda ()
- (with-error-to-file "/dev/console"
- (lambda ()
- (run-command install-command)))))
- (run-command install-command))))
+ (setenv "PATH" path)
+ (set! ret (apply (run-command-in-installer) install-command)))
(lambda ()
;; Restart guix-daemon so that it does no keep the MNT namespace
;; alive.
diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm
index efe422f4f4..07e8cf3864 100644
--- a/gnu/installer/newt/final.scm
+++ b/gnu/installer/newt/final.scm
@@ -98,14 +98,6 @@ (define (run-install-failed-page)
(send-to-clients '(installation-failure))
#t)))
-(define* (run-install-shell locale
- #:key (users '()))
- (clear-screen)
- (newt-suspend)
- (let ((install-ok? (install-system locale #:users users)))
- (newt-resume)
- install-ok?))
-
(define (run-final-page result prev-steps)
(define (wait-for-clients)
(unless (null? (current-clients))
@@ -129,7 +121,7 @@ (define (wait-for-clients)
user-partitions
(configuration->file configuration)
(run-config-display-page #:locale locale)
- (run-install-shell locale #:users users))))
+ (install-system locale #:users users))))
(if install-ok?
(run-install-success-page)
(run-install-failed-page))))
--
2.34.0
J
J
Josselin Poiret wrote on 6 Jan 2022 23:48
[PATCH wip-harden-installer 11/14] installer: Fix run-file-textbox-page when edit-button is #f.
(address . 53063@debbugs.gnu.org)(name . Josselin Poiret)(address . dev@jpoiret.xyz)
6ee8250b3edc7e2716cba69f40af99e4271c095b.1641507696.git.dev@jpoiret.xyz
* gnu/installer/newt/page.scm (run-file-textbox-page): Check if
edit-button is #f.
---
gnu/installer/newt/page.scm | 1 +
1 file changed, 1 insertion(+)

Toggle diff (14 lines)
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index d9901c33a1..9c684a3899 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -812,6 +812,7 @@ (define result
(destroy-form-and-pop form))))
(if (and (eq? exit-reason 'exit-component)
+ edit-button
(components=? argument edit-button))
(loop) ;recurse in tail position
result)))))
--
2.34.0
J
J
Josselin Poiret wrote on 6 Jan 2022 23:48
[PATCH wip-harden-installer 12/14] installer: Replace run-command by invoke in newt/page.scm.
(address . 53063@debbugs.gnu.org)(name . Josselin Poiret)(address . dev@jpoiret.xyz)
d7381fd33c473a08c3e39a64050e7babbec1a91f.1641507696.git.dev@jpoiret.xyz
* gnu/installer/newt/page.scm (edit-file): Replace it.
---
gnu/installer/newt/page.scm | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)

Toggle diff (24 lines)
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index 9c684a3899..695c7d875f 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -22,6 +22,7 @@ (define-module (gnu installer newt page)
#:use-module (gnu installer steps)
#:use-module (gnu installer utils)
#:use-module (gnu installer newt utils)
+ #:use-module (guix build utils)
#:use-module (guix i18n)
#:use-module (ice-9 i18n)
#:use-module (ice-9 match)
@@ -727,8 +728,7 @@ (define* (edit-file file #:key locale)
(newt-suspend)
;; Use Nano because it syntax-highlights Scheme by default.
;; TODO: Add a menu to choose an editor?
- (run-command (list "/run/current-system/profile/bin/nano" file)
- #:locale locale)
+ (invoke "nano" file)
(newt-resume))
(define* (run-file-textbox-page #:key
--
2.34.0
J
J
Josselin Poiret wrote on 6 Jan 2022 23:48
[PATCH wip-harden-installer 14/14] installer: Add confirmation page when running external commands.
(address . 53063@debbugs.gnu.org)(name . Josselin Poiret)(address . dev@jpoiret.xyz)
393a78f61a46d3030a8d8bde9d415d031bb4f190.1641507696.git.dev@jpoiret.xyz
* gnu/installer/newt.scm (newt-run-command): Add it.
---
gnu/installer/newt.scm | 10 ++++++++++
1 file changed, 10 insertions(+)

Toggle diff (23 lines)
diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm
index fc851339d1..4830667d4d 100644
--- a/gnu/installer/newt.scm
+++ b/gnu/installer/newt.scm
@@ -80,6 +80,16 @@ (define (exit-error file report key args)
(clear-screen))
(define (newt-run-command . args)
+ (define displayed-command
+ (string-join
+ (map (lambda (s) (string-append "\"" s "\"")) args)
+ " "))
+ (run-confirmation-page
+ (format #f "The installer will run the following command:~%~a~%"
+ displayed-command)
+ "External command"
+ #:exit-button-procedure (lambda ()
+ (abort-to-prompt 'installer-step 'abort)))
(newt-suspend)
(clear-screen)
(define result (run-command args))
--
2.34.0
J
J
Josselin Poiret wrote on 6 Jan 2022 23:48
[PATCH wip-harden-installer 13/14] installer: Use named prompt to abort or break installer steps.
(address . 53063@debbugs.gnu.org)(name . Josselin Poiret)(address . dev@jpoiret.xyz)
9c265e5c19afad5c3a1f8aa397657fb29389064c.1641507696.git.dev@jpoiret.xyz
* 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(-)

Toggle diff (450 lines)
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 07e8cf3864..bd1b53b9f3 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 1af4e7df2d..0a2fc834e1 100644
--- a/gnu/installer/newt/services.scm
+++ b/gnu/installer/newt/services.scm
@@ -45,9 +45,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."
@@ -64,9 +62,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-other-services-cbt-page)
"Run a page allowing the user to select other services."
@@ -86,9 +82,7 @@ (define (run-other-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-network-management-page)
"Run a page to select among several network management methods."
@@ -110,9 +104,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..bd99e1fa2a 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)))
This message was truncated. Download the full message here.
M
M
Mathieu Othacehe wrote on 7 Jan 2022 11:58
Re: [bug#53063] [PATCH wip-harden-installer 08/14] installer: Use run-command-in-installer in (gnu installer parted).
(name . Josselin Poiret via Guix-patches via)(address . guix-patches@gnu.org)
8735lz4xsv.fsf@gnu.org
Hello Josselin,

Toggle quote (8 lines)
> * gnu/installer/parted.scm (remove-logical-devices,
> create-btrfs-file-system, create-ext4-file-system,
> create-fat16-file-system, create-fat32-file-system,
> create-jfs-file-system, create-ntfs-file-system,
> create-xfs-file-system, create-swap-partition, luks-format-and-open,
> luks-close): Use run-command-in-installer.
> (with-null-output-ports): Remove.

Overall the series looks really nice! This one is a bit problematic as
it breaks the installer tests because the extra "External command"
pages are not handled.

Toggle snippet (18 lines)
Jan 7 11:44:28 localhost
conversation expecting pattern ((quote list-selection) ((quote title) "Partitioning method") ((quote multiple-choices?) #f) ((quote items) (not-encrypted encrypted _ ...)))
/gnu/store/6c0dnvp7a1sym52s4yrjzm3wvbsv1666-shepherd-marionette.scm:1:1718: ERROR:
1. &pattern-not-matched:
pattern: ((quote list-selection) ((quote title) "Partitioning method") ((quote multiple-choices?) #f) ((quote items) (not-encrypted encrypted _ ...)))
sexp: (confirmation (title "External command") (text "The installer will run the following command:\n\"dmsetup\" \"remove_all\"\n"))
Backtrace:
Jan 7 11:44:28 localhost installer[193]: running form #<newt-form 184bd30> ("External command") with 1 clients
2 (primitive-load "/gnu/store/qpsq43z9rdb7hlabzzyz6p8pzxb?")
In ice-9/eval.scm:
191:35 1 (_ #f)
619:8 0 (_ #(#<directory (guile-user) 7ffff3fd7c80> #<variabl?>))

ice-9/eval.scm:619:8: Throw to key `marionette-eval-failure' with args `((quote (choose-partitioning installer-socket #:encrypted? #f #:passphrase "thepassphrase" #:uefi-support? #f)))'.
note: keeping build directory `/tmp/guix-build-installation.drv-0'
builder for `/gnu/store/6xrbsa0psm30189rigjif17c6rvi8h9g-installation.drv' failed with exit code 1

Maybe we could only display those "External command" pages when the
command fails?

Another issue is that if any partitioning command fails, the installer
keeps going. Maybe we should instead propose to abort the installation
or restart the partitioning step?

Thanks,

Mathieu
J
J
Josselin Poiret wrote on 7 Jan 2022 12:46
(address . 53063@debbugs.gnu.org)
87pmp3dazp.fsf@jpoiret.xyz
Hello Mathieu,

Mathieu Othacehe <othacehe@gnu.org> writes:

Toggle quote (3 lines)
> Maybe we could only display those "External command" pages when the
> command fails?

Seems like my mental checklist swiftly removed the "Update installer
tests" part. I still like having every command the installer runs
displayed to me, but that's personal preference I reckon. Maybe I could
look into making the tests simply confirm every single confirmation page?

Toggle quote (4 lines)
> Another issue is that if any partitioning command fails, the installer
> keeps going. Maybe we should instead propose to abort the installation
> or restart the partitioning step?

Right, this patchset is still missing the switch to exceptions, along
with raising a condition on command error. I will post a follow-up
patchset addressing these! One thing though, is that &invoke-error is
not exported by (gnu build utils). I think for now using @@ would be
the right solution to avoid a world rebuild.

--
Josselin Poiret
L
L
Ludovic Courtès wrote on 7 Jan 2022 14:47
Re: bug#53063: [PATCH wip-harden-installer 00/14] General improvements to the installer
(name . Josselin Poiret)(address . dev@jpoiret.xyz)(address . 53063@debbugs.gnu.org)
87v8yvac9b.fsf_-_@gnu.org
Hello Josselin,

Josselin Poiret <dev@jpoiret.xyz> skribis:

Toggle quote (28 lines)
> +(define* (run-external-command-with-handler handler command)
> + "Run command specified by the list COMMAND in a child with output handler
> +HANDLER. HANDLER is a procedure taking an input port, to which the command
> +will write its standard output and error. Returns the integer status value of
> +the child process as returned by waitpid."
> + (match-let (((input . output) (pipe)))
> + (match (primitive-fork)
> + (0 ;; We're in the child
> + (close-port input)
> + (reset-fds
> + (open-fdes "/dev/null" O_WRONLY)
> + ;; Avoid port GC'ing closing the fd by increasing its revealed count.
> + (port->fdes output)
> + (fileno output))
> + (with-exception-handler
> + (lambda (exn)
> + ((@@ (ice-9 exceptions) format-exception) (current-error-port)
> + exn)
> + (primitive-_exit 1))
> + (lambda ()
> + (apply execlp (car command) command)
> + (primitive-_exit 1))))
> + (pid
> + (close-port output)
> + (handler input)
> + (close-port input)
> + (cdr (waitpid pid))))))

In general, I recommend using (ice-9 popen) instead of raw
‘primitive-fork’. It provides primitives that do fork+exec at once,
which avoids shenanigans with the finalization threads such as what you
work around in patch #6.

I haven’t looked in detail, but could the ‘pipeline’ procedure from
(ice-9 popen) be of any help?

If you really really do need to fiddle with finalization, I’d recommend
exporting ‘without-automatic-finalization’ from (guix build syscalls)
and using it, so that the hack is factorized.

HTH,
Ludo’.
J
J
Josselin Poiret wrote on 15 Jan 2022 14:49
[PATCH v2 wip-harden-installer 00/18] General improvements to the installer
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-1-dev@jpoiret.xyz
Hello again Mathieu and Ludo,

Here is a v2 that should follow the suggestions: the installer now
only shows command output and status when the command fails, so that
shouldn't break the installer tests.

The internal mechanism to capture a command's output and error was
reworked along Ludo's advice, and now uses open-pipe* instead (with a
small workaround to avoid

The second to last commit makes password objects opaque, so that
installer dumps don't accidentally contain them in cleartext.

Finally, the last commit (a big one) lets users choose whether to dump
or not from the error page, and from there they can choose and edit
the files (using nano) they would like to include in the dump archive.
It expands upon the initial work of Mathieu in 84d0d8ad3d. For now,
you can choose to include the installer backtrace, the installer
result alist, and the syslog and dmesg. We could also include a more
stripped down installer-log that the new logging facility produces,
but I think that it should be enough for now.

Things work smoothly on my end, but the installer test
"gui-installed-os" seems to fail while running `guix system init`,
when building linux-libre, but it seems unrelated to this patchset.

Best,
Josselin

Josselin Poiret (18):
installer: Use define instead of let at top-level.
installer: Generalize logging facility.
installer: Use new installer-log-line everywhere.
installer: Un-export syslog syntax.
installer: Keep PATH inside the install container.
installer: Remove specific logging code.
installer: Capture external commands output.
installer: Add installer-specific run command process.
installer: Use run-command-in-installer in (gnu installer parted).
installer: Raise condition when mklabel fails.
installer: Fix run-file-textbox-page when edit-button is #f.
installer: Replace run-command by invoke in newt/page.scm.
installer: Add nano to PATH.
installer: Use named prompt to abort or break installer steps.
installer: Add error page when running external commands.
installer: Use dynamic-wind to setup installer.
installer: Turn passwords into opaque records.
installer: Make dump archive creation optional and selective.

gnu/installer.scm | 95 ++++++++++--------
gnu/installer/dump.scm | 67 ++++++++-----
gnu/installer/final.scm | 28 +++---
gnu/installer/newt.scm | 126 +++++++++++++++++++-----
gnu/installer/newt/dump.scm | 36 -------
gnu/installer/newt/ethernet.scm | 8 +-
gnu/installer/newt/final.scm | 12 +--
gnu/installer/newt/keymap.scm | 8 +-
gnu/installer/newt/locale.scm | 25 ++---
gnu/installer/newt/network.scm | 16 +--
gnu/installer/newt/page.scm | 163 +++++++++++++++++++++++++++++--
gnu/installer/newt/partition.scm | 10 +-
gnu/installer/newt/services.scm | 16 +--
gnu/installer/newt/timezone.scm | 4 +-
gnu/installer/newt/user.scm | 11 +--
gnu/installer/newt/welcome.scm | 2 +-
gnu/installer/newt/wifi.scm | 4 +-
gnu/installer/parted.scm | 104 +++++++++-----------
gnu/installer/record.scm | 12 ++-
gnu/installer/steps.scm | 127 +++++++++++-------------
gnu/installer/user.scm | 18 +++-
gnu/installer/utils.scm | 158 +++++++++++++++++++++++++-----
gnu/local.mk | 1 -
23 files changed, 656 insertions(+), 395 deletions(-)
delete mode 100644 gnu/installer/newt/dump.scm

--
2.34.0
J
J
Josselin Poiret wrote on 15 Jan 2022 14:49
[PATCH v2 wip-harden-installer 04/18] installer: Un-export syslog syntax.
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-5-dev@jpoiret.xyz
* gnu/installer/utils.scm (syslog): Remove export.
---
gnu/installer/utils.scm | 1 -
1 file changed, 1 deletion(-)

Toggle diff (14 lines)
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 74046c9cab..1bff1e1229 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -38,7 +38,6 @@ (define-module (gnu installer utils)
syslog-port
%syslog-line-hook
- syslog
installer-log-port
%installer-log-line-hook
%default-installer-line-hooks
--
2.34.0
J
J
Josselin Poiret wrote on 15 Jan 2022 14:49
[PATCH v2 wip-harden-installer 05/18] installer: Keep PATH inside the install container.
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-6-dev@jpoiret.xyz
* gnu/installer/final.scm (install-system): Set PATH inside the
container.
---
gnu/installer/final.scm | 5 ++++-
1 file changed, 4 insertions(+), 1 deletion(-)

Toggle diff (25 lines)
diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm
index fbfac1f692..7d5eca4c7e 100644
--- a/gnu/installer/final.scm
+++ b/gnu/installer/final.scm
@@ -169,7 +169,8 @@ (define (assert-exit x)
(database-dir "/var/guix/db")
(database-file (string-append database-dir "/db.sqlite"))
(saved-database (string-append database-dir "/db.save"))
- (ret #f))
+ (ret #f)
+ (path (getenv "PATH")))
(mkdir-p (%installer-target-dir))
;; We want to initialize user passwords but we don't want to store them in
@@ -208,6 +209,8 @@ (define (assert-exit x)
(setvbuf (current-output-port) 'none)
(setvbuf (current-error-port) 'none)
+ (setenv "PATH" path)
+
;; If there are any connected clients, assume that we are running
;; installation tests. In that case, dump the standard and error
;; outputs to syslog.
--
2.34.0
J
J
Josselin Poiret wrote on 15 Jan 2022 14:49
[PATCH v2 wip-harden-installer 02/18] installer: Generalize logging facility.
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-3-dev@jpoiret.xyz
* gnu/installer/utils.scm (%syslog-line-hook, open-new-log-port,
installer-log-port, %installer-log-line-hook, %display-line-hook,
%default-installer-line-hooks, installer-log-line): Add new
variables.
---
gnu/installer/utils.scm | 45 +++++++++++++++++++++++++++++++++++++++++
1 file changed, 45 insertions(+)

Toggle diff (73 lines)
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 9bd41e2ca0..b1b6f8b23f 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -37,7 +37,12 @@ (define-module (gnu installer utils)
run-command
syslog-port
+ %syslog-line-hook
syslog
+ installer-log-port
+ %installer-log-line-hook
+ %default-installer-line-hooks
+ installer-log-line
call-with-time
let/time
@@ -142,6 +147,9 @@ (define syslog-port
(set! port (open-syslog-port)))
(or port (%make-void-port "w")))))
+(define (%syslog-line-hook line)
+ (format (syslog-port) "installer[~d]: ~a~%" (getpid) line))
+
(define-syntax syslog
(lambda (s)
"Like 'format', but write to syslog."
@@ -152,6 +160,43 @@ (define-syntax syslog
(syntax->datum #'fmt))))
#'(format (syslog-port) fmt (getpid) args ...))))))
+(define (open-new-log-port)
+ (define now (localtime (time-second (current-time))))
+ (define filename
+ (format #f "/tmp/installer.~a.log"
+ (strftime "%F.%T" now)))
+ (open filename (logior O_RDWR
+ O_CREAT)))
+
+(define installer-log-port
+ (let ((port #f))
+ (lambda ()
+ "Return an input and output port to the installer log."
+ (unless port
+ (set! port (open-new-log-port)))
+ port)))
+
+(define (%installer-log-line-hook line)
+ (format (installer-log-port) "~a~%" line))
+
+(define (%display-line-hook line)
+ (display line)
+ (newline))
+
+(define %default-installer-line-hooks
+ (list %syslog-line-hook
+ %installer-log-line-hook))
+
+(define-syntax installer-log-line
+ (lambda (s)
+ "Like 'format', but uses the default line hooks, and only formats one line."
+ (syntax-case s ()
+ ((_ fmt args ...)
+ (string? (syntax->datum #'fmt))
+ #'(let ((formatted (format #f fmt args ...)))
+ (for-each (lambda (f) (f formatted))
+ %default-installer-line-hooks))))))
+
;;;
;;; Client protocol.
--
2.34.0
J
J
Josselin Poiret wrote on 15 Jan 2022 14:49
[PATCH v2 wip-harden-installer 06/18] installer: Remove specific logging code.
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-7-dev@jpoiret.xyz
* gnu/installer/final.scm (install-system): Remove command logging to
syslog, as this is taken care of by the new facilities.
---
gnu/installer/final.scm | 12 +-----------
1 file changed, 1 insertion(+), 11 deletions(-)

Toggle diff (25 lines)
diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm
index 7d5eca4c7e..63e5073ff4 100644
--- a/gnu/installer/final.scm
+++ b/gnu/installer/final.scm
@@ -211,17 +211,7 @@ (define (assert-exit x)
(setenv "PATH" path)
- ;; If there are any connected clients, assume that we are running
- ;; installation tests. In that case, dump the standard and error
- ;; outputs to syslog.
- (set! ret
- (if (not (null? (current-clients)))
- (with-output-to-file "/dev/console"
- (lambda ()
- (with-error-to-file "/dev/console"
- (lambda ()
- (run-command install-command)))))
- (run-command install-command))))
+ (set! ret (run-command install-command)))
(lambda ()
;; Restart guix-daemon so that it does no keep the MNT namespace
;; alive.
--
2.34.0
J
J
Josselin Poiret wrote on 15 Jan 2022 14:49
[PATCH v2 wip-harden-installer 03/18] installer: Use new installer-log-line everywhere.
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-4-dev@jpoiret.xyz
* gnu/installer.scm (installer-program)
* gnu/installer/final.scm (install-locale)
* gnu/installer/newt.scm (init)
* gnu/installer/newt/final.scm (run-final-page)
* gnu/installer/newt/page.scm (run-form-with-clients)
* gnu/installer/newt/partition.scm (run-partitioning-page)
* gnu/installer/parted.scm (eligible-devices, mkpart,
luks-format-and-open, luks-close, mount-user-partitions,
umount-user-partitions, free-parted):
* gnu/installer/steps.scm (run-installer-steps):
* gnu/installer/utils.scm (run-command, send-to-clients): Use it.
---
gnu/installer.scm | 2 +-
gnu/installer/final.scm | 6 ++--
gnu/installer/newt.scm | 2 +-
gnu/installer/newt/final.scm | 4 +--
gnu/installer/newt/page.scm | 13 +++++----
gnu/installer/newt/partition.scm | 4 +--
gnu/installer/parted.scm | 50 ++++++++++++++++----------------
gnu/installer/steps.scm | 2 +-
gnu/installer/utils.scm | 13 +++++----
9 files changed, 49 insertions(+), 47 deletions(-)

Toggle diff (291 lines)
diff --git a/gnu/installer.scm b/gnu/installer.scm
index 134fa2faaf..d0d012f04b 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -435,7 +435,7 @@ (define results
#f)))
(const #f)
(lambda (key . args)
- (syslog "crashing due to uncaught exception: ~s ~s~%"
+ (installer-log-line "crashing due to uncaught exception: ~s ~s"
key args)
(let ((error-file "/tmp/last-installer-error")
(dump-archive "/tmp/dump.tgz"))
diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm
index 276af908f7..fbfac1f692 100644
--- a/gnu/installer/final.scm
+++ b/gnu/installer/final.scm
@@ -125,15 +125,15 @@ (define (install-locale locale)
(setlocale LC_ALL locale))))
(if supported?
(begin
- (syslog "install supported locale ~a~%." locale)
+ (installer-log-line "install supported locale ~a." locale)
(setenv "LC_ALL" locale))
(begin
;; If the selected locale is not supported, install a default UTF-8
;; locale. This is required to copy some files with UTF-8
;; characters, in the nss-certs package notably. Set LANGUAGE
;; anyways, to have translated messages if possible.
- (syslog "~a locale is not supported, installating en_US.utf8 \
-locale instead.~%" locale)
+ (installer-log-line "~a locale is not supported, installing \
+en_US.utf8 locale instead." locale)
(setlocale LC_ALL "en_US.utf8")
(setenv "LC_ALL" "en_US.utf8")
(setenv "LANGUAGE"
diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm
index d48e2c0129..61fb9cf2ca 100644
--- a/gnu/installer/newt.scm
+++ b/gnu/installer/newt.scm
@@ -48,7 +48,7 @@ (define (init)
(newt-init)
(clear-screen)
(set-screen-size!)
- (syslog "Display is ~ax~a.~%" (screen-columns) (screen-rows))
+ (installer-log-line "Display is ~ax~a." (screen-columns) (screen-rows))
(push-help-line
(format #f (G_ "Press <F1> for installation parameters."))))
diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm
index 7f6dd9f075..efe422f4f4 100644
--- a/gnu/installer/newt/final.scm
+++ b/gnu/installer/newt/final.scm
@@ -109,7 +109,7 @@ (define* (run-install-shell locale
(define (run-final-page result prev-steps)
(define (wait-for-clients)
(unless (null? (current-clients))
- (syslog "waiting with clients before starting final step~%")
+ (installer-log-line "waiting with clients before starting final step")
(send-to-clients '(starting-final-step))
(match (select (current-clients) '() '())
(((port _ ...) _ _)
@@ -119,7 +119,7 @@ (define (wait-for-clients)
;; things such as changing the swap partition label.
(wait-for-clients)
- (syslog "proceeding with final step~%")
+ (installer-log-line "proceeding with final step")
(let* ((configuration (format-configuration prev-steps result))
(user-partitions (result-step result 'partition))
(locale (result-step result 'locale))
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index 4209674c28..d9901c33a1 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -93,9 +93,9 @@ (define* (run-form-with-clients form exp)
Like 'run-form', return two values: the exit reason, and an \"argument\"."
(define* (discard-client! port #:optional errno)
(if errno
- (syslog "removing client ~d due to ~s~%"
+ (installer-log-line "removing client ~d due to ~s"
(fileno port) (strerror errno))
- (syslog "removing client ~d due to EOF~%"
+ (installer-log-line "removing client ~d due to EOF"
(fileno port)))
;; XXX: Watch out! There's no 'form-unwatch-fd' procedure in Newt so we
@@ -124,7 +124,7 @@ (define title
(send-to-clients exp)
(let loop ()
- (syslog "running form ~s (~s) with ~d clients~%"
+ (installer-log-line "running form ~s (~s) with ~d clients"
form title (length (current-clients)))
;; Call 'watch-clients!' within the loop because there might be new
@@ -146,7 +146,7 @@ (define title
(discard-client! port)
(loop))
(obj
- (syslog "form ~s (~s): client ~d replied ~s~%"
+ (installer-log-line "form ~s (~s): client ~d replied ~s"
form title (fileno port) obj)
(values 'exit-fd-ready obj))))
(lambda args
@@ -156,8 +156,9 @@ (define title
;; Accept a new client and send it EXP.
(match (accept port)
((client . _)
- (syslog "accepting new client ~d while on form ~s~%"
- (fileno client) form)
+ (installer-log-line
+ "accepting new client ~d while on form ~s"
+ (fileno client) form)
(catch 'system-error
(lambda ()
(write exp client)
diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm
index ccc7686906..6a3aa3daff 100644
--- a/gnu/installer/newt/partition.scm
+++ b/gnu/installer/newt/partition.scm
@@ -801,9 +801,9 @@ (define (run-page devices)
;; Make sure the disks are not in use before proceeding to formatting.
(free-parted eligible-devices)
(format-user-partitions user-partitions-with-pass)
- (syslog "formatted ~a user partitions~%"
+ (installer-log-line "formatted ~a user partitions"
(length user-partitions-with-pass))
- (syslog "user-partitions: ~a~%" user-partitions)
+ (installer-log-line "user-partitions: ~a" user-partitions)
(destroy-form-and-pop form)
user-partitions))
diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm
index 66e07574c9..ced7a757d7 100644
--- a/gnu/installer/parted.scm
+++ b/gnu/installer/parted.scm
@@ -371,7 +371,8 @@ (define (small-device? device)
(let ((length (device-length device))
(sector-size (device-sector-size device)))
(and (< (* length sector-size) %min-device-size)
- (syslog "~a is not eligible because it is smaller than ~a.~%"
+ (installer-log-line "~a is not eligible because it is smaller than \
+~a."
(device-path device)
(unit-format-custom-byte device
%min-device-size
@@ -391,7 +392,8 @@ (define (installation-device? device)
(string=? the-installer-root-partition-path
(partition-get-path partition)))
(disk-partitions disk)))))
- (syslog "~a is not eligible because it is the installation device.~%"
+ (installer-log-line "~a is not eligible because it is the \
+installation device."
(device-path device))))
(remove
@@ -817,24 +819,22 @@ (define* (extend-ranges! start-range end-range
(disk-add-partition disk partition no-constraint)))
(partition-ok?
(or partition-constraint-ok? partition-no-contraint-ok?)))
- (syslog "Creating partition:
-~/type: ~a
-~/filesystem-type: ~a
-~/start: ~a
-~/end: ~a
-~/start-range: [~a, ~a]
-~/end-range: [~a, ~a]
-~/constraint: ~a
-~/no-constraint: ~a
-"
- partition-type
- (filesystem-type-name filesystem-type)
- start-sector*
- end-sector
- (geometry-start start-range) (geometry-end start-range)
- (geometry-start end-range) (geometry-end end-range)
- partition-constraint-ok?
- partition-no-contraint-ok?)
+ (installer-log-line "Creating partition:")
+ (installer-log-line "~/type: ~a" partition-type)
+ (installer-log-line "~/filesystem-type: ~a"
+ (filesystem-type-name filesystem-type))
+ (installer-log-line "~/start: ~a" start-sector*)
+ (installer-log-line "~/end: ~a" end-sector)
+ (installer-log-line "~/start-range: [~a, ~a]"
+ (geometry-start start-range)
+ (geometry-end start-range))
+ (installer-log-line "~/end-range: [~a, ~a]"
+ (geometry-start end-range)
+ (geometry-end end-range))
+ (installer-log-line "~/constraint: ~a"
+ partition-constraint-ok?)
+ (installer-log-line "~/no-constraint: ~a"
+ partition-no-contraint-ok?)
;; Set the partition name if supported.
(when (and partition-ok? has-name? name)
(partition-set-name partition name))
@@ -1188,7 +1188,7 @@ (define (luks-format-and-open user-partition)
(call-with-luks-key-file
password
(lambda (key-file)
- (syslog "formatting and opening LUKS entry ~s at ~s~%"
+ (installer-log-line "formatting and opening LUKS entry ~s at ~s"
label file-name)
(system* "cryptsetup" "-q" "luksFormat" file-name key-file)
(system* "cryptsetup" "open" "--type" "luks"
@@ -1197,7 +1197,7 @@ (define (luks-format-and-open user-partition)
(define (luks-close user-partition)
"Close the encrypted partition pointed by USER-PARTITION."
(let ((label (user-partition-crypt-label user-partition)))
- (syslog "closing LUKS entry ~s~%" label)
+ (installer-log-line "closing LUKS entry ~s" label)
(system* "cryptsetup" "close" label)))
(define (format-user-partitions user-partitions)
@@ -1279,7 +1279,7 @@ (define (mount-user-partitions user-partitions)
(file-name
(user-partition-upper-file-name user-partition)))
(mkdir-p target)
- (syslog "mounting ~s on ~s~%" file-name target)
+ (installer-log-line "mounting ~s on ~s" file-name target)
(mount file-name target mount-type)))
sorted-partitions)))
@@ -1295,7 +1295,7 @@ (define (umount-user-partitions user-partitions)
(target
(string-append (%installer-target-dir)
mount-point)))
- (syslog "unmounting ~s~%" target)
+ (installer-log-line "unmounting ~s" target)
(umount target)
(when crypt-label
(luks-close user-partition))))
@@ -1486,6 +1486,6 @@ (define (free-parted devices)
(error
(format #f (G_ "Device ~a is still in use.")
file-name))
- (syslog "Syncing ~a took ~a seconds.~%"
+ (installer-log-line "Syncing ~a took ~a seconds."
file-name (time-second time)))))
device-file-names)))
diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm
index 55433cff31..d9b3d6d07e 100644
--- a/gnu/installer/steps.scm
+++ b/gnu/installer/steps.scm
@@ -185,7 +185,7 @@ (define* (run result #:key todo-steps done-steps)
#:done-steps '())))))
((installer-step-break? c)
(reverse result)))
- (syslog "running step '~a'~%" (installer-step-id step))
+ (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)))
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index b1b6f8b23f..74046c9cab 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -100,13 +100,13 @@ (define (pause)
(format (current-error-port)
(G_ "Command failed with exit code ~a.~%")
(invoke-error-exit-status c))
- (syslog "command ~s failed with exit code ~a"
- command (invoke-error-exit-status c))
+ (installer-log-line "command ~s failed with exit code ~a"
+ command (invoke-error-exit-status c))
(pause)
#f))
- (syslog "running command ~s~%" command)
+ (installer-log-line "running command ~s" command)
(apply invoke command)
- (syslog "command ~s succeeded~%" command)
+ (installer-log-line "command ~s succeeded" command)
(newline)
(pause)
#t))
@@ -259,8 +259,9 @@ (define remainder
(let ((errno (system-error-errno args)))
(if (memv errno (list EPIPE ECONNRESET ECONNABORTED))
(begin
- (syslog "removing client ~s due to ~s while replying~%"
- (fileno client) (strerror errno))
+ (installer-log-line
+ "removing client ~s due to ~s while replying"
+ (fileno client) (strerror errno))
(false-if-exception (close-port client))
remainder)
(cons client remainder))))))
--
2.34.0
J
J
Josselin Poiret wrote on 15 Jan 2022 14:50
[PATCH v2 wip-harden-installer 07/18] installer: Capture external commands output.
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-8-dev@jpoiret.xyz
* gnu/installer/utils.scm (run-external-command-with-handler,
run-external-command-with-line-hooks): New variables.
(run-command): Use run-external-command-with-line-hooks.
---
gnu/installer/utils.scm | 97 ++++++++++++++++++++++++++++++++---------
1 file changed, 77 insertions(+), 20 deletions(-)

Toggle diff (136 lines)
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 1bff1e1229..9cfff0054b 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -25,7 +25,9 @@ (define-module (gnu installer utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-34)
+ #:use-module (ice-9 control)
#:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (ice-9 format)
@@ -34,6 +36,8 @@ (define-module (gnu installer utils)
read-all
nearest-exact-integer
read-percentage
+ run-external-command-with-handler
+ run-external-command-with-line-hooks
run-command
syslog-port
@@ -78,37 +82,90 @@ (define (read-percentage percentage)
(and result
(string->number (match:substring result 1)))))
+(define* (run-external-command-with-handler handler command)
+ "Run command specified by the list COMMAND in a child with output handler
+HANDLER. HANDLER is a procedure taking an input port, to which the command
+will write its standard output and error. Returns the integer status value of
+the child process as returned by waitpid."
+ (match-let (((input . output) (pipe)))
+ ;; Hack to work around Guile bug 52835
+ (define dup-output (duplicate-port output "w"))
+ ;; Void pipe, but holds the pid for close-pipe.
+ (define dummy-pipe
+ (with-input-from-file "/dev/null"
+ (lambda ()
+ (with-output-to-port output
+ (lambda ()
+ (with-error-to-port dup-output
+ (lambda ()
+ (apply open-pipe* (cons "" command)))))))))
+ (close-port output)
+ (close-port dup-output)
+ (handler input)
+ (close-port input)
+ (close-pipe dummy-pipe)))
+
+(define (run-external-command-with-line-hooks line-hooks command)
+ "Run command specified by ARGS in a child, processing each output line with
+the procedures in LINE-HOOKS. Returns the integer status value of
+the child process as returned by waitpid."
+ (define (handler input)
+ (and (and=> (get-line input)
+ (lambda (line)
+ (if (eof-object? line)
+ #f
+ (begin (for-each (lambda (f) (f line))
+ (append line-hooks
+ %default-installer-line-hooks))
+ #t))))
+ (handler input)))
+ (run-external-command-with-handler handler command))
+
(define* (run-command command)
"Run COMMAND, a list of strings. Return true if COMMAND exited
successfully, #f otherwise."
- (define env (environ))
-
(define (pause)
(format #t (G_ "Press Enter to continue.~%"))
(send-to-clients '(pause))
- (environ env) ;restore environment variables
(match (select (cons (current-input-port) (current-clients))
'() '())
(((port _ ...) _ _)
(read-line port))))
- (setenv "PATH" "/run/current-system/profile/bin")
-
- (guard (c ((invoke-error? c)
- (newline)
- (format (current-error-port)
- (G_ "Command failed with exit code ~a.~%")
- (invoke-error-exit-status c))
- (installer-log-line "command ~s failed with exit code ~a"
- command (invoke-error-exit-status c))
- (pause)
- #f))
- (installer-log-line "running command ~s" command)
- (apply invoke command)
- (installer-log-line "command ~s succeeded" command)
- (newline)
- (pause)
- #t))
+ (installer-log-line "running command ~s" command)
+ (define result (run-external-command-with-line-hooks
+ (list %display-line-hook)
+ command))
+ (define exit-val (status:exit-val result))
+ (define term-sig (status:term-sig result))
+ (define stop-sig (status:stop-sig result))
+ (define succeeded?
+ (cond
+ ((and exit-val (not (zero? exit-val)))
+ (installer-log-line "command ~s exited with value ~a"
+ command exit-val)
+ (format #t (G_ "Command ~s exited with value ~a")
+ command exit-val)
+ #f)
+ (term-sig
+ (installer-log-line "command ~s killed by signal ~a"
+ command term-sig)
+ (format #t (G_ "Command ~s killed by signal ~a")
+ command term-sig)
+ #f)
+ (stop-sig
+ (installer-log-line "command ~s stopped by signal ~a"
+ command stop-sig)
+ (format #t (G_ "Command ~s stopped by signal ~a")
+ command stop-sig)
+ #f)
+ (else
+ (installer-log-line "command ~s succeeded" command)
+ (format #t (G_ "Command ~s succeeded") command)
+ #t)))
+ (newline)
+ (pause)
+ succeeded?)
;;;
--
2.34.0
J
J
Josselin Poiret wrote on 15 Jan 2022 14:50
[PATCH v2 wip-harden-installer 08/18] installer: Add installer-specific run command process.
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-9-dev@jpoiret.xyz
* 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.
---
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(-)

Toggle diff (174 lines)
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 @@ (define current-installer newt-installer)
(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 @@ (define (exit-error file report key args)
(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 @@ (define newt-installer
(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 @@ (define-module (gnu installer record)
installer-welcome-page
installer-parameters-menu
installer-parameters-page
- installer-dump-page))
+ installer-dump-page
+ installer-run-command))
;;;
@@ -94,4 +95,6 @@ (define-record-type* <installer>
;; 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 9cfff0054b..4f7c691690 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -25,6 +25,7 @@ (define-module (gnu installer utils)
#: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 @@ (define-module (gnu installer utils)
run-external-command-with-handler
run-external-command-with-line-hooks
run-command
+ run-command-in-installer
syslog-port
%syslog-line-hook
@@ -167,6 +169,14 @@ (define succeeded?
(pause)
succeeded?)
+(define run-command-in-installer
+ (make-parameter
+ (lambda (. args)
+ (raise
+ (condition
+ (&serious)
+ (&message (message "run-command-in-installer not set")))))))
+
;;;
;;; Logging.
--
2.34.0
J
J
Josselin Poiret wrote on 15 Jan 2022 14:50
[PATCH v2 wip-harden-installer 09/18] installer: Use run-command-in-installer in (gnu installer parted).
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-10-dev@jpoiret.xyz
* gnu/installer/parted.scm (remove-logical-devices,
create-btrfs-file-system, create-ext4-file-system,
create-fat16-file-system, create-fat32-file-system,
create-jfs-file-system, create-ntfs-file-system,
create-xfs-file-system, create-swap-partition, luks-format-and-open,
luks-close): Use run-command-in-installer.
(with-null-output-ports): Remove.
---
gnu/installer/parted.scm | 44 +++++++++++++---------------------------
1 file changed, 14 insertions(+), 30 deletions(-)

Toggle diff (99 lines)
diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm
index ced7a757d7..c8bb73ee64 100644
--- a/gnu/installer/parted.scm
+++ b/gnu/installer/parted.scm
@@ -343,8 +343,7 @@ (define* (force-device-sync device)
(define (remove-logical-devices)
"Remove all active logical devices."
- (with-null-output-ports
- (invoke "dmsetup" "remove_all")))
+ ((run-command-in-installer) "dmsetup" "remove_all"))
(define (installer-root-partition-path)
"Return the root partition path, or #f if it could not be detected."
@@ -1115,53 +1114,37 @@ (define (set-user-partitions-file-name user-partitions)
(file-name file-name))))
user-partitions))
-(define-syntax-rule (with-null-output-ports exp ...)
- "Evaluate EXP with both the output port and the error port pointing to the
-bit bucket."
- (with-output-to-port (%make-void-port "w")
- (lambda ()
- (with-error-to-port (%make-void-port "w")
- (lambda () exp ...)))))
-
(define (create-btrfs-file-system partition)
"Create a btrfs file-system for PARTITION file-name."
- (with-null-output-ports
- (invoke "mkfs.btrfs" "-f" partition)))
+ ((run-command-in-installer) "mkfs.btrfs" "-f" partition))
(define (create-ext4-file-system partition)
"Create an ext4 file-system for PARTITION file-name."
- (with-null-output-ports
- (invoke "mkfs.ext4" "-F" partition)))
+ ((run-command-in-installer) "mkfs.ext4" "-F" partition))
(define (create-fat16-file-system partition)
"Create a fat16 file-system for PARTITION file-name."
- (with-null-output-ports
- (invoke "mkfs.fat" "-F16" partition)))
+ ((run-command-in-installer) "mkfs.fat" "-F16" partition))
(define (create-fat32-file-system partition)
"Create a fat32 file-system for PARTITION file-name."
- (with-null-output-ports
- (invoke "mkfs.fat" "-F32" partition)))
+ ((run-command-in-installer) "mkfs.fat" "-F32" partition))
(define (create-jfs-file-system partition)
"Create a JFS file-system for PARTITION file-name."
- (with-null-output-ports
- (invoke "jfs_mkfs" "-f" partition)))
+ ((run-command-in-installer) "jfs_mkfs" "-f" partition))
(define (create-ntfs-file-system partition)
"Create a JFS file-system for PARTITION file-name."
- (with-null-output-ports
- (invoke "mkfs.ntfs" "-F" "-f" partition)))
+ ((run-command-in-installer) "mkfs.ntfs" "-F" "-f" partition))
(define (create-xfs-file-system partition)
"Create an XFS file-system for PARTITION file-name."
- (with-null-output-ports
- (invoke "mkfs.xfs" "-f" partition)))
+ ((run-command-in-installer) "mkfs.xfs" "-f" partition))
(define (create-swap-partition partition)
"Set up swap area on PARTITION file-name."
- (with-null-output-ports
- (invoke "mkswap" "-f" partition)))
+ ((run-command-in-installer) "mkswap" "-f" partition))
(define (call-with-luks-key-file password proc)
"Write PASSWORD in a temporary file and pass it to PROC as argument."
@@ -1190,15 +1173,16 @@ (define (luks-format-and-open user-partition)
(lambda (key-file)
(installer-log-line "formatting and opening LUKS entry ~s at ~s"
label file-name)
- (system* "cryptsetup" "-q" "luksFormat" file-name key-file)
- (system* "cryptsetup" "open" "--type" "luks"
- "--key-file" key-file file-name label)))))
+ ((run-command-in-installer) "cryptsetup" "-q" "luksFormat"
+ file-name key-file)
+ ((run-command-in-installer) "cryptsetup" "open" "--type" "luks"
+ "--key-file" key-file file-name label)))))
(define (luks-close user-partition)
"Close the encrypted partition pointed by USER-PARTITION."
(let ((label (user-partition-crypt-label user-partition)))
(installer-log-line "closing LUKS entry ~s" label)
- (system* "cryptsetup" "close" label)))
+ ((run-command-in-installer) "cryptsetup" "close" label)))
(define (format-user-partitions user-partitions)
"Format the <user-partition> records in USER-PARTITIONS list with
--
2.34.0
J
J
Josselin Poiret wrote on 15 Jan 2022 14:50
[PATCH v2 wip-harden-installer 10/18] installer: Raise condition when mklabel fails.
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-11-dev@jpoiret.xyz
* gnu/installer/parted.scm (mklabel): Do it.
---
gnu/installer/parted.scm | 10 ++++++++--
1 file changed, 8 insertions(+), 2 deletions(-)

Toggle diff (23 lines)
diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm
index c8bb73ee64..e33ef5f8fd 100644
--- a/gnu/installer/parted.scm
+++ b/gnu/installer/parted.scm
@@ -635,8 +635,14 @@ (define (user-partition-description user-partition)
(define (mklabel device type-name)
"Create a partition table on DEVICE. TYPE-NAME is the type of the partition
table, \"msdos\" or \"gpt\"."
- (let ((type (disk-type-get type-name)))
- (disk-new-fresh device type)))
+ (let* ((type (disk-type-get type-name))
+ (disk (disk-new-fresh device type)))
+ (or disk
+ (raise
+ (condition
+ (&error)
+ (&message (message (format #f "Cannot create partition table of type
+~a on device ~a." type-name (device-path device)))))))))
;;
--
2.34.0
J
J
Josselin Poiret wrote on 15 Jan 2022 14:50
[PATCH v2 wip-harden-installer 11/18] installer: Fix run-file-textbox-page when edit-button is #f.
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-12-dev@jpoiret.xyz
* gnu/installer/newt/page.scm (run-file-textbox-page): Check if
edit-button is #f.
---
gnu/installer/newt/page.scm | 1 +
1 file changed, 1 insertion(+)

Toggle diff (14 lines)
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index d9901c33a1..9c684a3899 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -812,6 +812,7 @@ (define result
(destroy-form-and-pop form))))
(if (and (eq? exit-reason 'exit-component)
+ edit-button
(components=? argument edit-button))
(loop) ;recurse in tail position
result)))))
--
2.34.0
J
J
Josselin Poiret wrote on 15 Jan 2022 14:50
[PATCH v2 wip-harden-installer 12/18] installer: Replace run-command by invoke in newt/page.scm.
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-13-dev@jpoiret.xyz
* gnu/installer/newt/page.scm (edit-file): Replace it.
---
gnu/installer/newt/page.scm | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)

Toggle diff (24 lines)
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index 9c684a3899..695c7d875f 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -22,6 +22,7 @@ (define-module (gnu installer newt page)
#:use-module (gnu installer steps)
#:use-module (gnu installer utils)
#:use-module (gnu installer newt utils)
+ #:use-module (guix build utils)
#:use-module (guix i18n)
#:use-module (ice-9 i18n)
#:use-module (ice-9 match)
@@ -727,8 +728,7 @@ (define* (edit-file file #:key locale)
(newt-suspend)
;; Use Nano because it syntax-highlights Scheme by default.
;; TODO: Add a menu to choose an editor?
- (run-command (list "/run/current-system/profile/bin/nano" file)
- #:locale locale)
+ (invoke "nano" file)
(newt-resume))
(define* (run-file-textbox-page #:key
--
2.34.0
J
J
Josselin Poiret wrote on 15 Jan 2022 14:50
[PATCH v2 wip-harden-installer 13/18] installer: Add nano to PATH.
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-14-dev@jpoiret.xyz
* gnu/installer.scm (installer-program): Add nano to the installer
PATH.
---
gnu/installer.scm | 2 ++
1 file changed, 2 insertions(+)

Toggle diff (22 lines)
diff --git a/gnu/installer.scm b/gnu/installer.scm
index 3cc5c79d4e..c7e0921a19 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -43,6 +43,7 @@ (define-module (gnu installer)
#:autoload (gnu packages gnupg) (guile-gcrypt)
#:use-module (gnu packages iso-codes)
#:use-module (gnu packages linux)
+ #:use-module (gnu packages nano)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages package-management)
#:use-module (gnu packages tls)
@@ -336,6 +337,7 @@ (define set-installer-path
kbd ;chvt
guix ;guix system init call
util-linux ;mkwap
+ nano
shadow
tar ;dump
gzip ;dump
--
2.34.0
J
J
Josselin Poiret wrote on 15 Jan 2022 14:50
[PATCH v2 wip-harden-installer 14/18] installer: Use named prompt to abort or break installer steps.
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-15-dev@jpoiret.xyz
* 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(-)

Toggle diff (450 lines)
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-s
This message was truncated. Download the full message here.
J
J
Josselin Poiret wrote on 15 Jan 2022 14:50
[PATCH v2 wip-harden-installer 15/18] installer: Add error page when running external commands.
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-16-dev@jpoiret.xyz
* 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(-)

Toggle diff (172 lines)
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
J
J
Josselin Poiret wrote on 15 Jan 2022 14:49
[PATCH v2 wip-harden-installer 01/18] installer: Use define instead of let at top-level.
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-2-dev@jpoiret.xyz
* gnu/installer.scm (installer-program): Improve readability by using
define at top-level.
---
gnu/installer.scm | 88 +++++++++++++++++++++++------------------------
1 file changed, 44 insertions(+), 44 deletions(-)

Toggle diff (101 lines)
diff --git a/gnu/installer.scm b/gnu/installer.scm
index d57b1d673a..134fa2faaf 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -412,50 +412,50 @@ (define installer-builder
;; verbose.
(terminal-width 200)
- (let* ((current-installer newt-installer)
- (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)
- (syslog "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)))))))
+ (define current-installer newt-installer)
+ (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)
+ (syslog "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))))))
(program-file
"installer"
--
2.34.0
J
J
Josselin Poiret wrote on 15 Jan 2022 14:50
[PATCH v2 wip-harden-installer 16/18] installer: Use dynamic-wind to setup installer.
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-17-dev@jpoiret.xyz
* gnu/installer.scm (installer-program): Use dynamic-wind, so that
completely uncaught exceptions can be printed properly.
---
gnu/installer.scm | 92 ++++++++++++++++++++++++-----------------------
1 file changed, 47 insertions(+), 45 deletions(-)

Toggle diff (105 lines)
diff --git a/gnu/installer.scm b/gnu/installer.scm
index c7e0921a19..86495a067b 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -416,51 +416,53 @@ (define installer-builder
(define current-installer newt-installer)
(define steps (#$steps current-installer))
- ((installer-init current-installer))
-
- (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))))))
+ (dynamic-wind
+ (installer-init current-installer)
+
+ (lambda ()
+ (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))))))
(program-file
"installer"
--
2.34.0
J
J
Josselin Poiret wrote on 15 Jan 2022 14:50
[PATCH v2 wip-harden-installer 17/18] installer: Turn passwords into opaque records.
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-18-dev@jpoiret.xyz
* gnu/installer/user.scm (<secret>, secret?, make-secret,
secret-content): Add opaque <secret> record that boxes its contents,
with a custom printer that doesn't display anything.
* gnu/installer/newt/user.scm (run-user-add-page, run-user-page): Box
it.
* gnu/installer/final.scm (create-user-database): Unbox it.
---
gnu/installer/final.scm | 5 +++--
gnu/installer/newt/user.scm | 6 +++---
gnu/installer/user.scm | 18 +++++++++++++++++-
3 files changed, 23 insertions(+), 6 deletions(-)

Toggle diff (83 lines)
diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm
index 63e5073ff4..2087536502 100644
--- a/gnu/installer/final.scm
+++ b/gnu/installer/final.scm
@@ -85,8 +85,9 @@ (define root?
(uid (if root? 0 #f))
(home-directory
(user-home-directory user))
- (password (crypt (user-password user)
- (salt)))
+ (password (crypt
+ (secret-content (user-password user))
+ (salt)))
;; We need a string here, not a file-like, hence
;; this choice.
diff --git a/gnu/installer/newt/user.scm b/gnu/installer/newt/user.scm
index 97141cfe64..7c1cc2249d 100644
--- a/gnu/installer/newt/user.scm
+++ b/gnu/installer/newt/user.scm
@@ -143,7 +143,7 @@ (define (pad-label label)
(name name)
(real-name real-name)
(home-directory home-directory)
- (password password))
+ (password (make-secret password)))
(run-user-add-page #:name name
#:real-name real-name
#:home-directory
@@ -266,7 +266,7 @@ (define (run users)
(map (lambda (name real-name home password)
(user (name name) (real-name real-name)
(home-directory home)
- (password password)))
+ (password (make-secret password))))
names real-names homes passwords))))))
(lambda ()
(destroy-form-and-pop form))))))
@@ -274,5 +274,5 @@ (define (run users)
;; Add a "root" user simply to convey the root password.
(cons (user (name "root")
(home-directory "/root")
- (password (run-root-password-page)))
+ (password (make-secret (run-root-password-page))))
(run '())))
diff --git a/gnu/installer/user.scm b/gnu/installer/user.scm
index 4e701e64ce..13114e9832 100644
--- a/gnu/installer/user.scm
+++ b/gnu/installer/user.scm
@@ -19,7 +19,14 @@
(define-module (gnu installer user)
#:use-module (guix records)
#:use-module (srfi srfi-1)
- #:export (<user>
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:export (<secret>
+ secret?
+ make-secret
+ secret-content
+
+ <user>
user
make-user
user-name
@@ -30,6 +37,15 @@ (define-module (gnu installer user)
users->configuration))
+(define-record-type <secret>
+ (make-secret content)
+ secret?
+ (content secret-content))
+(set-record-type-printer!
+ <secret>
+ (lambda (secret port)
+ (format port "<secret>")))
+
(define-record-type* <user>
user make-user
user?
--
2.34.0
J
J
Josselin Poiret wrote on 15 Jan 2022 14:50
[PATCH v2 wip-harden-installer 18/18] installer: Make dump archive creation optional and selective.
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
20220115135011.5817-19-dev@jpoiret.xyz
* 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

Toggle diff (426 lines)
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
M
M
Mathieu Othacehe wrote on 17 Jan 2022 11:16
Re: bug#53063: [PATCH wip-harden-installer 00/14] General improvements to the installer
(name . Josselin Poiret)(address . dev@jpoiret.xyz)
87mtju3bvr.fsf_-_@gnu.org
Hey Josselin,

Great work!

Toggle quote (6 lines)
> It expands upon the initial work of Mathieu in 84d0d8ad3d. For now,
> you can choose to include the installer backtrace, the installer
> result alist, and the syslog and dmesg. We could also include a more
> stripped down installer-log that the new logging facility produces,
> but I think that it should be enough for now.

I tweaked this commit a little bit to add an horizontal left anchor.

Toggle quote (4 lines)
> Things work smoothly on my end, but the installer test
> "gui-installed-os" seems to fail while running `guix system init`,
> when building linux-libre, but it seems unrelated to this patchset.

Things works really fine here too, I pushed the series on the
wip-harden-installer to have Cuirass run the installer tests.

Here are the few modifications I made:

Toggle snippet (214 lines)
diff --git a/gnu/installer.scm b/gnu/installer.scm
index 01eda04774..7b2914be98 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -420,7 +420,6 @@ (define steps (#$steps current-installer))
(dynamic-wind
(installer-init current-installer)
-
(lambda ()
(parameterize
((run-command-in-installer
@@ -439,15 +438,15 @@ (define results
(sync)
(stop-service 'root))
(_
- ;; The installation failed, exit so that it is restarted
- ;; by login.
+ ;; 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)
- (define dump-dir (prepare-dump key args
- #:result %current-result))
+ (define dump-dir
+ (prepare-dump key args #:result %current-result))
(define action
((installer-exit-error current-installer)
(get-string-all
@@ -458,7 +457,8 @@ (define action
(let* ((dump-files
((installer-dump-page current-installer)
dump-dir))
- (dump-archive (make-dump dump-dir dump-files)))
+ (dump-archive
+ (make-dump dump-dir dump-files)))
((installer-report-page current-installer)
dump-archive)))
(_ #f))
diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm
index 2646b5d369..1db78e6f0d 100644
--- a/gnu/installer/newt.scm
+++ b/gnu/installer/newt.scm
@@ -45,6 +45,7 @@ (define-module (gnu installer newt)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 ftw)
+ #:use-module (ice-9 match)
#:use-module (newt)
#:export (newt-installer))
@@ -71,8 +72,8 @@ (define action
#:content error
#:buttons-spec
(list
- (cons (G_ "Exit") (const 'exit))
- (cons (G_ "Dump") (const 'dump)))))
+ (cons (G_ "Dump") (const 'dump))
+ (cons (G_ "Exit") (const 'exit)))))
(newt-set-color COLORSET-ROOT "white" "blue")
action)
@@ -96,10 +97,11 @@ (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))
+ (fold (match-lambda*
+ (((file . enable?) acc)
+ (if enable?
+ (cons file acc)
+ acc)))
'()
(run-dump-page
dump-dir
@@ -144,7 +146,7 @@ (define stop-sig (status:stop-sig result))
(cons "Abort"
(lambda ()
(abort-to-prompt 'installer-step 'abort)))
- (cons "Dump"
+ (cons "Report"
(lambda ()
(raise
(condition
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index 060e633254..0f508a31c0 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -910,22 +910,29 @@ (define info-textbox
(define components
(map (match-lambda ((file . enabled)
(list
- (make-button -1 -1 "Edit")
+ (make-compact-button -1 -1 "Edit")
(make-checkbox -1 -1 file (if enabled #\x #\ ) " x")
file)))
file-choices))
+
+ (define sub-grid (make-grid 2 (length components)))
+
+ (for-each
+ (match-lambda* (((button checkbox _) index)
+ (set-grid-field sub-grid 0 index
+ GRID-ELEMENT-COMPONENT checkbox
+ #:anchor ANCHOR-LEFT)
+ (set-grid-field sub-grid 1 index
+ GRID-ELEMENT-COMPONENT button
+ #:anchor ANCHOR-LEFT)))
+ components (iota (length components)))
+
(define grid
- (apply vertically-stacked-grid
+ (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")))))
+ GRID-ELEMENT-SUBGRID sub-grid
+ GRID-ELEMENT-COMPONENT (make-button -1 -1 "Create")))
+
(define form (make-form #:flags FLAG-NOF12))
(add-form-to-grid grid form #t)
@@ -942,13 +949,13 @@ (define prompt-tag (make-prompt-tag))
(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)))
+ (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
diff --git a/gnu/installer/user.scm b/gnu/installer/user.scm
index 13114e9832..c894a91dc8 100644
--- a/gnu/installer/user.scm
+++ b/gnu/installer/user.scm
@@ -41,6 +41,7 @@ (define-record-type <secret>
(make-secret content)
secret?
(content secret-content))
+
(set-record-type-printer!
<secret>
(lambda (secret port)
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 4f7c691690..fb62fb8896 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -108,19 +108,20 @@ (define dummy-pipe
(close-pipe dummy-pipe)))
(define (run-external-command-with-line-hooks line-hooks command)
- "Run command specified by ARGS in a child, processing each output line with
-the procedures in LINE-HOOKS. Returns the integer status value of
-the child process as returned by waitpid."
+ "Run command specified by the list COMMAND in a child, processing each
+output line with the procedures in LINE-HOOKS. Returns the integer status
+value of the child process as returned by waitpid."
(define (handler input)
- (and (and=> (get-line input)
- (lambda (line)
- (if (eof-object? line)
- #f
- (begin (for-each (lambda (f) (f line))
- (append line-hooks
- %default-installer-line-hooks))
- #t))))
- (handler input)))
+ (and
+ (and=> (get-line input)
+ (lambda (line)
+ (if (eof-object? line)
+ #f
+ (begin (for-each (lambda (f) (f line))
+ (append line-hooks
+ %default-installer-line-hooks))
+ #t))))
+ (handler input)))
(run-external-command-with-handler handler command))
(define* (run-command command)--8
<---------------cut here---------------end--------------->8---

If it's OK for you, I think we can proceed as the concerns that Ludo
raised on the dump mechanism are addressed. Ludo do you agree?
Thanks,

Mathieu
J
J
Josselin Poiret wrote on 31 Jan 2022 18:45
[PATCH] installer: Use system-wide guix for system init.
(name . Mathieu Othacehe)(address . othacehe@gnu.org)
0ad78d6e393a326e5f83d8355833f364ec01966c.1643650595.git.dev@jpoiret.xyz
* gnu/installer.scm (installer-program): Remove dependency on the guix
package for the PATH.
* gnu/installer/final.scm (install-system): Set PATH inside container
to /run/current-system/profile/bin/.
---
Here's an additional patch that will use the system-wide guix in the
installer, so that tests work.

Cheers,
Josselin
gnu/installer.scm | 1 -
gnu/installer/final.scm | 5 ++---
2 files changed, 2 insertions(+), 4 deletions(-)

Toggle diff (37 lines)
diff --git a/gnu/installer.scm b/gnu/installer.scm
index 7b2914be98..415f5a7af7 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -335,7 +335,6 @@ (define set-installer-path
ntfs-3g ;mkfs.ntfs
xfsprogs ;mkfs.xfs
kbd ;chvt
- guix ;guix system init call
util-linux ;mkwap
nano
shadow
diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm
index 2087536502..3f6dacc490 100644
--- a/gnu/installer/final.scm
+++ b/gnu/installer/final.scm
@@ -170,8 +170,7 @@ (define (assert-exit x)
(database-dir "/var/guix/db")
(database-file (string-append database-dir "/db.sqlite"))
(saved-database (string-append database-dir "/db.save"))
- (ret #f)
- (path (getenv "PATH")))
+ (ret #f))
(mkdir-p (%installer-target-dir))
;; We want to initialize user passwords but we don't want to store them in
@@ -210,7 +209,7 @@ (define (assert-exit x)
(setvbuf (current-output-port) 'none)
(setvbuf (current-error-port) 'none)
- (setenv "PATH" path)
+ (setenv "PATH" "/run/current-system/profile/bin/")
(set! ret (run-command install-command)))
(lambda ()
--
2.34.0
M
M
Mathieu Othacehe wrote on 2 Feb 2022 16:50
(name . Josselin Poiret)(address . dev@jpoiret.xyz)
871r0le08u.fsf@gnu.org
Hey Josselin,

Toggle quote (3 lines)
> Here's an additional patch that will use the system-wide guix in the
> installer, so that tests work.

That's confirmed by the CI. I went ahead and pushed the whole series
with this additional patch. All those improvements are really welcomed
so thanks again for your contribution here.

Now we need people to test the soon to be 1.4.0 installer :)

Mathieu
Closed
?
Your comment

This issue is archived.

To comment on this conversation send an email to 53063@debbugs.gnu.org

To respond to this issue using the mumi CLI, first switch to it
mumi current 53063
Then, you may apply the latest patchset in this issue (with sign off)
mumi am -- -s
Or, compose a reply to this issue
mumi compose
Or, send patches to this issue
mumi send-email *.patch