diff options
Diffstat (limited to 'gnu/installer')
| -rw-r--r-- | gnu/installer/newt.scm | 54 | ||||
| -rw-r--r-- | 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 @@ #: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)) 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 @@ 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))))))) |