gnu: python-tempora: Switch to pyproject-build-system.

[jackhill/guix/guix.git] / gnu / installer.scm

diff --git a/gnu/installer.scm b/gnu/installer.scm
index d2be4b3..8a6e604 100644 (file)
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
 ;;;
@@ -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,8 +43,10 @@
   #: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)
   #:use-module (gnu packages xorg)
   #:use-module (gnu system locale)
   #:use-module (ice-9 match)
@@ -60,6 +63,7 @@
     (('gnu 'installer _ ...) #t)
     (('gnu 'build _ ...) #t)
     (('guix 'build _ ...) #t)
+    (('guix 'read-print) #t)
     (_ #f)))
 
 (define not-config?
@@ -330,10 +334,13 @@ selected keymap."
                        btrfs-progs
                        jfsutils ;jfs_mkfs
                        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 ()
@@ -350,7 +357,8 @@ selected keymap."
     ;; packages …), etc. modules.
     (with-extensions (list guile-gcrypt guile-newt
                            guile-parted guile-bytestructures
-                           guile-json-3 guile-git guix)
+                           guile-json-3 guile-git guile-webutils
+                           guix gnutls)
       (with-imported-modules `(,@(source-module-closure
                                   `(,@modules
                                     (gnu services herd)
@@ -361,6 +369,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)
@@ -377,7 +386,8 @@ selected keymap."
                          (guix build utils)
                          ((system repl debug)
                           #:select (terminal-width))
-                         (ice-9 match))
+                         (ice-9 match)
+                         (ice-9 textual-ports))
 
             ;; Initialize gettext support so that installers can use
             ;; (guix i18n) module.
@@ -405,43 +415,56 @@ selected keymap."
             ;; verbose.
             (terminal-width 200)
 
-            (let* ((current-installer newt-installer)
-                   (steps (#$steps current-installer)))
-              ((installer-init current-installer))
-
-              (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)
-                    ('success
-                     ;; We did it!  Let's reboot!
-                     (sync)
-                     (stop-service 'root))
-                    (_
-                     ;; The installation failed, exit so that it is restarted
-                     ;; by login.
-                     #f)))
-                (const #f)
-                (lambda (key . args)
-                  (syslog "crashing due to uncaught exception: ~s ~s~%"
-                          key args)
-                  (let ((error-file "/tmp/last-installer-error"))
-                    (call-with-output-file error-file
-                      (lambda (port)
-                        (display-backtrace (make-stack #t) port)
-                        (print-exception port
-                                         (stack-ref (make-stack #t) 1)
-                                         key args)))
-                    ((installer-exit-error current-installer)
-                     error-file key args))
-                  (primitive-exit 1)))
-
-              ((installer-exit current-installer)))))))
+            (define current-installer newt-installer)
+            (define steps (#$steps current-installer))
+
+            (dynamic-wind
+              (installer-init current-installer)
+              (lambda ()
+                (parameterize
+                    ((run-command-in-installer
+                      (installer-run-command current-installer)))
+                  (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)
+                        ('success
+                         ;; We did it!  Let's reboot!
+                         (sync)
+                         (stop-service 'root))
+                        (_
+                         ;; The installation failed, exit so that it is
+                         ;; restarted by login.
+                         #f)))
+                    (const #f)
+                    (lambda (key . args)
+                      (installer-log-line "crashing due to uncaught exception: ~s ~s"
+                                          key args)
+                      (define dump-dir
+                        (prepare-dump key args #:result %current-result))
+                      (define action
+                        ((installer-exit-error current-installer)
+                         (get-string-all
+                          (open-input-file
+                           (string-append dump-dir "/installer-backtrace")))))
+                      (match action
+                        ('dump
+                         (let* ((dump-files
+                                 ((installer-dump-page current-installer)
+                                  dump-dir))
+                                (dump-archive
+                                 (make-dump dump-dir dump-files)))
+                           ((installer-report-page current-installer)
+                            dump-archive)))
+                        (_ #f))
+                      (exit 1)))))
+
+              (installer-exit current-installer))))))
 
   (program-file
    "installer"