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