3
5
Fork 0
mirror of git://git.savannah.gnu.org/guix.git synced 2023-12-14 03:33:07 +01:00

installer: Add error page when running external commands.

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

Signed-off-by: Mathieu Othacehe <othacehe@gnu.org>
This commit is contained in:
Josselin Poiret 2022-01-15 14:50:08 +01:00 committed by Mathieu Othacehe
parent 726d0bd2f3
commit 7cbd95a9f6
No known key found for this signature in database
GPG key ID: 8354763531769CA6
2 changed files with 132 additions and 5 deletions

View file

@ -41,6 +41,8 @@
#: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 @@ problem. The backtrace is displayed below~a. Please report it by email to \
(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))

View file

@ -44,6 +44,9 @@
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 @@ ITEMS when 'Ok' is pressed."
(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)))))))