Package: guix-patches;
Reported by: Josselin Poiret <dev <at> jpoiret.xyz>
Date: Thu, 6 Jan 2022 22:47:01 UTC
Severity: normal
Tags: patch
Done: Mathieu Othacehe <othacehe <at> gnu.org>
Bug is archived. No further changes may be made.
To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 53063 in the body.
You can then email your comments to 53063 AT debbugs.gnu.org in the normal way.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Thu, 06 Jan 2022 22:47:01 GMT) Full text and rfc822 format available.Josselin Poiret <dev <at> jpoiret.xyz>:guix-patches <at> gnu.org.
(Thu, 06 Jan 2022 22:47:01 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: guix-patches <at> gnu.org Cc: Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH wip-harden-installer 00/14] General improvements to the installer Date: Thu, 6 Jan 2022 23:45:45 +0100
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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Thu, 06 Jan 2022 22:49:02 GMT) Full text and rfc822 format available.Message #8 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: 53063 <at> debbugs.gnu.org Cc: Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH wip-harden-installer 01/14] installer: Use define instead of let at top-level. Date: Thu, 6 Jan 2022 23:47:59 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Thu, 06 Jan 2022 22:49:02 GMT) Full text and rfc822 format available.Message #11 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: 53063 <at> debbugs.gnu.org Cc: Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH wip-harden-installer 02/14] installer: Generalize logging facility. Date: Thu, 6 Jan 2022 23:48:00 +0100
* 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))))))
+
;;;
;;; Client protocol.
--
2.34.0
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Thu, 06 Jan 2022 22:49:03 GMT) Full text and rfc822 format available.Message #14 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: 53063 <at> debbugs.gnu.org Cc: Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH wip-harden-installer 03/14] installer: Use new installer-log-line everywhere. Date: Thu, 6 Jan 2022 23:48:01 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Thu, 06 Jan 2022 22:49:03 GMT) Full text and rfc822 format available.Message #17 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: 53063 <at> debbugs.gnu.org Cc: Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH wip-harden-installer 04/14] installer: Un-export syslog syntax. Date: Thu, 6 Jan 2022 23:48:02 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Thu, 06 Jan 2022 22:49:04 GMT) Full text and rfc822 format available.Message #20 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: 53063 <at> debbugs.gnu.org Cc: Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH wip-harden-installer 05/14] installer: Capture external commands output. Date: Thu, 6 Jan 2022 23:48:03 +0100
* 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?)
;;;
--
2.34.0
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Thu, 06 Jan 2022 22:49:04 GMT) Full text and rfc822 format available.Message #23 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: 53063 <at> debbugs.gnu.org Cc: Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH wip-harden-installer 06/14] installer: Disable automatic finalization for child thread. Date: Thu, 6 Jan 2022 23:48:04 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Thu, 06 Jan 2022 22:49:04 GMT) Full text and rfc822 format available.Message #26 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: 53063 <at> debbugs.gnu.org Cc: Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH wip-harden-installer 07/14] installer: Add installer-specific run command process. Date: Thu, 6 Jan 2022 23:48:05 +0100
* 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))
;;;
@@ -94,4 +95,6 @@ (define-record-type* <installer>
;; procedure (keyboard-layout-selection) -> void
(parameters-page installer-parameters-page)
;; procedure (dump) -> void
- (dump-page installer-dump-page))
+ (dump-page installer-dump-page)
+ ;; procedure command -> bool
+ (run-command installer-run-command))
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index ad220492d9..b148fc2a81 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -25,6 +25,7 @@ (define-module (gnu installer utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (ice-9 control)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
@@ -39,6 +40,7 @@ (define-module (gnu installer utils)
nearest-exact-integer
read-percentage
run-command
+ run-command-in-installer
syslog-port
%syslog-line-hook
@@ -234,6 +236,14 @@ (define succeeded?
(pause)
succeeded?)
+(define run-command-in-installer
+ (make-parameter
+ (lambda (. args)
+ (raise
+ (condition
+ (&serious)
+ (&message (message "run-command-in-installer not set")))))))
+
;;;
;;; Logging.
--
2.34.0
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Thu, 06 Jan 2022 22:49:05 GMT) Full text and rfc822 format available.Message #29 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: 53063 <at> debbugs.gnu.org Cc: Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH wip-harden-installer 08/14] installer: Use run-command-in-installer in (gnu installer parted). Date: Thu, 6 Jan 2022 23:48:06 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Thu, 06 Jan 2022 22:49:05 GMT) Full text and rfc822 format available.Message #32 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: 53063 <at> debbugs.gnu.org Cc: Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH wip-harden-installer 10/14] installer: Raise condition when mklabel fails. Date: Thu, 6 Jan 2022 23:48:08 +0100
* 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))))))))) ;; -- 2.34.0
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Thu, 06 Jan 2022 22:49:05 GMT) Full text and rfc822 format available.Message #35 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: 53063 <at> debbugs.gnu.org Cc: Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH wip-harden-installer 09/14] installer: Use the command capturing facility for guix init. Date: Thu, 6 Jan 2022 23:48:07 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Thu, 06 Jan 2022 22:49:06 GMT) Full text and rfc822 format available.Message #38 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: 53063 <at> debbugs.gnu.org Cc: Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH wip-harden-installer 11/14] installer: Fix run-file-textbox-page when edit-button is #f. Date: Thu, 6 Jan 2022 23:48:09 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Thu, 06 Jan 2022 22:49:06 GMT) Full text and rfc822 format available.Message #41 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: 53063 <at> debbugs.gnu.org Cc: Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH wip-harden-installer 12/14] installer: Replace run-command by invoke in newt/page.scm. Date: Thu, 6 Jan 2022 23:48:10 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Thu, 06 Jan 2022 22:49:07 GMT) Full text and rfc822 format available.Message #44 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: 53063 <at> debbugs.gnu.org Cc: Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH wip-harden-installer 14/14] installer: Add confirmation page when running external commands. Date: Thu, 6 Jan 2022 23:48:12 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Thu, 06 Jan 2022 22:49:07 GMT) Full text and rfc822 format available.Message #47 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: 53063 <at> debbugs.gnu.org Cc: Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH wip-harden-installer 13/14] installer: Use named prompt to abort or break installer steps. Date: Thu, 6 Jan 2022 23:48:11 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Fri, 07 Jan 2022 10:59:02 GMT) Full text and rfc822 format available.Message #50 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Mathieu Othacehe <othacehe <at> gnu.org> To: Josselin Poiret via Guix-patches via <guix-patches <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: Re: [bug#53063] [PATCH wip-harden-installer 08/14] installer: Use run-command-in-installer in (gnu installer parted). Date: Fri, 07 Jan 2022 11:58:40 +0100
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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Fri, 07 Jan 2022 10:59:02 GMT) Full text and rfc822 format available.guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Fri, 07 Jan 2022 11:47:02 GMT) Full text and rfc822 format available.Message #56 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org>, Josselin Poiret via Guix-patches via <guix-patches <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org Subject: Re: [bug#53063] [PATCH wip-harden-installer 08/14] installer: Use run-command-in-installer in (gnu installer parted). Date: Fri, 07 Jan 2022 12:46:34 +0100
Hello Mathieu, Mathieu Othacehe <othacehe <at> 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Fri, 07 Jan 2022 11:47:02 GMT) Full text and rfc822 format available.guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Fri, 07 Jan 2022 13:48:01 GMT) Full text and rfc822 format available.Message #62 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: Josselin Poiret <dev <at> jpoiret.xyz> Cc: 53063 <at> debbugs.gnu.org Subject: Re: bug#53063: [PATCH wip-harden-installer 00/14] General improvements to the installer Date: Fri, 07 Jan 2022 14:47:28 +0100
Hello Josselin, Josselin Poiret <dev <at> 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’.
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:51:02 GMT) Full text and rfc822 format available.Message #65 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 00/18] General improvements to the installer Date: Sat, 15 Jan 2022 14:49:53 +0100
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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:51:02 GMT) Full text and rfc822 format available.Message #68 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 04/18] installer: Un-export syslog syntax. Date: Sat, 15 Jan 2022 14:49:57 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:51:03 GMT) Full text and rfc822 format available.Message #71 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 05/18] installer: Keep PATH inside the install container. Date: Sat, 15 Jan 2022 14:49:58 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:51:03 GMT) Full text and rfc822 format available.Message #74 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 02/18] installer: Generalize logging facility. Date: Sat, 15 Jan 2022 14:49:55 +0100
* 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))))))
+
;;;
;;; Client protocol.
--
2.34.0
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:51:04 GMT) Full text and rfc822 format available.Message #77 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 06/18] installer: Remove specific logging code. Date: Sat, 15 Jan 2022 14:49:59 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:51:04 GMT) Full text and rfc822 format available.Message #80 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 03/18] installer: Use new installer-log-line everywhere. Date: Sat, 15 Jan 2022 14:49:56 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:51:04 GMT) Full text and rfc822 format available.Message #83 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 07/18] installer: Capture external commands output. Date: Sat, 15 Jan 2022 14:50:00 +0100
* 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?)
;;;
--
2.34.0
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:51:05 GMT) Full text and rfc822 format available.Message #86 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 08/18] installer: Add installer-specific run command process. Date: Sat, 15 Jan 2022 14:50:01 +0100
* 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))
;;;
@@ -94,4 +95,6 @@ (define-record-type* <installer>
;; procedure (keyboard-layout-selection) -> void
(parameters-page installer-parameters-page)
;; procedure (dump) -> void
- (dump-page installer-dump-page))
+ (dump-page installer-dump-page)
+ ;; procedure command -> bool
+ (run-command installer-run-command))
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 9cfff0054b..4f7c691690 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -25,6 +25,7 @@ (define-module (gnu installer utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (ice-9 control)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
@@ -39,6 +40,7 @@ (define-module (gnu installer utils)
run-external-command-with-handler
run-external-command-with-line-hooks
run-command
+ run-command-in-installer
syslog-port
%syslog-line-hook
@@ -167,6 +169,14 @@ (define succeeded?
(pause)
succeeded?)
+(define run-command-in-installer
+ (make-parameter
+ (lambda (. args)
+ (raise
+ (condition
+ (&serious)
+ (&message (message "run-command-in-installer not set")))))))
+
;;;
;;; Logging.
--
2.34.0
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:51:05 GMT) Full text and rfc822 format available.Message #89 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 09/18] installer: Use run-command-in-installer in (gnu installer parted). Date: Sat, 15 Jan 2022 14:50:02 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:51:06 GMT) Full text and rfc822 format available.Message #92 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 10/18] installer: Raise condition when mklabel fails. Date: Sat, 15 Jan 2022 14:50:03 +0100
* 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))))))))) ;; -- 2.34.0
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:51:06 GMT) Full text and rfc822 format available.Message #95 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 11/18] installer: Fix run-file-textbox-page when edit-button is #f. Date: Sat, 15 Jan 2022 14:50:04 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:51:06 GMT) Full text and rfc822 format available.Message #98 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 12/18] installer: Replace run-command by invoke in newt/page.scm. Date: Sat, 15 Jan 2022 14:50:05 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:51:07 GMT) Full text and rfc822 format available.Message #101 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 13/18] installer: Add nano to PATH. Date: Sat, 15 Jan 2022 14:50:06 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:52:01 GMT) Full text and rfc822 format available.Message #104 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 14/18] installer: Use named prompt to abort or break installer steps. Date: Sat, 15 Jan 2022 14:50:07 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:52:02 GMT) Full text and rfc822 format available.Message #107 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 15/18] installer: Add error page when running external commands. Date: Sat, 15 Jan 2022 14:50:08 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:52:02 GMT) Full text and rfc822 format available.Message #110 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 01/18] installer: Use define instead of let at top-level. Date: Sat, 15 Jan 2022 14:49:54 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:52:02 GMT) Full text and rfc822 format available.Message #113 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 16/18] installer: Use dynamic-wind to setup installer. Date: Sat, 15 Jan 2022 14:50:09 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:52:03 GMT) Full text and rfc822 format available.Message #116 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 17/18] installer: Turn passwords into opaque records. Date: Sat, 15 Jan 2022 14:50:10 +0100
* 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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Sat, 15 Jan 2022 13:52:03 GMT) Full text and rfc822 format available.Message #119 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH v2 wip-harden-installer 18/18] installer: Make dump archive creation optional and selective. Date: Sat, 15 Jan 2022 14:50:11 +0100
* 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 <at> gnu.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (gnu installer newt dump)
- #:use-module (gnu installer dump)
- #:use-module (gnu installer newt page)
- #:use-module (guix i18n)
- #:use-module (newt)
- #:export (run-dump-page))
-
-(define (run-dump-page dump)
- "Run a dump page, proposing the user to upload the crash dump to Guix
-servers."
- (case (choice-window
- (G_ "Crash dump upload")
- (G_ "Yes")
- (G_ "No")
- (G_ "The installer failed. Do you accept to upload the crash dump \
-to Guix servers, so that we can investigate the issue?"))
- ((1) (send-dump-report dump))
- ((2) #f)))
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index b5d7c98094..060e633254 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -47,6 +47,7 @@ (define-module (gnu installer newt page)
%ok-button
%exit-button
run-textbox-page
+ run-dump-page
run-form-with-clients))
@@ -899,3 +900,60 @@ (define form (make-form #:flags FLAG-NOF12))
;; TODO
('exit-fd-ready
(raise (condition (&serious)))))))
+
+(define* (run-dump-page base-dir file-choices)
+ (define info-textbox
+ (make-reflowed-textbox -1 -1 "Please select files you wish to include in \
+the dump."
+ 50
+ #:flags FLAG-BORDER))
+ (define components
+ (map (match-lambda ((file . enabled)
+ (list
+ (make-button -1 -1 "Edit")
+ (make-checkbox -1 -1 file (if enabled #\x #\ ) " x")
+ file)))
+ file-choices))
+ (define grid
+ (apply vertically-stacked-grid
+ GRID-ELEMENT-COMPONENT info-textbox
+ (append
+ (append-map
+ (match-lambda ((button checkbox _)
+ (list GRID-ELEMENT-SUBGRID
+ (horizontal-stacked-grid
+ GRID-ELEMENT-COMPONENT checkbox
+ GRID-ELEMENT-COMPONENT button))))
+ components)
+ (list GRID-ELEMENT-COMPONENT (make-button -1 -1 "Create")))))
+ (define form (make-form #:flags FLAG-NOF12))
+
+ (add-form-to-grid grid form #t)
+ (make-wrapped-grid-window grid "Installer dump")
+
+ (define prompt-tag (make-prompt-tag))
+
+ (let loop ()
+ (call-with-prompt prompt-tag
+ (lambda ()
+ (receive (exit-reason argument)
+ (run-form-with-clients form
+ `(dump-page))
+ (match exit-reason
+ ('exit-component
+ (let ((result
+ (map (match-lambda
+ ((edit checkbox filename)
+ (if (components=? edit argument)
+ (abort-to-prompt prompt-tag filename)
+ (cons filename (eq? #\x
+ (checkbox-value checkbox))))))
+ components)))
+ (destroy-form-and-pop form)
+ result))
+ ;; TODO
+ ('exit-fd-ready
+ (raise (condition (&serious)))))))
+ (lambda (k file)
+ (edit-file (string-append base-dir "/" file))
+ (loop)))))
diff --git a/gnu/installer/record.scm b/gnu/installer/record.scm
index 23db3edd70..20519a26c3 100644
--- a/gnu/installer/record.scm
+++ b/gnu/installer/record.scm
@@ -43,7 +43,8 @@ (define-module (gnu installer record)
installer-parameters-menu
installer-parameters-page
installer-dump-page
- installer-run-command))
+ installer-run-command
+ installer-report-page))
;;;
@@ -63,7 +64,7 @@ (define-record-type* <installer>
(init installer-init)
;; procedure: void -> void
(exit installer-exit)
- ;; procedure (key arguments) -> void
+ ;; procedure (key arguments) -> (action)
(exit-error installer-exit-error)
;; procedure void -> void
(final-page installer-final-page)
@@ -97,4 +98,6 @@ (define-record-type* <installer>
;; procedure (dump) -> void
(dump-page installer-dump-page)
;; procedure command -> bool
- (run-command installer-run-command))
+ (run-command installer-run-command)
+ ;; procedure (report) -> void
+ (report-page installer-report-page))
diff --git a/gnu/local.mk b/gnu/local.mk
index a3818cdcbf..adb3d64e29 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -773,7 +773,6 @@ INSTALLER_MODULES = \
%D%/installer/user.scm \
%D%/installer/utils.scm \
\
- %D%/installer/newt/dump.scm \
%D%/installer/newt/ethernet.scm \
%D%/installer/newt/final.scm \
%D%/installer/newt/parameters.scm \
--
2.34.0
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Mon, 17 Jan 2022 10:18:02 GMT) Full text and rfc822 format available.Message #122 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Mathieu Othacehe <othacehe <at> gnu.org> To: Josselin Poiret <dev <at> jpoiret.xyz> Cc: 53063 <at> debbugs.gnu.org, ludo <at> gnu.org Subject: Re: bug#53063: [PATCH wip-harden-installer 00/14] General improvements to the installer Date: Mon, 17 Jan 2022 11:16:56 +0100
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
guix-patches <at> gnu.org:bug#53063; Package guix-patches.
(Mon, 31 Jan 2022 17:46:02 GMT) Full text and rfc822 format available.Message #125 received at 53063 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: Josselin Poiret <dev <at> jpoiret.xyz>, ludo <at> gnu.org, 53063 <at> debbugs.gnu.org Subject: [PATCH] installer: Use system-wide guix for system init. Date: Mon, 31 Jan 2022 18:45:17 +0100
* 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
Mathieu Othacehe <othacehe <at> gnu.org>:Josselin Poiret <dev <at> jpoiret.xyz>:Message #130 received at 53063-done <at> debbugs.gnu.org (full text, mbox):
From: Mathieu Othacehe <othacehe <at> gnu.org> To: Josselin Poiret <dev <at> jpoiret.xyz> Cc: 53063-done <at> debbugs.gnu.org, ludo <at> gnu.org Subject: Re: [PATCH] installer: Use system-wide guix for system init. Date: Wed, 02 Feb 2022 16:50:25 +0100
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
Debbugs Internal Request <help-debbugs <at> gnu.org>
to internal_control <at> debbugs.gnu.org.
(Thu, 03 Mar 2022 12:24:12 GMT) Full text and rfc822 format available.
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.