installer: Use system-wide guix for system init.

* gnu/installer.scm (installer-program): Remove dependency on the guix
package for the PATH.
* gnu/installer/final.scm (install-system): Set PATH inside container
to /run/current-system/profile/bin/.

Signed-off-by: Mathieu Othacehe <othacehe@gnu.org>

gnu/installer.scm

@@ -33,6 +33,7 @@
   #:use-module (gnu packages admin)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
+  #:use-module (gnu packages compression)
   #:use-module (gnu packages connman)
   #:use-module (gnu packages cryptsetup)
   #:use-module (gnu packages disk)
@@ -42,6 +43,7 @@
   #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:use-module (gnu packages iso-codes)
   #:use-module (gnu packages linux)
+  #:use-module (gnu packages nano)
   #:use-module (gnu packages ncurses)
   #:use-module (gnu packages package-management)
   #:use-module (gnu packages tls)
@@ -333,9 +335,11 @@ selected keymap."
                        ntfs-3g ;mkfs.ntfs
                        xfsprogs ;mkfs.xfs
                        kbd ;chvt
-                       guix ;guix system init call
                        util-linux ;mkwap
+                       nano
                        shadow
+                       tar ;dump
+                       gzip ;dump
                        coreutils)))
         (with-output-to-port (%make-void-port "w")
           (lambda ()
@@ -352,7 +356,8 @@ selected keymap."
     ;; packages …), etc. modules.
     (with-extensions (list guile-gcrypt guile-newt
                            guile-parted guile-bytestructures
-                           guile-json-3 guile-git guix gnutls)
+                           guile-json-3 guile-git guile-webutils
+                           guix gnutls)
       (with-imported-modules `(,@(source-module-closure
                                   `(,@modules
                                     (gnu services herd)
@@ -363,6 +368,7 @@ selected keymap."
             (use-modules (gnu installer record)
                          (gnu installer keymap)
                          (gnu installer steps)
+                         (gnu installer dump)
                          (gnu installer final)
                          (gnu installer hostname)
                          (gnu installer locale)
@@ -379,7 +385,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.
@@ -407,43 +414,56 @@ selected keymap."
             ;; verbose.
             (terminal-width 200)
 
-            (let* ((current-installer newt-installer)
+            (define current-installer newt-installer)
-                   (steps (#$steps current-installer)))
+            (define steps (#$steps current-installer))
-              ((installer-init current-installer))
 
-              (catch #t
+            (dynamic-wind
-                (lambda ()
+              (installer-init current-installer)
-                  (define results
+              (lambda ()
-                    (run-installer-steps
+                (parameterize
-                     #:rewind-strategy 'menu
+                    ((run-command-in-installer
-                     #:menu-proc (installer-menu-page current-installer)
+                      (installer-run-command current-installer)))
-                     #:steps steps))
+                  (catch #t
+                    (lambda ()
+                      (define results
+                        (run-installer-steps
+                         #:rewind-strategy 'menu
+                         #:menu-proc (installer-menu-page current-installer)
+                         #:steps steps))
 
-                  (match (result-step results 'final)
+                      (match (result-step results 'final)
-                    ('success
+                        ('success
-                     ;; We did it!  Let's reboot!
+                         ;; We did it!  Let's reboot!
-                     (sync)
+                         (sync)
-                     (stop-service 'root))
+                         (stop-service 'root))
-                    (_
+                        (_
-                     ;; The installation failed, exit so that it is restarted
+                         ;; The installation failed, exit so that it is
-                     ;; by login.
+                         ;; restarted by login.
-                     #f)))
+                         #f)))
-                (const #f)
+                    (const #f)
-                (lambda (key . args)
+                    (lambda (key . args)
-                  (syslog "crashing due to uncaught exception: ~s ~s~%"
+                      (installer-log-line "crashing due to uncaught exception: ~s ~s"
-                          key args)
+                                          key args)
-                  (let ((error-file "/tmp/last-installer-error"))
+                      (define dump-dir
-                    (call-with-output-file error-file
+                        (prepare-dump key args #:result %current-result))
-                      (lambda (port)
+                      (define action
-                        (display-backtrace (make-stack #t) port)
+                        ((installer-exit-error current-installer)
-                        (print-exception port
+                         (get-string-all
-                                         (stack-ref (make-stack #t) 1)
+                          (open-input-file
-                                         key args)))
+                           (string-append dump-dir "/installer-backtrace")))))
-                    ((installer-exit-error current-installer)
+                      (match action
-                     error-file key args))
+                        ('dump
-                  (primitive-exit 1)))
+                         (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)))))))
+              (installer-exit current-installer))))))
 
   (program-file
    "installer"

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)))))

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)
+                             (password (crypt
-                                              (salt)))
+                                        (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 \
+          (installer-log-line "~a locale is not supported, installing \
-locale instead.~%" locale)
+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
+             (setenv "PATH" "/run/current-system/profile/bin/")
-             ;; installation tests. In that case, dump the standard and error
+
-             ;; outputs to syslog.
+             (set! ret (run-command install-command)))
-             (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))))
            (lambda ()
              ;; Restart guix-daemon so that it does no keep the MNT namespace
              ;; alive.

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
+  (define action
-                (* (screen-columns) 0.8)))
+    (run-textbox-page
-        (height (nearest-exact-integer
+     #:info-text (G_ "The installer has encountered an unexpected problem. \
-                 (* (screen-rows) 0.7))))
+The backtrace is displayed below. You may choose to exit or create a dump \
-    (run-file-textbox-page
+archive.")
-     #: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)
      #:title (G_ "Unexpected problem")
-     #:file file
+     #:content error
-     #:exit-button? #f
+     #:buttons-spec
-     #:info-textbox-width width
+     (list
-     #:file-textbox-width width
+      (cons (G_ "Dump") (const 'dump))
-     #:file-textbox-height height))
+      (cons (G_ "Exit") (const 'exit)))))
   (newt-set-color COLORSET-ROOT "white" "blue")
-  (newt-finish)
+  action)
-  (clear-screen))
+
+(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)))

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
+     (abort-to-prompt 'installer-step 'abort))
-      (condition
-       (&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
+        (abort-to-prompt 'installer-step 'abort))
-         (condition
-          (&installer-step-abort))))
       #:listbox-callback-procedure connect-ethernet-service))))

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
+       (abort-to-prompt 'installer-step 'abort)))))
-        (condition
-         (&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
+       (1 (abort-to-prompt 'installer-step 'abort))
-           (condition
-            (&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))

gnu/installer/newt/keymap.scm

@@ -59,9 +59,7 @@ different layout at any time from the parameters menu.")))
        ((param) (const #f))
        (else
         (lambda _
-          (raise
+          (abort-to-prompt 'installer-step 'abort)))))))
-           (condition
-            (&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
+       (abort-to-prompt 'installer-step 'abort)))))
-        (condition
-         (&installer-step-abort)))))))
 
 (define (sort-layouts layouts)
   "Sort LAYOUTS list by putting the US layout ahead and return it."

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
+       (abort-to-prompt 'installer-step 'abort))))
-        (condition
-         (&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
+       (abort-to-prompt 'installer-step 'abort)))))
-        (condition
-         (&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
+       (abort-to-prompt 'installer-step 'abort)))))
-        (condition
-         (&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
+       (abort-to-prompt 'installer-step 'abort)))))
-        (condition
-         (&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
+         (abort-to-prompt 'installer-step 'break)))
-          (condition (&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
+  ;; locale. In that case, like if we exited by breaking to the installer
-  ;; condition, turn the result into a glibc locale string and return it.
+  ;; step, turn the result into a glibc locale string and return it.
   (result->locale-string
    supported-locales
    (run-installer-steps #:steps locale-steps)))

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
+       ((1) (abort-to-prompt 'installer-step 'break))
-             (condition
+       ((2) (abort-to-prompt 'installer-step 'abort))))
-              (&installer-step-break))))
-       ((2) (raise
-             (condition
-              (&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
+        (abort-to-prompt 'installer-step 'abort))))))
-         (condition
-          (&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
+      (abort-to-prompt 'installer-step 'abort))))
-       (condition
-        (&installer-step-abort))))))
 
 (define (run-network-page)
   "Run a page to allow the user to configure connman so that it can access the

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~%"
+                   (installer-log-line
-                           (fileno client) form)
+                    "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)
+  (invoke "nano" file)
-               #:locale locale)
   (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)))))

gnu/installer/newt/partition.scm

@@ -36,10 +36,8 @@
   #:export (run-partitioning-page))
 
 (define (button-exit-action)
-  "Raise the &installer-step-abort condition."
+  "Abort the installer step."
-  (raise
+  (abort-to-prompt 'installer-step 'abort))
-   (condition
-    (&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))

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
+       (abort-to-prompt 'installer-step 'abort)))))
-        (condition
-         (&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
+       (abort-to-prompt 'installer-step 'abort)))))
-        (condition
-         (&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
+       (abort-to-prompt 'installer-step 'abort)))))
-        (condition
-         (&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
+       (abort-to-prompt 'installer-step 'abort)))))
-        (condition
-         (&installer-step-abort)))))))
 
 (define (run-services-page)
   (let ((desktop (run-desktop-environments-cbt-page)))

gnu/installer/newt/timezone.scm

@@ -65,9 +65,7 @@ returned."
          #:button-callback-procedure
          (if (null? path)
              (lambda _
-               (raise
+               (abort-to-prompt 'installer-step 'abort))
-                (condition
-                 (&installer-step-abort))))
              (lambda _
                (loop (all-but-last path))))
          #:listbox-callback-procedure

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
+                 (abort-to-prompt 'installer-step 'abort))))
-                  (condition
-                   (&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 '())))

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))
 

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
+              (abort-to-prompt 'installer-step 'abort))
-               (condition
-                (&installer-step-abort))))
              ((components=? argument listbox)
               (let ((result (connect-wifi-service listbox service-items)))
                 (unless result

gnu/installer/parted.scm

@@ -343,8 +343,7 @@ 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
+   ((run-command-in-installer) "dmsetup" "remove_all"))
-   (invoke "dmsetup" "remove_all")))
 
 (define (installer-root-partition-path)
   "Return the root partition path, or #f if it could not be detected."
@@ -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)))
+  (let* ((type (disk-type-get type-name))
-    (disk-new-fresh device type)))
+         (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:
+         (installer-log-line "Creating partition:")
-~/type: ~a
+         (installer-log-line "~/type: ~a" partition-type)
-~/filesystem-type: ~a
+         (installer-log-line "~/filesystem-type: ~a"
-~/start: ~a
+                             (filesystem-type-name filesystem-type))
-~/end: ~a
+         (installer-log-line "~/start: ~a" start-sector*)
-~/start-range: [~a, ~a]
+         (installer-log-line "~/end: ~a" end-sector)
-~/end-range: [~a, ~a]
+         (installer-log-line "~/start-range: [~a, ~a]"
-~/constraint: ~a
+                             (geometry-start start-range)
-~/no-constraint: ~a
+                             (geometry-end start-range))
-"
+         (installer-log-line "~/end-range: [~a, ~a]"
-                 partition-type
+                             (geometry-start end-range)
-                 (filesystem-type-name filesystem-type)
+                             (geometry-end end-range))
-                 start-sector*
+         (installer-log-line "~/constraint: ~a"
-                 end-sector
+                             partition-constraint-ok?)
-                 (geometry-start start-range) (geometry-end start-range)
+         (installer-log-line "~/no-constraint: ~a"
-                 (geometry-start end-range) (geometry-end end-range)
+                             partition-no-contraint-ok?)
-                 partition-constraint-ok?
-                 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
+   ((run-command-in-installer) "mkfs.btrfs" "-f" partition))
-   (invoke "mkfs.btrfs" "-f" partition)))
 
 (define (create-ext4-file-system partition)
   "Create an ext4 file-system for PARTITION file-name."
-  (with-null-output-ports
+   ((run-command-in-installer) "mkfs.ext4" "-F" partition))
-   (invoke "mkfs.ext4" "-F" partition)))
 
 (define (create-fat16-file-system partition)
   "Create a fat16 file-system for PARTITION file-name."
-  (with-null-output-ports
+   ((run-command-in-installer) "mkfs.fat" "-F16" partition))
-   (invoke "mkfs.fat" "-F16" partition)))
 
 (define (create-fat32-file-system partition)
   "Create a fat32 file-system for PARTITION file-name."
-  (with-null-output-ports
+   ((run-command-in-installer) "mkfs.fat" "-F32" partition))
-   (invoke "mkfs.fat" "-F32" partition)))
 
 (define (create-jfs-file-system partition)
   "Create a JFS file-system for PARTITION file-name."
-  (with-null-output-ports
+   ((run-command-in-installer) "jfs_mkfs" "-f" partition))
-   (invoke "jfs_mkfs" "-f" partition)))
 
 (define (create-ntfs-file-system partition)
   "Create a JFS file-system for PARTITION file-name."
-  (with-null-output-ports
+   ((run-command-in-installer) "mkfs.ntfs" "-F" "-f" partition))
-   (invoke "mkfs.ntfs" "-F" "-f" partition)))
 
 (define (create-xfs-file-system partition)
   "Create an XFS file-system for PARTITION file-name."
-  (with-null-output-ports
+   ((run-command-in-installer) "mkfs.xfs" "-f" partition))
-   (invoke "mkfs.xfs" "-f" partition)))
 
 (define (create-swap-partition partition)
   "Set up swap area on PARTITION file-name."
-  (with-null-output-ports
+   ((run-command-in-installer) "mkswap" "-f" partition))
-   (invoke "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)
+       ((run-command-in-installer) "cryptsetup" "-q" "luksFormat"
-       (system* "cryptsetup" "open" "--type" "luks"
+        file-name key-file)
-                "--key-file" key-file file-name label)))))
+       ((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)
+    (installer-log-line "closing LUKS entry ~s" label)
-    (system* "cryptsetup" "close" 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)))

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))

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
+  #:export (<installer-step>
-            installer-step-abort?
-
-            &installer-step-break
-            installer-step-break?
-
-            <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.
+            %current-result))
-(define-condition-type &installer-step-abort &condition
-  installer-step-abort?)
 
-;; This condition may be raised to break out from the steps execution.
+;; Hash table storing the step results. Use it only for logging and debug
-(define-condition-type &installer-step-break &condition
+;; purposes.
-  installer-step-break?)
+(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
+sequentially, inside a the 'installer-step prompt.  When aborted to with a
-previous install-step, accordingly to the specified REWIND-STRATEGY.
+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.
+computation is over."
-
-If the &installer-step-break condition is raised, stop the computation and
-return the accumalated result so far."
   (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)
+       (call-with-prompt 'installer-step
-                  (case rewind-strategy
+         (lambda ()
-                    ((previous)
+           (installer-log-line "running step '~a'" (installer-step-id step))
-                     (match done-steps
+           (let* ((id (installer-step-id step))
-                       (()
+                  (compute (installer-step-compute step))
-                        ;; We cannot go previous the first step. So re-raise
+                  (res (compute result done-steps)))
-                        ;; the exception. It might be useful in the case of
+             (hash-set! %current-result id res)
-                        ;; nested run-installer-steps. Abort to 'raise-above
+             (run (alist-cons id res result)
-                        ;; prompt to prevent the condition from being catched
+                  #:todo-steps rest-steps
-                        ;; by one of the previously installed guard.
+                  #:done-steps (append done-steps (list step)))))
-                        (abort-to-prompt 'raise-above c))
+         (lambda (k action)
-                       ((prev-done ... last-done)
+           (match action
-                        (run (pop-result result)
+             ('abort
-                             #:todo-steps (cons last-done todo-steps)
+              (case rewind-strategy
-                             #:done-steps prev-done))))
+                ((previous)
-                    ((menu)
+                 (match done-steps
-                     (let ((goto-step (menu-proc
+                   (()
-                                       (append done-steps (list step)))))
+                    ;; We cannot go previous the first step. Abort again to
-                       (if (eq? goto-step step)
+                    ;; 'installer-step prompt. It might be useful in the case
-                           (run result
+                    ;; of nested run-installer-steps.
-                                #:todo-steps todo-steps
+                    (abort-to-prompt 'installer-step action))
-                                #:done-steps done-steps)
+                   ((prev-done ... last-done)
-                           (skip-to-step goto-step result
+                    (run (pop-result result)
-                                         #:todo-steps todo-steps
+                         #:todo-steps (cons last-done todo-steps)
-                                         #:done-steps done-steps))))
+                         #:done-steps prev-done))))
-                    ((start)
+                ((menu)
-                     (if (null? done-steps)
+                 (let ((goto-step (menu-proc
-                         ;; Same as above, it makes no sense to jump to start
+                                   (append done-steps (list step)))))
-                         ;; when we are at the first installer-step. Abort to
+                   (if (eq? goto-step step)
-                         ;; 'raise-above prompt to re-raise the condition.
+                       (run result
-                         (abort-to-prompt 'raise-above c)
+                            #:todo-steps todo-steps
-                         (run '()
+                            #:done-steps done-steps)
-                              #:todo-steps steps
+                       (skip-to-step goto-step result
-                              #:done-steps '())))))
+                                     #:todo-steps todo-steps
-                 ((installer-step-break? c)
+                                     #:done-steps done-steps))))
-                  (reverse result)))
+                ((start)
-         (syslog "running step '~a'~%" (installer-step-id step))
+                 (if (null? done-steps)
-         (let* ((id (installer-step-id step))
+                     ;; Same as above, it makes no sense to jump to start
-                (compute (installer-step-compute step))
+                     ;; when we are at the first installer-step. Abort to
-                (res (compute result done-steps)))
+                     ;; 'installer-step prompt again.
-           (run (alist-cons id res result)
+                     (abort-to-prompt 'installer-step action)
-                #:todo-steps rest-steps
+                     (run '()
-                #:done-steps (append done-steps (list step))))))))
+                          #: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
+    (run '()
-      (lambda ()
+         #:todo-steps steps
-        (run '()
+         #:done-steps '())))
-             #:todo-steps steps
-             #:done-steps '()))
-      (lambda (k condition)
-        (raise condition)))))
 
 (define (find-step-by-id steps id)
   "Find and return the step in STEPS whose id is equal to ID."

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?

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")
+  (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?)
 
-  (guard (c ((invoke-error? c)
+(define run-command-in-installer
-             (newline)
+  (make-parameter
-             (format (current-error-port)
+   (lambda (. args)
-                     (G_ "Command failed with exit code ~a.~%")
+     (raise
-                     (invoke-error-exit-status c))
+      (condition
-             (syslog "command ~s failed with exit code ~a"
+       (&serious)
-                     command (invoke-error-exit-status c))
+       (&message (message "run-command-in-installer not set")))))))
-             (pause)
-             #f))
-    (syslog "running command ~s~%" command)
-    (apply invoke command)
-    (syslog "command ~s succeeded~%" command)
-    (newline)
-    (pause)
-    #t))
 
 
 ;;;
@@ -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~%"
+                        (installer-log-line
-                                (fileno client) (strerror errno))
+                         "removing client ~s due to ~s while replying"
+                         (fileno client) (strerror errno))
                         (false-if-exception (close-port client))
                         remainder)
                       (cons client remainder))))))

gnu/local.mk

@@ -756,6 +756,7 @@ GNU_SYSTEM_MODULES =				\
 INSTALLER_MODULES =                             \
   %D%/installer.scm      			\
   %D%/installer/connman.scm			\
+  %D%/installer/dump.scm			\
   %D%/installer/final.scm			\
   %D%/installer/hostname.scm			\
   %D%/installer/keymap.scm			\