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