gnu/installer.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
   4 ;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (gnu installer)
  22   #:use-module (guix discovery)
  23   #:use-module (guix packages)
  24   #:use-module (guix gexp)
  25   #:use-module (guix modules)
  26   #:use-module (guix utils)
  27   #:use-module (guix ui)
  28   #:use-module ((guix self) #:select (make-config.scm))
  29   #:use-module (gnu packages admin)
  30   #:use-module (gnu packages base)
  31   #:use-module (gnu packages bash)
  32   #:use-module (gnu packages connman)
  33   #:use-module (gnu packages cryptsetup)
  34   #:use-module (gnu packages disk)
  35   #:use-module (gnu packages file-systems)
  36   #:use-module (gnu packages guile)
  37   #:use-module (gnu packages guile-xyz)
  38   #:autoload   (gnu packages gnupg) (guile-gcrypt)
  39   #:use-module (gnu packages iso-codes)
  40   #:use-module (gnu packages linux)
  41   #:use-module (gnu packages ncurses)
  42   #:use-module (gnu packages package-management)
  43   #:use-module (gnu packages xorg)
  44   #:use-module (gnu system locale)
  45   #:use-module (ice-9 match)
  46   #:use-module (srfi srfi-1)
  47   #:export (installer-program))
  48
  49 (define module-to-import?
  50   ;; Return true for modules that should be imported.  For (gnu system …) and
  51   ;; (gnu packages …) modules, we simply add the whole 'guix' package via
  52   ;; 'with-extensions' (to avoid having to rebuild it all), which is why these
  53   ;; modules are excluded here.
  54   (match-lambda
  55     (('guix 'config) #f)
  56     (('gnu 'installer _ ...) #t)
  57     (('gnu 'build _ ...) #t)
  58     (('guix 'build _ ...) #t)
  59     (_ #f)))
  60
  61 (define* (build-compiled-file name locale-builder)
  62   "Return a file-like object that evalutes the gexp LOCALE-BUILDER and store
  63 its result in the scheme file NAME. The derivation will also build a compiled
  64 version of this file."
  65   (define set-utf8-locale
  66     #~(begin
  67         (setenv "LOCPATH"
  68                 #$(file-append glibc-utf8-locales "/lib/locale/"
  69                                (version-major+minor
  70                                 (package-version glibc-utf8-locales))))
  71         (setlocale LC_ALL "en_US.utf8")))
  72
  73   (define builder
  74     (with-extensions (list guile-json-3)
  75       (with-imported-modules (source-module-closure
  76                               '((gnu installer locale)))
  77         #~(begin
  78             (use-modules (gnu installer locale))
  79
  80             ;; The locale files contain non-ASCII characters.
  81             #$set-utf8-locale
  82
  83             (mkdir #$output)
  84             (let ((locale-file
  85                    (string-append #$output "/" #$name ".scm"))
  86                   (locale-compiled-file
  87                    (string-append #$output "/" #$name ".go")))
  88               (call-with-output-file locale-file
  89                 (lambda (port)
  90                   (write #$locale-builder port)))
  91               (compile-file locale-file
  92                             #:output-file locale-compiled-file))))))
  93   (computed-file name builder))
  94
  95 (define apply-locale
  96   ;; Install the specified locale.
  97   (with-imported-modules (source-module-closure '((gnu services herd)))
  98     #~(lambda (locale)
  99         (false-if-exception
 100          (setlocale LC_ALL locale))
 101
 102         ;; Restart the documentation viewer so it displays the manual in
 103         ;; language that corresponds to LOCALE.
 104         (with-error-to-port (%make-void-port "w")
 105           (lambda ()
 106             (stop-service 'term-tty2)
 107             (start-service 'term-tty2 (list locale)))))))
 108
 109 (define* (compute-locale-step #:key
 110                               locales-name
 111                               iso639-languages-name
 112                               iso3166-territories-name)
 113   "Return a gexp that run the locale-page of INSTALLER, and install the
 114 selected locale. The list of locales, languages and territories passed to
 115 locale-page are computed in derivations named respectively LOCALES-NAME,
 116 ISO639-LANGUAGES-NAME and ISO3166-TERRITORIES-NAME. Those lists are compiled,
 117 so that when the installer is run, all the lengthy operations have already
 118 been performed at build time."
 119   (define (compiled-file-loader file name)
 120     #~(load-compiled
 121        (string-append #$file "/" #$name ".go")))
 122
 123   (let* ((supported-locales #~(supported-locales->locales
 124                                #+(glibc-supported-locales)))
 125          (iso-codes #~(string-append #$iso-codes "/share/iso-codes/json/"))
 126          (iso639-3 #~(string-append #$iso-codes "iso_639-3.json"))
 127          (iso639-5 #~(string-append #$iso-codes "iso_639-5.json"))
 128          (iso3166 #~(string-append #$iso-codes "iso_3166-1.json"))
 129          (locales-file (build-compiled-file
 130                         locales-name
 131                         #~`(quote ,#$supported-locales)))
 132          (iso639-file (build-compiled-file
 133                        iso639-languages-name
 134                        #~`(quote ,(iso639->iso639-languages
 135                                    #$supported-locales
 136                                    #$iso639-3 #$iso639-5))))
 137          (iso3166-file (build-compiled-file
 138                         iso3166-territories-name
 139                         #~`(quote ,(iso3166->iso3166-territories #$iso3166))))
 140          (locales-loader (compiled-file-loader locales-file
 141                                                locales-name))
 142          (iso639-loader (compiled-file-loader iso639-file
 143                                               iso639-languages-name))
 144          (iso3166-loader (compiled-file-loader iso3166-file
 145                                                iso3166-territories-name)))
 146     #~(lambda (current-installer)
 147         (let ((result
 148                ((installer-locale-page current-installer)
 149                 #:supported-locales #$locales-loader
 150                 #:iso639-languages #$iso639-loader
 151                 #:iso3166-territories #$iso3166-loader)))
 152           (#$apply-locale result)
 153           result))))
 154
 155 (define apply-keymap
 156   ;; Apply the specified keymap. Use the default keyboard model.
 157   #~(match-lambda
 158       ((layout variant)
 159        (kmscon-update-keymap (default-keyboard-model)
 160                              layout variant))))
 161
 162 (define* (compute-keymap-step)
 163   "Return a gexp that runs the keymap-page of INSTALLER and install the
 164 selected keymap."
 165   #~(lambda (current-installer)
 166       (let ((result
 167              (call-with-values
 168                  (lambda ()
 169                    (xkb-rules->models+layouts
 170                     (string-append #$xkeyboard-config
 171                                    "/share/X11/xkb/rules/base.xml")))
 172                (lambda (models layouts)
 173                  ((installer-keymap-page current-installer)
 174                   layouts)))))
 175         (#$apply-keymap result)
 176         result)))
 177
 178 (define (installer-steps)
 179   (let ((locale-step (compute-locale-step
 180                       #:locales-name "locales"
 181                       #:iso639-languages-name "iso639-languages"
 182                       #:iso3166-territories-name "iso3166-territories"))
 183         (keymap-step (compute-keymap-step))
 184         (timezone-data #~(string-append #$tzdata
 185                                         "/share/zoneinfo/zone.tab")))
 186     #~(lambda (current-installer)
 187         (list
 188          ;; Ask the user to choose a locale among those supported by
 189          ;; the glibc.  Install the selected locale right away, so that
 190          ;; the user may benefit from any available translation for the
 191          ;; installer messages.
 192          (installer-step
 193           (id 'locale)
 194           (description (G_ "Locale"))
 195           (compute (lambda _
 196                      (#$locale-step current-installer)))
 197           (configuration-formatter locale->configuration))
 198
 199          ;; Welcome the user and ask them to choose between manual
 200          ;; installation and graphical install.
 201          (installer-step
 202           (id 'welcome)
 203           (compute (lambda _
 204                      ((installer-welcome-page current-installer)
 205                       #$(local-file "installer/aux-files/logo.txt")))))
 206
 207          ;; Ask the user to select a timezone under glibc format.
 208          (installer-step
 209           (id 'timezone)
 210           (description (G_ "Timezone"))
 211           (compute (lambda _
 212                      ((installer-timezone-page current-installer)
 213                       #$timezone-data)))
 214           (configuration-formatter posix-tz->configuration))
 215
 216          ;; The installer runs in a kmscon virtual terminal where loadkeys
 217          ;; won't work. kmscon uses libxkbcommon as a backend for keyboard
 218          ;; input. It is possible to update kmscon current keymap by sending it
 219          ;; a keyboard model, layout and variant, in a somehow similar way as
 220          ;; what is done with setxkbmap utility.
 221          ;;
 222          ;; So ask for a keyboard model, layout and variant to update the
 223          ;; current kmscon keymap.
 224          (installer-step
 225           (id 'keymap)
 226           (description (G_ "Keyboard mapping selection"))
 227           (compute (lambda _
 228                      (#$keymap-step current-installer)))
 229           (configuration-formatter keyboard-layout->configuration))
 230
 231          ;; Ask the user to input a hostname for the system.
 232          (installer-step
 233           (id 'hostname)
 234           (description (G_ "Hostname"))
 235           (compute (lambda _
 236                      ((installer-hostname-page current-installer))))
 237           (configuration-formatter hostname->configuration))
 238
 239          ;; Provide an interface above connmanctl, so that the user can select
 240          ;; a network susceptible to acces Internet.
 241          (installer-step
 242           (id 'network)
 243           (description (G_ "Network selection"))
 244           (compute (lambda _
 245                      ((installer-network-page current-installer)))))
 246
 247          ;; Prompt for users (name, group and home directory).
 248          (installer-step
 249           (id 'user)
 250           (description (G_ "User creation"))
 251           (compute (lambda _
 252                      ((installer-user-page current-installer))))
 253           (configuration-formatter users->configuration))
 254
 255          ;; Ask the user to choose one or many desktop environment(s).
 256          (installer-step
 257           (id 'services)
 258           (description (G_ "Services"))
 259           (compute (lambda _
 260                      ((installer-services-page current-installer))))
 261           (configuration-formatter system-services->configuration))
 262
 263          ;; Run a partitioning tool allowing the user to modify
 264          ;; partition tables, partitions and their mount points.
 265          ;; Do this last so the user has something to boot if any
 266          ;; of the previous steps didn't go as expected.
 267          (installer-step
 268           (id 'partition)
 269           (description (G_ "Partitioning"))
 270           (compute (lambda _
 271                      ((installer-partition-page current-installer))))
 272           (configuration-formatter user-partitions->configuration))
 273
 274          (installer-step
 275           (id 'final)
 276           (description (G_ "Configuration file"))
 277           (compute
 278            (lambda (result prev-steps)
 279              ((installer-final-page current-installer)
 280               result prev-steps))))))))
 281
 282 (define (installer-program)
 283   "Return a file-like object that runs the given INSTALLER."
 284   (define init-gettext
 285     ;; Initialize gettext support, so that installer messages can be
 286     ;; translated.
 287     #~(begin
 288         (bindtextdomain "guix" (string-append #$guix "/share/locale"))
 289         (textdomain "guix")))
 290
 291   (define set-installer-path
 292     ;; Add the specified binary to PATH for later use by the installer.
 293     #~(let* ((inputs
 294               '#$(append (list bash ;start subshells
 295                                connman ;call connmanctl
 296                                cryptsetup
 297                                dosfstools ;mkfs.fat
 298                                e2fsprogs ;mkfs.ext4
 299                                btrfs-progs ;mkfs.btrfs
 300                                jfsutils ;jfs_mkfs
 301                                kbd ;chvt
 302                                guix ;guix system init call
 303                                util-linux ;mkwap
 304                                shadow)
 305                          (map canonical-package (list coreutils)))))
 306         (with-output-to-port (%make-void-port "w")
 307           (lambda ()
 308             (set-path-environment-variable "PATH" '("bin" "sbin") inputs)))))
 309
 310   (define steps (installer-steps))
 311   (define modules
 312     (scheme-modules*
 313      (string-append (current-source-directory) "/..")
 314      "gnu/installer"))
 315
 316   (define installer-builder
 317     ;; Note: Include GUIX as an extension to get all the (gnu system …), (gnu
 318     ;; packages …), etc. modules.
 319     (with-extensions (list guile-gcrypt guile-newt
 320                            guile-parted guile-bytestructures
 321                            guile-json-3 guile-git guix)
 322       (with-imported-modules `(,@(source-module-closure
 323                                   `(,@modules
 324                                     (gnu services herd)
 325                                     (guix build utils))
 326                                   #:select? module-to-import?)
 327                                ((guix config) => ,(make-config.scm)))
 328         #~(begin
 329             (use-modules (gnu installer record)
 330                          (gnu installer keymap)
 331                          (gnu installer steps)
 332                          (gnu installer final)
 333                          (gnu installer hostname)
 334                          (gnu installer locale)
 335                          (gnu installer parted)
 336                          (gnu installer services)
 337                          (gnu installer timezone)
 338                          (gnu installer user)
 339                          (gnu installer newt)
 340                          ((gnu installer newt keymap)
 341                           #:select (keyboard-layout->configuration))
 342                          (gnu services herd)
 343                          (guix i18n)
 344                          (guix build utils)
 345                          ((system repl debug)
 346                           #:select (terminal-width))
 347                          (ice-9 match))
 348
 349             ;; Initialize gettext support so that installers can use
 350             ;; (guix i18n) module.
 351             #$init-gettext
 352
 353             ;; Add some binaries used by the installers to PATH.
 354             #$set-installer-path
 355
 356             ;; Arrange for language and territory name translations to be
 357             ;; available.  We need them at run time, not just compile time,
 358             ;; because some territories have several corresponding languages
 359             ;; (e.g., "French" is always displayed as "français", but
 360             ;; "Belgium" could be translated to Dutch, French, or German.)
 361             (bindtextdomain "iso_639-3"           ;languages
 362                             #+(file-append iso-codes "/share/locale"))
 363             (bindtextdomain "iso_3166-1"          ;territories
 364                             #+(file-append iso-codes "/share/locale"))
 365
 366             ;; Likewise for XKB keyboard layout names.
 367             (bindtextdomain "xkeyboard-config"
 368                             #+(file-append xkeyboard-config "/share/locale"))
 369
 370             ;; Initialize 'terminal-width' in (system repl debug)
 371             ;; to a large-enough value to make backtrace more
 372             ;; verbose.
 373             (terminal-width 200)
 374
 375             (let* ((current-installer newt-installer)
 376                    (steps (#$steps current-installer)))
 377               ((installer-init current-installer))
 378
 379               (catch #t
 380                 (lambda ()
 381                   (define results
 382                     (run-installer-steps
 383                      #:rewind-strategy 'menu
 384                      #:menu-proc (installer-menu-page current-installer)
 385                      #:steps steps))
 386
 387                   (match (result-step results 'final)
 388                     ('success
 389                      ;; We did it!  Let's reboot!
 390                      (sync)
 391                      (stop-service 'root))
 392                     (_                            ;installation failed
 393                      ;; TODO: Honor the result of 'run-install-failed-page'.
 394                      #f)))
 395                 (const #f)
 396                 (lambda (key . args)
 397                   (let ((error-file "/tmp/last-installer-error"))
 398                     (call-with-output-file error-file
 399                       (lambda (port)
 400                         (display-backtrace (make-stack #t) port)
 401                         (print-exception port
 402                                          (stack-ref (make-stack #t) 1)
 403                                          key args)))
 404                     ((installer-exit-error current-installer)
 405                      error-file key args))
 406                   (primitive-exit 1)))
 407
 408               ((installer-exit current-installer)))))))
 409
 410   (program-file
 411    "installer"
 412    #~(begin
 413        ;; Set the default locale to install unicode support.  For
 414        ;; some reason, unicode support is not correctly installed
 415        ;; when calling this in 'installer-builder'.
 416        (setenv "LANG" "en_US.UTF-8")
 417        (execl #$(program-file "installer-real" installer-builder)
 418               "installer-real"))))