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