summaryrefslogtreecommitdiff
path: root/gnu/installer
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/installer')
-rw-r--r--gnu/installer/connman.scm2
-rw-r--r--gnu/installer/dump.scm118
-rw-r--r--gnu/installer/final.scm25
-rw-r--r--gnu/installer/newt.scm122
-rw-r--r--gnu/installer/newt/ethernet.scm8
-rw-r--r--gnu/installer/newt/final.scm12
-rw-r--r--gnu/installer/newt/keymap.scm8
-rw-r--r--gnu/installer/newt/locale.scm25
-rw-r--r--gnu/installer/newt/network.scm16
-rw-r--r--gnu/installer/newt/page.scm170
-rw-r--r--gnu/installer/newt/partition.scm10
-rw-r--r--gnu/installer/newt/services.scm16
-rw-r--r--gnu/installer/newt/timezone.scm4
-rw-r--r--gnu/installer/newt/user.scm11
-rw-r--r--gnu/installer/newt/welcome.scm2
-rw-r--r--gnu/installer/newt/wifi.scm4
-rw-r--r--gnu/installer/parted.scm106
-rw-r--r--gnu/installer/record.scm15
-rw-r--r--gnu/installer/steps.scm130
-rw-r--r--gnu/installer/user.scm19
-rw-r--r--gnu/installer/utils.scm159
21 files changed, 701 insertions, 281 deletions
diff --git a/gnu/installer/connman.scm b/gnu/installer/connman.scm
index 2f33b58453..d21272036f 100644
--- a/gnu/installer/connman.scm
+++ b/gnu/installer/connman.scm
@@ -287,7 +287,7 @@ list so that each keys of a given technology are gathered in a separate list."
(define (connman-online?)
(let ((state (connman-state)))
- (eq? state 'online)))
+ (memq state '(ready online))))
(define (connman-connect-with-auth service password-proc)
"Connect to the given SERVICE with the password returned by calling
diff --git a/gnu/installer/dump.scm b/gnu/installer/dump.scm
new file mode 100644
index 0000000000..daa02f205a
--- /dev/null
+++ b/gnu/installer/dump.scm
@@ -0,0 +1,118 @@
+;;; 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 dump)
+ #:use-module (gnu installer utils)
+ #:use-module (guix build utils)
+ #:use-module (srfi srfi-11)
+ #:use-module (ice-9 iconv)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 textual-ports)
+ #:use-module (web client)
+ #:use-module (web http)
+ #:use-module (web response)
+ #:use-module (webutils multipart)
+ #:export (prepare-dump
+ make-dump
+ send-dump-report))
+
+;; The installer crash dump type.
+(define %dump-type "installer-dump")
+
+(define (result->list result)
+ "Return the alist for the given RESULT."
+ (hash-map->list (lambda (k v)
+ (cons k v))
+ result))
+
+(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)))
+
+ ;; 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)))))
+ 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
+ (url "https://dump.guix.gnu.org"))
+ "Turn the DUMP archive into a multipart body and send it to the Guix crash
+dump server at URL."
+ (define (match-boundary kont)
+ (match-lambda
+ (('boundary . (? string? b))
+ (kont b))
+ (x #f)))
+
+ (define (response->string response)
+ (bytevector->string
+ (read-response-body response)
+ "UTF-8"))
+
+ (let-values (((body boundary)
+ (call-with-input-file dump
+ (lambda (port)
+ (format-multipart-body
+ `((,%dump-type . ,port)))))))
+ (false-if-exception
+ (response->string
+ (http-post
+ (string-append url "/upload")
+ #:keep-alive? #t
+ #:streaming? #t
+ #:headers `((content-type
+ . (multipart/form-data
+ (boundary . ,boundary))))
+ #:body body)))))
diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm
index 276af908f7..3f6dacc490 100644
--- a/gnu/installer/final.scm
+++ b/gnu/installer/final.scm
@@ -85,8 +85,9 @@ USERS."
(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.
@@ -125,15 +126,15 @@ it can interact with the rest of the system."
(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"
@@ -208,17 +209,9 @@ or #f. Return #t on success and #f on failure."
(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" "/run/current-system/profile/bin/")
+
+ (set! ret (run-command install-command)))
(lambda ()
;; Restart guix-daemon so that it does no keep the MNT namespace
;; alive.
diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm
index 4f7fc6f4dc..1db78e6f0d 100644
--- a/gnu/installer/newt.scm
+++ b/gnu/installer/newt.scm
@@ -19,6 +19,7 @@
(define-module (gnu installer newt)
#:use-module (gnu installer record)
#:use-module (gnu installer utils)
+ #:use-module (gnu installer dump)
#:use-module (gnu installer newt ethernet)
#:use-module (gnu installer newt final)
#:use-module (gnu installer newt parameters)
@@ -39,7 +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))
@@ -47,7 +53,7 @@
(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."))))
@@ -55,25 +61,102 @@
(newt-finish)
(clear-screen))
-(define (exit-error file 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))))
- (run-file-textbox-page
- #:info-text (format #f (G_ "The installer has encountered an unexpected \
-problem. The backtrace is displayed below. Please report it by email to \
-<~a>.") %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 "")
+ (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 "Report"
+ (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))
@@ -142,4 +225,7 @@ problem. The backtrace is displayed below. Please report it by email to \
(services-page services-page)
(welcome-page welcome-page)
(parameters-menu parameters-menu)
- (parameters-page parameters-page)))
+ (parameters-page parameters-page)
+ (dump-page dump-page)
+ (run-command newt-run-command)
+ (report-page report-page)))
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 @@ connection is pending."
(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 @@ connection is pending."
#: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 7f6dd9f075..7c3f73ee82 100644
--- a/gnu/installer/newt/final.scm
+++ b/gnu/installer/newt/final.scm
@@ -59,9 +59,7 @@ This will take a few minutes.")
#: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 @@ press the button to reboot.")))
(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)))
@@ -109,7 +105,7 @@ a specific step, or restart the installer."))
(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 +115,7 @@ a specific step, or restart the installer."))
;; 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/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 @@ different layout at any time from the parameters menu.")))
((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 @@ different layout at any time from the parameters menu.")))
#: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 @@ installation process and for the installed system.")
#: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 @@ installation process and for the installed system.")
#: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 @@ installation process and for the installed system.")
#: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 @@ symbol.")
#: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 @@ associating a territory code with a territory name. The formatted locale, under
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 @@ glibc locale string and return it."
;; 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 @@ Internet and return the selected technology. For now, only technologies with
(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 @@ network devices were found. Do you want to continue anyway?"))
#: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 @@ FULL-VALUE tentatives, spaced by 1 second."
(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 4209674c28..0f508a31c0 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -22,6 +22,7 @@
#: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)
@@ -43,6 +44,10 @@
run-scale-page
run-checkbox-tree-page
run-file-textbox-page
+ %ok-button
+ %exit-button
+ run-textbox-page
+ run-dump-page
run-form-with-clients))
@@ -93,9 +98,9 @@ disconnect.
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 +129,7 @@ Like 'run-form', return two values: the exit reason, and an \"argument\"."
(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 +151,7 @@ Like 'run-form', return two values: the exit reason, and an \"argument\"."
(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 +161,9 @@ Like 'run-form', return two values: the exit reason, and an \"argument\"."
;; 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)
@@ -486,7 +492,7 @@ the current listbox item has to be selected by key."
(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,
@@ -688,7 +694,7 @@ ITEMS when 'Ok' is pressed."
(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)
@@ -726,8 +732,7 @@ ITEMS when 'Ok' is pressed."
(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
@@ -811,6 +816,151 @@ ITEMS when 'Ok' is pressed."
(destroy-form-and-pop form))))
(if (and (eq? exit-reason 'exit-component)
+ edit-button
(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)))))))
+
+(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)))))
diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm
index ccc7686906..e7a97810ac 100644
--- a/gnu/installer/newt/partition.scm
+++ b/gnu/installer/newt/partition.scm
@@ -36,10 +36,8 @@
#: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."
@@ -801,9 +799,9 @@ by pressing the Exit button.~%~%")))
;; 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/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 @@ to choose from them later when you log in.")
#: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 @@ system.")
#: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 @@ system.")
#: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 @@ client may be enough for a server.")
#: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 @@ returned."
#: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..7c1cc2249d 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)
@@ -144,7 +143,7 @@ REAL-NAME, and HOME-DIRECTORY as the initial values in the form."
(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
@@ -257,9 +256,7 @@ administrator (\"root\").")
(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
@@ -269,7 +266,7 @@ administrator (\"root\").")
(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))))))
@@ -277,5 +274,5 @@ administrator (\"root\").")
;; 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/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 @@ we want this page to occupy all the screen space available."
(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 @@ force a wifi scan."
(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/parted.scm b/gnu/installer/parted.scm
index 66e07574c9..94ef9b42bc 100644
--- a/gnu/installer/parted.scm
+++ b/gnu/installer/parted.scm
@@ -343,13 +343,12 @@ fail. See rereadpt function in wipefs.c of util-linux for an explanation."
(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."
(let* ((cmdline (linux-command-line))
- (root (find-long-option "--root" cmdline)))
+ (root (find-long-option "root" cmdline)))
(and root
(or (and (access? root F_OK) root)
(find-partition-by-label root)
@@ -371,7 +370,8 @@ which are smaller than %MIN-DEVICE-SIZE."
(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 +391,8 @@ which are smaller than %MIN-DEVICE-SIZE."
(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
@@ -634,8 +635,14 @@ determined by MAX-LENGTH-COLUMN procedure."
(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)))))))))
;;
@@ -817,24 +824,22 @@ cause them to cross."
(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))
@@ -1115,53 +1120,37 @@ list and return the updated list."
(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."
@@ -1188,17 +1177,18 @@ USER-PARTITION if it is encrypted, or the plain file-name otherwise."
(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"
- "--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)))
- (syslog "closing LUKS entry ~s~%" label)
- (system* "cryptsetup" "close" label)))
+ (installer-log-line "closing LUKS entry ~s" label)
+ ((run-command-in-installer) "cryptsetup" "close" label)))
(define (format-user-partitions user-partitions)
"Format the <user-partition> records in USER-PARTITIONS list with
@@ -1279,7 +1269,7 @@ respective mount-points."
(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 +1285,7 @@ respective mount-points."
(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 +1476,6 @@ the devices not to be used before returning."
(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/record.scm b/gnu/installer/record.scm
index 0b34318c45..20519a26c3 100644
--- a/gnu/installer/record.scm
+++ b/gnu/installer/record.scm
@@ -41,7 +41,10 @@
installer-services-page
installer-welcome-page
installer-parameters-menu
- installer-parameters-page))
+ installer-parameters-page
+ installer-dump-page
+ installer-run-command
+ installer-report-page))
;;;
@@ -61,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)
@@ -91,4 +94,10 @@
;; procedure (menu-proc) -> void
(parameters-menu installer-parameters-menu)
;; procedure (keyboard-layout-selection) -> void
- (parameters-page installer-parameters-page))
+ (parameters-page installer-parameters-page)
+ ;; procedure (dump) -> void
+ (dump-page installer-dump-page)
+ ;; procedure command -> bool
+ (run-command installer-run-command)
+ ;; procedure (report) -> void
+ (report-page installer-report-page))
diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm
index c05dfa567a..8bc38181a7 100644
--- a/gnu/installer/steps.scm
+++ b/gnu/installer/steps.scm
@@ -28,13 +28,7 @@
#: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?
@@ -52,15 +46,13 @@
%installer-configuration-file
%installer-target-dir
format-configuration
- configuration->file))
+ configuration->file
-;; This condition may be raised to abort the current step.
-(define-condition-type &installer-step-abort &condition
- installer-step-abort?)
+ %current-result))
-;; This condition may be raised to break out from the steps execution.
-(define-condition-type &installer-step-break &condition
- installer-step-break?)
+;; Hash table storing the step results. Use it only for logging and debug
+;; purposes.
+(define %current-result (make-hash-table))
;; An installer-step record is basically an id associated to a compute
;; procedure. The COMPUTE procedure takes exactly one argument, an association
@@ -88,8 +80,10 @@
(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
@@ -106,10 +100,7 @@ the form:
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))
@@ -143,62 +134,61 @@ return the accumalated result so far."
(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)))
- (syslog "running step '~a'~%" (installer-step-id step))
- (let* ((id (installer-step-id step))
- (compute (installer-step-compute step))
- (res (compute result done-steps)))
- (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."
diff --git a/gnu/installer/user.scm b/gnu/installer/user.scm
index 4e701e64ce..c894a91dc8 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,16 @@
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?
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 9bd41e2ca0..fb62fb8896 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -25,7 +25,10 @@
#: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)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (ice-9 format)
@@ -34,10 +37,17 @@
read-all
nearest-exact-integer
read-percentage
+ run-external-command-with-handler
+ run-external-command-with-line-hooks
run-command
+ run-command-in-installer
syslog-port
- syslog
+ %syslog-line-hook
+ installer-log-port
+ %installer-log-line-hook
+ %default-installer-line-hooks
+ installer-log-line
call-with-time
let/time
@@ -74,37 +84,99 @@ number. If no percentage is found, return #f"
(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 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)))
+ (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))
- (syslog "command ~s failed with exit code ~a"
- command (invoke-error-exit-status c))
- (pause)
- #f))
- (syslog "running command ~s~%" command)
- (apply invoke command)
- (syslog "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?)
+
+(define run-command-in-installer
+ (make-parameter
+ (lambda (. args)
+ (raise
+ (condition
+ (&serious)
+ (&message (message "run-command-in-installer not set")))))))
;;;
@@ -142,6 +214,9 @@ values."
(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 +227,43 @@ values."
(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.
@@ -214,8 +326,9 @@ accepting socket."
(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))))))
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-19 14:05:46 +0000