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.
View this message in rfc822 format
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: [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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.