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