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