;;; 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>
;;;
;;; This file is part of GNU Guix.
;;;
#: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)
#: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)
(('gnu 'installer _ ...) #t)
(('gnu 'build _ ...) #t)
(('guix 'build _ ...) #t)
+ (('guix 'read-print) #t)
(_ #f)))
(define not-config?
(_ #f)))
(define* (build-compiled-file name locale-builder)
- "Return a file-like object that evalutes the gexp LOCALE-BUILDER and store
+ "Return a file-like object that evaluates the gexp LOCALE-BUILDER and store
its result in the scheme file NAME. The derivation will also build a compiled
version of this file."
(define set-utf8-locale
(setlocale LC_ALL locale))
;; Restart the documentation viewer so it displays the manual in
- ;; language that corresponds to LOCALE.
- (with-error-to-port (%make-void-port "w")
- (lambda ()
- (stop-service 'term-tty2)
- (start-service 'term-tty2 (list locale)))))))
+ ;; language that corresponds to LOCALE. Make sure that nothing is
+ ;; printed on the console.
+ (parameterize ((shepherd-message-port
+ (%make-void-port "w")))
+ (stop-service 'term-tty2)
+ (start-service 'term-tty2 (list locale))))))
(define* (compute-locale-step #:key
locales-name
(define apply-keymap
;; Apply the specified keymap. Use the default keyboard model.
#~(match-lambda
- ((layout variant)
+ ((layout variant options)
(kmscon-update-keymap (default-keyboard-model)
- layout variant))))
+ layout variant options))))
-(define* (compute-keymap-step)
+(define* (compute-keymap-step context)
"Return a gexp that runs the keymap-page of INSTALLER and install the
selected keymap."
#~(lambda (current-installer)
"/share/X11/xkb/rules/base.xml")))
(lambda (models layouts)
((installer-keymap-page current-installer)
- layouts)))))
- (#$apply-keymap result)
+ layouts '#$context)))))
+ (and result (#$apply-keymap result))
result)))
(define (installer-steps)
#:locales-name "locales"
#:iso639-languages-name "iso639-languages"
#:iso3166-territories-name "iso3166-territories"))
- (keymap-step (compute-keymap-step))
(timezone-data #~(string-append #$tzdata
"/share/zoneinfo/zone.tab")))
#~(lambda (current-installer)
+ ((installer-parameters-menu current-installer)
+ (lambda ()
+ ((installer-parameters-page current-installer)
+ (lambda _
+ (#$(compute-keymap-step 'param)
+ current-installer)))))
(list
;; Ask the user to choose a locale among those supported by
;; the glibc. Install the selected locale right away, so that
;; The installer runs in a kmscon virtual terminal where loadkeys
;; won't work. kmscon uses libxkbcommon as a backend for keyboard
- ;; input. It is possible to update kmscon current keymap by sending it
- ;; a keyboard model, layout and variant, in a somehow similar way as
- ;; what is done with setxkbmap utility.
+ ;; input. It is possible to update kmscon current keymap by sending
+ ;; it a keyboard model, layout, variant and options, in a somehow
+ ;; similar way as what is done with setxkbmap utility.
;;
;; So ask for a keyboard model, layout and variant to update the
- ;; current kmscon keymap.
+ ;; current kmscon keymap. For non-Latin layouts, we add an
+ ;; appropriate second layout and toggle via Alt+Shift.
(installer-step
(id 'keymap)
(description (G_ "Keyboard mapping selection"))
(compute (lambda _
- (#$keymap-step current-installer)))
+ (#$(compute-keymap-step 'default)
+ current-installer)))
(configuration-formatter keyboard-layout->configuration))
;; Ask the user to input a hostname for the system.
(compute (lambda _
((installer-network-page current-installer)))))
+ ;; Ask whether to enable substitute server discovery.
+ (installer-step
+ (id 'substitutes)
+ (description (G_ "Substitute server discovery"))
+ (compute (lambda _
+ ((installer-substitutes-page current-installer)))))
+
;; Prompt for users (name, group and home directory).
(installer-step
(id 'user)
(description (G_ "Services"))
(compute (lambda _
((installer-services-page current-installer))))
- (configuration-formatter system-services->configuration))
+ (configuration-formatter system-services->configuration))
;; Run a partitioning tool allowing the user to modify
;; partition tables, partitions and their mount points.
((installer-partition-page current-installer))))
(configuration-formatter user-partitions->configuration))
- (installer-step
+ (installer-step
(id 'final)
(description (G_ "Configuration file"))
(compute
((installer-final-page current-installer)
result prev-steps))))))))
-(define guile-newt
- ;; Guile-Newt with 'form-watch-fd'.
- ;; TODO: Remove once a new release is out.
- (let ((commit "b3c885d42cfac327d3531c9d064939514ce6bf12")
- (revision "1"))
- (package
- (inherit (@ (gnu packages guile-xyz) guile-newt))
- (name "guile-newt")
- (version (git-version "0.0.1" revision commit))
- (source (origin
- (method git-fetch)
- (uri (git-reference
- (url "https://gitlab.com/mothacehe/guile-newt")
- (commit commit)))
- (file-name (git-file-name name version))
- (sha256
- (base32
- "02p0bi6c05699idgx6gfkljhqgi8zf09clhzx81i8wa064s70r1y")))))))
-
(define (installer-program)
"Return a file-like object that runs the given INSTALLER."
(define init-gettext
;; translated.
#~(begin
(bindtextdomain "guix" (string-append #$guix "/share/locale"))
- (textdomain "guix")))
+ (textdomain "guix")
+ (setlocale LC_ALL "")))
(define set-installer-path
;; Add the specified binary to PATH for later use by the installer.
#~(let* ((inputs
- '#$(append (list bash ;start subshells
- connman ;call connmanctl
- cryptsetup
- dosfstools ;mkfs.fat
- e2fsprogs ;mkfs.ext4
- btrfs-progs ;mkfs.btrfs
- jfsutils ;jfs_mkfs
- kbd ;chvt
- guix ;guix system init call
- util-linux ;mkwap
- shadow)
- (map canonical-package (list coreutils)))))
+ '#$(list bash ;start subshells
+ connman ;call connmanctl
+ cryptsetup
+ dosfstools ;mkfs.fat
+ e2fsprogs ;mkfs.ext4
+ lvm2-static ;dmsetup
+ btrfs-progs
+ jfsutils ;jfs_mkfs
+ ntfs-3g ;mkfs.ntfs
+ xfsprogs ;mkfs.xfs
+ kbd ;chvt
+ util-linux ;mkwap
+ nano
+ shadow
+ tar ;dump
+ gzip ;dump
+ coreutils)))
(with-output-to-port (%make-void-port "w")
(lambda ()
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)))))
;; 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)
(use-modules (gnu installer record)
(gnu installer keymap)
(gnu installer steps)
+ (gnu installer dump)
(gnu installer final)
(gnu installer hostname)
(gnu installer locale)
(gnu installer services)
(gnu installer timezone)
(gnu installer user)
+ (gnu installer utils)
(gnu installer newt)
((gnu installer newt keymap)
#:select (keyboard-layout->configuration))
(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.
;; 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"
;; some reason, unicode support is not correctly installed
;; when calling this in 'installer-builder'.
(setenv "LANG" "en_US.UTF-8")
- (execl #$(program-file "installer-real" installer-builder)
+ (execl #$(program-file "installer-real" installer-builder
+ #:guile guile-3.0-latest)
"installer-real"))))
HCoop / jackhill / guix / guix.git / blobdiff