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