gnu/installer.scm

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