* [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer
@ 2022-01-06 22:45 Josselin Poiret via Guix-patches via
2022-01-06 22:47 ` [bug#53063] [PATCH wip-harden-installer 01/14] installer: Use define instead of let at top-level Josselin Poiret via Guix-patches via
` (13 more replies)
0 siblings, 14 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-06 22:45 UTC (permalink / raw)
To: 53063; +Cc: Josselin Poiret
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
^ permalink raw reply [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH wip-harden-installer 01/14] installer: Use define instead of let at top-level.
2022-01-06 22:45 [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Josselin Poiret via Guix-patches via
@ 2022-01-06 22:47 ` Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 02/14] installer: Generalize logging facility Josselin Poiret via Guix-patches via
` (12 subsequent siblings)
13 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-06 22:47 UTC (permalink / raw)
To: 53063; +Cc: Josselin Poiret
* gnu/installer.scm (installer-program): Improve readability by using
define at top-level.
---
gnu/installer.scm | 88 +++++++++++++++++++++++------------------------
1 file changed, 44 insertions(+), 44 deletions(-)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH wip-harden-installer 02/14] installer: Generalize logging facility.
2022-01-06 22:45 [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Josselin Poiret via Guix-patches via
2022-01-06 22:47 ` [bug#53063] [PATCH wip-harden-installer 01/14] installer: Use define instead of let at top-level Josselin Poiret via Guix-patches via
@ 2022-01-06 22:48 ` Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 03/14] installer: Use new installer-log-line everywhere Josselin Poiret via Guix-patches via
` (11 subsequent siblings)
13 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-06 22:48 UTC (permalink / raw)
To: 53063; +Cc: Josselin Poiret
* 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(+)
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))))))
+
\f
;;;
;;; Client protocol.
--
2.34.0
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH wip-harden-installer 03/14] installer: Use new installer-log-line everywhere.
2022-01-06 22:45 [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Josselin Poiret via Guix-patches via
2022-01-06 22:47 ` [bug#53063] [PATCH wip-harden-installer 01/14] installer: Use define instead of let at top-level Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 02/14] installer: Generalize logging facility Josselin Poiret via Guix-patches via
@ 2022-01-06 22:48 ` Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 04/14] installer: Un-export syslog syntax Josselin Poiret via Guix-patches via
` (10 subsequent siblings)
13 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-06 22:48 UTC (permalink / raw)
To: 53063; +Cc: Josselin Poiret
* 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(-)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH wip-harden-installer 04/14] installer: Un-export syslog syntax.
2022-01-06 22:45 [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Josselin Poiret via Guix-patches via
` (2 preceding siblings ...)
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 03/14] installer: Use new installer-log-line everywhere Josselin Poiret via Guix-patches via
@ 2022-01-06 22:48 ` Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 05/14] installer: Capture external commands output Josselin Poiret via Guix-patches via
` (9 subsequent siblings)
13 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-06 22:48 UTC (permalink / raw)
To: 53063; +Cc: Josselin Poiret
* gnu/installer/utils.scm (syslog): Remove export.
---
gnu/installer/utils.scm | 1 -
1 file changed, 1 deletion(-)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH wip-harden-installer 05/14] installer: Capture external commands output.
2022-01-06 22:45 [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Josselin Poiret via Guix-patches via
` (3 preceding siblings ...)
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 04/14] installer: Un-export syslog syntax Josselin Poiret via Guix-patches via
@ 2022-01-06 22:48 ` Josselin Poiret via Guix-patches via
2022-01-07 13:47 ` [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Ludovic Courtès
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 06/14] installer: Disable automatic finalization for child thread Josselin Poiret via Guix-patches via
` (8 subsequent siblings)
13 siblings, 1 reply; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-06 22:48 UTC (permalink / raw)
To: 53063; +Cc: Josselin Poiret
* 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(-)
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?)
\f
;;;
--
2.34.0
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH wip-harden-installer 06/14] installer: Disable automatic finalization for child thread.
2022-01-06 22:45 [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Josselin Poiret via Guix-patches via
` (4 preceding siblings ...)
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 05/14] installer: Capture external commands output Josselin Poiret via Guix-patches via
@ 2022-01-06 22:48 ` Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 07/14] installer: Add installer-specific run command process Josselin Poiret via Guix-patches via
` (7 subsequent siblings)
13 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-06 22:48 UTC (permalink / raw)
To: 53063; +Cc: Josselin Poiret
* 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(+)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH wip-harden-installer 07/14] installer: Add installer-specific run command process.
2022-01-06 22:45 [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Josselin Poiret via Guix-patches via
` (5 preceding siblings ...)
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 06/14] installer: Disable automatic finalization for child thread Josselin Poiret via Guix-patches via
@ 2022-01-06 22:48 ` Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 08/14] installer: Use run-command-in-installer in (gnu installer parted) Josselin Poiret via Guix-patches via
` (6 subsequent siblings)
13 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-06 22:48 UTC (permalink / raw)
To: 53063; +Cc: Josselin Poiret
* 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(-)
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))
\f
;;;
@@ -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")))))))
+
\f
;;;
;;; Logging.
--
2.34.0
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH wip-harden-installer 08/14] installer: Use run-command-in-installer in (gnu installer parted).
2022-01-06 22:45 [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Josselin Poiret via Guix-patches via
` (6 preceding siblings ...)
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 07/14] installer: Add installer-specific run command process Josselin Poiret via Guix-patches via
@ 2022-01-06 22:48 ` Josselin Poiret via Guix-patches via
2022-01-07 10:58 ` Mathieu Othacehe
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 09/14] installer: Use the command capturing facility for guix init Josselin Poiret via Guix-patches via
` (5 subsequent siblings)
13 siblings, 1 reply; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-06 22:48 UTC (permalink / raw)
To: 53063; +Cc: Josselin Poiret
* 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(-)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH wip-harden-installer 09/14] installer: Use the command capturing facility for guix init.
2022-01-06 22:45 [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Josselin Poiret via Guix-patches via
` (7 preceding siblings ...)
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 08/14] installer: Use run-command-in-installer in (gnu installer parted) Josselin Poiret via Guix-patches via
@ 2022-01-06 22:48 ` Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 10/14] installer: Raise condition when mklabel fails Josselin Poiret via Guix-patches via
` (4 subsequent siblings)
13 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-06 22:48 UTC (permalink / raw)
To: 53063; +Cc: Josselin Poiret
* 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(-)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH wip-harden-installer 10/14] installer: Raise condition when mklabel fails.
2022-01-06 22:45 [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Josselin Poiret via Guix-patches via
` (8 preceding siblings ...)
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 09/14] installer: Use the command capturing facility for guix init Josselin Poiret via Guix-patches via
@ 2022-01-06 22:48 ` Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 11/14] installer: Fix run-file-textbox-page when edit-button is #f Josselin Poiret via Guix-patches via
` (3 subsequent siblings)
13 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-06 22:48 UTC (permalink / raw)
To: 53063; +Cc: Josselin Poiret
* gnu/installer/parted.scm (mklabel): Do it.
---
gnu/installer/parted.scm | 10 ++++++++--
1 file changed, 8 insertions(+), 2 deletions(-)
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)))))))))
\f
;;
--
2.34.0
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH wip-harden-installer 11/14] installer: Fix run-file-textbox-page when edit-button is #f.
2022-01-06 22:45 [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Josselin Poiret via Guix-patches via
` (9 preceding siblings ...)
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 10/14] installer: Raise condition when mklabel fails Josselin Poiret via Guix-patches via
@ 2022-01-06 22:48 ` Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 12/14] installer: Replace run-command by invoke in newt/page.scm Josselin Poiret via Guix-patches via
` (2 subsequent siblings)
13 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-06 22:48 UTC (permalink / raw)
To: 53063; +Cc: Josselin Poiret
* 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(+)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH wip-harden-installer 12/14] installer: Replace run-command by invoke in newt/page.scm.
2022-01-06 22:45 [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Josselin Poiret via Guix-patches via
` (10 preceding siblings ...)
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 11/14] installer: Fix run-file-textbox-page when edit-button is #f Josselin Poiret via Guix-patches via
@ 2022-01-06 22:48 ` Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 13/14] installer: Use named prompt to abort or break installer steps Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 14/14] installer: Add confirmation page when running external commands Josselin Poiret via Guix-patches via
13 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-06 22:48 UTC (permalink / raw)
To: 53063; +Cc: Josselin Poiret
* gnu/installer/newt/page.scm (edit-file): Replace it.
---
gnu/installer/newt/page.scm | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH wip-harden-installer 13/14] installer: Use named prompt to abort or break installer steps.
2022-01-06 22:45 [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Josselin Poiret via Guix-patches via
` (11 preceding siblings ...)
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 12/14] installer: Replace run-command by invoke in newt/page.scm Josselin Poiret via Guix-patches via
@ 2022-01-06 22:48 ` Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 14/14] installer: Add confirmation page when running external commands Josselin Poiret via Guix-patches via
13 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-06 22:48 UTC (permalink / raw)
To: 53063; +Cc: Josselin Poiret
* gnu/installer/steps.scm (run-installer-steps): Set up
'installer-step prompt.
* gnu/installer/newt/ethernet.scm (run-ethernet-page)
* gnu/installer/newt/final.scm (run-config-display-page,
run-install-failed-page)
* gnu/installer/newt/keymap.scm (run-layout-page, run-variant-page)
* gnu/installer/newt/locale.scm (run-language-page,
run-territory-page, run-codeset-page, run-modifier-page,
run-locale-page)
* gnu/installer/newt/network.scm (run-technology-page,
wait-service-online)
* gnu/installer/newt/page.scm (run-listbox-selection-page,
run-checkbox-tree-page)
* gnu/installer/newt/partition.scm (button-exit-action)
* gnu/installer/newt/services.scm (run-desktop-environments-cbt-page,
run-networking-cbt-page, run-other-services-cbt-page,
run-network-management-page)
* gnu/installer/newt/timezone.scm (run-timezone-page)
* gnu/installer/newt/user.scm (run-user-page)
* gnu/installer/newt/welcome.scm (run-menu-page)
* gnu/installer/newt/wifi.scm (run-wifi-page): Use the 'installer-step
prompt to abort.
---
gnu/installer/newt/ethernet.scm | 8 +-
gnu/installer/newt/final.scm | 8 +-
gnu/installer/newt/keymap.scm | 8 +-
gnu/installer/newt/locale.scm | 25 ++----
gnu/installer/newt/network.scm | 16 +---
gnu/installer/newt/page.scm | 4 +-
gnu/installer/newt/partition.scm | 6 +-
gnu/installer/newt/services.scm | 16 +---
gnu/installer/newt/timezone.scm | 4 +-
gnu/installer/newt/user.scm | 5 +-
gnu/installer/newt/welcome.scm | 2 +-
gnu/installer/newt/wifi.scm | 4 +-
gnu/installer/steps.scm | 127 +++++++++++++------------------
13 files changed, 85 insertions(+), 148 deletions(-)
diff --git a/gnu/installer/newt/ethernet.scm b/gnu/installer/newt/ethernet.scm
index ecd22efbb2..d75a640519 100644
--- a/gnu/installer/newt/ethernet.scm
+++ b/gnu/installer/newt/ethernet.scm
@@ -65,9 +65,7 @@ (define (run-ethernet-page)
(run-error-page
(G_ "No ethernet service available, please try again.")
(G_ "No service"))
- (raise
- (condition
- (&installer-step-abort))))
+ (abort-to-prompt 'installer-step 'abort))
((service)
;; Only one service is available so return it directly.
service)
@@ -81,7 +79,5 @@ (define (run-ethernet-page)
#:button-text (G_ "Exit")
#:button-callback-procedure
(lambda _
- (raise
- (condition
- (&installer-step-abort))))
+ (abort-to-prompt 'installer-step 'abort))
#:listbox-callback-procedure connect-ethernet-service))))
diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm
index 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))))))))
+ (call-with-prompt 'installer-step
+ (lambda ()
+ (installer-log-line "running step '~a'~%" (installer-step-id step))
+ (let* ((id (installer-step-id step))
+ (compute (installer-step-compute step))
+ (res (compute result done-steps)))
+ (hash-set! %current-result id res)
+ (run (alist-cons id res result)
+ #:todo-steps rest-steps
+ #:done-steps (append done-steps (list step)))))
+ (lambda (k action)
+ (match action
+ ('abort
+ (case rewind-strategy
+ ((previous)
+ (match done-steps
+ (()
+ ;; We cannot go previous the first step. Abort again to
+ ;; 'installer-step prompt. It might be useful in the case
+ ;; of nested run-installer-steps.
+ (abort-to-prompt 'installer-step action))
+ ((prev-done ... last-done)
+ (run (pop-result result)
+ #:todo-steps (cons last-done todo-steps)
+ #:done-steps prev-done))))
+ ((menu)
+ (let ((goto-step (menu-proc
+ (append done-steps (list step)))))
+ (if (eq? goto-step step)
+ (run result
+ #:todo-steps todo-steps
+ #:done-steps done-steps)
+ (skip-to-step goto-step result
+ #:todo-steps todo-steps
+ #:done-steps done-steps))))
+ ((start)
+ (if (null? done-steps)
+ ;; Same as above, it makes no sense to jump to start
+ ;; when we are at the first installer-step. Abort to
+ ;; 'installer-step prompt again.
+ (abort-to-prompt 'installer-step action)
+ (run '()
+ #:todo-steps steps
+ #:done-steps '())))))
+ ('break
+ (reverse result))))))))
;; Ignore SIGPIPE so that we don't die if a client closes the connection
;; prematurely.
(sigaction SIGPIPE SIG_IGN)
(with-server-socket
- (call-with-prompt 'raise-above
- (lambda ()
- (run '()
- #:todo-steps steps
- #:done-steps '()))
- (lambda (k condition)
- (raise condition)))))
+ (run '()
+ #:todo-steps steps
+ #:done-steps '())))
(define (find-step-by-id steps id)
"Find and return the step in STEPS whose id is equal to ID."
--
2.34.0
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH wip-harden-installer 14/14] installer: Add confirmation page when running external commands.
2022-01-06 22:45 [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Josselin Poiret via Guix-patches via
` (12 preceding siblings ...)
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 13/14] installer: Use named prompt to abort or break installer steps Josselin Poiret via Guix-patches via
@ 2022-01-06 22:48 ` Josselin Poiret via Guix-patches via
13 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-06 22:48 UTC (permalink / raw)
To: 53063; +Cc: Josselin Poiret
* gnu/installer/newt.scm (newt-run-command): Add it.
---
gnu/installer/newt.scm | 10 ++++++++++
1 file changed, 10 insertions(+)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH wip-harden-installer 08/14] installer: Use run-command-in-installer in (gnu installer parted).
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 08/14] installer: Use run-command-in-installer in (gnu installer parted) Josselin Poiret via Guix-patches via
@ 2022-01-07 10:58 ` Mathieu Othacehe
2022-01-07 11:46 ` Josselin Poiret via Guix-patches via
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
0 siblings, 2 replies; 40+ messages in thread
From: Mathieu Othacehe @ 2022-01-07 10:58 UTC (permalink / raw)
To: 53063; +Cc: dev
Hello Josselin,
> * 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.
--8<---------------cut here---------------start------------->8---
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
--8<---------------cut here---------------end--------------->8---
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
^ permalink raw reply [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH wip-harden-installer 08/14] installer: Use run-command-in-installer in (gnu installer parted).
2022-01-07 10:58 ` Mathieu Othacehe
@ 2022-01-07 11:46 ` Josselin Poiret via Guix-patches via
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
1 sibling, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-07 11:46 UTC (permalink / raw)
To: othacehe, 53063
Hello Mathieu,
Mathieu Othacehe <othacehe@gnu.org> writes:
> 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?
> 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
^ permalink raw reply [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 05/14] installer: Capture external commands output Josselin Poiret via Guix-patches via
@ 2022-01-07 13:47 ` Ludovic Courtès
0 siblings, 0 replies; 40+ messages in thread
From: Ludovic Courtès @ 2022-01-07 13:47 UTC (permalink / raw)
To: Josselin Poiret; +Cc: 53063
Hello Josselin,
Josselin Poiret <dev@jpoiret.xyz> skribis:
> +(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’.
^ permalink raw reply [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer
2022-01-07 10:58 ` Mathieu Othacehe
2022-01-07 11:46 ` Josselin Poiret via Guix-patches via
@ 2022-01-15 13:49 ` Josselin Poiret via Guix-patches via
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 01/18] installer: Use define instead of let at top-level Josselin Poiret via Guix-patches via
` (18 more replies)
1 sibling, 19 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:49 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
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
https://debbugs.gnu.org/cgi/bugreport.cgi?bug=52835).
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
^ permalink raw reply [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 01/18] installer: Use define instead of let at top-level.
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
@ 2022-01-15 13:49 ` Josselin Poiret via Guix-patches via
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 02/18] installer: Generalize logging facility Josselin Poiret via Guix-patches via
` (17 subsequent siblings)
18 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:49 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
* gnu/installer.scm (installer-program): Improve readability by using
define at top-level.
---
gnu/installer.scm | 88 +++++++++++++++++++++++------------------------
1 file changed, 44 insertions(+), 44 deletions(-)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 02/18] installer: Generalize logging facility.
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 01/18] installer: Use define instead of let at top-level Josselin Poiret via Guix-patches via
@ 2022-01-15 13:49 ` Josselin Poiret via Guix-patches via
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 03/18] installer: Use new installer-log-line everywhere Josselin Poiret via Guix-patches via
` (16 subsequent siblings)
18 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:49 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
* 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(+)
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))))))
+
\f
;;;
;;; Client protocol.
--
2.34.0
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 03/18] installer: Use new installer-log-line everywhere.
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 01/18] installer: Use define instead of let at top-level Josselin Poiret via Guix-patches via
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 02/18] installer: Generalize logging facility Josselin Poiret via Guix-patches via
@ 2022-01-15 13:49 ` Josselin Poiret via Guix-patches via
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 04/18] installer: Un-export syslog syntax Josselin Poiret via Guix-patches via
` (15 subsequent siblings)
18 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:49 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
* 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(-)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 04/18] installer: Un-export syslog syntax.
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
` (2 preceding siblings ...)
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 03/18] installer: Use new installer-log-line everywhere Josselin Poiret via Guix-patches via
@ 2022-01-15 13:49 ` Josselin Poiret via Guix-patches via
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 05/18] installer: Keep PATH inside the install container Josselin Poiret via Guix-patches via
` (14 subsequent siblings)
18 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:49 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
* gnu/installer/utils.scm (syslog): Remove export.
---
gnu/installer/utils.scm | 1 -
1 file changed, 1 deletion(-)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 05/18] installer: Keep PATH inside the install container.
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
` (3 preceding siblings ...)
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 04/18] installer: Un-export syslog syntax Josselin Poiret via Guix-patches via
@ 2022-01-15 13:49 ` Josselin Poiret via Guix-patches via
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 06/18] installer: Remove specific logging code Josselin Poiret via Guix-patches via
` (13 subsequent siblings)
18 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:49 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
* gnu/installer/final.scm (install-system): Set PATH inside the
container.
---
gnu/installer/final.scm | 5 ++++-
1 file changed, 4 insertions(+), 1 deletion(-)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 06/18] installer: Remove specific logging code.
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
` (4 preceding siblings ...)
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 05/18] installer: Keep PATH inside the install container Josselin Poiret via Guix-patches via
@ 2022-01-15 13:49 ` Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 07/18] installer: Capture external commands output Josselin Poiret via Guix-patches via
` (12 subsequent siblings)
18 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:49 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
* 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(-)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 07/18] installer: Capture external commands output.
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
` (5 preceding siblings ...)
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 06/18] installer: Remove specific logging code Josselin Poiret via Guix-patches via
@ 2022-01-15 13:50 ` Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 08/18] installer: Add installer-specific run command process Josselin Poiret via Guix-patches via
` (11 subsequent siblings)
18 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:50 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
* 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(-)
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?)
\f
;;;
--
2.34.0
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 08/18] installer: Add installer-specific run command process.
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
` (6 preceding siblings ...)
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 07/18] installer: Capture external commands output Josselin Poiret via Guix-patches via
@ 2022-01-15 13:50 ` Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 09/18] installer: Use run-command-in-installer in (gnu installer parted) Josselin Poiret via Guix-patches via
` (10 subsequent siblings)
18 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:50 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
* 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(-)
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))
\f
;;;
@@ -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")))))))
+
\f
;;;
;;; Logging.
--
2.34.0
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 09/18] installer: Use run-command-in-installer in (gnu installer parted).
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
` (7 preceding siblings ...)
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 08/18] installer: Add installer-specific run command process Josselin Poiret via Guix-patches via
@ 2022-01-15 13:50 ` Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 10/18] installer: Raise condition when mklabel fails Josselin Poiret via Guix-patches via
` (9 subsequent siblings)
18 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:50 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
* 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(-)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 10/18] installer: Raise condition when mklabel fails.
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
` (8 preceding siblings ...)
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 09/18] installer: Use run-command-in-installer in (gnu installer parted) Josselin Poiret via Guix-patches via
@ 2022-01-15 13:50 ` Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 11/18] installer: Fix run-file-textbox-page when edit-button is #f Josselin Poiret via Guix-patches via
` (8 subsequent siblings)
18 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:50 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
* gnu/installer/parted.scm (mklabel): Do it.
---
gnu/installer/parted.scm | 10 ++++++++--
1 file changed, 8 insertions(+), 2 deletions(-)
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)))))))))
\f
;;
--
2.34.0
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 11/18] installer: Fix run-file-textbox-page when edit-button is #f.
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
` (9 preceding siblings ...)
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 10/18] installer: Raise condition when mklabel fails Josselin Poiret via Guix-patches via
@ 2022-01-15 13:50 ` Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 12/18] installer: Replace run-command by invoke in newt/page.scm Josselin Poiret via Guix-patches via
` (7 subsequent siblings)
18 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:50 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
* 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(+)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 12/18] installer: Replace run-command by invoke in newt/page.scm.
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
` (10 preceding siblings ...)
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 11/18] installer: Fix run-file-textbox-page when edit-button is #f Josselin Poiret via Guix-patches via
@ 2022-01-15 13:50 ` Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 13/18] installer: Add nano to PATH Josselin Poiret via Guix-patches via
` (6 subsequent siblings)
18 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:50 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
* gnu/installer/newt/page.scm (edit-file): Replace it.
---
gnu/installer/newt/page.scm | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 13/18] installer: Add nano to PATH.
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
` (11 preceding siblings ...)
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 12/18] installer: Replace run-command by invoke in newt/page.scm Josselin Poiret via Guix-patches via
@ 2022-01-15 13:50 ` Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 14/18] installer: Use named prompt to abort or break installer steps Josselin Poiret via Guix-patches via
` (5 subsequent siblings)
18 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:50 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
* gnu/installer.scm (installer-program): Add nano to the installer
PATH.
---
gnu/installer.scm | 2 ++
1 file changed, 2 insertions(+)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 14/18] installer: Use named prompt to abort or break installer steps.
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
` (12 preceding siblings ...)
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 13/18] installer: Add nano to PATH Josselin Poiret via Guix-patches via
@ 2022-01-15 13:50 ` Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 15/18] installer: Add error page when running external commands Josselin Poiret via Guix-patches via
` (4 subsequent siblings)
18 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:50 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
* gnu/installer/steps.scm (run-installer-steps): Set up
'installer-step prompt.
* gnu/installer/newt/ethernet.scm (run-ethernet-page)
* gnu/installer/newt/final.scm (run-config-display-page,
run-install-failed-page)
* gnu/installer/newt/keymap.scm (run-layout-page, run-variant-page)
* gnu/installer/newt/locale.scm (run-language-page,
run-territory-page, run-codeset-page, run-modifier-page,
run-locale-page)
* gnu/installer/newt/network.scm (run-technology-page,
wait-service-online)
* gnu/installer/newt/page.scm (run-listbox-selection-page,
run-checkbox-tree-page)
* gnu/installer/newt/partition.scm (button-exit-action)
* gnu/installer/newt/services.scm (run-desktop-environments-cbt-page,
run-networking-cbt-page, run-other-services-cbt-page,
run-network-management-page)
* gnu/installer/newt/timezone.scm (run-timezone-page)
* gnu/installer/newt/user.scm (run-user-page)
* gnu/installer/newt/welcome.scm (run-menu-page)
* gnu/installer/newt/wifi.scm (run-wifi-page): Use the 'installer-step
prompt to abort.
---
gnu/installer/newt/ethernet.scm | 8 +-
gnu/installer/newt/final.scm | 8 +-
gnu/installer/newt/keymap.scm | 8 +-
gnu/installer/newt/locale.scm | 25 ++----
gnu/installer/newt/network.scm | 16 +---
gnu/installer/newt/page.scm | 4 +-
gnu/installer/newt/partition.scm | 6 +-
gnu/installer/newt/services.scm | 16 +---
gnu/installer/newt/timezone.scm | 4 +-
gnu/installer/newt/user.scm | 5 +-
gnu/installer/newt/welcome.scm | 2 +-
gnu/installer/newt/wifi.scm | 4 +-
gnu/installer/steps.scm | 127 +++++++++++++------------------
13 files changed, 85 insertions(+), 148 deletions(-)
diff --git a/gnu/installer/newt/ethernet.scm b/gnu/installer/newt/ethernet.scm
index ecd22efbb2..d75a640519 100644
--- a/gnu/installer/newt/ethernet.scm
+++ b/gnu/installer/newt/ethernet.scm
@@ -65,9 +65,7 @@ (define (run-ethernet-page)
(run-error-page
(G_ "No ethernet service available, please try again.")
(G_ "No service"))
- (raise
- (condition
- (&installer-step-abort))))
+ (abort-to-prompt 'installer-step 'abort))
((service)
;; Only one service is available so return it directly.
service)
@@ -81,7 +79,5 @@ (define (run-ethernet-page)
#:button-text (G_ "Exit")
#:button-callback-procedure
(lambda _
- (raise
- (condition
- (&installer-step-abort))))
+ (abort-to-prompt 'installer-step 'abort))
#:listbox-callback-procedure connect-ethernet-service))))
diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm
index efe422f4f4..7c3f73ee82 100644
--- a/gnu/installer/newt/final.scm
+++ b/gnu/installer/newt/final.scm
@@ -59,9 +59,7 @@ (define* (run-config-display-page #:key locale)
#:file-textbox-height height
#:exit-button-callback-procedure
(lambda ()
- (raise
- (condition
- (&installer-step-abort)))))))
+ (abort-to-prompt 'installer-step 'abort)))))
(define (run-install-success-page)
(match (current-clients)
@@ -88,9 +86,7 @@ (define (run-install-failed-page)
(G_ "Restart the installer")
(G_ "The final system installation step failed. You can resume from \
a specific step, or restart the installer."))
- (1 (raise
- (condition
- (&installer-step-abort))))
+ (1 (abort-to-prompt 'installer-step 'abort))
(2
;; Keep going, the installer will be restarted later on.
#t)))
diff --git a/gnu/installer/newt/keymap.scm b/gnu/installer/newt/keymap.scm
index 92f7f46f34..c5d4be6792 100644
--- a/gnu/installer/newt/keymap.scm
+++ b/gnu/installer/newt/keymap.scm
@@ -59,9 +59,7 @@ (define (run-layout-page layouts layout->text context)
((param) (const #f))
(else
(lambda _
- (raise
- (condition
- (&installer-step-abort)))))))))
+ (abort-to-prompt 'installer-step 'abort)))))))
(define (run-variant-page variants variant->text)
(let ((title (G_ "Variant")))
@@ -74,9 +72,7 @@ (define (run-variant-page variants variant->text)
#:button-text (G_ "Back")
#:button-callback-procedure
(lambda _
- (raise
- (condition
- (&installer-step-abort)))))))
+ (abort-to-prompt 'installer-step 'abort)))))
(define (sort-layouts layouts)
"Sort LAYOUTS list by putting the US layout ahead and return it."
diff --git a/gnu/installer/newt/locale.scm b/gnu/installer/newt/locale.scm
index bfd89aca2c..01171e253f 100644
--- a/gnu/installer/newt/locale.scm
+++ b/gnu/installer/newt/locale.scm
@@ -43,9 +43,7 @@ (define result
#:button-text (G_ "Exit")
#:button-callback-procedure
(lambda _
- (raise
- (condition
- (&installer-step-abort))))))
+ (abort-to-prompt 'installer-step 'abort))))
;; Immediately install the chosen language so that the territory page that
;; comes after (optionally) is displayed in the chosen language.
@@ -63,9 +61,7 @@ (define (run-territory-page territories territory->text)
#:button-text (G_ "Back")
#:button-callback-procedure
(lambda _
- (raise
- (condition
- (&installer-step-abort)))))))
+ (abort-to-prompt 'installer-step 'abort)))))
(define (run-codeset-page codesets)
(let ((title (G_ "Locale codeset")))
@@ -78,9 +74,7 @@ (define (run-codeset-page codesets)
#:button-text (G_ "Back")
#:button-callback-procedure
(lambda _
- (raise
- (condition
- (&installer-step-abort)))))))
+ (abort-to-prompt 'installer-step 'abort)))))
(define (run-modifier-page modifiers modifier->text)
(let ((title (G_ "Locale modifier")))
@@ -94,9 +88,7 @@ (define (run-modifier-page modifiers modifier->text)
#:button-text (G_ "Back")
#:button-callback-procedure
(lambda _
- (raise
- (condition
- (&installer-step-abort)))))))
+ (abort-to-prompt 'installer-step 'abort)))))
(define* (run-locale-page #:key
supported-locales
@@ -110,11 +102,10 @@ (define* (run-locale-page #:key
glibc format is returned."
(define (break-on-locale-found locales)
- "Raise the &installer-step-break condition if LOCALES contains exactly one
+ "Break to the installer step if LOCALES contains exactly one
element."
(and (= (length locales) 1)
- (raise
- (condition (&installer-step-break)))))
+ (abort-to-prompt 'installer-step 'break)))
(define (filter-locales locales result)
"Filter the list of locale records LOCALES using the RESULT returned by
@@ -218,8 +209,8 @@ (define locale-steps
;; If run-installer-steps returns locally, it means that the user had to go
;; through all steps (language, territory, codeset and modifier) to select a
- ;; locale. In that case, like if we exited by raising &installer-step-break
- ;; condition, turn the result into a glibc locale string and return it.
+ ;; locale. In that case, like if we exited by breaking to the installer
+ ;; step, turn the result into a glibc locale string and return it.
(result->locale-string
supported-locales
(run-installer-steps #:steps locale-steps)))
diff --git a/gnu/installer/newt/network.scm b/gnu/installer/newt/network.scm
index fb221483c3..0477a489be 100644
--- a/gnu/installer/newt/network.scm
+++ b/gnu/installer/newt/network.scm
@@ -65,12 +65,8 @@ (define (technology-items)
(G_ "Exit")
(G_ "The install process requires Internet access but no \
network devices were found. Do you want to continue anyway?"))
- ((1) (raise
- (condition
- (&installer-step-break))))
- ((2) (raise
- (condition
- (&installer-step-abort))))))
+ ((1) (abort-to-prompt 'installer-step 'break))
+ ((2) (abort-to-prompt 'installer-step 'abort))))
((technology)
;; Since there's only one technology available, skip the selection
;; screen.
@@ -86,9 +82,7 @@ (define (technology-items)
#:button-text (G_ "Exit")
#:button-callback-procedure
(lambda _
- (raise
- (condition
- (&installer-step-abort))))))))
+ (abort-to-prompt 'installer-step 'abort))))))
(define (find-technology-by-type technologies type)
"Find and return a technology with the given TYPE in TECHNOLOGIES list."
@@ -156,9 +150,7 @@ (define (online?)
(G_ "The selected network does not provide access to the \
Internet and the Guix substitute server, please try again.")
(G_ "Connection error"))
- (raise
- (condition
- (&installer-step-abort))))))
+ (abort-to-prompt 'installer-step 'abort))))
(define (run-network-page)
"Run a page to allow the user to configure connman so that it can access the
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index 695c7d875f..8c675fa837 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -488,7 +488,7 @@ (define (choice->item str)
(string=? str (listbox-item->text item))))
keys)
((key . item) item)
- (#f (raise (condition (&installer-step-abort))))))
+ (#f (abort-to-prompt 'installer-step 'abort))))
;; On every listbox element change, check if we need to skip it. If yes,
;; depending on the 'last-listbox-key', jump forward or backward. If no,
@@ -690,7 +690,7 @@ (define (choice->item str)
(string=? str (item->text item))))
keys)
((key . item) item)
- (#f (raise (condition (&installer-step-abort))))))
+ (#f (abort-to-prompt 'installer-step 'abort))))
(add-form-to-grid grid form #t)
(make-wrapped-grid-window grid title)
diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm
index 6a3aa3daff..e7a97810ac 100644
--- a/gnu/installer/newt/partition.scm
+++ b/gnu/installer/newt/partition.scm
@@ -36,10 +36,8 @@ (define-module (gnu installer newt partition)
#:export (run-partitioning-page))
(define (button-exit-action)
- "Raise the &installer-step-abort condition."
- (raise
- (condition
- (&installer-step-abort))))
+ "Abort the installer step."
+ (abort-to-prompt 'installer-step 'abort))
(define (run-scheme-page)
"Run a page asking the user for a partitioning scheme."
diff --git a/gnu/installer/newt/services.scm b/gnu/installer/newt/services.scm
index c218825813..9951ad2212 100644
--- a/gnu/installer/newt/services.scm
+++ b/gnu/installer/newt/services.scm
@@ -46,9 +46,7 @@ (define (run-desktop-environments-cbt-page)
#:checkbox-tree-height 9
#:exit-button-callback-procedure
(lambda ()
- (raise
- (condition
- (&installer-step-abort)))))))
+ (abort-to-prompt 'installer-step 'abort)))))
(define (run-networking-cbt-page)
"Run a page allowing the user to select networking services."
@@ -65,9 +63,7 @@ (define (run-networking-cbt-page)
#:checkbox-tree-height 5
#:exit-button-callback-procedure
(lambda ()
- (raise
- (condition
- (&installer-step-abort)))))))
+ (abort-to-prompt 'installer-step 'abort)))))
(define (run-printing-services-cbt-page)
"Run a page allowing the user to select document services such as CUPS."
@@ -85,9 +81,7 @@ (define (run-printing-services-cbt-page)
#:checkbox-tree-height 9
#:exit-button-callback-procedure
(lambda ()
- (raise
- (condition
- (&installer-step-abort)))))))
+ (abort-to-prompt 'installer-step 'abort)))))
(define (run-console-services-cbt-page)
"Run a page to select various system adminstration services for non-graphical
@@ -130,9 +124,7 @@ (define (run-network-management-page)
#:button-text (G_ "Exit")
#:button-callback-procedure
(lambda _
- (raise
- (condition
- (&installer-step-abort)))))))
+ (abort-to-prompt 'installer-step 'abort)))))
(define (run-services-page)
(let ((desktop (run-desktop-environments-cbt-page)))
diff --git a/gnu/installer/newt/timezone.scm b/gnu/installer/newt/timezone.scm
index 67bf41ff84..bed9f9d5cb 100644
--- a/gnu/installer/newt/timezone.scm
+++ b/gnu/installer/newt/timezone.scm
@@ -65,9 +65,7 @@ (define (loop path)
#:button-callback-procedure
(if (null? path)
(lambda _
- (raise
- (condition
- (&installer-step-abort))))
+ (abort-to-prompt 'installer-step 'abort))
(lambda _
(loop (all-but-last path))))
#:listbox-callback-procedure
diff --git a/gnu/installer/newt/user.scm b/gnu/installer/newt/user.scm
index 58bb86bf96..97141cfe64 100644
--- a/gnu/installer/newt/user.scm
+++ b/gnu/installer/newt/user.scm
@@ -20,7 +20,6 @@
(define-module (gnu installer newt user)
#:use-module (gnu installer user)
- #:use-module ((gnu installer steps) #:select (&installer-step-abort))
#:use-module (gnu installer newt page)
#:use-module (gnu installer newt utils)
#:use-module (gnu installer utils)
@@ -257,9 +256,7 @@ (define (run users)
(run users))
(reverse users))
((components=? argument exit-button)
- (raise
- (condition
- (&installer-step-abort))))))
+ (abort-to-prompt 'installer-step 'abort))))
('exit-fd-ready
;; Read the complete user list at once.
(match argument
diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm
index 5f461279e2..7a7ddfb7bd 100644
--- a/gnu/installer/newt/welcome.scm
+++ b/gnu/installer/newt/welcome.scm
@@ -84,7 +84,7 @@ (define (choice->item str)
(string=? str (listbox-item->text item))))
keys)
((key . item) item)
- (#f (raise (condition (&installer-step-abort))))))
+ (#f (abort-to-prompt 'installer-step 'abort))))
(set-textbox-text logo-textbox (read-all logo))
diff --git a/gnu/installer/newt/wifi.scm b/gnu/installer/newt/wifi.scm
index f5d8f1fdbf..8a87cbdf4b 100644
--- a/gnu/installer/newt/wifi.scm
+++ b/gnu/installer/newt/wifi.scm
@@ -237,9 +237,7 @@ (define (run-wifi-page)
(run-wifi-scan-page)
(run-wifi-page))
((components=? argument exit-button)
- (raise
- (condition
- (&installer-step-abort))))
+ (abort-to-prompt 'installer-step 'abort))
((components=? argument listbox)
(let ((result (connect-wifi-service listbox service-items)))
(unless result
diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm
index d9b3d6d07e..8bc38181a7 100644
--- a/gnu/installer/steps.scm
+++ b/gnu/installer/steps.scm
@@ -28,13 +28,7 @@ (define-module (gnu installer steps)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (rnrs io ports)
- #:export (&installer-step-abort
- installer-step-abort?
-
- &installer-step-break
- installer-step-break?
-
- <installer-step>
+ #:export (<installer-step>
installer-step
make-installer-step
installer-step?
@@ -60,14 +54,6 @@ (define-module (gnu installer steps)
;; purposes.
(define %current-result (make-hash-table))
-;; This condition may be raised to abort the current step.
-(define-condition-type &installer-step-abort &condition
- installer-step-abort?)
-
-;; This condition may be raised to break out from the steps execution.
-(define-condition-type &installer-step-break &condition
- installer-step-break?)
-
;; An installer-step record is basically an id associated to a compute
;; procedure. The COMPUTE procedure takes exactly one argument, an association
;; list containing the results of previously executed installer-steps (see
@@ -94,8 +80,10 @@ (define* (run-installer-steps #:key
(rewind-strategy 'previous)
(menu-proc (const #f)))
"Run the COMPUTE procedure of all <installer-step> records in STEPS
-sequentially. If the &installer-step-abort condition is raised, fallback to a
-previous install-step, accordingly to the specified REWIND-STRATEGY.
+sequentially, inside a the 'installer-step prompt. When aborted to with a
+parameter of 'abort, fallback to a previous install-step, accordingly to the
+specified REWIND-STRATEGY. When aborted to with a parameter of 'break, stop
+the computation and return the accumalated result so far.
REWIND-STRATEGY possible values are 'previous, 'menu and 'start. If 'previous
is selected, the execution will resume at the previous installer-step. If
@@ -112,10 +100,7 @@ (define* (run-installer-steps #:key
where STEP-ID is the ID field of the installer-step and COMPUTE-RESULT the
result of the associated COMPUTE procedure. This result association list is
passed as argument of every COMPUTE procedure. It is finally returned when the
-computation is over.
-
-If the &installer-step-break condition is raised, stop the computation and
-return the accumalated result so far."
+computation is over."
(define (pop-result list)
(cdr list))
@@ -149,63 +134,61 @@ (define* (run result #:key todo-steps done-steps)
(match todo-steps
(() (reverse result))
((step . rest-steps)
- (guard (c ((installer-step-abort? c)
- (case rewind-strategy
- ((previous)
- (match done-steps
- (()
- ;; We cannot go previous the first step. So re-raise
- ;; the exception. It might be useful in the case of
- ;; nested run-installer-steps. Abort to 'raise-above
- ;; prompt to prevent the condition from being catched
- ;; by one of the previously installed guard.
- (abort-to-prompt 'raise-above c))
- ((prev-done ... last-done)
- (run (pop-result result)
- #:todo-steps (cons last-done todo-steps)
- #:done-steps prev-done))))
- ((menu)
- (let ((goto-step (menu-proc
- (append done-steps (list step)))))
- (if (eq? goto-step step)
- (run result
- #:todo-steps todo-steps
- #:done-steps done-steps)
- (skip-to-step goto-step result
- #:todo-steps todo-steps
- #:done-steps done-steps))))
- ((start)
- (if (null? done-steps)
- ;; Same as above, it makes no sense to jump to start
- ;; when we are at the first installer-step. Abort to
- ;; 'raise-above prompt to re-raise the condition.
- (abort-to-prompt 'raise-above c)
- (run '()
- #:todo-steps steps
- #:done-steps '())))))
- ((installer-step-break? c)
- (reverse result)))
- (installer-log-line "running step '~a'" (installer-step-id step))
- (let* ((id (installer-step-id step))
- (compute (installer-step-compute step))
- (res (compute result done-steps)))
- (hash-set! %current-result id res)
- (run (alist-cons id res result)
- #:todo-steps rest-steps
- #:done-steps (append done-steps (list step))))))))
+ (call-with-prompt 'installer-step
+ (lambda ()
+ (installer-log-line "running step '~a'" (installer-step-id step))
+ (let* ((id (installer-step-id step))
+ (compute (installer-step-compute step))
+ (res (compute result done-steps)))
+ (hash-set! %current-result id res)
+ (run (alist-cons id res result)
+ #:todo-steps rest-steps
+ #:done-steps (append done-steps (list step)))))
+ (lambda (k action)
+ (match action
+ ('abort
+ (case rewind-strategy
+ ((previous)
+ (match done-steps
+ (()
+ ;; We cannot go previous the first step. Abort again to
+ ;; 'installer-step prompt. It might be useful in the case
+ ;; of nested run-installer-steps.
+ (abort-to-prompt 'installer-step action))
+ ((prev-done ... last-done)
+ (run (pop-result result)
+ #:todo-steps (cons last-done todo-steps)
+ #:done-steps prev-done))))
+ ((menu)
+ (let ((goto-step (menu-proc
+ (append done-steps (list step)))))
+ (if (eq? goto-step step)
+ (run result
+ #:todo-steps todo-steps
+ #:done-steps done-steps)
+ (skip-to-step goto-step result
+ #:todo-steps todo-steps
+ #:done-steps done-steps))))
+ ((start)
+ (if (null? done-steps)
+ ;; Same as above, it makes no sense to jump to start
+ ;; when we are at the first installer-step. Abort to
+ ;; 'installer-step prompt again.
+ (abort-to-prompt 'installer-step action)
+ (run '()
+ #:todo-steps steps
+ #:done-steps '())))))
+ ('break
+ (reverse result))))))))
;; Ignore SIGPIPE so that we don't die if a client closes the connection
;; prematurely.
(sigaction SIGPIPE SIG_IGN)
(with-server-socket
- (call-with-prompt 'raise-above
- (lambda ()
- (run '()
- #:todo-steps steps
- #:done-steps '()))
- (lambda (k condition)
- (raise condition)))))
+ (run '()
+ #:todo-steps steps
+ #:done-steps '())))
(define (find-step-by-id steps id)
"Find and return the step in STEPS whose id is equal to ID."
--
2.34.0
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 15/18] installer: Add error page when running external commands.
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
` (13 preceding siblings ...)
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 14/18] installer: Use named prompt to abort or break installer steps Josselin Poiret via Guix-patches via
@ 2022-01-15 13:50 ` Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 16/18] installer: Use dynamic-wind to setup installer Josselin Poiret via Guix-patches via
` (3 subsequent siblings)
18 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:50 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
* gnu/installer/newt.scm (newt-run-command): Add it.
* gnu/installer/newt/page.scm (%ok-button, %exit-button,
%default-buttons, make-newt-buttons, run-textbox-page): Add them.
---
gnu/installer/newt.scm | 54 +++++++++++++++++++++---
gnu/installer/newt/page.scm | 83 +++++++++++++++++++++++++++++++++++++
2 files changed, 132 insertions(+), 5 deletions(-)
diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm
index fc851339d1..352d2997bd 100644
--- a/gnu/installer/newt.scm
+++ b/gnu/installer/newt.scm
@@ -41,6 +41,8 @@ (define-module (gnu installer newt)
#:use-module (guix discovery)
#:use-module (guix i18n)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (newt)
#:export (newt-installer))
@@ -80,11 +82,53 @@ (define (exit-error file report key args)
(clear-screen))
(define (newt-run-command . args)
- (newt-suspend)
- (clear-screen)
- (define result (run-command args))
- (newt-resume)
- result)
+ (define command-output "")
+ (define (line-accumulator line)
+ (set! command-output
+ (string-append/shared command-output line "\n")))
+ (define displayed-command
+ (string-join
+ (map (lambda (s) (string-append "\"" s "\"")) args)
+ " "))
+ (define result (run-external-command-with-line-hooks (list line-accumulator)
+ args))
+ (define exit-val (status:exit-val result))
+ (define term-sig (status:term-sig result))
+ (define stop-sig (status:stop-sig result))
+
+ (if (and exit-val (zero? exit-val))
+ #t
+ (let ((info-text
+ (cond
+ (exit-val
+ (format #f (G_ "External command ~s exited with code ~a")
+ args exit-val))
+ (term-sig
+ (format #f (G_ "External command ~s terminated by signal ~a")
+ args term-sig))
+ (stop-sig
+ (format #f (G_ "External command ~s stopped by signal ~a")
+ args stop-sig)))))
+ (run-textbox-page #:title (G_ "External command error")
+ #:info-text info-text
+ #:content command-output
+ #:buttons-spec
+ (list
+ (cons "Ignore" (const #t))
+ (cons "Abort"
+ (lambda ()
+ (abort-to-prompt 'installer-step 'abort)))
+ (cons "Dump"
+ (lambda ()
+ (raise
+ (condition
+ ((@@ (guix build utils)
+ &invoke-error)
+ (program (car args))
+ (arguments (cdr args))
+ (exit-status exit-val)
+ (term-signal term-sig)
+ (stop-signal stop-sig)))))))))))
(define (final-page result prev-steps)
(run-final-page result prev-steps))
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index 8c675fa837..b5d7c98094 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -44,6 +44,9 @@ (define-module (gnu installer newt page)
run-scale-page
run-checkbox-tree-page
run-file-textbox-page
+ %ok-button
+ %exit-button
+ run-textbox-page
run-form-with-clients))
@@ -816,3 +819,83 @@ (define result
(components=? argument edit-button))
(loop) ;recurse in tail position
result)))))
+
+(define %ok-button
+ (cons (G_ "Ok") (lambda () #t)))
+
+(define %exit-button
+ (cons (G_ "Exit") (lambda () (abort-to-prompt 'installer-step 'abort))))
+
+(define %default-buttons
+ (list %ok-button %exit-button))
+
+(define (make-newt-buttons buttons-spec)
+ (map
+ (match-lambda ((title . proc)
+ (cons (make-button -1 -1 title) proc)))
+ buttons-spec))
+
+(define* (run-textbox-page #:key
+ title
+ info-text
+ content
+ (buttons-spec %default-buttons))
+ "Run a page to display INFO-TEXT followed by CONTENT to the user, who has to
+choose an action among the buttons specified by BUTTONS-SPEC.
+
+BUTTONS-SPEC is an association list with button labels as keys, and callback
+procedures as values.
+
+This procedure returns the result of the callback procedure of the button
+chosen by the user."
+ (define info-textbox
+ (make-reflowed-textbox -1 -1 info-text
+ 50
+ #:flags FLAG-BORDER))
+ (define content-textbox
+ (make-textbox -1 -1
+ 50
+ 30
+ (logior FLAG-SCROLL FLAG-BORDER)))
+ (define buttons
+ (make-newt-buttons buttons-spec))
+ (define grid
+ (vertically-stacked-grid
+ GRID-ELEMENT-COMPONENT info-textbox
+ GRID-ELEMENT-COMPONENT content-textbox
+ GRID-ELEMENT-SUBGRID
+ (apply
+ horizontal-stacked-grid
+ (append-map (match-lambda ((button . proc)
+ (list GRID-ELEMENT-COMPONENT button)))
+ buttons))))
+ (define form (make-form #:flags FLAG-NOF12))
+ (add-form-to-grid grid form #t)
+ (make-wrapped-grid-window grid title)
+ (set-textbox-text content-textbox
+ (receive (_w _h text)
+ (reflow-text content
+ 50
+ 0 0)
+ text))
+
+ (receive (exit-reason argument)
+ (run-form-with-clients form
+ `(contents-dialog (title ,title)
+ (text ,info-text)
+ (content ,content)))
+ (destroy-form-and-pop form)
+ (match exit-reason
+ ('exit-component
+ (let ((proc (assq-ref buttons argument)))
+ (if proc
+ (proc)
+ (raise
+ (condition
+ (&serious)
+ (&message
+ (message (format #f "Unable to find corresponding PROC for \
+component ~a." argument))))))))
+ ;; TODO
+ ('exit-fd-ready
+ (raise (condition (&serious)))))))
--
2.34.0
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 16/18] installer: Use dynamic-wind to setup installer.
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
` (14 preceding siblings ...)
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 15/18] installer: Add error page when running external commands Josselin Poiret via Guix-patches via
@ 2022-01-15 13:50 ` Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 17/18] installer: Turn passwords into opaque records Josselin Poiret via Guix-patches via
` (2 subsequent siblings)
18 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:50 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
* 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(-)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 17/18] installer: Turn passwords into opaque records.
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
` (15 preceding siblings ...)
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 16/18] installer: Use dynamic-wind to setup installer Josselin Poiret via Guix-patches via
@ 2022-01-15 13:50 ` Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 18/18] installer: Make dump archive creation optional and selective Josselin Poiret via Guix-patches via
2022-01-17 10:16 ` [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Mathieu Othacehe
18 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:50 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
* 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(-)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH v2 wip-harden-installer 18/18] installer: Make dump archive creation optional and selective.
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
` (16 preceding siblings ...)
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 17/18] installer: Turn passwords into opaque records Josselin Poiret via Guix-patches via
@ 2022-01-15 13:50 ` Josselin Poiret via Guix-patches via
2022-01-17 10:16 ` [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Mathieu Othacehe
18 siblings, 0 replies; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-15 13:50 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: 53063, ludo, Josselin Poiret
* 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
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))
\f
;;;
@@ -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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
` (17 preceding siblings ...)
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 18/18] installer: Make dump archive creation optional and selective Josselin Poiret via Guix-patches via
@ 2022-01-17 10:16 ` Mathieu Othacehe
2022-01-31 17:45 ` [bug#53063] [PATCH] installer: Use system-wide guix for system init Josselin Poiret via Guix-patches via
18 siblings, 1 reply; 40+ messages in thread
From: Mathieu Othacehe @ 2022-01-17 10:16 UTC (permalink / raw)
To: Josselin Poiret; +Cc: 53063, ludo
Hey Josselin,
Great work!
> 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.
> 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:
--8<---------------cut here---------------start------------->8---
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* [bug#53063] [PATCH] installer: Use system-wide guix for system init.
2022-01-17 10:16 ` [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Mathieu Othacehe
@ 2022-01-31 17:45 ` Josselin Poiret via Guix-patches via
2022-02-02 15:50 ` bug#53063: " Mathieu Othacehe
0 siblings, 1 reply; 40+ messages in thread
From: Josselin Poiret via Guix-patches via @ 2022-01-31 17:45 UTC (permalink / raw)
To: Mathieu Othacehe; +Cc: Josselin Poiret, ludo, 53063
* 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(-)
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
^ permalink raw reply related [flat|nested] 40+ messages in thread
* bug#53063: [PATCH] installer: Use system-wide guix for system init.
2022-01-31 17:45 ` [bug#53063] [PATCH] installer: Use system-wide guix for system init Josselin Poiret via Guix-patches via
@ 2022-02-02 15:50 ` Mathieu Othacehe
0 siblings, 0 replies; 40+ messages in thread
From: Mathieu Othacehe @ 2022-02-02 15:50 UTC (permalink / raw)
To: Josselin Poiret; +Cc: 53063-done, ludo
Hey Josselin,
> 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
^ permalink raw reply [flat|nested] 40+ messages in thread
end of thread, other threads:[~2022-02-02 17:57 UTC | newest]
Thread overview: 40+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-01-06 22:45 [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Josselin Poiret via Guix-patches via
2022-01-06 22:47 ` [bug#53063] [PATCH wip-harden-installer 01/14] installer: Use define instead of let at top-level Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 02/14] installer: Generalize logging facility Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 03/14] installer: Use new installer-log-line everywhere Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 04/14] installer: Un-export syslog syntax Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 05/14] installer: Capture external commands output Josselin Poiret via Guix-patches via
2022-01-07 13:47 ` [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Ludovic Courtès
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 06/14] installer: Disable automatic finalization for child thread Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 07/14] installer: Add installer-specific run command process Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 08/14] installer: Use run-command-in-installer in (gnu installer parted) Josselin Poiret via Guix-patches via
2022-01-07 10:58 ` Mathieu Othacehe
2022-01-07 11:46 ` Josselin Poiret via Guix-patches via
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Josselin Poiret via Guix-patches via
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 01/18] installer: Use define instead of let at top-level Josselin Poiret via Guix-patches via
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 02/18] installer: Generalize logging facility Josselin Poiret via Guix-patches via
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 03/18] installer: Use new installer-log-line everywhere Josselin Poiret via Guix-patches via
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 04/18] installer: Un-export syslog syntax Josselin Poiret via Guix-patches via
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 05/18] installer: Keep PATH inside the install container Josselin Poiret via Guix-patches via
2022-01-15 13:49 ` [bug#53063] [PATCH v2 wip-harden-installer 06/18] installer: Remove specific logging code Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 07/18] installer: Capture external commands output Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 08/18] installer: Add installer-specific run command process Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 09/18] installer: Use run-command-in-installer in (gnu installer parted) Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 10/18] installer: Raise condition when mklabel fails Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 11/18] installer: Fix run-file-textbox-page when edit-button is #f Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 12/18] installer: Replace run-command by invoke in newt/page.scm Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 13/18] installer: Add nano to PATH Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 14/18] installer: Use named prompt to abort or break installer steps Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 15/18] installer: Add error page when running external commands Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 16/18] installer: Use dynamic-wind to setup installer Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 17/18] installer: Turn passwords into opaque records Josselin Poiret via Guix-patches via
2022-01-15 13:50 ` [bug#53063] [PATCH v2 wip-harden-installer 18/18] installer: Make dump archive creation optional and selective Josselin Poiret via Guix-patches via
2022-01-17 10:16 ` [bug#53063] [PATCH wip-harden-installer 00/14] General improvements to the installer Mathieu Othacehe
2022-01-31 17:45 ` [bug#53063] [PATCH] installer: Use system-wide guix for system init Josselin Poiret via Guix-patches via
2022-02-02 15:50 ` bug#53063: " Mathieu Othacehe
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 09/14] installer: Use the command capturing facility for guix init Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 10/14] installer: Raise condition when mklabel fails Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 11/14] installer: Fix run-file-textbox-page when edit-button is #f Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 12/14] installer: Replace run-command by invoke in newt/page.scm Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 13/14] installer: Use named prompt to abort or break installer steps Josselin Poiret via Guix-patches via
2022-01-06 22:48 ` [bug#53063] [PATCH wip-harden-installer 14/14] installer: Add confirmation page when running external commands Josselin Poiret via Guix-patches via
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.