gnu/installer.scm

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