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 evalutes 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         (#$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          ;; Prompt for users (name, group and home directory).
 270          (installer-step
 271           (id 'user)
 272           (description (G_ "User creation"))
 273           (compute (lambda _
 274                      ((installer-user-page current-installer))))
 275           (configuration-formatter users->configuration))
 276
 277          ;; Ask the user to choose one or many desktop environment(s).
 278          (installer-step
 279           (id 'services)
 280           (description (G_ "Services"))
 281           (compute (lambda _
 282                      ((installer-services-page current-installer))))
 283           (configuration-formatter system-services->configuration))
 284
 285          ;; Run a partitioning tool allowing the user to modify
 286          ;; partition tables, partitions and their mount points.
 287          ;; Do this last so the user has something to boot if any
 288          ;; of the previous steps didn't go as expected.
 289          (installer-step
 290           (id 'partition)
 291           (description (G_ "Partitioning"))
 292           (compute (lambda _
 293                      ((installer-partition-page current-installer))))
 294           (configuration-formatter user-partitions->configuration))
 295
 296          (installer-step
 297           (id 'final)
 298           (description (G_ "Configuration file"))
 299           (compute
 300            (lambda (result prev-steps)
 301              ((installer-final-page current-installer)
 302               result prev-steps))))))))
 303
 304 (define (installer-program)
 305   "Return a file-like object that runs the given INSTALLER."
 306   (define init-gettext
 307     ;; Initialize gettext support, so that installer messages can be
 308     ;; translated.
 309     #~(begin
 310         (bindtextdomain "guix" (string-append #$guix "/share/locale"))
 311         (textdomain "guix")))
 312
 313   (define set-installer-path
 314     ;; Add the specified binary to PATH for later use by the installer.
 315     #~(let* ((inputs
 316               '#$(list bash ;start subshells
 317                        connman ;call connmanctl
 318                        cryptsetup
 319                        dosfstools ;mkfs.fat
 320                        e2fsprogs ;mkfs.ext4
 321                        lvm2-static ;dmsetup
 322                        btrfs-progs
 323                        jfsutils ;jfs_mkfs
 324                        ntfs-3g ;mkfs.ntfs
 325                        kbd ;chvt
 326                        guix ;guix system init call
 327                        util-linux ;mkwap
 328                        shadow
 329                        coreutils)))
 330         (with-output-to-port (%make-void-port "w")
 331           (lambda ()
 332             (set-path-environment-variable "PATH" '("bin" "sbin") inputs)))))
 333
 334   (define steps (installer-steps))
 335   (define modules
 336     (scheme-modules*
 337      (string-append (current-source-directory) "/..")
 338      "gnu/installer"))
 339
 340   (define installer-builder
 341     ;; Note: Include GUIX as an extension to get all the (gnu system …), (gnu
 342     ;; packages …), etc. modules.
 343     (with-extensions (list guile-gcrypt guile-newt
 344                            guile-parted guile-bytestructures
 345                            guile-json-3 guile-git guix)
 346       (with-imported-modules `(,@(source-module-closure
 347                                   `(,@modules
 348                                     (gnu services herd)
 349                                     (guix build utils))
 350                                   #:select? module-to-import?)
 351                                ((guix config) => ,(make-config.scm)))
 352         #~(begin
 353             (use-modules (gnu installer record)
 354                          (gnu installer keymap)
 355                          (gnu installer steps)
 356                          (gnu installer final)
 357                          (gnu installer hostname)
 358                          (gnu installer locale)
 359                          (gnu installer parted)
 360                          (gnu installer services)
 361                          (gnu installer timezone)
 362                          (gnu installer user)
 363                          (gnu installer utils)
 364                          (gnu installer newt)
 365                          ((gnu installer newt keymap)
 366                           #:select (keyboard-layout->configuration))
 367                          (gnu services herd)
 368                          (guix i18n)
 369                          (guix build utils)
 370                          ((system repl debug)
 371                           #:select (terminal-width))
 372                          (ice-9 match))
 373
 374             ;; Initialize gettext support so that installers can use
 375             ;; (guix i18n) module.
 376             #$init-gettext
 377
 378             ;; Add some binaries used by the installers to PATH.
 379             #$set-installer-path
 380
 381             ;; Arrange for language and territory name translations to be
 382             ;; available.  We need them at run time, not just compile time,
 383             ;; because some territories have several corresponding languages
 384             ;; (e.g., "French" is always displayed as "français", but
 385             ;; "Belgium" could be translated to Dutch, French, or German.)
 386             (bindtextdomain "iso_639-3"           ;languages
 387                             #+(file-append iso-codes "/share/locale"))
 388             (bindtextdomain "iso_3166-1"          ;territories
 389                             #+(file-append iso-codes "/share/locale"))
 390
 391             ;; Likewise for XKB keyboard layout names.
 392             (bindtextdomain "xkeyboard-config"
 393                             #+(file-append xkeyboard-config "/share/locale"))
 394
 395             ;; Initialize 'terminal-width' in (system repl debug)
 396             ;; to a large-enough value to make backtrace more
 397             ;; verbose.
 398             (terminal-width 200)
 399
 400             (let* ((current-installer newt-installer)
 401                    (steps (#$steps current-installer)))
 402               ((installer-init current-installer))
 403
 404               (catch #t
 405                 (lambda ()
 406                   (define results
 407                     (run-installer-steps
 408                      #:rewind-strategy 'menu
 409                      #:menu-proc (installer-menu-page current-installer)
 410                      #:steps steps))
 411
 412                   (match (result-step results 'final)
 413                     ('success
 414                      ;; We did it!  Let's reboot!
 415                      (sync)
 416                      (stop-service 'root))
 417                     (_
 418                      ;; The installation failed, exit so that it is restarted
 419                      ;; by login.
 420                      #f)))
 421                 (const #f)
 422                 (lambda (key . args)
 423                   (syslog "crashing due to uncaught exception: ~s ~s~%"
 424                           key args)
 425                   (let ((error-file "/tmp/last-installer-error"))
 426                     (call-with-output-file error-file
 427                       (lambda (port)
 428                         (display-backtrace (make-stack #t) port)
 429                         (print-exception port
 430                                          (stack-ref (make-stack #t) 1)
 431                                          key args)))
 432                     ((installer-exit-error current-installer)
 433                      error-file key args))
 434                   (primitive-exit 1)))
 435
 436               ((installer-exit current-installer)))))))
 437
 438   (program-file
 439    "installer"
 440    #~(begin
 441        ;; Set the default locale to install unicode support.  For
 442        ;; some reason, unicode support is not correctly installed
 443        ;; when calling this in 'installer-builder'.
 444        (setenv "LANG" "en_US.UTF-8")
 445        (execl #$(program-file "installer-real" installer-builder
 446                               #:guile guile-3.0-latest)
 447               "installer-real"))))