summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--configure.ac6
-rw-r--r--gnu/installer.scm111
-rw-r--r--gnu/installer/aux-files/SUPPORTED484
-rw-r--r--gnu/installer/aux-files/logo.txt19
-rw-r--r--gnu/installer/build-installer.scm290
-rw-r--r--gnu/installer/connman.scm400
-rw-r--r--gnu/installer/keymap.scm162
-rw-r--r--gnu/installer/locale.scm199
-rw-r--r--gnu/installer/newt.scm102
-rw-r--r--gnu/installer/newt/ethernet.scm80
-rw-r--r--gnu/installer/newt/hostname.scm26
-rw-r--r--gnu/installer/newt/keymap.scm132
-rw-r--r--gnu/installer/newt/locale.scm193
-rw-r--r--gnu/installer/newt/menu.scm44
-rw-r--r--gnu/installer/newt/network.scm159
-rw-r--r--gnu/installer/newt/page.scm313
-rw-r--r--gnu/installer/newt/timezone.scm83
-rw-r--r--gnu/installer/newt/user.scm181
-rw-r--r--gnu/installer/newt/utils.scm43
-rw-r--r--gnu/installer/newt/welcome.scm122
-rw-r--r--gnu/installer/newt/wifi.scm243
-rw-r--r--gnu/installer/steps.scm187
-rw-r--r--gnu/installer/timezone.scm117
-rw-r--r--gnu/installer/utils.scm37
-rw-r--r--gnu/local.mk22
-rw-r--r--gnu/system.scm1
-rw-r--r--gnu/system/install.scm246
-rw-r--r--po/guix/POTFILES.in21
28 files changed, 3904 insertions, 119 deletions
diff --git a/configure.ac b/configure.ac
index 891fce28ae7..83a9b87d77e 100644
--- a/configure.ac
+++ b/configure.ac
@@ -135,6 +135,12 @@ if test "x$have_guile_gcrypt" != "xyes"; then
135 AC_MSG_ERROR([Guile-Gcrypt could not be found; please install it.]) 135 AC_MSG_ERROR([Guile-Gcrypt could not be found; please install it.])
136fi 136fi
137 137
138dnl Guile-newt is used by the graphical installer.
139GUILE_MODULE_AVAILABLE([have_guile_newt], [(newt)])
140if test "x$have_guile_newt" != "xyes"; then
141 AC_MSG_ERROR([Guile-newt could not be found; please install it.])
142fi
143
138dnl Make sure we have a full-fledged Guile. 144dnl Make sure we have a full-fledged Guile.
139GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads]) 145GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads])
140 146
diff --git a/gnu/installer.scm b/gnu/installer.scm
new file mode 100644
index 00000000000..f3323ea3bcd
--- /dev/null
+++ b/gnu/installer.scm
@@ -0,0 +1,111 @@
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 records)
22 #:use-module (guix ui)
23 #:use-module (srfi srfi-1)
24 #:export (<installer>
25 installer
26 make-installer
27 installer?
28 installer-name
29 installer-modules
30 installer-init
31 installer-exit
32 installer-exit-error
33 installer-keymap-page
34 installer-locale-page
35 installer-menu-page
36 installer-network-page
37 installer-timezone-page
38 installer-hostname-page
39 installer-user-page
40 installer-welcome-page
41
42 %installers
43 lookup-installer-by-name))
44
45
46;;;
47;;; Installer record.
48;;;
49
50;; The <installer> record contains pages that will be run to prompt the user
51;; for the system configuration. The goal of the installer is to produce a
52;; complete <operating-system> record and install it.
53
54(define-record-type* <installer>
55 installer make-installer
56 installer?
57 ;; symbol
58 (name installer-name)
59 ;; list of installer modules
60 (modules installer-modules)
61 ;; procedure: void -> void
62 (init installer-init)
63 ;; procedure: void -> void
64 (exit installer-exit)
65 ;; procedure (key arguments) -> void
66 (exit-error installer-exit-error)
67 ;; procedure (#:key models layouts) -> (list model layout variant)
68 (keymap-page installer-keymap-page)
69 ;; procedure: (#:key supported-locales iso639-languages iso3166-territories)
70 ;; -> glibc-locale
71 (locale-page installer-locale-page)
72 ;; procedure: (steps) -> step-id
73 (menu-page installer-menu-page)
74 ;; procedure void -> void
75 (network-page installer-network-page)
76 ;; procedure (zonetab) -> posix-timezone
77 (timezone-page installer-timezone-page)
78 ;; procedure void -> void
79 (hostname-page installer-hostname-page)
80 ;; procedure void -> void
81 (user-page installer-user-page)
82 ;; procedure (logo) -> void
83 (welcome-page installer-welcome-page))
84
85
86;;;
87;;; Installers.
88;;;
89
90(define (installer-top-modules)
91 "Return the list of installer modules."
92 (all-modules (map (lambda (entry)
93 `(,entry . "gnu/installer"))
94 %load-path)
95 #:warn warn-about-load-error))
96
97(define %installers
98 ;; The list of publically-known installers.
99 (delay (fold-module-public-variables (lambda (obj result)
100 (if (installer? obj)
101 (cons obj result)
102 result))
103 '()
104 (installer-top-modules))))
105
106(define (lookup-installer-by-name name)
107 "Return the installer called NAME."
108 (or (find (lambda (installer)
109 (eq? name (installer-name installer)))
110 (force %installers))
111 (leave (G_ "~a: no such installer~%") name)))
diff --git a/gnu/installer/aux-files/SUPPORTED b/gnu/installer/aux-files/SUPPORTED
new file mode 100644
index 00000000000..24aae1e089f
--- /dev/null
+++ b/gnu/installer/aux-files/SUPPORTED
@@ -0,0 +1,484 @@
1aa_DJ.UTF-8 UTF-8
2aa_DJ ISO-8859-1
3aa_ER UTF-8
4aa_ER@saaho UTF-8
5aa_ET UTF-8
6af_ZA.UTF-8 UTF-8
7af_ZA ISO-8859-1
8agr_PE UTF-8
9ak_GH UTF-8
10am_ET UTF-8
11an_ES.UTF-8 UTF-8
12an_ES ISO-8859-15
13anp_IN UTF-8
14ar_AE.UTF-8 UTF-8
15ar_AE ISO-8859-6
16ar_BH.UTF-8 UTF-8
17ar_BH ISO-8859-6
18ar_DZ.UTF-8 UTF-8
19ar_DZ ISO-8859-6
20ar_EG.UTF-8 UTF-8
21ar_EG ISO-8859-6
22ar_IN UTF-8
23ar_IQ.UTF-8 UTF-8
24ar_IQ ISO-8859-6
25ar_JO.UTF-8 UTF-8
26ar_JO ISO-8859-6
27ar_KW.UTF-8 UTF-8
28ar_KW ISO-8859-6
29ar_LB.UTF-8 UTF-8
30ar_LB ISO-8859-6
31ar_LY.UTF-8 UTF-8
32ar_LY ISO-8859-6
33ar_MA.UTF-8 UTF-8
34ar_MA ISO-8859-6
35ar_OM.UTF-8 UTF-8
36ar_OM ISO-8859-6
37ar_QA.UTF-8 UTF-8
38ar_QA ISO-8859-6
39ar_SA.UTF-8 UTF-8
40ar_SA ISO-8859-6
41ar_SD.UTF-8 UTF-8
42ar_SD ISO-8859-6
43ar_SS UTF-8
44ar_SY.UTF-8 UTF-8
45ar_SY ISO-8859-6
46ar_TN.UTF-8 UTF-8
47ar_TN ISO-8859-6
48ar_YE.UTF-8 UTF-8
49ar_YE ISO-8859-6
50ayc_PE UTF-8
51az_AZ UTF-8
52az_IR UTF-8
53as_IN UTF-8
54ast_ES.UTF-8 UTF-8
55ast_ES ISO-8859-15
56be_BY.UTF-8 UTF-8
57be_BY CP1251
58be_BY@latin UTF-8
59bem_ZM UTF-8
60ber_DZ UTF-8
61ber_MA UTF-8
62bg_BG.UTF-8 UTF-8
63bg_BG CP1251
64bhb_IN.UTF-8 UTF-8
65bho_IN UTF-8
66bho_NP UTF-8
67bi_VU UTF-8
68bn_BD UTF-8
69bn_IN UTF-8
70bo_CN UTF-8
71bo_IN UTF-8
72br_FR.UTF-8 UTF-8
73br_FR ISO-8859-1
74br_FR@euro ISO-8859-15
75brx_IN UTF-8
76bs_BA.UTF-8 UTF-8
77bs_BA ISO-8859-2
78byn_ER UTF-8
79ca_AD.UTF-8 UTF-8
80ca_AD ISO-8859-15
81ca_ES.UTF-8 UTF-8
82ca_ES ISO-8859-1
83ca_ES@euro ISO-8859-15
84ca_ES@valencia UTF-8
85ca_FR.UTF-8 UTF-8
86ca_FR ISO-8859-15
87ca_IT.UTF-8 UTF-8
88ca_IT ISO-8859-15
89ce_RU UTF-8
90chr_US UTF-8
91cmn_TW UTF-8
92crh_UA UTF-8
93cs_CZ.UTF-8 UTF-8
94cs_CZ ISO-8859-2
95csb_PL UTF-8
96cv_RU UTF-8
97cy_GB.UTF-8 UTF-8
98cy_GB ISO-8859-14
99da_DK.UTF-8 UTF-8
100da_DK ISO-8859-1
101de_AT.UTF-8 UTF-8
102de_AT ISO-8859-1
103de_AT@euro ISO-8859-15
104de_BE.UTF-8 UTF-8
105de_BE ISO-8859-1
106de_BE@euro ISO-8859-15
107de_CH.UTF-8 UTF-8
108de_CH ISO-8859-1
109de_DE.UTF-8 UTF-8
110de_DE ISO-8859-1
111de_DE@euro ISO-8859-15
112de_IT.UTF-8 UTF-8
113de_IT ISO-8859-1
114de_LI.UTF-8 UTF-8
115de_LU.UTF-8 UTF-8
116de_LU ISO-8859-1
117de_LU@euro ISO-8859-15
118doi_IN UTF-8
119dv_MV UTF-8
120dz_BT UTF-8
121el_GR.UTF-8 UTF-8
122el_GR ISO-8859-7
123el_GR@euro ISO-8859-7
124el_CY.UTF-8 UTF-8
125el_CY ISO-8859-7
126en_AG UTF-8
127en_AU.UTF-8 UTF-8
128en_AU ISO-8859-1
129en_BW.UTF-8 UTF-8
130en_BW ISO-8859-1
131en_CA.UTF-8 UTF-8
132en_CA ISO-8859-1
133en_DK.UTF-8 UTF-8
134en_DK ISO-8859-1
135en_GB.UTF-8 UTF-8
136en_GB ISO-8859-1
137en_HK.UTF-8 UTF-8
138en_HK ISO-8859-1
139en_IE.UTF-8 UTF-8
140en_IE ISO-8859-1
141en_IE@euro ISO-8859-15
142en_IL UTF-8
143en_IN UTF-8
144en_NG UTF-8
145en_NZ.UTF-8 UTF-8
146en_NZ ISO-8859-1
147en_PH.UTF-8 UTF-8
148en_PH ISO-8859-1
149en_SC.UTF-8 UTF-8
150en_SG.UTF-8 UTF-8
151en_SG ISO-8859-1
152en_US.UTF-8 UTF-8
153en_US ISO-8859-1
154en_ZA.UTF-8 UTF-8
155en_ZA ISO-8859-1
156en_ZM UTF-8
157en_ZW.UTF-8 UTF-8
158en_ZW ISO-8859-1
159eo UTF-8
160es_AR.UTF-8 UTF-8
161es_AR ISO-8859-1
162es_BO.UTF-8 UTF-8
163es_BO ISO-8859-1
164es_CL.UTF-8 UTF-8
165es_CL ISO-8859-1
166es_CO.UTF-8 UTF-8
167es_CO ISO-8859-1
168es_CR.UTF-8 UTF-8
169es_CR ISO-8859-1
170es_CU UTF-8
171es_DO.UTF-8 UTF-8
172es_DO ISO-8859-1
173es_EC.UTF-8 UTF-8
174es_EC ISO-8859-1
175es_ES.UTF-8 UTF-8
176es_ES ISO-8859-1
177es_ES@euro ISO-8859-15
178es_GT.UTF-8 UTF-8
179es_GT ISO-8859-1
180es_HN.UTF-8 UTF-8
181es_HN ISO-8859-1
182es_MX.UTF-8 UTF-8
183es_MX ISO-8859-1
184es_NI.UTF-8 UTF-8
185es_NI ISO-8859-1
186es_PA.UTF-8 UTF-8
187es_PA ISO-8859-1
188es_PE.UTF-8 UTF-8
189es_PE ISO-8859-1
190es_PR.UTF-8 UTF-8
191es_PR ISO-8859-1
192es_PY.UTF-8 UTF-8
193es_PY ISO-8859-1
194es_SV.UTF-8 UTF-8
195es_SV ISO-8859-1
196es_US.UTF-8 UTF-8
197es_US ISO-8859-1
198es_UY.UTF-8 UTF-8
199es_UY ISO-8859-1
200es_VE.UTF-8 UTF-8
201es_VE ISO-8859-1
202et_EE.UTF-8 UTF-8
203et_EE ISO-8859-1
204et_EE.ISO-8859-15 ISO-8859-15
205eu_ES.UTF-8 UTF-8
206eu_ES ISO-8859-1
207eu_ES@euro ISO-8859-15
208fa_IR UTF-8
209ff_SN UTF-8
210fi_FI.UTF-8 UTF-8
211fi_FI ISO-8859-1
212fi_FI@euro ISO-8859-15
213fil_PH UTF-8
214fo_FO.UTF-8 UTF-8
215fo_FO ISO-8859-1
216fr_BE.UTF-8 UTF-8
217fr_BE ISO-8859-1
218fr_BE@euro ISO-8859-15
219fr_CA.UTF-8 UTF-8
220fr_CA ISO-8859-1
221fr_CH.UTF-8 UTF-8
222fr_CH ISO-8859-1
223fr_FR.UTF-8 UTF-8
224fr_FR ISO-8859-1
225fr_FR@euro ISO-8859-15
226fr_LU.UTF-8 UTF-8
227fr_LU ISO-8859-1
228fr_LU@euro ISO-8859-15
229fur_IT UTF-8
230fy_NL UTF-8
231fy_DE UTF-8
232ga_IE.UTF-8 UTF-8
233ga_IE ISO-8859-1
234ga_IE@euro ISO-8859-15
235gd_GB.UTF-8 UTF-8
236gd_GB ISO-8859-15
237gez_ER UTF-8
238gez_ER@abegede UTF-8
239gez_ET UTF-8
240gez_ET@abegede UTF-8
241gl_ES.UTF-8 UTF-8
242gl_ES ISO-8859-1
243gl_ES@euro ISO-8859-15
244gu_IN UTF-8
245gv_GB.UTF-8 UTF-8
246gv_GB ISO-8859-1
247ha_NG UTF-8
248hak_TW UTF-8
249he_IL.UTF-8 UTF-8
250he_IL ISO-8859-8
251hi_IN UTF-8
252hif_FJ UTF-8
253hne_IN UTF-8
254hr_HR.UTF-8 UTF-8
255hr_HR ISO-8859-2
256hsb_DE ISO-8859-2
257hsb_DE.UTF-8 UTF-8
258ht_HT UTF-8
259hu_HU.UTF-8 UTF-8
260hu_HU ISO-8859-2
261hy_AM UTF-8
262hy_AM.ARMSCII-8 ARMSCII-8
263ia_FR UTF-8
264id_ID.UTF-8 UTF-8
265id_ID ISO-8859-1
266ig_NG UTF-8
267ik_CA UTF-8
268is_IS.UTF-8 UTF-8
269is_IS ISO-8859-1
270it_CH.UTF-8 UTF-8
271it_CH ISO-8859-1
272it_IT.UTF-8 UTF-8
273it_IT ISO-8859-1
274it_IT@euro ISO-8859-15
275iu_CA UTF-8
276ja_JP.EUC-JP EUC-JP
277ja_JP.UTF-8 UTF-8
278ka_GE.UTF-8 UTF-8
279ka_GE GEORGIAN-PS
280kab_DZ UTF-8
281kk_KZ.UTF-8 UTF-8
282kk_KZ PT154
283kl_GL.UTF-8 UTF-8
284kl_GL ISO-8859-1
285km_KH UTF-8
286kn_IN UTF-8
287ko_KR.EUC-KR EUC-KR
288ko_KR.UTF-8 UTF-8
289kok_IN UTF-8
290ks_IN UTF-8
291ks_IN@devanagari UTF-8
292ku_TR.UTF-8 UTF-8
293ku_TR ISO-8859-9
294kw_GB.UTF-8 UTF-8
295kw_GB ISO-8859-1
296ky_KG UTF-8
297lb_LU UTF-8
298lg_UG.UTF-8 UTF-8
299lg_UG ISO-8859-10
300li_BE UTF-8
301li_NL UTF-8
302lij_IT UTF-8
303ln_CD UTF-8
304lo_LA UTF-8
305lt_LT.UTF-8 UTF-8
306lt_LT ISO-8859-13
307lv_LV.UTF-8 UTF-8
308lv_LV ISO-8859-13
309lzh_TW UTF-8
310mag_IN UTF-8
311mai_IN UTF-8
312mai_NP UTF-8
313mfe_MU UTF-8
314mg_MG.UTF-8 UTF-8
315mg_MG ISO-8859-15
316mhr_RU UTF-8
317mi_NZ.UTF-8 UTF-8
318mi_NZ ISO-8859-13
319miq_NI UTF-8
320mjw_IN UTF-8
321mk_MK.UTF-8 UTF-8
322mk_MK ISO-8859-5
323ml_IN UTF-8
324mn_MN UTF-8
325mni_IN UTF-8
326mr_IN UTF-8
327ms_MY.UTF-8 UTF-8
328ms_MY ISO-8859-1
329mt_MT.UTF-8 UTF-8
330mt_MT ISO-8859-3
331my_MM UTF-8
332nan_TW UTF-8
333nan_TW@latin UTF-8
334nb_NO.UTF-8 UTF-8
335nb_NO ISO-8859-1
336nds_DE UTF-8
337nds_NL UTF-8
338ne_NP UTF-8
339nhn_MX UTF-8
340niu_NU UTF-8
341niu_NZ UTF-8
342nl_AW UTF-8
343nl_BE.UTF-8 UTF-8
344nl_BE ISO-8859-1
345nl_BE@euro ISO-8859-15
346nl_NL.UTF-8 UTF-8
347nl_NL ISO-8859-1
348nl_NL@euro ISO-8859-15
349nn_NO.UTF-8 UTF-8
350nn_NO ISO-8859-1
351nr_ZA UTF-8
352nso_ZA UTF-8
353oc_FR.UTF-8 UTF-8
354oc_FR ISO-8859-1
355om_ET UTF-8
356om_KE.UTF-8 UTF-8
357om_KE ISO-8859-1
358or_IN UTF-8
359os_RU UTF-8
360pa_IN UTF-8
361pa_PK UTF-8
362pap_AW UTF-8
363pap_CW UTF-8
364pl_PL.UTF-8 UTF-8
365pl_PL ISO-8859-2
366ps_AF UTF-8
367pt_BR.UTF-8 UTF-8
368pt_BR ISO-8859-1
369pt_PT.UTF-8 UTF-8
370pt_PT ISO-8859-1
371pt_PT@euro ISO-8859-15
372quz_PE UTF-8
373raj_IN UTF-8
374ro_RO.UTF-8 UTF-8
375ro_RO ISO-8859-2
376ru_RU.KOI8-R KOI8-R
377ru_RU.UTF-8 UTF-8
378ru_RU ISO-8859-5
379ru_UA.UTF-8 UTF-8
380ru_UA KOI8-U
381rw_RW UTF-8
382sa_IN UTF-8
383sat_IN UTF-8
384sc_IT UTF-8
385sd_IN UTF-8
386sd_IN@devanagari UTF-8
387se_NO UTF-8
388sgs_LT UTF-8
389shn_MM UTF-8
390shs_CA UTF-8
391si_LK UTF-8
392sid_ET UTF-8
393sk_SK.UTF-8 UTF-8
394sk_SK ISO-8859-2
395sl_SI.UTF-8 UTF-8
396sl_SI ISO-8859-2
397sm_WS UTF-8
398so_DJ.UTF-8 UTF-8
399so_DJ ISO-8859-1
400so_ET UTF-8
401so_KE.UTF-8 UTF-8
402so_KE ISO-8859-1
403so_SO.UTF-8 UTF-8
404so_SO ISO-8859-1
405sq_AL.UTF-8 UTF-8
406sq_AL ISO-8859-1
407sq_MK UTF-8
408sr_ME UTF-8
409sr_RS UTF-8
410sr_RS@latin UTF-8
411ss_ZA UTF-8
412st_ZA.UTF-8 UTF-8
413st_ZA ISO-8859-1
414sv_FI.UTF-8 UTF-8
415sv_FI ISO-8859-1
416sv_FI@euro ISO-8859-15
417sv_SE.UTF-8 UTF-8
418sv_SE ISO-8859-1
419sw_KE UTF-8
420sw_TZ UTF-8
421szl_PL UTF-8
422ta_IN UTF-8
423ta_LK UTF-8
424tcy_IN.UTF-8 UTF-8
425te_IN UTF-8
426tg_TJ.UTF-8 UTF-8
427tg_TJ KOI8-T
428th_TH.UTF-8 UTF-8
429th_TH TIS-620
430the_NP UTF-8
431ti_ER UTF-8
432ti_ET UTF-8
433tig_ER UTF-8
434tk_TM UTF-8
435tl_PH.UTF-8 UTF-8
436tl_PH ISO-8859-1
437tn_ZA UTF-8
438to_TO UTF-8
439tpi_PG UTF-8
440tr_CY.UTF-8 UTF-8
441tr_CY ISO-8859-9
442tr_TR.UTF-8 UTF-8
443tr_TR ISO-8859-9
444ts_ZA UTF-8
445tt_RU UTF-8
446tt_RU@iqtelif UTF-8
447ug_CN UTF-8
448uk_UA.UTF-8 UTF-8
449uk_UA KOI8-U
450unm_US UTF-8
451ur_IN UTF-8
452ur_PK UTF-8
453uz_UZ.UTF-8 UTF-8
454uz_UZ ISO-8859-1
455uz_UZ@cyrillic UTF-8
456ve_ZA UTF-8
457vi_VN UTF-8
458wa_BE ISO-8859-1
459wa_BE@euro ISO-8859-15
460wa_BE.UTF-8 UTF-8
461wae_CH UTF-8
462wal_ET UTF-8
463wo_SN UTF-8
464xh_ZA.UTF-8 UTF-8
465xh_ZA ISO-8859-1
466yi_US.UTF-8 UTF-8
467yi_US CP1255
468yo_NG UTF-8
469yue_HK UTF-8
470yuw_PG UTF-8
471zh_CN.GB18030 GB18030
472zh_CN.GBK GBK
473zh_CN.UTF-8 UTF-8
474zh_CN GB2312
475zh_HK.UTF-8 UTF-8
476zh_HK BIG5-HKSCS
477zh_SG.UTF-8 UTF-8
478zh_SG.GBK GBK
479zh_SG GB2312
480zh_TW.EUC-TW EUC-TW
481zh_TW.UTF-8 UTF-8
482zh_TW BIG5
483zu_ZA.UTF-8 UTF-8
484zu_ZA ISO-8859-1
diff --git a/gnu/installer/aux-files/logo.txt b/gnu/installer/aux-files/logo.txt
new file mode 100644
index 00000000000..52418d88c11
--- /dev/null
+++ b/gnu/installer/aux-files/logo.txt
@@ -0,0 +1,19 @@
1 ░░░ ░░░
2 ░░▒▒░░░░░░░░░ ░░░░░░░░░▒▒░░
3 ░░▒▒▒▒▒░░░░░░░ ░░░░░░░▒▒▒▒▒░
4 ░▒▒▒░░▒▒▒▒▒ ░░░░░░░▒▒░
5 ░▒▒▒▒░ ░░░░░░
6 ▒▒▒▒▒ ░░░░░░
7 ▒▒▒▒▒ ░░░░░
8 ░▒▒▒▒▒ ░░░░░
9 ▒▒▒▒▒ ░░░░░
10 ▒▒▒▒▒ ░░░░░
11 ░▒▒▒▒▒░░░░░
12 ▒▒▒▒▒▒░░░
13 ▒▒▒▒▒▒░
14 _____ _ _ _ _ _____ _
15 / ____| \ | | | | | / ____| (_)
16| | __| \| | | | | | | __ _ _ ___ __
17| | |_ | . ' | | | | | | |_ | | | | \ \/ /
18| |__| | |\ | |__| | | |__| | |_| | |> <
19 \_____|_| \_|\____/ \_____|\__,_|_/_/\_\
diff --git a/gnu/installer/build-installer.scm b/gnu/installer/build-installer.scm
new file mode 100644
index 00000000000..1a084bc3dc7
--- /dev/null
+++ b/gnu/installer/build-installer.scm
@@ -0,0 +1,290 @@
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 build-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 installer)
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 guile)
32 #:autoload (gnu packages gnupg) (guile-gcrypt)
33 #:use-module (gnu packages iso-codes)
34 #:use-module (gnu packages linux)
35 #:use-module (gnu packages ncurses)
36 #:use-module (gnu packages package-management)
37 #:use-module (gnu packages xorg)
38 #:use-module (ice-9 match)
39 #:use-module (srfi srfi-1)
40 #:export (installer-program))
41
42(define not-config?
43 ;; Select (guix …) and (gnu …) modules, except (guix config).
44 (match-lambda
45 (('guix 'config) #f)
46 (('guix rest ...) #t)
47 (('gnu rest ...) #t)
48 (rest #f)))
49
50(define* (build-compiled-file name locale-builder)
51 "Return a file-like object that evalutes the gexp LOCALE-BUILDER and store
52its result in the scheme file NAME. The derivation will also build a compiled
53version of this file."
54 (define set-utf8-locale
55 #~(begin
56 (setenv "LOCPATH"
57 #$(file-append glibc-utf8-locales "/lib/locale/"
58 (version-major+minor
59 (package-version glibc-utf8-locales))))
60 (setlocale LC_ALL "en_US.utf8")))
61
62 (define builder
63 (with-extensions (list guile-json)
64 (with-imported-modules (source-module-closure
65 '((gnu installer locale)))
66 #~(begin
67 (use-modules (gnu installer locale))
68
69 ;; The locale files contain non-ASCII characters.
70 #$set-utf8-locale
71
72 (mkdir #$output)
73 (let ((locale-file
74 (string-append #$output "/" #$name ".scm"))
75 (locale-compiled-file
76 (string-append #$output "/" #$name ".go")))
77 (call-with-output-file locale-file
78 (lambda (port)
79 (write #$locale-builder port)))
80 (compile-file locale-file
81 #:output-file locale-compiled-file))))))
82 (computed-file name builder))
83
84(define apply-locale
85 ;; Install the specified locale.
86 #~(lambda (locale-name)
87 (false-if-exception
88 (setlocale LC_ALL locale-name))))
89
90(define* (compute-locale-step installer
91 #:key
92 locales-name
93 iso639-languages-name
94 iso3166-territories-name)
95 "Return a gexp that run the locale-page of INSTALLER, and install the
96selected locale. The list of locales, languages and territories passed to
97locale-page are computed in derivations named respectively LOCALES-NAME,
98ISO639-LANGUAGES-NAME and ISO3166-TERRITORIES-NAME. Those lists are compiled,
99so that when the installer is run, all the lengthy operations have already
100been performed at build time."
101 (define (compiled-file-loader file name)
102 #~(load-compiled
103 (string-append #$file "/" #$name ".go")))
104
105 (let* ((supported-locales #~(supported-locales->locales
106 #$(local-file "aux-files/SUPPORTED")))
107 (iso-codes #~(string-append #$iso-codes "/share/iso-codes/json/"))
108 (iso639-3 #~(string-append #$iso-codes "iso_639-3.json"))
109 (iso639-5 #~(string-append #$iso-codes "iso_639-5.json"))
110 (iso3166 #~(string-append #$iso-codes "iso_3166-1.json"))
111 (locales-file (build-compiled-file
112 locales-name
113 #~`(quote ,#$supported-locales)))
114 (iso639-file (build-compiled-file
115 iso639-languages-name
116 #~`(quote ,(iso639->iso639-languages
117 #$supported-locales
118 #$iso639-3 #$iso639-5))))
119 (iso3166-file (build-compiled-file
120 iso3166-territories-name
121 #~`(quote ,(iso3166->iso3166-territories #$iso3166))))
122 (locales-loader (compiled-file-loader locales-file
123 locales-name))
124 (iso639-loader (compiled-file-loader iso639-file
125 iso639-languages-name))
126 (iso3166-loader (compiled-file-loader iso3166-file
127 iso3166-territories-name)))
128 #~(let ((result
129 (#$(installer-locale-page installer)
130 #:supported-locales #$locales-loader
131 #:iso639-languages #$iso639-loader
132 #:iso3166-territories #$iso3166-loader)))
133 (#$apply-locale result))))
134
135(define apply-keymap
136 ;; Apply the specified keymap.
137 #~(match-lambda
138 ((model layout variant)
139 (kmscon-update-keymap model layout variant))))
140
141(define* (compute-keymap-step installer)
142 "Return a gexp that runs the keymap-page of INSTALLER and install the
143selected keymap."
144 #~(let ((result
145 (call-with-values
146 (lambda ()
147 (xkb-rules->models+layouts
148 (string-append #$xkeyboard-config
149 "/share/X11/xkb/rules/base.xml")))
150 (lambda (models layouts)
151 (#$(installer-keymap-page installer)
152 #:models models
153 #:layouts layouts)))))
154 (#$apply-keymap result)))
155
156(define (installer-steps installer)
157 (let ((locale-step (compute-locale-step
158 installer
159 #:locales-name "locales"
160 #:iso639-languages-name "iso639-languages"
161 #:iso3166-territories-name "iso3166-territories"))
162 (keymap-step (compute-keymap-step installer))
163 (timezone-data #~(string-append #$tzdata
164 "/share/zoneinfo/zone.tab")))
165 #~(list
166 ;; Welcome the user and ask him to choose between manual installation
167 ;; and graphical install.
168 (installer-step
169 (id 'welcome)
170 (compute (lambda _
171 #$(installer-welcome-page installer))))
172
173 ;; Ask the user to choose a locale among those supported by the glibc.
174 ;; Install the selected locale right away, so that the user may
175 ;; benefit from any available translation for the installer messages.
176 (installer-step
177 (id 'locale)
178 (description (G_ "Locale selection"))
179 (compute (lambda _
180 #$locale-step)))
181
182 ;; Ask the user to select a timezone under glibc format.
183 (installer-step
184 (id 'timezone)
185 (description (G_ "Timezone selection"))
186 (compute (lambda _
187 (#$(installer-timezone-page installer)
188 #$timezone-data))))
189
190 ;; The installer runs in a kmscon virtual terminal where loadkeys
191 ;; won't work. kmscon uses libxkbcommon as a backend for keyboard
192 ;; input. It is possible to update kmscon current keymap by sending it
193 ;; a keyboard model, layout and variant, in a somehow similar way as
194 ;; what is done with setxkbmap utility.
195 ;;
196 ;; So ask for a keyboard model, layout and variant to update the
197 ;; current kmscon keymap.
198 (installer-step
199 (id 'keymap)
200 (description (G_ "Keyboard mapping selection"))
201 (compute (lambda _
202 #$keymap-step)))
203
204 ;; Ask the user to input a hostname for the system.
205 (installer-step
206 (id 'hostname)
207 (description (G_ "Hostname selection"))
208 (compute (lambda _
209 #$(installer-hostname-page installer))))
210
211 ;; Provide an interface above connmanctl, so that the user can select
212 ;; a network susceptible to acces Internet.
213 (installer-step
214 (id 'network)
215 (description (G_ "Network selection"))
216 (compute (lambda _
217 #$(installer-network-page installer))))
218
219 ;; Prompt for users (name, group and home directory).
220 (installer-step
221 (id 'hostname)
222 (description (G_ "User selection"))
223 (compute (lambda _
224 #$(installer-user-page installer)))))))
225
226(define (installer-program installer)
227 "Return a file-like object that runs the given INSTALLER."
228 (define init-gettext
229 ;; Initialize gettext support, so that installer messages can be
230 ;; translated.
231 #~(begin
232 (bindtextdomain "guix" (string-append #$guix "/share/locale"))
233 (textdomain "guix")))
234
235 (define set-installer-path
236 ;; Add the specified binary to PATH for later use by the installer.
237 #~(let* ((inputs
238 '#$(append (list bash connman shadow)
239 (map canonical-package (list coreutils)))))
240 (with-output-to-port (%make-void-port "w")
241 (lambda ()
242 (set-path-environment-variable "PATH" '("bin" "sbin") inputs)))))
243
244 (define installer-builder
245 (with-extensions (list guile-gcrypt guile-newt guile-json)
246 (with-imported-modules `(,@(source-module-closure
247 `(,@(installer-modules installer)
248 (guix build utils))
249 #:select? not-config?)
250 ((guix config) => ,(make-config.scm)))
251 #~(begin
252 (use-modules (gnu installer keymap)
253 (gnu installer steps)
254 (gnu installer locale)
255 #$@(installer-modules installer)
256 (guix i18n)
257 (guix build utils)
258 (ice-9 match))
259
260 ;; Initialize gettext support so that installers can use
261 ;; (guix i18n) module.
262 #$init-gettext
263
264 ;; Add some binaries used by the installers to PATH.
265 #$set-installer-path
266
267 #$(installer-init installer)
268
269 (catch #t
270 (lambda ()
271 (run-installer-steps
272 #:rewind-strategy 'menu
273 #:menu-proc #$(installer-menu-page installer)
274 #:steps #$(installer-steps installer)))
275 (const #f)
276 (lambda (key . args)
277 (#$(installer-exit-error installer) key args)
278
279 ;; Be sure to call newt-finish, to restore the terminal into
280 ;; its original state before printing the error report.
281 (call-with-output-file "/tmp/error"
282 (lambda (port)
283 (display-backtrace (make-stack #t) port)
284 (print-exception port
285 (stack-ref (make-stack #t) 1)
286 key args)))
287 (primitive-exit 1)))
288 #$(installer-exit installer)))))
289
290 (program-file "installer" installer-builder))
diff --git a/gnu/installer/connman.scm b/gnu/installer/connman.scm
new file mode 100644
index 00000000000..740df7424a1
--- /dev/null
+++ b/gnu/installer/connman.scm
@@ -0,0 +1,400 @@
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 connman)
20 #:use-module (gnu installer utils)
21 #:use-module (guix records)
22 #:use-module (ice-9 match)
23 #:use-module (ice-9 popen)
24 #:use-module (ice-9 regex)
25 #:use-module (srfi srfi-11)
26 #:use-module (srfi srfi-34)
27 #:use-module (srfi srfi-35)
28 #:export (<technology>
29 technology
30 technology?
31 technology-name
32 technology-type
33 technology-powered?
34 technology-connected?
35
36 <service>
37 service
38 service?
39 service-name
40 service-type
41 service-path
42 service-strength
43 service-state
44
45 &connman-error
46 connman-error?
47 connman-error-command
48 connman-error-output
49 connman-error-status
50
51 &connman-connection-error
52 connman-connection-error?
53 connman-connection-error-service
54 connman-connection-error-output
55
56 &connman-password-error
57 connman-password-error?
58
59 &connman-already-connected-error
60 connman-already-connected-error?
61
62 connman-state
63 connman-technologies
64 connman-enable-technology
65 connman-disable-technology
66 connman-scan-technology
67 connman-services
68 connman-connect
69 connman-disconnect
70 connman-online?
71 connman-connect-with-auth))
72
73;;; Commentary:
74;;;
75;;; This module provides procedures for talking with the connman daemon.
76;;; The best approach would have been using connman dbus interface.
77;;; However, as Guile dbus bindings are not available yet, the console client
78;;; "connmanctl" is used to talk with the daemon.
79;;;
80
81
82;;;
83;;; Technology record.
84;;;
85
86;; The <technology> record encapsulates the "Technology" object of connman.
87;; Technology type will be typically "ethernet", "wifi" or "bluetooth".
88
89(define-record-type* <technology>
90 technology make-technology
91 technology?
92 (name technology-name) ; string
93 (type technology-type) ; string
94 (powered? technology-powered?) ; boolean
95 (connected? technology-connected?)) ; boolean
96
97
98;;;
99;;; Service record.
100;;;
101
102;; The <service> record encapsulates the "Service" object of connman.
103;; Service type is the same as the technology it is associated to, path is a
104;; unique identifier given by connman, strength describes the signal quality
105;; if applicable. Finally, state is "idle", "failure", "association",
106;; "configuration", "ready", "disconnect" or "online".
107
108(define-record-type* <service>
109 service make-service
110 service?
111 (name service-name) ; string
112 (type service-type) ; string
113 (path service-path) ; string
114 (strength service-strength) ; integer
115 (state service-state)) ; string
116
117
118;;;
119;;; Condition types.
120;;;
121
122(define-condition-type &connman-error &error
123 connman-error?
124 (command connman-error-command)
125 (output connman-error-output)
126 (status connman-error-status))
127
128(define-condition-type &connman-connection-error &error
129 connman-connection-error?
130 (service connman-connection-error-service)
131 (output connman-connection-error-output))
132
133(define-condition-type &connman-password-error &connman-connection-error
134 connman-password-error?)
135
136(define-condition-type &connman-already-connected-error
137 &connman-connection-error connman-already-connected-error?)
138
139
140;;;
141;;; Procedures.
142;;;
143
144(define (connman-run command env arguments)
145 "Run the given COMMAND, with the specified ENV and ARGUMENTS. The error
146output is discarded and &connman-error condition is raised if the command
147returns a non zero exit code."
148 (let* ((command `("env" ,env ,command ,@arguments "2>" "/dev/null"))
149 (command-string (string-join command " "))
150 (pipe (open-input-pipe command-string))
151 (output (read-lines pipe))
152 (ret (close-pipe pipe)))
153 (case (status:exit-val ret)
154 ((0) output)
155 (else (raise (condition (&connman-error
156 (command command)
157 (output output)
158 (status ret))))))))
159
160(define (connman . arguments)
161 "Run connmanctl with the specified ARGUMENTS. Set the LANG environment
162variable to C because the command output will be parsed and we don't want it
163to be translated."
164 (connman-run "connmanctl" "LANG=C" arguments))
165
166(define (parse-keys keys)
167 "Parse the given list of strings KEYS, under the following format:
168
169 '((\"KEY = VALUE\") (\"KEY2 = VALUE2\") ...)
170
171Return the corresponding association list of '((KEY . VALUE) (KEY2 . VALUE2)
172...) elements."
173 (let ((key-regex (make-regexp "([^ ]+) = ([^$]+)")))
174 (map (lambda (key)
175 (let ((match-key (regexp-exec key-regex key)))
176 (cons (match:substring match-key 1)
177 (match:substring match-key 2))))
178 keys)))
179
180(define (connman-state)
181 "Return the state of connman. The nominal states are 'offline, 'idle,
182'ready, 'oneline. If an unexpected state is read, 'unknown is
183returned. Finally, an error is raised if the comman output could not be
184parsed, usually because the connman daemon is not responding."
185 (let* ((output (connman "state"))
186 (state-keys (parse-keys output)))
187 (let ((state (assoc-ref state-keys "State")))
188 (if state
189 (cond ((string=? state "offline") 'offline)
190 ((string=? state "idle") 'idle)
191 ((string=? state "ready") 'ready)
192 ((string=? state "online") 'online)
193 (else 'unknown))
194 (raise (condition
195 (&message
196 (message "Could not determine the state of connman."))))))))
197
198(define (split-technology-list technologies)
199 "Parse the given strings list TECHNOLOGIES, under the following format:
200
201 '((\"/net/connman/technology/xxx\")
202 (\"KEY = VALUE\")
203 ...
204 (\"/net/connman/technology/yyy\")
205 (\"KEY2 = VALUE2\")
206 ...)
207 Return the corresponding '(((\"KEY = VALUE\") ...) ((\"KEY2 = VALUE2\") ...))
208list so that each keys of a given technology are gathered in a separate list."
209 (let loop ((result '())
210 (cur-list '())
211 (input (reverse technologies)))
212 (if (null? input)
213 result
214 (let ((item (car input)))
215 (if (string-match "/net/connman/technology" item)
216 (loop (cons cur-list result) '() (cdr input))
217 (loop result (cons item cur-list) (cdr input)))))))
218
219(define (string->boolean string)
220 (equal? string "True"))
221
222(define (connman-technologies)
223 "Return a list of available <technology> records."
224
225 (define (technology-output->technology output)
226 (let ((keys (parse-keys output)))
227 (technology
228 (name (assoc-ref keys "Name"))
229 (type (assoc-ref keys "Type"))
230 (powered? (string->boolean (assoc-ref keys "Powered")))
231 (connected? (string->boolean (assoc-ref keys "Connected"))))))
232
233 (let* ((output (connman "technologies"))
234 (technologies (split-technology-list output)))
235 (map technology-output->technology technologies)))
236
237(define (connman-enable-technology technology)
238 "Enable the given TECHNOLOGY."
239 (let ((type (technology-type technology)))
240 (connman "enable" type)))
241
242(define (connman-disable-technology technology)
243 "Disable the given TECHNOLOGY."
244 (let ((type (technology-type technology)))
245 (connman "disable" type)))
246
247(define (connman-scan-technology technology)
248 "Run a scan for the given TECHNOLOGY."
249 (let ((type (technology-type technology)))
250 (connman "scan" type)))
251
252(define (connman-services)
253 "Return a list of available <services> records."
254
255 (define (service-output->service path output)
256 (let* ((service-keys
257 (match output
258 ((_ . rest) rest)))
259 (keys (parse-keys service-keys)))
260 (service
261 (name (assoc-ref keys "Name"))
262 (type (assoc-ref keys "Type"))
263 (path path)
264 (strength (and=> (assoc-ref keys "Strength") string->number))
265 (state (assoc-ref keys "State")))))
266
267 (let* ((out (connman "services"))
268 (out-filtered (delete "" out))
269 (services-path (map (lambda (service)
270 (match (string-split service #\ )
271 ((_ ... path) path)))
272 out-filtered))
273 (services-output (map (lambda (service)
274 (connman "services" service))
275 services-path)))
276 (map service-output->service services-path services-output)))
277
278(define (connman-connect service)
279 "Connect to the given SERVICE."
280 (let ((path (service-path service)))
281 (connman "connect" path)))
282
283(define (connman-disconnect service)
284 "Disconnect from the given SERVICE."
285 (let ((path (service-path service)))
286 (connman "disconnect" path)))
287
288(define (connman-online?)
289 (let ((state (connman-state)))
290 (eq? state 'online)))
291
292(define (connman-connect-with-auth service password-proc)
293 "Connect to the given SERVICE with the password returned by calling
294PASSWORD-PROC. This is only possible in the interactive mode of connmanctl
295because authentication is done by communicating with an agent.
296
297As the open-pipe procedure of Guile do not allow to read from stderr, we have
298to merge stdout and stderr using bash redirection. Then error messages are
299extracted from connmanctl output using a regexp. This makes the whole
300procedure even more unreliable.
301
302Raise &connman-connection-error if an error occured during connection. Raise
303&connman-password-error if the given password is incorrect."
304
305 (define connman-error-regexp (make-regexp "Error[ ]*([^\n]+)\n"))
306
307 (define (match-connman-error str)
308 (let ((match-error (regexp-exec connman-error-regexp str)))
309 (and match-error (match:substring match-error 1))))
310
311 (define* (read-regexps-or-error port regexps error-handler)
312 "Read characters from port until an error is detected, or one of the given
313REGEXPS is matched. If an error is detected, call ERROR-HANDLER with the error
314string as argument. Raise an error if the eof is reached before one of the
315regexps is matched."
316 (let loop ((res ""))
317 (let ((char (read-char port)))
318 (cond
319 ((eof-object? char)
320 (raise (condition
321 (&message
322 (message "Unable to find expected regexp.")))))
323 ((match-connman-error res)
324 =>
325 (lambda (match)
326 (error-handler match)))
327 ((or-map (lambda (regexp)
328 (and (regexp-exec regexp res) regexp))
329 regexps)
330 =>
331 (lambda (match)
332 match))
333 (else
334 (loop (string-append res (string char))))))))
335
336 (define* (read-regexp-or-error port regexp error-handler)
337 "Same as READ-REGEXPS-OR-ERROR above, but with a single REGEXP."
338 (read-regexps-or-error port (list regexp) error-handler))
339
340 (define (connman-error->condition path error)
341 (cond
342 ((string-match "Already connected" error)
343 (condition (&connman-already-connected-error
344 (service path)
345 (output error))))
346 (else
347 (condition (&connman-connection-error
348 (service path)
349 (output error))))))
350
351 (define (run-connection-sequence pipe)
352 "Run the connection sequence using PIPE as an opened port to an
353interactive connmanctl process."
354 (let* ((path (service-path service))
355 (error-handler (lambda (error)
356 (raise
357 (connman-error->condition path error)))))
358 ;; Start the agent.
359 (format pipe "agent on\n")
360 (read-regexp-or-error pipe (make-regexp "Agent registered") error-handler)
361
362 ;; Let's try to connect to the service. If the service does not require
363 ;; a password, the connection might succeed right after this call.
364 ;; Otherwise, connmanctl will prompt us for a password.
365 (format pipe "connect ~a\n" path)
366 (let* ((connected-regexp (make-regexp (format #f "Connected ~a" path)))
367 (passphrase-regexp (make-regexp "\nPassphrase\\?[ ]*"))
368 (regexps (list connected-regexp passphrase-regexp))
369 (result (read-regexps-or-error pipe regexps error-handler)))
370
371 ;; A password is required.
372 (when (eq? result passphrase-regexp)
373 (format pipe "~a~%" (password-proc))
374
375 ;; Now, we have to wait for the connection to succeed. If an error
376 ;; occurs, it is most likely because the password is incorrect.
377 ;; In that case, we escape from an eventual retry loop that would
378 ;; add complexity to this procedure, and raise a
379 ;; &connman-password-error condition.
380 (read-regexp-or-error pipe connected-regexp
381 (lambda (error)
382 ;; Escape from retry loop.
383 (format pipe "no\n")
384 (raise
385 (condition (&connman-password-error
386 (service path)
387 (output error))))))))))
388
389 ;; XXX: Find a better way to read stderr, like with the "subprocess"
390 ;; procedure of racket that return input ports piped on the process stdin and
391 ;; stderr.
392 (let ((pipe (open-pipe "connmanctl 2>&1" OPEN_BOTH)))
393 (dynamic-wind
394 (const #t)
395 (lambda ()
396 (run-connection-sequence pipe)
397 #t)
398 (lambda ()
399 (format pipe "quit\n")
400 (close-pipe pipe)))))
diff --git a/gnu/installer/keymap.scm b/gnu/installer/keymap.scm
new file mode 100644
index 00000000000..78065aa6c62
--- /dev/null
+++ b/gnu/installer/keymap.scm
@@ -0,0 +1,162 @@
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 keymap)
20 #:use-module (guix records)
21 #:use-module (sxml match)
22 #:use-module (sxml simple)
23 #:use-module (ice-9 binary-ports)
24 #:use-module (ice-9 ftw)
25 #:use-module (ice-9 match)
26 #:use-module (ice-9 regex)
27 #:export (<x11-keymap-model>
28 x11-keymap-model
29 make-x11-keymap-model
30 x11-keymap-model?
31 x11-keymap-model-name
32 x11-keymap-model-description
33
34 <x11-keymap-layout>
35 x11-keymap-layout
36 make-x11-keymap-layout
37 x11-keymap-layout?
38 x11-keymap-layout-name
39 x11-keymap-layout-description
40 x11-keymap-layout-variants
41
42 <x11-keymap-variant>
43 x11-keymap-variant
44 make-x11-keymap-variant
45 x11-keymap-variant?
46 x11-keymap-variant-name
47 x11-keymap-variant-description
48
49 xkb-rules->models+layouts
50 kmscon-update-keymap))
51
52(define-record-type* <x11-keymap-model>
53 x11-keymap-model make-x11-keymap-model
54 x11-keymap-model?
55 (name x11-keymap-model-name) ;string
56 (description x11-keymap-model-description)) ;string
57
58(define-record-type* <x11-keymap-layout>
59 x11-keymap-layout make-x11-keymap-layout
60 x11-keymap-layout?
61 (name x11-keymap-layout-name) ;string
62 (description x11-keymap-layout-description) ;string
63 (variants x11-keymap-layout-variants)) ;list of <x11-keymap-variant>
64
65(define-record-type* <x11-keymap-variant>
66 x11-keymap-variant make-x11-keymap-variant
67 x11-keymap-variant?
68 (name x11-keymap-variant-name) ;string
69 (description x11-keymap-variant-description)) ;string
70
71(define (xkb-rules->models+layouts file)
72 "Parse FILE and return two values, the list of supported X11-KEYMAP-MODEL
73and X11-KEYMAP-LAYOUT records. FILE is an XML file from the X Keyboard
74Configuration Database, describing possible XKB configurations."
75 (define (model m)
76 (sxml-match m
77 [(model
78 (configItem
79 (name ,name)
80 (description ,description)
81 . ,rest))
82 (x11-keymap-model
83 (name name)
84 (description description))]))
85
86 (define (variant v)
87 (sxml-match v
88 [(variant
89 ;; According to xbd-rules DTD, the definition of a
90 ;; configItem is: <!ELEMENT configItem
91 ;; (name,shortDescription*,description*,vendor?,
92 ;; countryList?,languageList?,hwList?)>
93 ;;
94 ;; shortDescription and description are optional elements
95 ;; but sxml-match does not support default values for
96 ;; elements (only attributes). So to avoid writing as many
97 ;; patterns as existing possibilities, gather all the
98 ;; remaining elements but name in REST-VARIANT.
99 (configItem
100 (name ,name)
101 . ,rest-variant))
102 (x11-keymap-variant
103 (name name)
104 (description (car
105 (assoc-ref rest-variant 'description))))]))
106
107 (define (layout l)
108 (sxml-match l
109 [(layout
110 (configItem
111 (name ,name)
112 . ,rest-layout)
113 (variantList ,[variant -> v] ...))
114 (x11-keymap-layout
115 (name name)
116 (description (car
117 (assoc-ref rest-layout 'description)))
118 (variants (list v ...)))]
119 [(layout
120 (configItem
121 (name ,name)
122 . ,rest-layout))
123 (x11-keymap-layout
124 (name name)
125 (description (car
126 (assoc-ref rest-layout 'description)))
127 (variants '()))]))
128
129 (let ((sxml (call-with-input-file file
130 (lambda (port)
131 (xml->sxml port #:trim-whitespace? #t)))))
132 (match
133 (sxml-match sxml
134 [(*TOP*
135 ,pi
136 (xkbConfigRegistry
137 (@ . ,ignored)
138 (modelList ,[model -> m] ...)
139 (layoutList ,[layout -> l] ...)
140 . ,rest))
141 (list
142 (list m ...)
143 (list l ...))])
144 ((models layouts)
145 (values models layouts)))))
146
147(define (kmscon-update-keymap model layout variant)
148 (let ((keymap-file (getenv "KEYMAP_UPDATE")))
149 (unless (and keymap-file
150 (file-exists? keymap-file))
151 (error "Unable to locate keymap update file"))
152
153 (call-with-output-file keymap-file
154 (lambda (port)
155 (format port model)
156 (put-u8 port 0)
157
158 (format port layout)
159 (put-u8 port 0)
160
161 (format port variant)
162 (put-u8 port 0)))))
diff --git a/gnu/installer/locale.scm b/gnu/installer/locale.scm
new file mode 100644
index 00000000000..504070d41d1
--- /dev/null
+++ b/gnu/installer/locale.scm
@@ -0,0 +1,199 @@
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 locale)
20 #:use-module (gnu installer utils)
21 #:use-module (guix records)
22 #:use-module (json)
23 #:use-module (srfi srfi-1)
24 #:use-module (ice-9 match)
25 #:use-module (ice-9 regex)
26 #:export (locale-language
27 locale-territory
28 locale-codeset
29 locale-modifier
30
31 locale->locale-string
32 supported-locales->locales
33
34 iso639->iso639-languages
35 language-code->language-name
36
37 iso3166->iso3166-territories
38 territory-code->territory-name))
39
40
41;;;
42;;; Locale.
43;;;
44
45;; A glibc locale string has the following format:
46;; language[_territory[.codeset][@modifier]].
47(define locale-regexp "^([^_@]+)(_([^\\.@]+))?(\\.([^@]+))?(@([^$]+))?$")
48
49;; LOCALE will be better expressed in a (guix record) that in an association
50;; list. However, loading large files containing records does not scale
51;; well. The same thing goes for ISO639 and ISO3166 association lists used
52;; later in this module.
53(define (locale-language assoc)
54 (assoc-ref assoc 'language))
55(define (locale-territory assoc)
56 (assoc-ref assoc 'territory))
57(define (locale-codeset assoc)
58 (assoc-ref assoc 'codeset))
59(define (locale-modifier assoc)
60 (assoc-ref assoc 'modifier))
61
62(define (locale-string->locale string)
63 "Return the locale association list built from the parsing of STRING."
64 (let ((matches (string-match locale-regexp string)))
65 `((language . ,(match:substring matches 1))
66 (territory . ,(match:substring matches 3))
67 (codeset . ,(match:substring matches 5))
68 (modifier . ,(match:substring matches 7)))))
69
70(define (locale->locale-string locale)
71 "Reverse operation of locale-string->locale."
72 (let ((language (locale-language locale))
73 (territory (locale-territory locale))
74 (codeset (locale-codeset locale))
75 (modifier (locale-modifier locale)))
76 (apply string-append
77 `(,language
78 ,@(if territory
79 `("_" ,territory)
80 '())
81 ,@(if codeset
82 `("." ,codeset)
83 '())
84 ,@(if modifier
85 `("@" ,modifier)
86 '())))))
87
88(define (supported-locales->locales supported-locales)
89 "Parse the SUPPORTED-LOCALES file from the glibc and return the matching
90list of LOCALE association lists."
91 (call-with-input-file supported-locales
92 (lambda (port)
93 (let ((lines (read-lines port)))
94 (map (lambda (line)
95 (match (string-split line #\ )
96 ((locale-string codeset)
97 (let ((line-locale (locale-string->locale locale-string)))
98 (assoc-set! line-locale 'codeset codeset)))))
99 lines)))))
100
101
102;;;
103;;; Language.
104;;;
105
106(define (iso639-language-alpha2 assoc)
107 (assoc-ref assoc 'alpha2))
108
109(define (iso639-language-alpha3 assoc)
110 (assoc-ref assoc 'alpha3))
111
112(define (iso639-language-name assoc)
113 (assoc-ref assoc 'name))
114
115(define (supported-locale? locales alpha2 alpha3)
116 "Find a locale in LOCALES whose alpha2 field matches ALPHA-2 or alpha3 field
117matches ALPHA-3. The ISO639 standard specifies that ALPHA-2 is optional. Thus,
118if ALPHA-2 is #f, only consider ALPHA-3. Return #f if not matching locale was
119found."
120 (find (lambda (locale)
121 (let ((language (locale-language locale)))
122 (or (and=> alpha2
123 (lambda (code)
124 (string=? language code)))
125 (string=? language alpha3))))
126 locales))
127
128(define (iso639->iso639-languages locales iso639-3 iso639-5)
129 "Return a list of ISO639 association lists created from the parsing of
130ISO639-3 and ISO639-5 files."
131 (call-with-input-file iso639-3
132 (lambda (port-iso639-3)
133 (call-with-input-file iso639-5
134 (lambda (port-iso639-5)
135 (filter-map
136 (lambda (hash)
137 (let ((alpha2 (hash-ref hash "alpha_2"))
138 (alpha3 (hash-ref hash "alpha_3"))
139 (name (hash-ref hash "name")))
140 (and (supported-locale? locales alpha2 alpha3)
141 `((alpha2 . ,alpha2)
142 (alpha3 . ,alpha3)
143 (name . ,name)))))
144 (append
145 (hash-ref (json->scm port-iso639-3) "639-3")
146 (hash-ref (json->scm port-iso639-5) "639-5"))))))))
147
148(define (language-code->language-name languages language-code)
149 "Using LANGUAGES as a list of ISO639 association lists, return the language
150name corresponding to the given LANGUAGE-CODE."
151 (let ((iso639-language
152 (find (lambda (language)
153 (or
154 (and=> (iso639-language-alpha2 language)
155 (lambda (alpha2)
156 (string=? alpha2 language-code)))
157 (string=? (iso639-language-alpha3 language)
158 language-code)))
159 languages)))
160 (iso639-language-name iso639-language)))
161
162
163;;;
164;;; Territory.
165;;;
166
167(define (iso3166-territory-alpha2 assoc)
168 (assoc-ref assoc 'alpha2))
169
170(define (iso3166-territory-alpha3 assoc)
171 (assoc-ref assoc 'alpha3))
172
173(define (iso3166-territory-name assoc)
174 (assoc-ref assoc 'name))
175
176(define (iso3166->iso3166-territories iso3166)
177 "Return a list of ISO3166 association lists created from the parsing of
178ISO3166 file."
179 (call-with-input-file iso3166
180 (lambda (port)
181 (map (lambda (hash)
182 `((alpha2 . ,(hash-ref hash "alpha_2"))
183 (alpha3 . ,(hash-ref hash "alpha_3"))
184 (name . ,(hash-ref hash "name"))))
185 (hash-ref (json->scm port) "3166-1")))))
186
187(define (territory-code->territory-name territories territory-code)
188 "Using TERRITORIES as a list of ISO3166 association lists return the
189territory name corresponding to the given TERRITORY-CODE."
190 (let ((iso3166-territory
191 (find (lambda (territory)
192 (or
193 (and=> (iso3166-territory-alpha2 territory)
194 (lambda (alpha2)
195 (string=? alpha2 territory-code)))
196 (string=? (iso3166-territory-alpha3 territory)
197 territory-code)))
198 territories)))
199 (iso3166-territory-name iso3166-territory)))
diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm
new file mode 100644
index 00000000000..abf752959b6
--- /dev/null
+++ b/gnu/installer/newt.scm
@@ -0,0 +1,102 @@
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 newt)
20 #:use-module (gnu installer)
21 #:use-module (guix discovery)
22 #:use-module (guix gexp)
23 #:use-module (guix ui)
24 #:export (newt-installer))
25
26(define (modules)
27 (cons '(newt)
28 (map module-name
29 (scheme-modules
30 (dirname (search-path %load-path "guix.scm"))
31 "gnu/installer/newt"
32 #:warn warn-about-load-error))))
33
34(define init
35 #~(begin
36 (newt-init)
37 (clear-screen)
38 (set-screen-size!)))
39
40(define exit
41 #~(begin
42 (newt-finish)))
43
44(define exit-error
45 #~(lambda (key args)
46 (newt-finish)))
47
48(define locale-page
49 #~(lambda* (#:key
50 supported-locales
51 iso639-languages
52 iso3166-territories)
53 (run-locale-page
54 #:supported-locales supported-locales
55 #:iso639-languages iso639-languages
56 #:iso3166-territories iso3166-territories)))
57
58(define timezone-page
59 #~(lambda* (zonetab)
60 (run-timezone-page zonetab)))
61
62(define logo
63 (string-append
64 (dirname (search-path %load-path "guix.scm"))
65 "/gnu/installer/aux-files/logo.txt"))
66
67(define welcome-page
68 #~(run-welcome-page #$(local-file logo)))
69
70(define menu-page
71 #~(lambda (steps)
72 (run-menu-page steps)))
73
74(define keymap-page
75 #~(lambda* (#:key models layouts)
76 (run-keymap-page #:models models
77 #:layouts layouts)))
78
79(define network-page
80 #~(run-network-page))
81
82(define hostname-page
83 #~(run-hostname-page))
84
85(define user-page
86 #~(run-user-page))
87
88(define newt-installer
89 (installer
90 (name 'newt)
91 (modules (modules))
92 (init init)
93 (exit exit)
94 (exit-error exit-error)
95 (keymap-page keymap-page)
96 (locale-page locale-page)
97 (menu-page menu-page)
98 (network-page network-page)
99 (timezone-page timezone-page)
100 (hostname-page hostname-page)
101 (user-page user-page)
102 (welcome-page welcome-page)))
diff --git a/gnu/installer/newt/ethernet.scm b/gnu/installer/newt/ethernet.scm
new file mode 100644
index 00000000000..2cbbfddacd9
--- /dev/null
+++ b/gnu/installer/newt/ethernet.scm
@@ -0,0 +1,80 @@
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 newt ethernet)
20 #:use-module (gnu installer connman)
21 #:use-module (gnu installer steps)
22 #:use-module (gnu installer newt utils)
23 #:use-module (gnu installer newt page)
24 #:use-module (guix i18n)
25 #:use-module (ice-9 format)
26 #:use-module (srfi srfi-34)
27 #:use-module (srfi srfi-35)
28 #:use-module (newt)
29 #:export (run-ethernet-page))
30
31(define (ethernet-services)
32 "Return all the connman services of ethernet type."
33 (let ((services (connman-services)))
34 (filter (lambda (service)
35 (and (string=? (service-type service) "ethernet")
36 (not (string-null? (service-name service)))))
37 services)))
38
39(define (ethernet-service->text service)
40 "Return a string describing the given ethernet SERVICE."
41 (let* ((name (service-name service))
42 (path (service-path service))
43 (full-name (string-append name "-" path))
44 (state (service-state service))
45 (connected? (or (string=? state "online")
46 (string=? state "ready"))))
47 (format #f "~c ~a~%"
48 (if connected? #\* #\ )
49 full-name)))
50
51(define (connect-ethernet-service service)
52 "Connect to the given ethernet SERVICE. Display a connecting page while the
53connection is pending."
54 (let* ((service-name (service-name service))
55 (form (draw-connecting-page service-name)))
56 (connman-connect service)
57 (destroy-form-and-pop form)))
58
59(define (run-ethernet-page)
60 (let ((services (ethernet-services)))
61 (if (null? services)
62 (begin
63 (run-error-page
64 (G_ "No ethernet service available, please try again.")
65 (G_ "No service"))
66 (raise
67 (condition
68 (&installer-step-abort))))
69 (run-listbox-selection-page
70 #:info-text (G_ "Please select an ethernet network.")
71 #:title (G_ "Ethernet connection")
72 #:listbox-items services
73 #:listbox-item->text ethernet-service->text
74 #:button-text (G_ "Cancel")
75 #:button-callback-procedure
76 (lambda _
77 (raise
78 (condition
79 (&installer-step-abort))))
80 #:listbox-callback-procedure connect-ethernet-service))))
diff --git a/gnu/installer/newt/hostname.scm b/gnu/installer/newt/hostname.scm
new file mode 100644
index 00000000000..acbee64a6a5
--- /dev/null
+++ b/gnu/installer/newt/hostname.scm
@@ -0,0 +1,26 @@
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 newt hostname)
20 #:use-module (gnu installer newt page)
21 #:use-module (guix i18n)
22 #:export (run-hostname-page))
23
24(define (run-hostname-page)
25 (run-input-page (G_ "Please enter the system hostname")
26 (G_ "Hostname selection")))
diff --git a/gnu/installer/newt/keymap.scm b/gnu/installer/newt/keymap.scm
new file mode 100644
index 00000000000..219ac3f8e23
--- /dev/null
+++ b/gnu/installer/newt/keymap.scm
@@ -0,0 +1,132 @@
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 newt keymap)
20 #:use-module (gnu installer keymap)
21 #:use-module (gnu installer steps)
22 #:use-module (gnu installer newt page)
23 #:use-module (guix i18n)
24 #:use-module (guix records)
25 #:use-module (newt)
26 #:use-module (srfi srfi-1)
27 #:use-module (srfi srfi-34)
28 #:use-module (srfi srfi-35)
29 #:export (run-keymap-page))
30
31(define (run-layout-page layouts layout->text)
32 (let ((title (G_ "Layout selection")))
33 (run-listbox-selection-page
34 #:title title
35 #:info-text (G_ "Please choose your keyboard layout.")
36 #:listbox-items layouts
37 #:listbox-item->text layout->text
38 #:button-text (G_ "Cancel")
39 #:button-callback-procedure
40 (lambda _
41 (raise
42 (condition
43 (&installer-step-abort)))))))
44
45(define (run-variant-page variants variant->text)
46 (let ((title (G_ "Variant selection")))
47 (run-listbox-selection-page
48 #:title title
49 #:info-text (G_ "Please choose a variant for your keyboard layout.")
50 #:listbox-items variants
51 #:listbox-item->text variant->text
52 #:button-text (G_ "Back")
53 #:button-callback-procedure
54 (lambda _
55 (raise
56 (condition
57 (&installer-step-abort)))))))
58
59(define (run-model-page models model->text)
60 (let ((title (G_ "Keyboard model selection")))
61 (run-listbox-selection-page
62 #:title title
63 #:info-text (G_ "Please choose your keyboard model.")
64 #:listbox-items models
65 #:listbox-item->text model->text
66 #:listbox-default-item (find (lambda (model)
67 (string=? (x11-keymap-model-name model)
68 "pc105"))
69 models)
70 #:sort-listbox-items? #f
71 #:button-text (G_ "Back")
72 #:button-callback-procedure
73 (lambda _
74 (raise
75 (condition
76 (&installer-step-abort)))))))
77
78(define* (run-keymap-page #:key models layouts)
79 "Run a page asking the user to select a keyboard model, layout and
80variant. MODELS and LAYOUTS are lists of supported X11-KEYMAP-MODEL and
81X11-KEYMAP-LAYOUT. Return a list of three elements, the names of the selected
82keyboard model, layout and variant."
83 (define keymap-steps
84 (list
85 (installer-step
86 (id 'model)
87 (compute
88 (lambda _
89 ;; TODO: Understand why (run-model-page models x11-keymap-model-name)
90 ;; fails with: warning: possibly unbound variable
91 ;; `%x11-keymap-model-description-procedure.
92 (run-model-page models (lambda (model)
93 (x11-keymap-model-description
94 model))))))
95 (installer-step
96 (id 'layout)
97 (compute
98 (lambda _
99 (let* ((layout (run-layout-page
100 layouts
101 (lambda (layout)
102 (x11-keymap-layout-description layout)))))
103 (if (null? (x11-keymap-layout-variants layout))
104 ;; Break if this layout does not have any variant.
105 (raise
106 (condition
107 (&installer-step-break)))
108 layout)))))
109 ;; Propose the user to select a variant among those supported by the
110 ;; previously selected layout.
111 (installer-step
112 (id 'variant)
113 (compute
114 (lambda (result)
115 (let ((variants (x11-keymap-layout-variants
116 (result-step result 'layout))))
117 (run-variant-page variants
118 (lambda (variant)
119 (x11-keymap-variant-description
120 variant)))))))))
121
122 (define (format-result result)
123 (let ((model (x11-keymap-model-name
124 (result-step result 'model)))
125 (layout (x11-keymap-layout-name
126 (result-step result 'layout)))
127 (variant (and=> (result-step result 'variant)
128 (lambda (variant)
129 (x11-keymap-variant-name variant)))))
130 (list model layout (or variant ""))))
131 (format-result
132 (run-installer-steps #:steps keymap-steps)))
diff --git a/gnu/installer/newt/locale.scm b/gnu/installer/newt/locale.scm
new file mode 100644
index 00000000000..5444a075984
--- /dev/null
+++ b/gnu/installer/newt/locale.scm
@@ -0,0 +1,193 @@
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 newt locale)
20 #:use-module (gnu installer locale)
21 #:use-module (gnu installer steps)
22 #:use-module (gnu installer newt page)
23 #:use-module (guix i18n)
24 #:use-module (newt)
25 #:use-module (srfi srfi-1)
26 #:use-module (srfi srfi-26)
27 #:use-module (srfi srfi-34)
28 #:use-module (srfi srfi-35)
29 #:use-module (ice-9 match)
30 #:export (run-locale-page))
31
32(define (run-language-page languages language->text)
33 (let ((title (G_ "Language selection")))
34 (run-listbox-selection-page
35 #:title title
36 #:info-text (G_ "Choose the language to be used for the installation \
37process. The selected language will also be the default \
38language for the installed system.")
39 #:listbox-items languages
40 #:listbox-item->text language->text
41 #:button-text (G_ "Cancel")
42 #:button-callback-procedure
43 (lambda _
44 (raise
45 (condition
46 (&installer-step-abort)))))))
47
48(define (run-territory-page territories territory->text)
49 (let ((title (G_ "Location selection")))
50 (run-listbox-selection-page
51 #:title title
52 #:info-text (G_ "Choose your location. This is a shortlist of locations \
53based on the language you selected.")
54 #:listbox-items territories
55 #:listbox-item->text territory->text
56 #:button-text (G_ "Back")
57 #:button-callback-procedure
58 (lambda _
59 (raise
60 (condition
61 (&installer-step-abort)))))))
62
63(define (run-codeset-page codesets)
64 (let ((title (G_ "Codeset selection")))
65 (run-listbox-selection-page
66 #:title title
67 #:info-text (G_ "Choose your codeset. If UTF-8 is available, it should be \
68preferred.")
69 #:listbox-items codesets
70 #:listbox-item->text identity
71 #:listbox-default-item "UTF-8"
72 #:button-text (G_ "Back")
73 #:button-callback-procedure
74 (lambda _
75 (raise
76 (condition
77 (&installer-step-abort)))))))
78
79(define (run-modifier-page modifiers modifier->text)
80 (let ((title (G_ "Modifier selection")))
81 (run-listbox-selection-page
82 #:title title
83 #:info-text (G_ "Choose your modifier.")
84 #:listbox-items modifiers
85 #:listbox-item->text modifier->text
86 #:button-text (G_ "Back")
87 #:button-callback-procedure
88 (lambda _
89 (raise
90 (condition
91 (&installer-step-abort)))))))
92
93(define* (run-locale-page #:key
94 supported-locales
95 iso639-languages
96 iso3166-territories)
97
98 (define (break-on-locale-found locales)
99 "Raise the &installer-step-break condition if LOCALES contains exactly one
100element."
101 (and (= (length locales) 1)
102 (raise
103 (condition (&installer-step-break)))))
104
105 (define (filter-locales locales result)
106 "Filter the list of locale records LOCALES using the RESULT returned by
107the installer-steps defined below."
108 (filter
109 (lambda (locale)
110 (and-map identity
111 `(,(string=? (locale-language locale)
112 (result-step result 'language))
113 ,@(if (result-step-done? result 'territory)
114 (list (equal? (locale-territory locale)
115 (result-step result 'territory)))
116 '())
117 ,@(if (result-step-done? result 'codeset)
118 (list (equal? (locale-codeset locale)
119 (result-step result 'codeset)))
120 '())
121 ,@(if (result-step-done? result 'modifier)
122 (list (equal? (locale-modifier locale)
123 (result-step result 'modifier)))
124 '()))))
125 locales))
126
127 (define (result->locale-string locales result)
128 "Supposing that LOCALES contains exactly one locale record, turn it into a
129glibc locale string and return it."
130 (match (filter-locales locales result)
131 ((locale)
132 (locale->locale-string locale))))
133
134 (define locale-steps
135 (list
136 (installer-step
137 (id 'language)
138 (compute
139 (lambda _
140 (run-language-page
141 (delete-duplicates (map locale-language supported-locales))
142 (cut language-code->language-name iso639-languages <>)))))
143 (installer-step
144 (id 'territory)
145 (compute
146 (lambda (result)
147 (let ((locales (filter-locales supported-locales result)))
148 ;; Stop the process if the language returned by the previous step
149 ;; is matching one and only one supported locale.
150 (break-on-locale-found locales)
151
152 ;; Otherwise, ask the user to select a territory among those
153 ;; supported by the previously selected language.
154 (run-territory-page
155 (delete-duplicates (map locale-territory locales))
156 (lambda (territory-code)
157 (if territory-code
158 (territory-code->territory-name iso3166-territories
159 territory-code)
160 (G_ "No location"))))))))
161 (installer-step
162 (id 'codeset)
163 (compute
164 (lambda (result)
165 (let ((locales (filter-locales supported-locales result)))
166 ;; Same as above but we now have a language and a territory to
167 ;; narrow down the search of a locale.
168 (break-on-locale-found locales)
169
170 ;; Otherwise, ask for a codeset.
171 (run-codeset-page
172 (delete-duplicates (map locale-codeset locales)))))))
173 (installer-step
174 (id 'modifier)
175 (compute
176 (lambda (result)
177 (let ((locales (filter-locales supported-locales result)))
178 ;; Same thing with a language, a territory and a codeset this time.
179 (break-on-locale-found locales)
180
181 ;; Otherwise, ask for a modifier.
182 (run-modifier-page
183 (delete-duplicates (map locale-modifier locales))
184 (lambda (modifier)
185 (or modifier (G_ "No modifier"))))))))))
186
187 ;; If run-installer-steps returns locally, it means that the user had to go
188 ;; through all steps (language, territory, codeset and modifier) to select a
189 ;; locale. In that case, like if we exited by raising &installer-step-break
190 ;; condition, turn the result into a glibc locale string and return it.
191 (result->locale-string
192 supported-locales
193 (run-installer-steps #:steps locale-steps)))
diff --git a/gnu/installer/newt/menu.scm b/gnu/installer/newt/menu.scm
new file mode 100644
index 00000000000..756b582a500
--- /dev/null
+++ b/gnu/installer/newt/menu.scm
@@ -0,0 +1,44 @@
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 newt menu)
20 #:use-module (gnu installer steps)
21 #:use-module (gnu installer newt page)
22 #:use-module (guix i18n)
23 #:use-module (newt)
24 #:export (run-menu-page))
25
26(define (run-menu-page steps)
27 "Run a menu page, asking the user to select where to resume the install
28process from."
29 (define (steps->items steps)
30 (filter (lambda (step)
31 (installer-step-description step))
32 steps))
33
34 (run-listbox-selection-page
35 #:info-text (G_ "Choose where you want to resume the install.\
36You can also abort the installion by pressing the button.")
37 #:title (G_ "Installation menu")
38 #:listbox-items (steps->items steps)
39 #:listbox-item->text installer-step-description
40 #:sort-listbox-items? #f
41 #:button-text (G_ "Abort")
42 #:button-callback-procedure (lambda ()
43 (newt-finish)
44 (primitive-exit 1))))
diff --git a/gnu/installer/newt/network.scm b/gnu/installer/newt/network.scm
new file mode 100644
index 00000000000..c6ba69d4e88
--- /dev/null
+++ b/gnu/installer/newt/network.scm
@@ -0,0 +1,159 @@
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 newt network)
20 #:use-module (gnu installer connman)
21 #:use-module (gnu installer steps)
22 #:use-module (gnu installer utils)
23 #:use-module (gnu installer newt ethernet)
24 #:use-module (gnu installer newt page)
25 #:use-module (gnu installer newt wifi)
26 #:use-module (guix i18n)
27 #:use-module (srfi srfi-1)
28 #:use-module (srfi srfi-11)
29 #:use-module (srfi srfi-34)
30 #:use-module (srfi srfi-35)
31 #:use-module (newt)
32 #:export (run-network-page))
33
34;; Maximum length of a technology name.
35(define technology-name-max-length (make-parameter 20))
36
37(define (technology->text technology)
38 "Return a string describing the given TECHNOLOGY."
39 (let* ((name (technology-name technology))
40 (padded-name (string-pad-right name
41 (technology-name-max-length))))
42 (format #f "~a~%" padded-name)))
43
44(define (run-technology-page)
45 "Run a page to ask the user which technology shall be used to access
46Internet and return the selected technology. For now, only technologies with
47\"ethernet\" or \"wifi\" types are supported."
48 (define (technology-items)
49 (filter (lambda (technology)
50 (let ((type (technology-type technology)))
51 (or
52 (string=? type "ethernet")
53 (string=? type "wifi"))))
54 (connman-technologies)))
55
56 (run-listbox-selection-page
57 #:info-text (G_ "The install process requires an internet access.\
58 Please select a network technology.")
59 #:title (G_ "Technology selection")
60 #:listbox-items (technology-items)
61 #:listbox-item->text technology->text
62 #:button-text (G_ "Cancel")
63 #:button-callback-procedure
64 (lambda _
65 (raise
66 (condition
67 (&installer-step-abort))))))
68
69(define (find-technology-by-type technologies type)
70 "Find and return a technology with the given TYPE in TECHNOLOGIES list."
71 (find (lambda (technology)
72 (string=? (technology-type technology)
73 type))
74 technologies))
75
76(define (wait-technology-powered technology)
77 "Wait and display a progress bar until the given TECHNOLOGY is powered."
78 (let ((name (technology-name technology))
79 (full-value 5))
80 (run-scale-page
81 #:title (G_ "Powering technology")
82 #:info-text (format #f "Waiting for technology ~a to be powered." name)
83 #:scale-full-value full-value
84 #:scale-update-proc
85 (lambda (value)
86 (let* ((technologies (connman-technologies))
87 (type (technology-type technology))
88 (updated-technology
89 (find-technology-by-type technologies type))
90 (technology-powered? updated-technology))
91 (sleep 1)
92 (if technology-powered?
93 full-value
94 (+ value 1)))))))
95
96(define (wait-service-online)
97 "Display a newt scale until connman detects an Internet access. Do
98FULL-VALUE tentatives, spaced by 1 second."
99 (let* ((full-value 5))
100 (run-scale-page
101 #:title (G_ "Checking connectivity")
102 #:info-text (G_ "Waiting internet access is established")
103 #:scale-full-value full-value
104 #:scale-update-proc
105 (lambda (value)
106 (sleep 1)
107 (if (connman-online?)
108 full-value
109 (+ value 1))))
110 (unless (connman-online?)
111 (run-error-page
112 (G_ "The selected network does not provide an Internet \
113access, please try again.")
114 (G_ "Connection error"))
115 (raise
116 (condition
117 (&installer-step-abort))))))
118
119(define (run-network-page)
120 "Run a page to allow the user to configure connman so that it can access the
121Internet."
122 (define network-steps
123 (list
124 ;; Ask the user to choose between ethernet and wifi technologies.
125 (installer-step
126 (id 'select-technology)
127 (compute
128 (lambda _
129 (run-technology-page))))
130 ;; Enable the previously selected technology.
131 (installer-step
132 (id 'power-technology)
133 (compute
134 (lambda (result)
135 (let ((technology (result-step result 'select-technology)))
136 (connman-enable-technology technology)
137 (wait-technology-powered technology)))))
138 ;; Propose the user to connect to one of the service available for the
139 ;; previously selected technology.
140 (installer-step
141 (id 'connect-service)
142 (compute
143 (lambda (result)
144 (let* ((technology (result-step result 'select-technology))
145 (type (technology-type technology)))
146 (cond
147 ((string=? "wifi" type)
148 (run-wifi-page))
149 ((string=? "ethernet" type)
150 (run-ethernet-page)))))))
151 ;; Wait for connman status to switch to 'online, which means it can
152 ;; access Internet.
153 (installer-step
154 (id 'wait-online)
155 (compute (lambda _
156 (wait-service-online))))))
157 (run-installer-steps
158 #:steps network-steps
159 #:rewind-strategy 'start))
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
new file mode 100644
index 00000000000..bcede3e333e
--- /dev/null
+++ b/gnu/installer/newt/page.scm
@@ -0,0 +1,313 @@
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 newt page)
20 #:use-module (gnu installer newt utils)
21 #:use-module (guix i18n)
22 #:use-module (ice-9 match)
23 #:use-module (ice-9 receive)
24 #:use-module (newt)
25 #:export (draw-info-page
26 draw-connecting-page
27 run-input-page
28 run-error-page
29 run-listbox-selection-page
30 run-scale-page))
31
32;;; Commentary:
33;;;
34;;; Some helpers around guile-newt to draw or run generic pages. The
35;;; difference between 'draw' and 'run' terms comes from newt library. A page
36;;; is drawn when the form it contains does not expect any user
37;;; interaction. In that case, it is necessary to call (newt-refresh) to force
38;;; the page to be displayed. When a form is 'run', it is blocked waiting for
39;;; any action from the user (press a button, input some text, ...).
40;;;
41;;; Code:
42
43(define (draw-info-page text title)
44 "Draw an informative page with the given TEXT as content. Set the title of
45this page to TITLE."
46 (let* ((text-box
47 (make-reflowed-textbox -1 -1 text 40
48 #:flags FLAG-BORDER))
49 (grid (make-grid 1 1))
50 (form (make-form)))
51 (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box)
52 (add-component-to-form form text-box)
53 (make-wrapped-grid-window grid title)
54 (draw-form form)
55 ;; This call is imperative, otherwise the form won't be displayed. See the
56 ;; explanation in the above commentary.
57 (newt-refresh)
58 form))
59
60(define (draw-connecting-page service-name)
61 "Draw a page to indicate a connection in in progress."
62 (draw-info-page
63 (format #f (G_ "Connecting to ~a, please wait.") service-name)
64 (G_ "Connection in progress")))
65
66(define* (run-input-page text title
67 #:key
68 (allow-empty-input? #f)
69 (input-field-width 40))
70 "Run a page to prompt user for an input. The given TEXT will be displayed
71above the input field. The page title is set to TITLE. Unless
72allow-empty-input? is set to #t, an error page will be displayed if the user
73enters an empty input."
74 (let* ((text-box
75 (make-reflowed-textbox -1 -1 text
76 input-field-width
77 #:flags FLAG-BORDER))
78 (grid (make-grid 1 3))
79 (input-entry (make-entry -1 -1 20))
80 (ok-button (make-button -1 -1 (G_ "Ok")))
81 (form (make-form)))
82
83 (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box)
84 (set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT input-entry
85 #:pad-top 1)
86 (set-grid-field grid 0 2 GRID-ELEMENT-COMPONENT ok-button
87 #:pad-top 1)
88
89 (add-components-to-form form text-box input-entry ok-button)
90 (make-wrapped-grid-window grid title)
91 (let ((error-page (lambda ()
92 (run-error-page (G_ "Please enter a non empty input")
93 (G_ "Empty input")))))
94 (let loop ()
95 (receive (exit-reason argument)
96 (run-form form)
97 (let ((input (entry-value input-entry)))
98 (if (and (not allow-empty-input?)
99 (eq? exit-reason 'exit-component)
100 (string=? input ""))
101 (begin
102 ;; Display the error page.
103 (error-page)
104 ;; Set the focus back to the input input field.
105 (set-current-component form input-entry)
106 (loop))
107 (begin
108 (destroy-form-and-pop form)
109 input))))))))
110
111(define (run-error-page text title)
112 "Run a page to inform the user of an error. The page contains the given TEXT
113to explain the error and an \"OK\" button to acknowledge the error. The title
114of the page is set to TITLE."
115 (let* ((text-box
116 (make-reflowed-textbox -1 -1 text 40
117 #:flags FLAG-BORDER))
118 (grid (make-grid 1 2))
119 (ok-button (make-button -1 -1 "Ok"))
120 (form (make-form)))
121
122 (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box)
123 (set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT ok-button
124 #:pad-top 1)
125
126 ;; Set the background color to red to indicate something went wrong.
127 (newt-set-color COLORSET-ROOT "white" "red")
128 (add-components-to-form form text-box ok-button)
129 (make-wrapped-grid-window grid title)
130 (run-form form)
131 ;; Restore the background to its original color.
132 (newt-set-color COLORSET-ROOT "white" "blue")
133 (destroy-form-and-pop form)))
134
135(define* (run-listbox-selection-page #:key
136 info-text
137 title
138 (info-textbox-width 50)
139 listbox-items
140 listbox-item->text
141 (listbox-height 20)
142 (listbox-default-item #f)
143 (listbox-allow-multiple? #f)
144 (sort-listbox-items? #t)
145 button-text
146 (button-callback-procedure
147 (const #t))
148 (listbox-callback-procedure
149 (const #t)))
150 "Run a page asking the user to select an item in a listbox. The page
151contains, stacked vertically from the top to the bottom, an informative text
152set to INFO-TEXT, a listbox and a button. The listbox will be filled with
153LISTBOX-ITEMS converted to text by applying the procedure LISTBOX-ITEM->TEXT
154on every item. The selected item from LISTBOX-ITEMS is returned. The button
155text is set to BUTTON-TEXT and the procedure BUTTON-CALLBACK-PROCEDURE called
156when it is pressed. The procedure LISTBOX-CALLBACK-PROCEDURE is called when an
157item from the listbox is selected (by pressing the <ENTER> key).
158
159INFO-TEXTBOX-WIDTH is the width of the textbox where INFO-TEXT will be
160displayed. LISTBOX-HEIGHT is the height of the listbox.
161
162If LISTBOX-DEFAULT-ITEM is set to the value of one of the items in
163LISTBOX-ITEMS, it will be selected by default. Otherwise, the first element of
164the listbox is selected.
165
166If LISTBOX-ALLOW-MULTIPLE? is set to #t, multiple items from the listbox can
167be selected (using the <SPACE> key). It that case, a list containing the
168selected items will be returned.
169
170If SORT-LISTBOX-ITEMS? is set to #t, the listbox items are sorted using
171'string<=' procedure (after being converted to text)."
172
173 (define (fill-listbox listbox items)
174 "Append the given ITEMS to LISTBOX, once they have been converted to text
175with LISTBOX-ITEM->TEXT. Each item appended to the LISTBOX is given a key by
176newt. Save this key by returning an association list under the form:
177
178 ((NEWT-LISTBOX-KEY . ITEM) ...)
179
180where NEWT-LISTBOX-KEY is the key returned by APPEND-ENTRY-TO-LISTBOX, when
181ITEM was inserted into LISTBOX."
182 (map (lambda (item)
183 (let* ((text (listbox-item->text item))
184 (key (append-entry-to-listbox listbox text)))
185 (cons key item)))
186 items))
187
188 (define (sort-listbox-items listbox-items)
189 "Return LISTBOX-ITEMS sorted using the 'string<=' procedure on the text
190corresponding to each item in the list."
191 (let* ((items (map (lambda (item)
192 (cons item (listbox-item->text item)))
193 listbox-items))
194 (sorted-items
195 (sort items (lambda (a b)
196 (let ((text-a (cdr a))
197 (text-b (cdr b)))
198 (string<= text-a text-b))))))
199 (map car sorted-items)))
200
201 (define (set-default-item listbox listbox-keys default-item)
202 "Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the
203association list returned by the FILL-LISTBOX procedure. It is used because
204the current listbox item has to be selected by key."
205 (for-each (match-lambda
206 ((key . item)
207 (when (equal? item default-item)
208 (set-current-listbox-entry-by-key listbox key))))
209 listbox-keys))
210
211 (let* ((listbox (make-listbox
212 -1 -1
213 listbox-height
214 (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT
215 (if listbox-allow-multiple?
216 FLAG-MULTIPLE
217 0))))
218 (form (make-form))
219 (info-textbox
220 (make-reflowed-textbox -1 -1 info-text
221 info-textbox-width
222 #:flags FLAG-BORDER))
223 (button (make-button -1 -1 button-text))
224 (grid (vertically-stacked-grid
225 GRID-ELEMENT-COMPONENT info-textbox
226 GRID-ELEMENT-COMPONENT listbox
227 GRID-ELEMENT-COMPONENT button))
228 (sorted-items (if sort-listbox-items?
229 (sort-listbox-items listbox-items)
230 listbox-items))
231 (keys (fill-listbox listbox sorted-items)))
232
233 (when listbox-default-item
234 (set-default-item listbox keys listbox-default-item))
235
236 (add-form-to-grid grid form #t)
237 (make-wrapped-grid-window grid title)
238
239 (receive (exit-reason argument)
240 (run-form form)
241 (dynamic-wind
242 (const #t)
243 (lambda ()
244 (when (eq? exit-reason 'exit-component)
245 (cond
246 ((components=? argument button)
247 (button-callback-procedure))
248 ((components=? argument listbox)
249 (if listbox-allow-multiple?
250 (let* ((entries (listbox-selection listbox))
251 (items (map (lambda (entry)
252 (assoc-ref keys entry))
253 entries)))
254 (listbox-callback-procedure items)
255 items)
256 (let* ((entry (current-listbox-entry listbox))
257 (item (assoc-ref keys entry)))
258 (listbox-callback-procedure item)
259 item))))))
260 (lambda ()
261 (destroy-form-and-pop form))))))
262
263(define* (run-scale-page #:key
264 title
265 info-text
266 (info-textbox-width 50)
267 (scale-width 40)
268 (scale-full-value 100)
269 scale-update-proc
270 (max-scale-update 5))
271 "Run a page with a progress bar (called 'scale' in newt). The given
272INFO-TEXT is displayed in a textbox above the scale. The width of the textbox
273is set to INFO-TEXTBOX-WIDTH. The width of the scale is set to
274SCALE-WIDTH. SCALE-FULL-VALUE indicates the value that correspond to 100% of
275the scale.
276
277The procedure SCALE-UPDATE-PROC shall return a new scale
278value. SCALE-UPDATE-PROC will be called until the returned value is superior
279or equal to SCALE-FULL-VALUE, but no more than MAX-SCALE-UPDATE times. An
280error is raised if the MAX-SCALE-UPDATE limit is reached."
281 (let* ((info-textbox
282 (make-reflowed-textbox -1 -1 info-text
283 info-textbox-width
284 #:flags FLAG-BORDER))
285 (scale (make-scale -1 -1 scale-width scale-full-value))
286 (grid (vertically-stacked-grid
287 GRID-ELEMENT-COMPONENT info-textbox
288 GRID-ELEMENT-COMPONENT scale))
289 (form (make-form)))
290
291 (add-form-to-grid grid form #t)
292 (make-wrapped-grid-window grid title)
293
294 (draw-form form)
295 ;; This call is imperative, otherwise the form won't be displayed. See the
296 ;; explanation in the above commentary.
297 (newt-refresh)
298
299 (dynamic-wind
300 (const #t)
301 (lambda ()
302 (let loop ((i max-scale-update)
303 (last-value 0))
304 (let ((value (scale-update-proc last-value)))
305 (set-scale-value scale value)
306 ;; Same as above.
307 (newt-refresh)
308 (unless (>= value scale-full-value)
309 (if (> i 0)
310 (loop (- i 1) value)
311 (error "Max scale updates reached."))))))
312 (lambda ()
313 (destroy-form-and-pop form)))))
diff --git a/gnu/installer/newt/timezone.scm b/gnu/installer/newt/timezone.scm
new file mode 100644
index 00000000000..a2c9b458f51
--- /dev/null
+++ b/gnu/installer/newt/timezone.scm
@@ -0,0 +1,83 @@
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 newt timezone)
20 #:use-module (gnu installer steps)
21 #:use-module (gnu installer timezone)
22 #:use-module (gnu installer newt page)
23 #:use-module (guix i18n)
24 #:use-module (srfi srfi-1)
25 #:use-module (srfi srfi-26)
26 #:use-module (srfi srfi-34)
27 #:use-module (srfi srfi-35)
28 #:use-module (ice-9 match)
29 #:use-module (ice-9 receive)
30 #:use-module (newt)
31 #:export (run-timezone-page))
32
33;; Heigth of the listbox displaying timezones.
34(define timezone-listbox-heigth (make-parameter 20))
35
36;; Information textbox width.
37(define info-textbox-width (make-parameter 40))
38
39(define (fill-timezones listbox timezones)
40 "Fill the given LISTBOX with TIMEZONES. Return an association list
41correlating listbox keys with timezones."
42 (map (lambda (timezone)
43 (let ((key (append-entry-to-listbox listbox timezone)))
44 (cons key timezone)))
45 timezones))
46
47(define (run-timezone-page zonetab)
48 "Run a page displaying available timezones, grouped by regions. The user is
49invited to select a timezone. The selected timezone, under Posix format is
50returned."
51 (define (all-but-last list)
52 (reverse (cdr (reverse list))))
53
54 (define (run-page timezone-tree)
55 (define (loop path)
56 (let ((timezones (locate-childrens timezone-tree path)))
57 (run-listbox-selection-page
58 #:title (G_ "Timezone selection")
59 #:info-text (G_ "Please select a timezone.")
60 #:listbox-items timezones
61 #:listbox-item->text identity
62 #:button-text (if (null? path)
63 (G_ "Cancel")
64 (G_ "Back"))
65 #:button-callback-procedure
66 (if (null? path)
67 (lambda _
68 (raise
69 (condition
70 (&installer-step-abort))))
71 (lambda _
72 (loop (all-but-last path))))
73 #:listbox-callback-procedure
74 (lambda (timezone)
75 (let* ((timezone* (append path (list timezone)))
76 (tz (timezone->posix-tz timezone*)))
77 (if (timezone-has-child? timezone-tree timezone*)
78 (loop timezone*)
79 tz))))))
80 (loop '()))
81
82 (let ((timezone-tree (zonetab->timezone-tree zonetab)))
83 (run-page timezone-tree)))
diff --git a/gnu/installer/newt/user.scm b/gnu/installer/newt/user.scm
new file mode 100644
index 00000000000..f342caae043
--- /dev/null
+++ b/gnu/installer/newt/user.scm
@@ -0,0 +1,181 @@
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 newt user)
20 #:use-module (gnu installer newt page)
21 #:use-module (gnu installer newt utils)
22 #:use-module (guix i18n)
23 #:use-module (newt)
24 #:use-module (ice-9 match)
25 #:use-module (ice-9 receive)
26 #:use-module (srfi srfi-1)
27 #:use-module (srfi srfi-26)
28 #:export (run-user-page))
29
30(define (run-user-add-page)
31 (define (pad-label label)
32 (string-pad-right label 20))
33
34 (let* ((label-name
35 (make-label -1 -1 (pad-label (G_ "Name"))))
36 (label-group
37 (make-label -1 -1 (pad-label (G_ "Group"))))
38 (label-home-directory
39 (make-label -1 -1 (pad-label (G_ "Home directory"))))
40 (entry-width 30)
41 (entry-name (make-entry -1 -1 entry-width))
42 (entry-group (make-entry -1 -1 entry-width
43 #:initial-value "users"))
44 (entry-home-directory (make-entry -1 -1 entry-width))
45 (entry-grid (make-grid 2 3))
46 (button-grid (make-grid 1 1))
47 (ok-button (make-button -1 -1 (G_ "Ok")))
48 (grid (make-grid 1 2))
49 (title (G_ "User creation"))
50 (set-entry-grid-field
51 (cut set-grid-field entry-grid <> <> GRID-ELEMENT-COMPONENT <>))
52 (form (make-form)))
53
54 (set-entry-grid-field 0 0 label-name)
55 (set-entry-grid-field 1 0 entry-name)
56 (set-entry-grid-field 0 1 label-group)
57 (set-entry-grid-field 1 1 entry-group)
58 (set-entry-grid-field 0 2 label-home-directory)
59 (set-entry-grid-field 1 2 entry-home-directory)
60
61 (set-grid-field button-grid 0 0 GRID-ELEMENT-COMPONENT ok-button)
62
63 (add-component-callback
64 entry-name
65 (lambda (component)
66 (set-entry-text entry-home-directory
67 (string-append "/home/" (entry-value entry-name)))))
68
69 (add-components-to-form form
70 label-name label-group label-home-directory
71 entry-name entry-group entry-home-directory
72 ok-button)
73
74 (make-wrapped-grid-window (vertically-stacked-grid
75 GRID-ELEMENT-SUBGRID entry-grid
76 GRID-ELEMENT-SUBGRID button-grid)
77 title)
78 (let ((error-page
79 (lambda ()
80 (run-error-page (G_ "Empty inputs are not allowed")
81 (G_ "Empty input")))))
82 (receive (exit-reason argument)
83 (run-form form)
84 (dynamic-wind
85 (const #t)
86 (lambda ()
87 (when (eq? exit-reason 'exit-component)
88 (cond
89 ((components=? argument ok-button)
90 (let ((name (entry-value entry-name))
91 (group (entry-value entry-group))
92 (home-directory (entry-value entry-home-directory)))
93 (if (or (string=? name "")
94 (string=? group "")
95 (string=? home-directory ""))
96 (begin
97 (error-page)
98 (run-user-add-page))
99 `((name . ,name)
100 (group . ,group)
101 (home-directory . ,home-directory))))))))
102 (lambda ()
103 (destroy-form-and-pop form)))))))
104
105(define (run-user-page)
106 (define (run users)
107 (let* ((listbox (make-listbox
108 -1 -1 10
109 (logior FLAG-SCROLL FLAG-BORDER)))
110 (info-textbox
111 (make-reflowed-textbox
112 -1 -1
113 (G_ "Please add at least one user to system\
114 using the 'Add' button.")
115 40 #:flags FLAG-BORDER))
116 (add-button (make-compact-button -1 -1 (G_ "Add")))
117 (del-button (make-compact-button -1 -1 (G_ "Delete")))
118 (listbox-button-grid
119 (apply
120 vertically-stacked-grid
121 GRID-ELEMENT-COMPONENT add-button
122 `(,@(if (null? users)
123 '()
124 (list GRID-ELEMENT-COMPONENT del-button)))))
125 (ok-button (make-button -1 -1 (G_ "Ok")))
126 (cancel-button (make-button -1 -1 (G_ "Cancel")))
127 (title "User selection")
128 (grid
129 (vertically-stacked-grid
130 GRID-ELEMENT-COMPONENT info-textbox
131 GRID-ELEMENT-SUBGRID (horizontal-stacked-grid
132 GRID-ELEMENT-COMPONENT listbox
133 GRID-ELEMENT-SUBGRID listbox-button-grid)
134 GRID-ELEMENT-SUBGRID (horizontal-stacked-grid
135 GRID-ELEMENT-COMPONENT ok-button
136 GRID-ELEMENT-COMPONENT cancel-button)))
137 (sorted-users (sort users (lambda (a b)
138 (string<= (assoc-ref a 'name)
139 (assoc-ref b 'name)))))
140 (listbox-elements
141 (map
142 (lambda (user)
143 `((key . ,(append-entry-to-listbox listbox
144 (assoc-ref user 'name)))
145 (user . ,user)))
146 sorted-users))
147 (form (make-form)))
148
149
150 (add-form-to-grid grid form #t)
151 (make-wrapped-grid-window grid title)
152 (if (null? users)
153 (set-current-component form add-button)
154 (set-current-component form ok-button))
155
156 (receive (exit-reason argument)
157 (run-form form)
158 (dynamic-wind
159 (const #t)
160 (lambda ()
161 (when (eq? exit-reason 'exit-component)
162 (cond
163 ((components=? argument add-button)
164 (run (cons (run-user-add-page) users)))
165 ((components=? argument del-button)
166 (let* ((current-user-key (current-listbox-entry listbox))
167 (users
168 (map (cut assoc-ref <> 'user)
169 (remove (lambda (element)
170 (equal? (assoc-ref element 'key)
171 current-user-key))
172 listbox-elements))))
173 (run users)))
174 ((components=? argument ok-button)
175 (when (null? users)
176 (run-error-page (G_ "Please create at least one user.")
177 (G_ "No user"))
178 (run users))))))
179 (lambda ()
180 (destroy-form-and-pop form))))))
181 (run '()))
diff --git a/gnu/installer/newt/utils.scm b/gnu/installer/newt/utils.scm
new file mode 100644
index 00000000000..1c2ce4e6283
--- /dev/null
+++ b/gnu/installer/newt/utils.scm
@@ -0,0 +1,43 @@
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 newt utils)
20 #:use-module (ice-9 receive)
21 #:use-module (newt)
22 #:export (screen-columns
23 screen-rows
24
25 destroy-form-and-pop
26 set-screen-size!))
27
28;; Number of columns and rows of the terminal.
29(define screen-columns (make-parameter 0))
30(define screen-rows (make-parameter 0))
31
32(define (destroy-form-and-pop form)
33 "Destory the given FORM and pop the current window."
34 (destroy-form form)
35 (pop-window))
36
37(define (set-screen-size!)
38 "Set the parameters 'screen-columns' and 'screen-rows' to the number of
39columns and rows respectively of the current terminal."
40 (receive (columns rows)
41 (screen-size)
42 (screen-columns columns)
43 (screen-rows rows)))
diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm
new file mode 100644
index 00000000000..8ed9f68918b
--- /dev/null
+++ b/gnu/installer/newt/welcome.scm
@@ -0,0 +1,122 @@
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
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 newt welcome)
20 #:use-module (gnu installer utils)
21 #:use-module (gnu installer newt utils)
22 #:use-module (guix build syscalls)
23 #:use-module (guix i18n)
24 #:use-module (ice-9 match)
25 #:use-module (ice-9 receive)
26 #:use-module (newt)
27 #:export (run-welcome-page))
28
29;; Margin between screen border and newt root window.
30(define margin-left (make-parameter 3))
31(define margin-top (make-parameter 3))
32
33;; Expected width and height for the logo.
34(define logo-width (make-parameter 50))
35(define logo-height (make-parameter 23))
36
37(define (nearest-exact-integer x)
38 "Given a real number X, return the nearest exact integer, with ties going to
39the nearest exact even integer."
40 (inexact->exact (round x)))
41
42(define* (run-menu-page title logo
43 #:key
44 listbox-items
45 listbox-item->text)
46 "Run a page with the given TITLE, to ask the user to choose between
47LISTBOX-ITEMS displayed in a listbox. The listbox items are converted to text
48using LISTBOX-ITEM->TEXT procedure. Display the textual LOGO in the center of
49the page. Contrary to other pages, we cannot resort to grid layouts, because
50we want this page to occupy all the screen space available."
51 (define (fill-listbox listbox items)
52 (map (lambda (item)
53 (let* ((text (listbox-item->text item))
54 (key (append-entry-to-listbox listbox text)))
55 (cons key item)))
56 items))
57
58 (let* ((windows
59 (make-window (margin-left)
60 (margin-top)
61 (- (screen-columns) (* 2 (margin-left)))
62 (- (screen-rows) (* 2 (margin-top)))
63 title))
64 (logo-textbox
65 (make-textbox (nearest-exact-integer
66 (- (/ (screen-columns) 2)
67 (+ (/ (logo-width) 2) (margin-left))))
68 (margin-top) (logo-width) (logo-height) 0))
69 (text (set-textbox-text logo-textbox
70 (read-all logo)))
71 (options-listbox
72 (make-listbox (margin-left)
73 (+ (logo-height) (margin-top))
74 (- (screen-rows) (+ (logo-height)
75 (* (margin-top) 4)))
76 (logior FLAG-BORDER FLAG-RETURNEXIT)))
77 (keys (fill-listbox options-listbox listbox-items))
78 (form (make-form)))
79 (set-listbox-width options-listbox (- (screen-columns)
80 (* (margin-left) 4)))
81 (add-components-to-form form logo-textbox options-listbox)
82
83 (receive (exit-reason argument)
84 (run-form form)
85 (dynamic-wind
86 (const #t)
87 (lambda ()
88 (when (eq? exit-reason 'exit-component)
89 (cond
90 ((components=? argument options-listbox)
91 (let* ((entry (current-listbox-entry options-listbox))
92 (item (assoc-ref keys entry)))
93 (match item
94 ((text . proc)
95 (proc))))))))
96 (lambda ()
97 (destroy-form-and-pop form))))))
98
99(define (run-welcome-page logo)
100 "Run a welcome page with the given textual LOGO displayed at the center of
101the page. Ask the user to choose between manual installation, graphical
102installation and reboot."
103 (run-menu-page
104 (G_ "GNU GuixSD install")
105 logo
106 #:listbox-items
107 `((,(G_ "Install using the unguided shell based process")
108 .
109 ,(lambda ()
110 (clear-screen)
111 (newt-suspend)
112 (system* "bash" "-l")
113 (newt-resume)))
114 (,(G_ "Graphical install using a guided terminal based interface")
115 .
116 ,(const #t))
117 (,(G_ "Reboot")
118 .
119 ,(lambda ()
120 (newt-finish)
121 (reboot))))
122 #:listbox-item->text car))
diff --git a/gnu/installer/newt/wifi.scm b/gnu/installer/newt/wifi.scm
new file mode 100644
index 00000000000..6cac54399a3
--- /dev/null
+++ b/gnu/installer/newt/wifi.scm
@@ -0,0 +1,243 @@
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 newt wifi)
20 #:use-module (gnu installer connman)
21 #:use-module (gnu installer steps)
22 #:use-module (gnu installer newt utils)
23 #:use-module (gnu installer newt page)
24 #:use-module (guix i18n)
25 #:use-module (guix records)
26 #:use-module (ice-9 format)
27 #:use-module (ice-9 popen)
28 #:use-module (ice-9 receive)
29 #:use-module (ice-9 regex)
30 #:use-module (ice-9 rdelim)
31 #:use-module (srfi srfi-1)
32 #:use-module (srfi srfi-34)
33 #:use-module (srfi srfi-35)
34 #:use-module (newt)
35 #:export (run-wifi-page))
36
37;; This record associates a connman service to its key the listbox.
38(define-record-type* <service-item>
39 service-item make-service-item
40 service-item?
41 (service service-item-service) ; connman <service>
42 (key service-item-key)) ; newt listbox-key
43
44(define (strength->string strength)
45 "Convert STRENGTH as an integer percentage into a text printable strength
46bar using unicode characters. Taken from NetworkManager's
47nmc_wifi_strength_bars."
48 (let ((quarter #\x2582)
49 (half #\x2584)
50 (three-quarter #\x2586)
51 (full #\x2588))
52 (cond
53 ((> strength 80)
54 ;; ▂▄▆█
55 (string quarter half three-quarter full))
56 ((> strength 55)
57 ;; ▂▄▆_
58 (string quarter half three-quarter #\_))
59 ((> strength 30)
60 ;; ▂▄__
61 (string quarter half #\_ #\_))
62 ((> strength 5)
63 ;; ▂___
64 (string quarter #\_ #\_ #\_))
65 (else
66 ;; ____
67 (string quarter #\_ #\_ #\_ #\_)))))
68
69(define (force-wifi-scan)
70 "Force a wifi scan. Raise a condition if no wifi technology is available."
71 (let* ((technologies (connman-technologies))
72 (wifi-technology
73 (find (lambda (technology)
74 (string=? (technology-type technology) "wifi"))
75 technologies)))
76 (if wifi-technology
77 (connman-scan-technology wifi-technology)
78 (raise (condition
79 (&message
80 (message (G_ "Unable to find a wifi technology"))))))))
81
82(define (draw-scanning-page)
83 "Draw a page to indicate a wifi scan in in progress."
84 (draw-info-page (G_ "Scanning wifi for available networks, please wait.")
85 (G_ "Scan in progress")))
86
87(define (run-wifi-password-page)
88 "Run a page prompting user for a password and return it."
89 (run-input-page (G_ "Please enter the wifi password")
90 (G_ "Password required")))
91
92(define (run-wrong-password-page service-name)
93 "Run a page to inform user of a wrong password input."
94 (run-error-page
95 (format #f (G_ "The password you entered for ~a is incorrect.")
96 service-name)
97 (G_ "Wrong password")))
98
99(define (run-unknown-error-page service-name)
100 "Run a page to inform user that a connection error happened."
101 (run-error-page
102 (format #f
103 (G_ "An error occured while trying to connect to ~a, please retry.")
104 service-name)
105 (G_ "Connection error")))
106
107(define (password-callback)
108 (run-wifi-password-page))
109
110(define (connect-wifi-service listbox service-items)
111 "Connect to the wifi service selected in LISTBOX. SERVICE-ITEMS is the list
112of <service-item> records present in LISTBOX."
113 (let* ((listbox-key (current-listbox-entry listbox))
114 (item (find (lambda (item)
115 (eq? (service-item-key item) listbox-key))
116 service-items))
117 (service (service-item-service item))
118 (service-name (service-name service))
119 (form (draw-connecting-page service-name)))
120 (dynamic-wind
121 (const #t)
122 (lambda ()
123 (guard (c ((connman-password-error? c)
124 (run-wrong-password-page service-name)
125 #f)
126 ((connman-already-connected-error? c)
127 #t)
128 ((connman-connection-error? c)
129 (run-unknown-error-page service-name)
130 #f))
131 (connman-connect-with-auth service password-callback)))
132 (lambda ()
133 (destroy-form-and-pop form)))))
134
135(define (run-wifi-scan-page)
136 "Force a wifi scan and draw a page during the operation."
137 (let ((form (draw-scanning-page)))
138 (force-wifi-scan)
139 (destroy-form-and-pop form)))
140
141(define (wifi-services)
142 "Return all the connman services of wifi type."
143 (let ((services (connman-services)))
144 (filter (lambda (service)
145 (and (string=? (service-type service) "wifi")
146 (not (string-null? (service-name service)))))
147 services)))
148
149(define* (fill-wifi-services listbox wifi-services)
150 "Append all the services in WIFI-SERVICES to the given LISTBOX."
151 (clear-listbox listbox)
152 (map (lambda (service)
153 (let* ((text (service->text service))
154 (key (append-entry-to-listbox listbox text)))
155 (service-item
156 (service service)
157 (key key))))
158 wifi-services))
159
160;; Maximum length of a wifi service name.
161(define service-name-max-length (make-parameter 20))
162
163;; Heigth of the listbox displaying wifi services.
164(define wifi-listbox-heigth (make-parameter 20))
165
166;; Information textbox width.
167(define info-textbox-width (make-parameter 40))
168
169(define (service->text service)
170 "Return a string composed of the name and the strength of the given
171SERVICE. A '*' preceding the service name indicates that it is connected."
172 (let* ((name (service-name service))
173 (padded-name (string-pad-right name
174 (service-name-max-length)))
175 (strength (service-strength service))
176 (strength-string (strength->string strength))
177 (state (service-state service))
178 (connected? (or (string=? state "online")
179 (string=? state "ready"))))
180 (format #f "~c ~a ~a~%"
181 (if connected? #\* #\ )
182 padded-name
183 strength-string)))
184
185(define (run-wifi-page)
186 "Run a page displaying available wifi networks in a listbox. Connect to the
187network when the corresponding listbox entry is selected. A button allow to
188force a wifi scan."
189 (let* ((listbox (make-listbox
190 -1 -1
191 (wifi-listbox-heigth)
192 (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT)))
193 (form (make-form))
194 (buttons-grid (make-grid 1 1))
195 (middle-grid (make-grid 2 1))
196 (info-text (G_ "Please select a wifi network."))
197 (info-textbox
198 (make-reflowed-textbox -1 -1 info-text
199 (info-textbox-width)
200 #:flags FLAG-BORDER))
201 (cancel-button (make-button -1 -1 (G_ "Cancel")))
202 (scan-button (make-button -1 -1 (G_ "Scan")))
203 (services (wifi-services))
204 (service-items '()))
205
206 (if (null? services)
207 (append-entry-to-listbox listbox (G_ "No wifi detected"))
208 (set! service-items (fill-wifi-services listbox services)))
209
210 (set-grid-field middle-grid 0 0 GRID-ELEMENT-COMPONENT listbox)
211 (set-grid-field middle-grid 1 0 GRID-ELEMENT-COMPONENT scan-button
212 #:anchor ANCHOR-TOP
213 #:pad-left 2)
214 (set-grid-field buttons-grid 0 0 GRID-ELEMENT-COMPONENT cancel-button)
215
216 (add-components-to-form form
217 info-textbox
218 listbox scan-button
219 cancel-button)
220 (make-wrapped-grid-window
221 (basic-window-grid info-textbox middle-grid buttons-grid)
222 (G_ "Wifi selection"))
223
224 (receive (exit-reason argument)
225 (run-form form)
226 (dynamic-wind
227 (const #t)
228 (lambda ()
229 (when (eq? exit-reason 'exit-component)
230 (cond
231 ((components=? argument scan-button)
232 (run-wifi-scan-page)
233 (run-wifi-page))
234 ((components=? argument cancel-button)
235 (raise
236 (condition
237 (&installer-step-abort))))
238 ((components=? argument listbox)
239 (let ((result (connect-wifi-service listbox service-items)))
240 (unless result
241 (run-wifi-page)))))))
242 (lambda ()
243 (destroy-form-and-pop form))))))
diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm
new file mode 100644
index 00000000000..5fd54356dd7
--- /dev/null
+++ b/gnu/installer/steps.scm
@@ -0,0 +1,187 @@
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 steps)
20 #:use-module (guix records)
21 #:use-module (ice-9 match)
22 #:use-module (srfi srfi-1)
23 #:use-module (srfi srfi-34)
24 #:use-module (srfi srfi-35)
25 #:export (&installer-step-abort
26 installer-step-abort?
27
28 &installer-step-break
29 installer-step-break?
30
31 <installer-step>
32 installer-step
33 make-installer-step
34 installer-step?
35 installer-step-id
36 installer-step-description
37 installer-step-compute
38 installer-step-configuration-proc
39
40 run-installer-steps
41 find-step-by-id
42 result->step-ids
43 result-step
44 result-step-done?))
45
46;; This condition may be raised to abort the current step.
47(define-condition-type &installer-step-abort &condition
48 installer-step-abort?)
49
50;; This condition may be raised to break out from the steps execution.
51(define-condition-type &installer-step-break &condition
52 installer-step-break?)
53
54;; An installer-step record is basically an id associated to a compute
55;; procedure. The COMPUTE procedure takes exactly one argument, an association
56;; list containing the results of previously executed installer-steps (see
57;; RUN-INSTALLER-STEPS description). The value returned by the COMPUTE
58;; procedure will be stored in the results list passed to the next
59;; installer-step and so on.
60(define-record-type* <installer-step>
61 installer-step make-installer-step
62 installer-step?
63 (id installer-step-id) ;symbol
64 (description installer-step-description ;string
65 (default #f))
66 (compute installer-step-compute) ;procedure
67 (configuration-format-proc installer-step-configuration-proc ;procedure
68 (default #f)))
69
70(define* (run-installer-steps #:key
71 steps
72 (rewind-strategy 'previous)
73 (menu-proc (const #f)))
74 "Run the COMPUTE procedure of all <installer-step> records in STEPS
75sequencially. If the &installer-step-abort condition is raised, fallback to a
76previous install-step, accordingly to the specified REWIND-STRATEGY.
77
78REWIND-STRATEGY possible values are 'previous, 'menu and 'start. If 'previous
79is selected, the execution will resume at the previous installer-step. If
80'menu is selected, the MENU-PROC procedure will be called. Its return value
81has to be an installer-step ID to jump to. The ID has to be the one of a
82previously executed step. It is impossible to jump forward. Finally if 'start
83is selected, the execution will resume at the first installer-step.
84
85The result of every COMPUTE procedures is stored in an association list, under
86the form:
87
88 '((STEP-ID . COMPUTE-RESULT) ...)
89
90where STEP-ID is the ID field of the installer-step and COMPUTE-RESULT the
91result of the associated COMPUTE procedure. This result association list is
92passed as argument of every COMPUTE procedure. It is finally returned when the
93computation is over.
94
95If the &installer-step-break condition is raised, stop the computation and
96return the accumalated result so far."
97 (define (pop-result list)
98 (cdr list))
99
100 (define (first-step? steps step)
101 (match steps
102 ((first-step . rest-steps)
103 (equal? first-step step))))
104
105 (define* (skip-to-step step result
106 #:key todo-steps done-steps)
107 (match (list todo-steps done-steps)
108 (((todo . rest-todo) (prev-done ... last-done))
109 (if (eq? (installer-step-id todo)
110 (installer-step-id step))
111 (run result
112 #:todo-steps todo-steps
113 #:done-steps done-steps)
114 (skip-to-step step (pop-result result)
115 #:todo-steps (cons last-done todo-steps)
116 #:done-steps prev-done)))))
117
118 (define* (run result #:key todo-steps done-steps)
119 (match todo-steps
120 (() (reverse result))
121 ((step . rest-steps)
122 (guard (c ((installer-step-abort? c)
123 (case rewind-strategy
124 ((previous)
125 (match done-steps
126 (()
127 ;; We cannot go previous the first step. So re-raise
128 ;; the exception. It might be useful in the case of
129 ;; nested run-installer-steps. Abort to 'raise-above
130 ;; prompt to prevent the condition from being catched
131 ;; by one of the previously installed guard.
132 (abort-to-prompt 'raise-above c))
133 ((prev-done ... last-done)
134 (run (pop-result result)
135 #:todo-steps (cons last-done todo-steps)
136 #:done-steps prev-done))))
137 ((menu)
138 (let ((goto-step (menu-proc
139 (append done-steps (list step)))))
140 (if (eq? goto-step step)
141 (run result
142 #:todo-steps todo-steps
143 #:done-steps done-steps)
144 (skip-to-step goto-step result
145 #:todo-steps todo-steps
146 #:done-steps done-steps))))
147 ((start)
148 (if (null? done-steps)
149 ;; Same as above, it makes no sense to jump to start
150 ;; when we are at the first installer-step. Abort to
151 ;; 'raise-above prompt to re-raise the condition.
152 (abort-to-prompt 'raise-above c)
153 (run '()
154 #:todo-steps steps
155 #:done-steps '())))))
156 ((installer-step-break? c)
157 (reverse result)))
158 (let* ((id (installer-step-id step))
159 (compute (installer-step-compute step))
160 (res (compute result)))
161 (run (alist-cons id res result)
162 #:todo-steps rest-steps
163 #:done-steps (append done-steps (list step))))))))
164
165 (call-with-prompt 'raise-above
166 (lambda ()
167 (run '()
168 #:todo-steps steps
169 #:done-steps '()))
170 (lambda (k condition)
171 (raise condition))))
172
173(define (find-step-by-id steps id)
174 "Find and return the step in STEPS whose id is equal to ID."
175 (find (lambda (step)
176 (eq? (installer-step-id step) id))
177 steps))
178
179(define (result-step results step-id)
180 "Return the result of the installer-step specified by STEP-ID in
181RESULTS."
182 (assoc-ref results step-id))
183
184(define (result-step-done? results step-id)
185 "Return #t if the installer-step specified by STEP-ID has a COMPUTE value
186stored in RESULTS. Return #f otherwise."
187 (and (assoc step-id results) #t))
diff --git a/gnu/installer/timezone.scm b/gnu/installer/timezone.scm
new file mode 100644
index 00000000000..061e8c2e48c
--- /dev/null
+++ b/gnu/installer/timezone.scm
@@ -0,0 +1,117 @@
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 timezone)
20 #:use-module (gnu installer utils)
21 #:use-module (guix i18n)
22 #:use-module (srfi srfi-1)
23 #:use-module (srfi srfi-26)
24 #:use-module (srfi srfi-34)
25 #:use-module (srfi srfi-35)
26 #:use-module (ice-9 match)
27 #:use-module (ice-9 receive)
28 #:export (locate-childrens
29 timezone->posix-tz
30 timezone-has-child?
31 zonetab->timezone-tree))
32
33(define %not-blank
34 (char-set-complement char-set:blank))
35
36(define (posix-tz->timezone tz)
37 "Convert given TZ in Posix format like \"Europe/Paris\" into a list like
38(\"Europe\" \"Paris\")."
39 (string-split tz #\/))
40
41(define (timezone->posix-tz timezone)
42 "Convert given TIMEZONE like (\"Europe\" \"Paris\") into a Posix timezone
43like \"Europe/Paris\"."
44 (string-join timezone "/"))
45
46(define (zonetab->timezones zonetab)
47 "Parse ZONETAB file and return the corresponding list of timezones."
48
49 (define (zonetab-line->posix-tz line)
50 (let ((tokens (string-tokenize line %not-blank)))
51 (match tokens
52 ((code coordinates tz _ ...)
53 tz))))
54
55 (call-with-input-file zonetab
56 (lambda (port)
57 (let* ((lines (read-lines port))
58 ;; Filter comment lines starting with '#' character.
59 (tz-lines (filter (lambda (line)
60 (not (eq? (string-ref line 0)
61 #\#)))
62 lines)))
63 (map (lambda (line)
64 (posix-tz->timezone
65 (zonetab-line->posix-tz line)))
66 tz-lines)))))
67
68(define (timezones->timezone-tree timezones)
69 "Convert the list of timezones, TIMEZONES into a tree under the form:
70
71 (\"America\" (\"North_Dakota\" \"New_Salem\" \"Center\"))
72
73representing America/North_Dakota/New_Salem and America/North_Dakota/Center
74timezones."
75
76 (define (remove-first lists)
77 "Remove the first element of every sublists in the argument LISTS."
78 (map (lambda (list)
79 (if (null? list) list (cdr list)))
80 lists))
81
82 (let loop ((cur-timezones timezones))
83 (match cur-timezones
84 (() '())
85 (((region . rest-region) . rest-timezones)
86 (if (null? rest-region)
87 (cons (list region) (loop rest-timezones))
88 (receive (same-region other-region)
89 (partition (lambda (timezone)
90 (string=? (car timezone) region))
91 cur-timezones)
92 (acons region
93 (loop (remove-first same-region))
94 (loop other-region))))))))
95
96(define (locate-childrens tree path)
97 "Return the childrens of the timezone indicated by PATH in the given
98TREE. Raise a condition if the PATH could not be found."
99 (let ((extract-proc (cut map car <>)))
100 (match path
101 (() (sort (extract-proc tree) string<?))
102 ((region . rest)
103 (or (and=> (assoc-ref tree region)
104 (cut locate-childrens <> rest))
105 (raise
106 (condition
107 (&message
108 (message
109 (format #f (G_ "Unable to locate path: ~a.") path))))))))))
110
111(define (timezone-has-child? tree timezone)
112 "Return #t if the given TIMEZONE any child in TREE and #f otherwise."
113 (not (null? (locate-childrens tree timezone))))
114
115(define* (zonetab->timezone-tree zonetab)
116 "Return the timezone tree corresponding to the given ZONETAB file."
117 (timezones->timezone-tree (zonetab->timezones zonetab)))
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
new file mode 100644
index 00000000000..50876837151
--- /dev/null
+++ b/gnu/installer/utils.scm
@@ -0,0 +1,37 @@
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 utils)
20 #:use-module (ice-9 rdelim)
21 #:use-module (ice-9 textual-ports)
22 #:export (read-lines
23 read-all))
24
25(define* (read-lines #:optional (port (current-input-port)))
26 "Read lines from PORT and return them as a list."
27 (let loop ((line (read-line port))
28 (lines '()))
29 (if (eof-object? line)
30 (reverse lines)
31 (loop (read-line port)
32 (cons line lines)))))
33
34(define (read-all file)
35 "Return the content of the given FILE as a string."
36 (call-with-input-file file
37 get-string-all))
diff --git a/gnu/local.mk b/gnu/local.mk
index 1268e0c600a..3e6d30d8e92 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -543,6 +543,28 @@ GNU_SYSTEM_MODULES = \
543 %D%/build/marionette.scm \ 543 %D%/build/marionette.scm \
544 %D%/build/vm.scm \ 544 %D%/build/vm.scm \
545 \ 545 \
546 %D%/installer.scm \
547 %D%/installer/build-installer.scm \
548 %D%/installer/connman.scm \
549 %D%/installer/keymap.scm \
550 %D%/installer/locale.scm \
551 %D%/installer/newt.scm \
552 %D%/installer/steps.scm \
553 %D%/installer/timezone.scm \
554 %D%/installer/utils.scm \
555 \
556 %D%/installer/newt/ethernet.scm \
557 %D%/installer/newt/hostname.scm \
558 %D%/installer/newt/keymap.scm \
559 %D%/installer/newt/locale.scm \
560 %D%/installer/newt/menu.scm \
561 %D%/installer/newt/network.scm \
562 %D%/installer/newt/page.scm \
563 %D%/installer/newt/timezone.scm \
564 %D%/installer/newt/utils.scm \
565 %D%/installer/newt/welcome.scm \
566 %D%/installer/newt/wifi.scm \
567 \
546 %D%/tests.scm \ 568 %D%/tests.scm \
547 %D%/tests/audio.scm \ 569 %D%/tests/audio.scm \
548 %D%/tests/base.scm \ 570 %D%/tests/base.scm \
diff --git a/gnu/system.scm b/gnu/system.scm
index 09ee88d433c..e6c86cb9ba5 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -119,6 +119,7 @@
119 boot-parameters->menu-entry 119 boot-parameters->menu-entry
120 120
121 local-host-aliases 121 local-host-aliases
122 %root-account
122 %setuid-programs 123 %setuid-programs
123 %base-packages 124 %base-packages
124 %base-firmware)) 125 %base-firmware))
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index 3aded93f385..05f3795b818 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -22,16 +22,23 @@
22 22
23(define-module (gnu system install) 23(define-module (gnu system install)
24 #:use-module (gnu) 24 #:use-module (gnu)
25 #:use-module (gnu system)
25 #:use-module (gnu bootloader u-boot) 26 #:use-module (gnu bootloader u-boot)
26 #:use-module (guix gexp) 27 #:use-module (guix gexp)
27 #:use-module (guix store) 28 #:use-module (guix store)
28 #:use-module (guix monads) 29 #:use-module (guix monads)
29 #:use-module ((guix store) #:select (%store-prefix)) 30 #:use-module ((guix store) #:select (%store-prefix))
31 #:use-module (gnu installer newt)
32 #:use-module (gnu installer build-installer)
33 #:use-module (gnu services dbus)
34 #:use-module (gnu services networking)
30 #:use-module (gnu services shepherd) 35 #:use-module (gnu services shepherd)
31 #:use-module (gnu services ssh) 36 #:use-module (gnu services ssh)
32 #:use-module (gnu packages admin) 37 #:use-module (gnu packages admin)
33 #:use-module (gnu packages bash) 38 #:use-module (gnu packages bash)
34 #:use-module (gnu packages bootloaders) 39 #:use-module (gnu packages bootloaders)
40 #:use-module (gnu packages fonts)
41 #:use-module (gnu packages fontutils)
35 #:use-module (gnu packages guile) 42 #:use-module (gnu packages guile)
36 #:use-module (gnu packages linux) 43 #:use-module (gnu packages linux)
37 #:use-module (gnu packages ssh) 44 #:use-module (gnu packages ssh)
@@ -202,120 +209,114 @@ the user's target storage device rather than on the RAM disk."
202 (persistent? #f) 209 (persistent? #f)
203 (max-database-size (* 5 (expt 2 20)))))) ;5 MiB 210 (max-database-size (* 5 (expt 2 20)))))) ;5 MiB
204 211
212(define (normal-tty tty)
213 (service kmscon-service-type
214 (kmscon-configuration
215 (virtual-terminal tty)
216 (auto-login "root"))))
217
218(define bare-bones-os
219 (load "examples/bare-bones.tmpl"))
220
205(define %installation-services 221(define %installation-services
206 ;; List of services of the installation system. 222 ;; List of services of the installation system.
207 (let ((motd (plain-file "motd" " 223 (list (login-service (login-configuration
208\x1b[1;37mWelcome to the installation of the Guix System Distribution!\x1b[0m 224 ;; The motd is overlapped by the graphical installer,
209 225 ;; so make sure it is not printed.
210\x1b[2mThere is NO WARRANTY, to the extent permitted by law. In particular, you may 226 (motd #f)))
211LOSE ALL YOUR DATA as a side effect of the installation process. Furthermore, 227
212it is 'beta' software, so it may contain bugs. 228 ;; This will be the active virtual terminal at boot. The graphical
213 229 ;; installer is launched as the 'shell' program of the root
214You have been warned. Thanks for being so brave.\x1b[0m 230 ;; user-account. Thanks to auto-login, it will be started
215"))) 231 ;; automatically. Another option would have been to set the graphical
216 (define (normal-tty tty) 232 ;; installer as a login program. However, it is preferable to wait
217 (mingetty-service (mingetty-configuration (tty tty) 233 ;; for the login phase to be over, so that the environnment variables
218 (auto-login "root") 234 ;; of /etc/environment like LANG are loaded by PAM.
219 (login-pause? #t)))) 235 (normal-tty "tty1")
220 236
221 (define bare-bones-os 237 ;; Documentation.
222 (load "examples/bare-bones.tmpl")) 238 (service kmscon-service-type
223 239 (kmscon-configuration
224 (list (service virtual-terminal-service-type) 240 (virtual-terminal "tty2")
225 241 (login-program (log-to-info))
226 (mingetty-service (mingetty-configuration 242 (auto-login "guest")))
227 (tty "tty1") 243
228 (auto-login "root"))) 244 ;; Documentation add-on.
229 245 %configuration-template-service
230 (login-service (login-configuration 246
231 (motd motd))) 247 ;; A bunch of 'root' ttys.
232 248 (normal-tty "tty3")
233 ;; Documentation. The manual is in UTF-8, but 249 (normal-tty "tty4")
234 ;; 'console-font-service' sets up Unicode support and loads a font 250 (normal-tty "tty5")
235 ;; with all the useful glyphs like em dash and quotation marks. 251 (normal-tty "tty6")
236 (mingetty-service (mingetty-configuration 252
237 (tty "tty2") 253 ;; The usual services.
238 (auto-login "guest") 254 (syslog-service)
239 (login-program (log-to-info)))) 255
240 256 ;; The build daemon. Register the hydra.gnu.org key as trusted.
241 ;; Documentation add-on. 257 ;; This allows the installation process to use substitutes by
242 %configuration-template-service 258 ;; default.
243 259 (service guix-service-type
244 ;; A bunch of 'root' ttys. 260 (guix-configuration (authorize-key? #t)))
245 (normal-tty "tty3") 261
246 (normal-tty "tty4") 262 ;; Start udev so that useful device nodes are available.
247 (normal-tty "tty5") 263 ;; Use device-mapper rules for cryptsetup & co; enable the CRDA for
248 (normal-tty "tty6") 264 ;; regulations-compliant WiFi access.
249 265 (udev-service #:rules (list lvm2 crda))
250 ;; The usual services. 266
251 (syslog-service) 267 ;; Add the 'cow-store' service, which users have to start manually
252 268 ;; since it takes the installation directory as an argument.
253 ;; The build daemon. Register the official server keys as trusted. 269 (cow-store-service)
254 ;; This allows the installation process to use substitutes by 270
255 ;; default. 271 ;; To facilitate copy/paste.
256 (service guix-service-type 272 (service gpm-service-type)
257 (guix-configuration (authorize-key? #t))) 273
258 274 ;; Add an SSH server to facilitate remote installs.
259 ;; Start udev so that useful device nodes are available. 275 (service openssh-service-type
260 ;; Use device-mapper rules for cryptsetup & co; enable the CRDA for 276 (openssh-configuration
261 ;; regulations-compliant WiFi access. 277 (port-number 22)
262 (udev-service #:rules (list lvm2 crda)) 278 (permit-root-login #t)
263 279 ;; The root account is passwordless, so make sure
264 ;; Add the 'cow-store' service, which users have to start manually 280 ;; a password is set before allowing logins.
265 ;; since it takes the installation directory as an argument. 281 (allow-empty-passwords? #f)
266 (cow-store-service) 282 (password-authentication? #t)
267 283
268 ;; Install Unicode support and a suitable font. Use a font that 284 ;; Don't start it upfront.
269 ;; doesn't have more than 256 glyphs so that we can use colors with 285 (%auto-start? #f)))
270 ;; varying brightness levels (see note in setfont(8)). 286
271 (service console-font-service-type 287 ;; Since this is running on a USB stick with a overlayfs as the root
272 (map (lambda (tty) 288 ;; file system, use an appropriate cache configuration.
273 (cons tty "lat9u-16")) 289 (nscd-service (nscd-configuration
274 '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6"))) 290 (caches %nscd-minimal-caches)))
275 291
276 ;; To facilitate copy/paste. 292 ;; Having /bin/sh is a good idea. In particular it allows Tramp
277 (service gpm-service-type) 293 ;; connections to this system to work.
278 294 (service special-files-service-type
279 ;; Add an SSH server to facilitate remote installs. 295 `(("/bin/sh" ,(file-append (canonical-package bash)
280 (service openssh-service-type 296 "/bin/sh"))))
281 (openssh-configuration 297
282 (port-number 22) 298 ;; Loopback device, needed by OpenSSH notably.
283 (permit-root-login #t) 299 (service static-networking-service-type
284 ;; The root account is passwordless, so make sure 300 (list (static-networking (interface "lo")
285 ;; a password is set before allowing logins. 301 (ip "127.0.0.1")
286 (allow-empty-passwords? #f) 302 (requirement '())
287 (password-authentication? #t) 303 (provision '(loopback)))))
288 304
289 ;; Don't start it upfront. 305 (service wpa-supplicant-service-type)
290 (%auto-start? #f))) 306 (dbus-service)
291 307 (service connman-service-type
292 ;; Since this is running on a USB stick with a overlayfs as the root 308 (connman-configuration
293 ;; file system, use an appropriate cache configuration. 309 (disable-vpn? #t)))
294 (nscd-service (nscd-configuration 310
295 (caches %nscd-minimal-caches))) 311 ;; Keep a reference to BARE-BONES-OS to make sure it can be
296 312 ;; installed without downloading/building anything. Also keep the
297 ;; Having /bin/sh is a good idea. In particular it allows Tramp 313 ;; things needed by 'profile-derivation' to minimize the amount of
298 ;; connections to this system to work. 314 ;; download.
299 (service special-files-service-type 315 (service gc-root-service-type
300 `(("/bin/sh" ,(file-append (canonical-package bash) 316 (list bare-bones-os
301 "/bin/sh")))) 317 glibc-utf8-locales
302 318 texinfo
303 ;; Loopback device, needed by OpenSSH notably. 319 (canonical-package guile-2.2)))))
304 (service static-networking-service-type
305 (list (static-networking (interface "lo")
306 (ip "127.0.0.1")
307 (requirement '())
308 (provision '(loopback)))))
309
310 ;; Keep a reference to BARE-BONES-OS to make sure it can be
311 ;; installed without downloading/building anything. Also keep the
312 ;; things needed by 'profile-derivation' to minimize the amount of
313 ;; download.
314 (service gc-root-service-type
315 (list bare-bones-os
316 glibc-utf8-locales
317 texinfo
318 (canonical-package guile-2.2))))))
319 320
320(define %issue 321(define %issue
321 ;; Greeting. 322 ;; Greeting.
@@ -360,13 +361,18 @@ You have been warned. Thanks for being so brave.\x1b[0m
360 %shared-memory-file-system 361 %shared-memory-file-system
361 %immutable-store))) 362 %immutable-store)))
362 363
363 (users (list (user-account 364 (users (list
364 (name "guest") 365 (user-account
365 (group "users") 366 (inherit %root-account)
366 (supplementary-groups '("wheel")) ; allow use of sudo 367 ;; Launch the graphical installer.
367 (password "") 368 (shell (installer-program newt-installer)))
368 (comment "Guest of GNU") 369 (user-account
369 (home-directory "/home/guest")))) 370 (name "guest")
371 (group "users")
372 (supplementary-groups '("wheel")) ; allow use of sudo
373 (password "")
374 (comment "Guest of GNU")
375 (home-directory "/home/guest"))))
370 376
371 (issue %issue) 377 (issue %issue)
372 (services %installation-services) 378 (services %installation-services)
@@ -381,6 +387,8 @@ You have been warned. Thanks for being so brave.\x1b[0m
381 387
382 (packages (cons* (canonical-package glibc) ;for 'tzselect' & co. 388 (packages (cons* (canonical-package glibc) ;for 'tzselect' & co.
383 parted gptfdisk ddrescue 389 parted gptfdisk ddrescue
390 fontconfig
391 font-dejavu font-gnu-unifont
384 grub ;mostly so xrefs to its manual work 392 grub ;mostly so xrefs to its manual work
385 cryptsetup 393 cryptsetup
386 mdadm 394 mdadm
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index f7360489c66..585ceeb5c22 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -8,6 +8,27 @@ gnu/services/shepherd.scm
8gnu/system/mapped-devices.scm 8gnu/system/mapped-devices.scm
9gnu/system/shadow.scm 9gnu/system/shadow.scm
10guix/import/opam.scm 10guix/import/opam.scm
11gnu/installer.scm
12gnu/installer/build-installer.scm
13gnu/installer/connman.scm
14gnu/installer/keymap.scm
15gnu/installer/locale.scm
16gnu/installer/newt.scm
17gnu/installer/newt/ethernet.scm
18gnu/installer/newt/hostname.scm
19gnu/installer/newt/keymap.scm
20gnu/installer/newt/locale.scm
21gnu/installer/newt/menu.scm
22gnu/installer/newt/network.scm
23gnu/installer/newt/page.scm
24gnu/installer/newt/timezone.scm
25gnu/installer/newt/user.scm
26gnu/installer/newt/utils.scm
27gnu/installer/newt/welcome.scm
28gnu/installer/newt/wifi.scm
29gnu/installer/steps.scm
30gnu/installer/timezone.scm
31gnu/installer/utils.scm
11guix/scripts.scm 32guix/scripts.scm
12guix/scripts/build.scm 33guix/scripts/build.scm
13guix/discovery.scm 34guix/discovery.scm