guix
/
guix
mirror of git://git.savannah.gnu.org/guix.git
3
4
Fork 0
Code Issues Releases Wiki Activity

installer: Make dump archive creation optional and selective. 

* 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.

Signed-off-by: Mathieu Othacehe <othacehe@gnu.org>
This commit is contained in:
Josselin Poiret 2022-01-15 14:50:11 +01:00 committed by Mathieu Othacehe
parent 112ef30b84
commit ad55ccf9b1
No known key found for this signature in database
GPG Key ID: 8354763531769CA6
7 changed files with 187 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
gnu/installer.scm
View File

@ -386,7 +386,8 @@ selected keymap."
(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 @@ selected keymap."
(define current-installer newt-installer)
(define steps (#$steps current-installer))
(dynamic-wind
(installer-init current-installer)
(lambda ()
@ -436,30 +438,31 @@ selected keymap."
(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)
(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))))))

69
gnu/installer/dump.scm
View File

@ -28,7 +28,8 @@
#: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 @@
(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"
;; installer result
(call-with-output-file "installer-result"
(lambda (port)
(write (result->list result) port)))
;; syslog
(copy-file "/var/log/messages" "syslog")
;; dmesg
(let ((pipe (open-pipe* OPEN_READ "dmesg")))
(call-with-output-file "dmesg"
(lambda (port)
(write (result->list result) port)))
(dump-port pipe port)
(close-pipe pipe)))))
dump-dir)
;; 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)))))
(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

76
gnu/installer/newt.scm
View File

@ -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,12 @@
#: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 (ice-9 match)
#:use-module (newt)
#:export (newt-installer))
@ -58,28 +61,53 @@
(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_ "Dump") (const 'dump))
(cons (G_ "Exit") (const 'exit)))))
(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 (match-lambda*
(((file . enable?) acc)
(if enable?
(cons file acc)
acc)))
'()
(run-dump-page
dump-dir
(map (lambda (x)
(cons x #f))
files))))
(define (newt-run-command . args)
(define command-output "")
@ -118,7 +146,7 @@ problem. The backtrace is displayed below~a. Please report it by email to \
(cons "Abort"
(lambda ()
(abort-to-prompt 'installer-step 'abort)))
(cons "Dump"
(cons "Report"
(lambda ()
(raise
(condition
@ -178,9 +206,6 @@ problem. The backtrace is displayed below~a. Please report it by email to \
(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 +227,5 @@ problem. The backtrace is displayed below~a. Please report it by email to \
(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)))

36
gnu/installer/newt/dump.scm
View File

@ -1,36 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu installer newt dump)
#:use-module (gnu installer dump)
#:use-module (gnu installer newt page)
#:use-module (guix i18n)
#:use-module (newt)
#:export (run-dump-page))
(define (run-dump-page dump)
"Run a dump page, proposing the user to upload the crash dump to Guix
servers."
(case (choice-window
(G_ "Crash dump upload")
(G_ "Yes")
(G_ "No")
(G_ "The installer failed. Do you accept to upload the crash dump \
to Guix servers, so that we can investigate the issue?"))
((1) (send-dump-report dump))
((2) #f)))

65
gnu/installer/newt/page.scm
View File

@ -47,6 +47,7 @@
%ok-button
%exit-button
run-textbox-page
run-dump-page
run-form-with-clients))
@ -899,3 +900,67 @@ component ~a." argument))))))))
;; 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-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
(vertically-stacked-grid
GRID-ELEMENT-COMPONENT info-textbox
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)
(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)))))

9
gnu/installer/record.scm
View File

@ -43,7 +43,8 @@
installer-parameters-menu
installer-parameters-page
installer-dump-page
installer-run-command))
installer-run-command
installer-report-page))
;;;
@ -63,7 +64,7 @@
(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 @@
;; 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))

1
gnu/local.mk
View File

@ -775,7 +775,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 \