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