You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

291 lines
12 KiB

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