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