installer.scm 19 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
  3. ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
  4. ;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
  5. ;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
  6. ;;;
  7. ;;; This file is part of GNU Guix.
  8. ;;;
  9. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  10. ;;; under the terms of the GNU General Public License as published by
  11. ;;; the Free Software Foundation; either version 3 of the License, or (at
  12. ;;; your option) any later version.
  13. ;;;
  14. ;;; GNU Guix is distributed in the hope that it will be useful, but
  15. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  17. ;;; GNU General Public License for more details.
  18. ;;;
  19. ;;; You should have received a copy of the GNU General Public License
  20. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  21. (define-module (gnu installer)
  22. #:use-module (guix discovery)
  23. #:use-module (guix packages)
  24. #:use-module (guix gexp)
  25. #:use-module (guix modules)
  26. #:use-module (guix utils)
  27. #:use-module (guix ui)
  28. #:use-module ((guix self) #:select (make-config.scm))
  29. #:use-module (guix packages)
  30. #:use-module (guix git-download)
  31. #:use-module (gnu installer utils)
  32. #:use-module (gnu packages admin)
  33. #:use-module (gnu packages base)
  34. #:use-module (gnu packages bash)
  35. #:use-module (gnu packages connman)
  36. #:use-module (gnu packages cryptsetup)
  37. #:use-module (gnu packages disk)
  38. #:use-module (gnu packages file-systems)
  39. #:use-module (gnu packages guile)
  40. #:use-module (gnu packages guile-xyz)
  41. #:autoload (gnu packages gnupg) (guile-gcrypt)
  42. #:use-module (gnu packages iso-codes)
  43. #:use-module (gnu packages linux)
  44. #:use-module (gnu packages ncurses)
  45. #:use-module (gnu packages package-management)
  46. #:use-module (gnu packages xorg)
  47. #:use-module (gnu system locale)
  48. #:use-module (ice-9 match)
  49. #:use-module (srfi srfi-1)
  50. #:export (installer-program))
  51. (define module-to-import?
  52. ;; Return true for modules that should be imported. For (gnu system …) and
  53. ;; (gnu packages …) modules, we simply add the whole 'guix' package via
  54. ;; 'with-extensions' (to avoid having to rebuild it all), which is why these
  55. ;; modules are excluded here.
  56. (match-lambda
  57. (('guix 'config) #f)
  58. (('gnu 'installer _ ...) #t)
  59. (('gnu 'build _ ...) #t)
  60. (('guix 'build _ ...) #t)
  61. (_ #f)))
  62. (define not-config?
  63. ;; Select (guix …) and (gnu …) modules, except (guix config).
  64. (match-lambda
  65. (('guix 'config) #f)
  66. (('guix _ ...) #t)
  67. (('gnu _ ...) #t)
  68. (_ #f)))
  69. (define* (build-compiled-file name locale-builder)
  70. "Return a file-like object that evaluates the gexp LOCALE-BUILDER and store
  71. its result in the scheme file NAME. The derivation will also build a compiled
  72. version of this file."
  73. (define set-utf8-locale
  74. #~(begin
  75. (setenv "LOCPATH"
  76. #$(file-append glibc-utf8-locales "/lib/locale/"
  77. (version-major+minor
  78. (package-version glibc-utf8-locales))))
  79. (setlocale LC_ALL "en_US.utf8")))
  80. (define builder
  81. (with-extensions (list guile-json-3)
  82. (with-imported-modules `(,@(source-module-closure
  83. '((gnu installer locale))
  84. #:select? not-config?)
  85. ((guix config) => ,(make-config.scm)))
  86. #~(begin
  87. (use-modules (gnu installer locale))
  88. ;; The locale files contain non-ASCII characters.
  89. #$set-utf8-locale
  90. (mkdir #$output)
  91. (let ((locale-file
  92. (string-append #$output "/" #$name ".scm"))
  93. (locale-compiled-file
  94. (string-append #$output "/" #$name ".go")))
  95. (call-with-output-file locale-file
  96. (lambda (port)
  97. (write #$locale-builder port)))
  98. (compile-file locale-file
  99. #:output-file locale-compiled-file))))))
  100. (computed-file name builder))
  101. (define apply-locale
  102. ;; Install the specified locale.
  103. (with-imported-modules (source-module-closure '((gnu services herd)))
  104. #~(lambda (locale)
  105. (false-if-exception
  106. (setlocale LC_ALL locale))
  107. ;; Restart the documentation viewer so it displays the manual in
  108. ;; language that corresponds to LOCALE. Make sure that nothing is
  109. ;; printed on the console.
  110. (parameterize ((shepherd-message-port
  111. (%make-void-port "w")))
  112. (stop-service 'term-tty2)
  113. (start-service 'term-tty2 (list locale))))))
  114. (define* (compute-locale-step #:key
  115. locales-name
  116. iso639-languages-name
  117. iso3166-territories-name)
  118. "Return a gexp that run the locale-page of INSTALLER, and install the
  119. selected locale. The list of locales, languages and territories passed to
  120. locale-page are computed in derivations named respectively LOCALES-NAME,
  121. ISO639-LANGUAGES-NAME and ISO3166-TERRITORIES-NAME. Those lists are compiled,
  122. so that when the installer is run, all the lengthy operations have already
  123. been performed at build time."
  124. (define (compiled-file-loader file name)
  125. #~(load-compiled
  126. (string-append #$file "/" #$name ".go")))
  127. (let* ((supported-locales #~(supported-locales->locales
  128. #+(glibc-supported-locales)))
  129. (iso-codes #~(string-append #$iso-codes "/share/iso-codes/json/"))
  130. (iso639-3 #~(string-append #$iso-codes "iso_639-3.json"))
  131. (iso639-5 #~(string-append #$iso-codes "iso_639-5.json"))
  132. (iso3166 #~(string-append #$iso-codes "iso_3166-1.json"))
  133. (locales-file (build-compiled-file
  134. locales-name
  135. #~`(quote ,#$supported-locales)))
  136. (iso639-file (build-compiled-file
  137. iso639-languages-name
  138. #~`(quote ,(iso639->iso639-languages
  139. #$supported-locales
  140. #$iso639-3 #$iso639-5))))
  141. (iso3166-file (build-compiled-file
  142. iso3166-territories-name
  143. #~`(quote ,(iso3166->iso3166-territories #$iso3166))))
  144. (locales-loader (compiled-file-loader locales-file
  145. locales-name))
  146. (iso639-loader (compiled-file-loader iso639-file
  147. iso639-languages-name))
  148. (iso3166-loader (compiled-file-loader iso3166-file
  149. iso3166-territories-name)))
  150. #~(lambda (current-installer)
  151. (let ((result
  152. ((installer-locale-page current-installer)
  153. #:supported-locales #$locales-loader
  154. #:iso639-languages #$iso639-loader
  155. #:iso3166-territories #$iso3166-loader)))
  156. (#$apply-locale result)
  157. result))))
  158. (define apply-keymap
  159. ;; Apply the specified keymap. Use the default keyboard model.
  160. #~(match-lambda
  161. ((layout variant options)
  162. (kmscon-update-keymap (default-keyboard-model)
  163. layout variant options))))
  164. (define* (compute-keymap-step context)
  165. "Return a gexp that runs the keymap-page of INSTALLER and install the
  166. selected keymap."
  167. #~(lambda (current-installer)
  168. (let ((result
  169. (call-with-values
  170. (lambda ()
  171. (xkb-rules->models+layouts
  172. (string-append #$xkeyboard-config
  173. "/share/X11/xkb/rules/base.xml")))
  174. (lambda (models layouts)
  175. ((installer-keymap-page current-installer)
  176. layouts '#$context)))))
  177. (and result (#$apply-keymap result))
  178. result)))
  179. (define (installer-steps)
  180. (let ((locale-step (compute-locale-step
  181. #:locales-name "locales"
  182. #:iso639-languages-name "iso639-languages"
  183. #:iso3166-territories-name "iso3166-territories"))
  184. (timezone-data #~(string-append #$tzdata
  185. "/share/zoneinfo/zone.tab")))
  186. #~(lambda (current-installer)
  187. ((installer-parameters-menu current-installer)
  188. (lambda ()
  189. ((installer-parameters-page current-installer)
  190. (lambda _
  191. (#$(compute-keymap-step 'param)
  192. current-installer)))))
  193. (list
  194. ;; Ask the user to choose a locale among those supported by
  195. ;; the glibc. Install the selected locale right away, so that
  196. ;; the user may benefit from any available translation for the
  197. ;; installer messages.
  198. (installer-step
  199. (id 'locale)
  200. (description (G_ "Locale"))
  201. (compute (lambda _
  202. (#$locale-step current-installer)))
  203. (configuration-formatter locale->configuration))
  204. ;; Welcome the user and ask them to choose between manual
  205. ;; installation and graphical install.
  206. (installer-step
  207. (id 'welcome)
  208. (compute (lambda _
  209. ((installer-welcome-page current-installer)
  210. #$(local-file "installer/aux-files/logo.txt")))))
  211. ;; Ask the user to select a timezone under glibc format.
  212. (installer-step
  213. (id 'timezone)
  214. (description (G_ "Timezone"))
  215. (compute (lambda _
  216. ((installer-timezone-page current-installer)
  217. #$timezone-data)))
  218. (configuration-formatter posix-tz->configuration))
  219. ;; The installer runs in a kmscon virtual terminal where loadkeys
  220. ;; won't work. kmscon uses libxkbcommon as a backend for keyboard
  221. ;; input. It is possible to update kmscon current keymap by sending
  222. ;; it a keyboard model, layout, variant and options, in a somehow
  223. ;; similar way as what is done with setxkbmap utility.
  224. ;;
  225. ;; So ask for a keyboard model, layout and variant to update the
  226. ;; current kmscon keymap. For non-Latin layouts, we add an
  227. ;; appropriate second layout and toggle via Alt+Shift.
  228. (installer-step
  229. (id 'keymap)
  230. (description (G_ "Keyboard mapping selection"))
  231. (compute (lambda _
  232. (#$(compute-keymap-step 'default)
  233. current-installer)))
  234. (configuration-formatter keyboard-layout->configuration))
  235. ;; Ask the user to input a hostname for the system.
  236. (installer-step
  237. (id 'hostname)
  238. (description (G_ "Hostname"))
  239. (compute (lambda _
  240. ((installer-hostname-page current-installer))))
  241. (configuration-formatter hostname->configuration))
  242. ;; Provide an interface above connmanctl, so that the user can select
  243. ;; a network susceptible to acces Internet.
  244. (installer-step
  245. (id 'network)
  246. (description (G_ "Network selection"))
  247. (compute (lambda _
  248. ((installer-network-page current-installer)))))
  249. ;; Ask whether to enable substitute server discovery.
  250. (installer-step
  251. (id 'substitutes)
  252. (description (G_ "Substitute server discovery"))
  253. (compute (lambda _
  254. ((installer-substitutes-page current-installer)))))
  255. ;; Prompt for users (name, group and home directory).
  256. (installer-step
  257. (id 'user)
  258. (description (G_ "User creation"))
  259. (compute (lambda _
  260. ((installer-user-page current-installer))))
  261. (configuration-formatter users->configuration))
  262. ;; Ask the user to choose one or many desktop environment(s).
  263. (installer-step
  264. (id 'services)
  265. (description (G_ "Services"))
  266. (compute (lambda _
  267. ((installer-services-page current-installer))))
  268. (configuration-formatter system-services->configuration))
  269. ;; Run a partitioning tool allowing the user to modify
  270. ;; partition tables, partitions and their mount points.
  271. ;; Do this last so the user has something to boot if any
  272. ;; of the previous steps didn't go as expected.
  273. (installer-step
  274. (id 'partition)
  275. (description (G_ "Partitioning"))
  276. (compute (lambda _
  277. ((installer-partition-page current-installer))))
  278. (configuration-formatter user-partitions->configuration))
  279. (installer-step
  280. (id 'final)
  281. (description (G_ "Configuration file"))
  282. (compute
  283. (lambda (result prev-steps)
  284. ((installer-final-page current-installer)
  285. result prev-steps))))))))
  286. (define (installer-program)
  287. "Return a file-like object that runs the given INSTALLER."
  288. (define init-gettext
  289. ;; Initialize gettext support, so that installer messages can be
  290. ;; translated.
  291. #~(begin
  292. (bindtextdomain "guix" (string-append #$guix "/share/locale"))
  293. (textdomain "guix")
  294. (setlocale LC_ALL "")))
  295. (define set-installer-path
  296. ;; Add the specified binary to PATH for later use by the installer.
  297. #~(let* ((inputs
  298. '#$(list bash ;start subshells
  299. connman ;call connmanctl
  300. cryptsetup
  301. dosfstools ;mkfs.fat
  302. e2fsprogs ;mkfs.ext4
  303. lvm2-static ;dmsetup
  304. btrfs-progs
  305. jfsutils ;jfs_mkfs
  306. ntfs-3g ;mkfs.ntfs
  307. kbd ;chvt
  308. guix ;guix system init call
  309. util-linux ;mkwap
  310. shadow
  311. coreutils)))
  312. (with-output-to-port (%make-void-port "w")
  313. (lambda ()
  314. (set-path-environment-variable "PATH" '("bin" "sbin") inputs)))))
  315. (define steps (installer-steps))
  316. (define modules
  317. (scheme-modules*
  318. (string-append (current-source-directory) "/..")
  319. "gnu/installer"))
  320. (define installer-builder
  321. ;; Note: Include GUIX as an extension to get all the (gnu system …), (gnu
  322. ;; packages …), etc. modules.
  323. (with-extensions (list guile-gcrypt guile-newt
  324. guile-parted guile-bytestructures
  325. guile-json-3 guile-git guix)
  326. (with-imported-modules `(,@(source-module-closure
  327. `(,@modules
  328. (gnu services herd)
  329. (guix build utils))
  330. #:select? module-to-import?)
  331. ((guix config) => ,(make-config.scm)))
  332. #~(begin
  333. (use-modules (gnu installer record)
  334. (gnu installer keymap)
  335. (gnu installer steps)
  336. (gnu installer final)
  337. (gnu installer hostname)
  338. (gnu installer locale)
  339. (gnu installer parted)
  340. (gnu installer services)
  341. (gnu installer timezone)
  342. (gnu installer user)
  343. (gnu installer utils)
  344. (gnu installer newt)
  345. ((gnu installer newt keymap)
  346. #:select (keyboard-layout->configuration))
  347. (gnu services herd)
  348. (guix i18n)
  349. (guix build utils)
  350. ((system repl debug)
  351. #:select (terminal-width))
  352. (ice-9 match))
  353. ;; Initialize gettext support so that installers can use
  354. ;; (guix i18n) module.
  355. #$init-gettext
  356. ;; Add some binaries used by the installers to PATH.
  357. #$set-installer-path
  358. ;; Arrange for language and territory name translations to be
  359. ;; available. We need them at run time, not just compile time,
  360. ;; because some territories have several corresponding languages
  361. ;; (e.g., "French" is always displayed as "français", but
  362. ;; "Belgium" could be translated to Dutch, French, or German.)
  363. (bindtextdomain "iso_639-3" ;languages
  364. #+(file-append iso-codes "/share/locale"))
  365. (bindtextdomain "iso_3166-1" ;territories
  366. #+(file-append iso-codes "/share/locale"))
  367. ;; Likewise for XKB keyboard layout names.
  368. (bindtextdomain "xkeyboard-config"
  369. #+(file-append xkeyboard-config "/share/locale"))
  370. ;; Initialize 'terminal-width' in (system repl debug)
  371. ;; to a large-enough value to make backtrace more
  372. ;; verbose.
  373. (terminal-width 200)
  374. (let* ((current-installer newt-installer)
  375. (steps (#$steps current-installer)))
  376. ((installer-init current-installer))
  377. (catch #t
  378. (lambda ()
  379. (define results
  380. (run-installer-steps
  381. #:rewind-strategy 'menu
  382. #:menu-proc (installer-menu-page current-installer)
  383. #:steps steps))
  384. (match (result-step results 'final)
  385. ('success
  386. ;; We did it! Let's reboot!
  387. (sync)
  388. (stop-service 'root))
  389. (_
  390. ;; The installation failed, exit so that it is restarted
  391. ;; by login.
  392. #f)))
  393. (const #f)
  394. (lambda (key . args)
  395. (syslog "crashing due to uncaught exception: ~s ~s~%"
  396. key args)
  397. (let ((error-file "/tmp/last-installer-error"))
  398. (call-with-output-file error-file
  399. (lambda (port)
  400. (display-backtrace (make-stack #t) port)
  401. (print-exception port
  402. (stack-ref (make-stack #t) 1)
  403. key args)))
  404. ((installer-exit-error current-installer)
  405. error-file key args))
  406. (primitive-exit 1)))
  407. ((installer-exit current-installer)))))))
  408. (program-file
  409. "installer"
  410. #~(begin
  411. ;; Set the default locale to install unicode support. For
  412. ;; some reason, unicode support is not correctly installed
  413. ;; when calling this in 'installer-builder'.
  414. (setenv "LANG" "en_US.UTF-8")
  415. (execl #$(program-file "installer-real" installer-builder
  416. #:guile guile-3.0-latest)
  417. "installer-real"))))