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