guix-bioinformatics
/
guix
3
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
Browse Source

gnu: Add graphical installer support. 

* configure.ac: Require that guile-newt is available.
* gnu/installer.scm: New file.
* gnu/installer/aux-files/logo.txt: New file.
* gnu/installer/build-installer.scm: New file.
* gnu/installer/connman.scm: New file.
* gnu/installer/keymap.scm: New file.
* gnu/installer/locale.scm: New file.
* gnu/installer/newt.scm: New file.
* gnu/installer/newt/ethernet.scm: New file.
* gnu/installer/newt/hostname.scm: New file.
* gnu/installer/newt/keymap.scm: New file.
* gnu/installer/newt/locale.scm: New file.
* gnu/installer/newt/menu.scm: New file.
* gnu/installer/newt/network.scm: New file.
* gnu/installer/newt/page.scm: New file.
* gnu/installer/newt/timezone.scm: New file.
* gnu/installer/newt/user.scm: New file.
* gnu/installer/newt/utils.scm: New file.
* gnu/installer/newt/welcome.scm: New file.
* gnu/installer/newt/wifi.scm: New file.
* gnu/installer/steps.scm: New file.
* gnu/installer/timezone.scm: New file.
* gnu/installer/utils.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add previous files.
* gnu/system.scm: Export %root-account.
* gnu/system/install.scm (%installation-services): Use kmscon instead of linux
VT for all tty.
(installation-os)[users]: Add the graphical installer as shell of the root
account.
[packages]: Add font related packages.
* po/guix/POTFILES.in: Add installer files.
gn-latest-20200428
Mathieu Othacehe 3 years ago
committed by Ludovic Courtès
parent
08af580bde
commit
d0f3a672dc
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
28 changed files with 3904 additions and 119 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 6
      configure.ac
  2. 111
      gnu/installer.scm
  3. 484
      gnu/installer/aux-files/SUPPORTED
  4. 19
      gnu/installer/aux-files/logo.txt
  5. 290
      gnu/installer/build-installer.scm
  6. 400
      gnu/installer/connman.scm
  7. 162
      gnu/installer/keymap.scm
  8. 199
      gnu/installer/locale.scm
  9. 102
      gnu/installer/newt.scm
  10. 80
      gnu/installer/newt/ethernet.scm
  11. 26
      gnu/installer/newt/hostname.scm
  12. 132
      gnu/installer/newt/keymap.scm
  13. 193
      gnu/installer/newt/locale.scm
  14. 44
      gnu/installer/newt/menu.scm
  15. 159
      gnu/installer/newt/network.scm
  16. 313
      gnu/installer/newt/page.scm
  17. 83
      gnu/installer/newt/timezone.scm
  18. 181
      gnu/installer/newt/user.scm
  19. 43
      gnu/installer/newt/utils.scm
  20. 122
      gnu/installer/newt/welcome.scm
  21. 243
      gnu/installer/newt/wifi.scm
  22. 187
      gnu/installer/steps.scm
  23. 117
      gnu/installer/timezone.scm
  24. 37
      gnu/installer/utils.scm
  25. 22
      gnu/local.mk
  26. 1
      gnu/system.scm
  27. 246
      gnu/system/install.scm
  28. 21
      po/guix/POTFILES.in

6
configure.ac
View File

@ -135,6 +135,12 @@ if test "x$have_guile_gcrypt" != "xyes"; then
AC_MSG_ERROR([Guile-Gcrypt could not be found; please install it.])
fi
dnl Guile-newt is used by the graphical installer.
GUILE_MODULE_AVAILABLE([have_guile_newt], [(newt)])
if test "x$have_guile_newt" != "xyes"; then
AC_MSG_ERROR([Guile-newt could not be found; please install it.])
fi
dnl Make sure we have a full-fledged Guile.
GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads])

111
gnu/installer.scm
View File

@ -0,0 +1,111 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu installer)
#:use-module (guix discovery)
#:use-module (guix records)
#:use-module (guix ui)
#:use-module (srfi srfi-1)
#:export (<installer>
installer
make-installer
installer?
installer-name
installer-modules
installer-init
installer-exit
installer-exit-error
installer-keymap-page
installer-locale-page
installer-menu-page
installer-network-page
installer-timezone-page
installer-hostname-page
installer-user-page
installer-welcome-page
%installers
lookup-installer-by-name))
;;;
;;; Installer record.
;;;
;; The <installer> record contains pages that will be run to prompt the user
;; for the system configuration. The goal of the installer is to produce a
;; complete <operating-system> record and install it.
(define-record-type* <installer>
installer make-installer
installer?
;; symbol
(name installer-name)
;; list of installer modules
(modules installer-modules)
;; procedure: void -> void
(init installer-init)
;; procedure: void -> void
(exit installer-exit)
;; procedure (key arguments) -> void
(exit-error installer-exit-error)
;; procedure (#:key models layouts) -> (list model layout variant)
(keymap-page installer-keymap-page)
;; procedure: (#:key supported-locales iso639-languages iso3166-territories)
;; -> glibc-locale
(locale-page installer-locale-page)
;; procedure: (steps) -> step-id
(menu-page installer-menu-page)
;; procedure void -> void
(network-page installer-network-page)
;; procedure (zonetab) -> posix-timezone
(timezone-page installer-timezone-page)
;; procedure void -> void
(hostname-page installer-hostname-page)
;; procedure void -> void
(user-page installer-user-page)
;; procedure (logo) -> void
(welcome-page installer-welcome-page))
;;;
;;; Installers.
;;;
(define (installer-top-modules)
"Return the list of installer modules."
(all-modules (map (lambda (entry)
`(,entry . "gnu/installer"))
%load-path)
#:warn warn-about-load-error))
(define %installers
;; The list of publically-known installers.
(delay (fold-module-public-variables (lambda (obj result)
(if (installer? obj)
(cons obj result)
result))
'()
(installer-top-modules))))
(define (lookup-installer-by-name name)
"Return the installer called NAME."
(or (find (lambda (installer)
(eq? name (installer-name installer)))
(force %installers))
(leave (G_ "~a: no such installer~%") name)))

484
gnu/installer/aux-files/SUPPORTED
View File

@ -0,0 +1,484 @@
aa_DJ.UTF-8 UTF-8
aa_DJ ISO-8859-1
aa_ER UTF-8
aa_ER@saaho UTF-8
aa_ET UTF-8
af_ZA.UTF-8 UTF-8
af_ZA ISO-8859-1
agr_PE UTF-8
ak_GH UTF-8
am_ET UTF-8
an_ES.UTF-8 UTF-8
an_ES ISO-8859-15
anp_IN UTF-8
ar_AE.UTF-8 UTF-8
ar_AE ISO-8859-6
ar_BH.UTF-8 UTF-8
ar_BH ISO-8859-6
ar_DZ.UTF-8 UTF-8
ar_DZ ISO-8859-6
ar_EG.UTF-8 UTF-8
ar_EG ISO-8859-6
ar_IN UTF-8
ar_IQ.UTF-8 UTF-8
ar_IQ ISO-8859-6
ar_JO.UTF-8 UTF-8
ar_JO ISO-8859-6
ar_KW.UTF-8 UTF-8
ar_KW ISO-8859-6
ar_LB.UTF-8 UTF-8
ar_LB ISO-8859-6
ar_LY.UTF-8 UTF-8
ar_LY ISO-8859-6
ar_MA.UTF-8 UTF-8
ar_MA ISO-8859-6
ar_OM.UTF-8 UTF-8
ar_OM ISO-8859-6
ar_QA.UTF-8 UTF-8
ar_QA ISO-8859-6
ar_SA.UTF-8 UTF-8
ar_SA ISO-8859-6
ar_SD.UTF-8 UTF-8
ar_SD ISO-8859-6
ar_SS UTF-8
ar_SY.UTF-8 UTF-8
ar_SY ISO-8859-6
ar_TN.UTF-8 UTF-8
ar_TN ISO-8859-6
ar_YE.UTF-8 UTF-8
ar_YE ISO-8859-6
ayc_PE UTF-8
az_AZ UTF-8
az_IR UTF-8
as_IN UTF-8
ast_ES.UTF-8 UTF-8
ast_ES ISO-8859-15
be_BY.UTF-8 UTF-8
be_BY CP1251
be_BY@latin UTF-8
bem_ZM UTF-8
ber_DZ UTF-8
ber_MA UTF-8
bg_BG.UTF-8 UTF-8
bg_BG CP1251
bhb_IN.UTF-8 UTF-8
bho_IN UTF-8
bho_NP UTF-8
bi_VU UTF-8
bn_BD UTF-8
bn_IN UTF-8
bo_CN UTF-8
bo_IN UTF-8
br_FR.UTF-8 UTF-8
br_FR ISO-8859-1
br_FR@euro ISO-8859-15
brx_IN UTF-8
bs_BA.UTF-8 UTF-8
bs_BA ISO-8859-2
byn_ER UTF-8
ca_AD.UTF-8 UTF-8
ca_AD ISO-8859-15
ca_ES.UTF-8 UTF-8
ca_ES ISO-8859-1
ca_ES@euro ISO-8859-15
ca_ES@valencia UTF-8
ca_FR.UTF-8 UTF-8
ca_FR ISO-8859-15
ca_IT.UTF-8 UTF-8
ca_IT ISO-8859-15
ce_RU UTF-8
chr_US UTF-8
cmn_TW UTF-8
crh_UA UTF-8
cs_CZ.UTF-8 UTF-8
cs_CZ ISO-8859-2
csb_PL UTF-8
cv_RU UTF-8
cy_GB.UTF-8 UTF-8
cy_GB ISO-8859-14
da_DK.UTF-8 UTF-8
da_DK ISO-8859-1
de_AT.UTF-8 UTF-8
de_AT ISO-8859-1
de_AT@euro ISO-8859-15
de_BE.UTF-8 UTF-8
de_BE ISO-8859-1
de_BE@euro ISO-8859-15
de_CH.UTF-8 UTF-8
de_CH ISO-8859-1
de_DE.UTF-8 UTF-8
de_DE ISO-8859-1
de_DE@euro ISO-8859-15
de_IT.UTF-8 UTF-8
de_IT ISO-8859-1
de_LI.UTF-8 UTF-8
de_LU.UTF-8 UTF-8
de_LU ISO-8859-1
de_LU@euro ISO-8859-15
doi_IN UTF-8
dv_MV UTF-8
dz_BT UTF-8
el_GR.UTF-8 UTF-8
el_GR ISO-8859-7
el_GR@euro ISO-8859-7
el_CY.UTF-8 UTF-8
el_CY ISO-8859-7
en_AG UTF-8
en_AU.UTF-8 UTF-8
en_AU ISO-8859-1
en_BW.UTF-8 UTF-8
en_BW ISO-8859-1
en_CA.UTF-8 UTF-8
en_CA ISO-8859-1
en_DK.UTF-8 UTF-8
en_DK ISO-8859-1
en_GB.UTF-8 UTF-8
en_GB ISO-8859-1
en_HK.UTF-8 UTF-8
en_HK ISO-8859-1
en_IE.UTF-8 UTF-8
en_IE ISO-8859-1
en_IE@euro ISO-8859-15
en_IL UTF-8
en_IN UTF-8
en_NG UTF-8
en_NZ.UTF-8 UTF-8
en_NZ ISO-8859-1
en_PH.UTF-8 UTF-8
en_PH ISO-8859-1
en_SC.UTF-8 UTF-8
en_SG.UTF-8 UTF-8
en_SG ISO-8859-1
en_US.UTF-8 UTF-8
en_US ISO-8859-1
en_ZA.UTF-8 UTF-8
en_ZA ISO-8859-1
en_ZM UTF-8
en_ZW.UTF-8 UTF-8
en_ZW ISO-8859-1
eo UTF-8
es_AR.UTF-8 UTF-8
es_AR ISO-8859-1
es_BO.UTF-8 UTF-8
es_BO ISO-8859-1
es_CL.UTF-8 UTF-8
es_CL ISO-8859-1
es_CO.UTF-8 UTF-8
es_CO ISO-8859-1
es_CR.UTF-8 UTF-8
es_CR ISO-8859-1
es_CU UTF-8
es_DO.UTF-8 UTF-8
es_DO ISO-8859-1
es_EC.UTF-8 UTF-8
es_EC ISO-8859-1
es_ES.UTF-8 UTF-8
es_ES ISO-8859-1
es_ES@euro ISO-8859-15
es_GT.UTF-8 UTF-8
es_GT ISO-8859-1
es_HN.UTF-8 UTF-8
es_HN ISO-8859-1
es_MX.UTF-8 UTF-8
es_MX ISO-8859-1
es_NI.UTF-8 UTF-8
es_NI ISO-8859-1
es_PA.UTF-8 UTF-8
es_PA ISO-8859-1
es_PE.UTF-8 UTF-8
es_PE ISO-8859-1
es_PR.UTF-8 UTF-8
es_PR ISO-8859-1
es_PY.UTF-8 UTF-8
es_PY ISO-8859-1
es_SV.UTF-8 UTF-8
es_SV ISO-8859-1
es_US.UTF-8 UTF-8
es_US ISO-8859-1
es_UY.UTF-8 UTF-8
es_UY ISO-8859-1
es_VE.UTF-8 UTF-8
es_VE ISO-8859-1
et_EE.UTF-8 UTF-8
et_EE ISO-8859-1
et_EE.ISO-8859-15 ISO-8859-15
eu_ES.UTF-8 UTF-8
eu_ES ISO-8859-1
eu_ES@euro ISO-8859-15
fa_IR UTF-8
ff_SN UTF-8
fi_FI.UTF-8 UTF-8
fi_FI ISO-8859-1
fi_FI@euro ISO-8859-15
fil_PH UTF-8
fo_FO.UTF-8 UTF-8
fo_FO ISO-8859-1
fr_BE.UTF-8 UTF-8
fr_BE ISO-8859-1
fr_BE@euro ISO-8859-15
fr_CA.UTF-8 UTF-8
fr_CA ISO-8859-1
fr_CH.UTF-8 UTF-8
fr_CH ISO-8859-1
fr_FR.UTF-8 UTF-8
fr_FR ISO-8859-1
fr_FR@euro ISO-8859-15
fr_LU.UTF-8 UTF-8
fr_LU ISO-8859-1
fr_LU@euro ISO-8859-15
fur_IT UTF-8
fy_NL UTF-8
fy_DE UTF-8
ga_IE.UTF-8 UTF-8
ga_IE ISO-8859-1
ga_IE@euro ISO-8859-15
gd_GB.UTF-8 UTF-8
gd_GB ISO-8859-15
gez_ER UTF-8
gez_ER@abegede UTF-8
gez_ET UTF-8
gez_ET@abegede UTF-8
gl_ES.UTF-8 UTF-8
gl_ES ISO-8859-1
gl_ES@euro ISO-8859-15
gu_IN UTF-8
gv_GB.UTF-8 UTF-8
gv_GB ISO-8859-1
ha_NG UTF-8
hak_TW UTF-8
he_IL.UTF-8 UTF-8
he_IL ISO-8859-8
hi_IN UTF-8
hif_FJ UTF-8
hne_IN UTF-8
hr_HR.UTF-8 UTF-8
hr_HR ISO-8859-2
hsb_DE ISO-8859-2
hsb_DE.UTF-8 UTF-8
ht_HT UTF-8
hu_HU.UTF-8 UTF-8
hu_HU ISO-8859-2
hy_AM UTF-8
hy_AM.ARMSCII-8 ARMSCII-8
ia_FR UTF-8
id_ID.UTF-8 UTF-8
id_ID ISO-8859-1
ig_NG UTF-8
ik_CA UTF-8
is_IS.UTF-8 UTF-8
is_IS ISO-8859-1
it_CH.UTF-8 UTF-8
it_CH ISO-8859-1
it_IT.UTF-8 UTF-8
it_IT ISO-8859-1
it_IT@euro ISO-8859-15
iu_CA UTF-8
ja_JP.EUC-JP EUC-JP
ja_JP.UTF-8 UTF-8
ka_GE.UTF-8 UTF-8
ka_GE GEORGIAN-PS
kab_DZ UTF-8
kk_KZ.UTF-8 UTF-8
kk_KZ PT154
kl_GL.UTF-8 UTF-8
kl_GL ISO-8859-1
km_KH UTF-8
kn_IN UTF-8
ko_KR.EUC-KR EUC-KR
ko_KR.UTF-8 UTF-8
kok_IN UTF-8
ks_IN UTF-8
ks_IN@devanagari UTF-8
ku_TR.UTF-8 UTF-8
ku_TR ISO-8859-9
kw_GB.UTF-8 UTF-8
kw_GB ISO-8859-1
ky_KG UTF-8
lb_LU UTF-8
lg_UG.UTF-8 UTF-8
lg_UG ISO-8859-10
li_BE UTF-8
li_NL UTF-8
lij_IT UTF-8
ln_CD UTF-8
lo_LA UTF-8
lt_LT.UTF-8 UTF-8
lt_LT ISO-8859-13
lv_LV.UTF-8 UTF-8
lv_LV ISO-8859-13
lzh_TW UTF-8
mag_IN UTF-8
mai_IN UTF-8
mai_NP UTF-8
mfe_MU UTF-8
mg_MG.UTF-8 UTF-8
mg_MG ISO-8859-15
mhr_RU UTF-8
mi_NZ.UTF-8 UTF-8
mi_NZ ISO-8859-13
miq_NI UTF-8
mjw_IN UTF-8
mk_MK.UTF-8 UTF-8
mk_MK ISO-8859-5
ml_IN UTF-8
mn_MN UTF-8
mni_IN UTF-8
mr_IN UTF-8
ms_MY.UTF-8 UTF-8
ms_MY ISO-8859-1
mt_MT.UTF-8 UTF-8
mt_MT ISO-8859-3
my_MM UTF-8
nan_TW UTF-8
nan_TW@latin UTF-8
nb_NO.UTF-8 UTF-8
nb_NO ISO-8859-1
nds_DE UTF-8
nds_NL UTF-8
ne_NP UTF-8
nhn_MX UTF-8
niu_NU UTF-8
niu_NZ UTF-8
nl_AW UTF-8
nl_BE.UTF-8 UTF-8
nl_BE ISO-8859-1
nl_BE@euro ISO-8859-15
nl_NL.UTF-8 UTF-8
nl_NL ISO-8859-1
nl_NL@euro ISO-8859-15
nn_NO.UTF-8 UTF-8
nn_NO ISO-8859-1
nr_ZA UTF-8
nso_ZA UTF-8
oc_FR.UTF-8 UTF-8
oc_FR ISO-8859-1
om_ET UTF-8
om_KE.UTF-8 UTF-8
om_KE ISO-8859-1
or_IN UTF-8
os_RU UTF-8
pa_IN UTF-8
pa_PK UTF-8
pap_AW UTF-8
pap_CW UTF-8
pl_PL.UTF-8 UTF-8
pl_PL ISO-8859-2
ps_AF UTF-8
pt_BR.UTF-8 UTF-8
pt_BR ISO-8859-1
pt_PT.UTF-8 UTF-8
pt_PT ISO-8859-1
pt_PT@euro ISO-8859-15
quz_PE UTF-8
raj_IN UTF-8
ro_RO.UTF-8 UTF-8
ro_RO ISO-8859-2
ru_RU.KOI8-R KOI8-R
ru_RU.UTF-8 UTF-8
ru_RU ISO-8859-5
ru_UA.UTF-8 UTF-8
ru_UA KOI8-U
rw_RW UTF-8
sa_IN UTF-8
sat_IN UTF-8
sc_IT UTF-8
sd_IN UTF-8
sd_IN@devanagari UTF-8
se_NO UTF-8
sgs_LT UTF-8
shn_MM UTF-8
shs_CA UTF-8
si_LK UTF-8
sid_ET UTF-8
sk_SK.UTF-8 UTF-8
sk_SK ISO-8859-2
sl_SI.UTF-8 UTF-8
sl_SI ISO-8859-2
sm_WS UTF-8
so_DJ.UTF-8 UTF-8
so_DJ ISO-8859-1
so_ET UTF-8
so_KE.UTF-8 UTF-8
so_KE ISO-8859-1
so_SO.UTF-8 UTF-8
so_SO ISO-8859-1
sq_AL.UTF-8 UTF-8
sq_AL ISO-8859-1
sq_MK UTF-8
sr_ME UTF-8
sr_RS UTF-8
sr_RS@latin UTF-8
ss_ZA UTF-8
st_ZA.UTF-8 UTF-8
st_ZA ISO-8859-1
sv_FI.UTF-8 UTF-8
sv_FI ISO-8859-1
sv_FI@euro ISO-8859-15
sv_SE.UTF-8 UTF-8
sv_SE ISO-8859-1
sw_KE UTF-8
sw_TZ UTF-8
szl_PL UTF-8
ta_IN UTF-8
ta_LK UTF-8
tcy_IN.UTF-8 UTF-8
te_IN UTF-8
tg_TJ.UTF-8 UTF-8
tg_TJ KOI8-T
th_TH.UTF-8 UTF-8
th_TH TIS-620
the_NP UTF-8
ti_ER UTF-8
ti_ET UTF-8
tig_ER UTF-8
tk_TM UTF-8
tl_PH.UTF-8 UTF-8
tl_PH ISO-8859-1
tn_ZA UTF-8
to_TO UTF-8
tpi_PG UTF-8
tr_CY.UTF-8 UTF-8
tr_CY ISO-8859-9
tr_TR.UTF-8 UTF-8
tr_TR ISO-8859-9
ts_ZA UTF-8
tt_RU UTF-8
tt_RU@iqtelif UTF-8
ug_CN UTF-8
uk_UA.UTF-8 UTF-8
uk_UA KOI8-U
unm_US UTF-8
ur_IN UTF-8
ur_PK UTF-8
uz_UZ.UTF-8 UTF-8
uz_UZ ISO-8859-1
uz_UZ@cyrillic UTF-8
ve_ZA UTF-8
vi_VN UTF-8
wa_BE ISO-8859-1
wa_BE@euro ISO-8859-15
wa_BE.UTF-8 UTF-8
wae_CH UTF-8
wal_ET UTF-8
wo_SN UTF-8
xh_ZA.UTF-8 UTF-8
xh_ZA ISO-8859-1
yi_US.UTF-8 UTF-8
yi_US CP1255
yo_NG UTF-8
yue_HK UTF-8
yuw_PG UTF-8
zh_CN.GB18030 GB18030
zh_CN.GBK GBK
zh_CN.UTF-8 UTF-8
zh_CN GB2312
zh_HK.UTF-8 UTF-8
zh_HK BIG5-HKSCS
zh_SG.UTF-8 UTF-8
zh_SG.GBK GBK
zh_SG GB2312
zh_TW.EUC-TW EUC-TW
zh_TW.UTF-8 UTF-8
zh_TW BIG5
zu_ZA.UTF-8 UTF-8
zu_ZA ISO-8859-1

19
gnu/installer/aux-files/logo.txt
View File

@ -0,0 +1,19 @@
░░░ ░░░
░░▒▒░░░░░░░░░ ░░░░░░░░░▒▒░░
░░▒▒▒▒▒░░░░░░░ ░░░░░░░▒▒▒▒▒░
░▒▒▒░░▒▒▒▒▒ ░░░░░░░▒▒░
░▒▒▒▒░ ░░░░░░
▒▒▒▒▒ ░░░░░░
▒▒▒▒▒ ░░░░░
░▒▒▒▒▒ ░░░░░
▒▒▒▒▒ ░░░░░
▒▒▒▒▒ ░░░░░
░▒▒▒▒▒░░░░░
▒▒▒▒▒▒░░░
▒▒▒▒▒▒░
_____ _ _ _ _ _____ _
/ ____| \ | | | | | / ____| (_)
| | __| \| | | | | | | __ _ _ ___ __
| | |_ | . ' | | | | | | |_ | | | | \ \/ /
| |__| | |\ | |__| | | |__| | |_| | |> <
\_____|_| \_|\____/ \_____|\__,_|_/_/\_\

290
gnu/installer/build-installer.scm
View File

@ -0,0 +1,290 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu installer build-installer)
#:use-module (guix packages)
#:use-module (guix gexp)
#:use-module (guix modules)
#:use-module (guix utils)
#:use-module (guix ui)
#:use-module ((guix self) #:select (make-config.scm))
#:use-module (gnu installer)
#:use-module (gnu packages admin)
#:use-module (gnu packages base)
#:use-module (gnu packages bash)
#:use-module (gnu packages connman)
#:use-module (gnu packages guile)
#:autoload (gnu packages gnupg) (guile-gcrypt)
#:use-module (gnu packages iso-codes)
#:use-module (gnu packages linux)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages package-management)
#:use-module (gnu packages xorg)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:export (installer-program))
(define not-config?
;; Select (guix …) and (gnu …) modules, except (guix config).
(match-lambda
(('guix 'config) #f)
(('guix rest ...) #t)
(('gnu rest ...) #t)
(rest #f)))
(define* (build-compiled-file name locale-builder)
"Return a file-like object that evalutes the gexp LOCALE-BUILDER and store
its result in the scheme file NAME. The derivation will also build a compiled
version of this file."
(define set-utf8-locale
#~(begin
(setenv "LOCPATH"
#$(file-append glibc-utf8-locales "/lib/locale/"
(version-major+minor
(package-version glibc-utf8-locales))))
(setlocale LC_ALL "en_US.utf8")))
(define builder
(with-extensions (list guile-json)
(with-imported-modules (source-module-closure
'((gnu installer locale)))
#~(begin
(use-modules (gnu installer locale))
;; The locale files contain non-ASCII characters.
#$set-utf8-locale
(mkdir #$output)
(let ((locale-file
(string-append #$output "/" #$name ".scm"))
(locale-compiled-file
(string-append #$output "/" #$name ".go")))
(call-with-output-file locale-file
(lambda (port)
(write #$locale-builder port)))
(compile-file locale-file
#:output-file locale-compiled-file))))))
(computed-file name builder))
(define apply-locale
;; Install the specified locale.
#~(lambda (locale-name)
(false-if-exception
(setlocale LC_ALL locale-name))))
(define* (compute-locale-step installer
#:key
locales-name
iso639-languages-name
iso3166-territories-name)
"Return a gexp that run the locale-page of INSTALLER, and install the
selected locale. The list of locales, languages and territories passed to
locale-page are computed in derivations named respectively LOCALES-NAME,
ISO639-LANGUAGES-NAME and ISO3166-TERRITORIES-NAME. Those lists are compiled,
so that when the installer is run, all the lengthy operations have already
been performed at build time."
(define (compiled-file-loader file name)
#~(load-compiled
(string-append #$file "/" #$name ".go")))
(let* ((supported-locales #~(supported-locales->locales
#$(local-file "aux-files/SUPPORTED")))
(iso-codes #~(string-append #$iso-codes "/share/iso-codes/json/"))
(iso639-3 #~(string-append #$iso-codes "iso_639-3.json"))
(iso639-5 #~(string-append #$iso-codes "iso_639-5.json"))
(iso3166 #~(string-append #$iso-codes "iso_3166-1.json"))
(locales-file (build-compiled-file
locales-name
#~`(quote ,#$supported-locales)))
(iso639-file (build-compiled-file
iso639-languages-name
#~`(quote ,(iso639->iso639-languages
#$supported-locales
#$iso639-3 #$iso639-5))))
(iso3166-file (build-compiled-file
iso3166-territories-name
#~`(quote ,(iso3166->iso3166-territories #$iso3166))))
(locales-loader (compiled-file-loader locales-file
locales-name))
(iso639-loader (compiled-file-loader iso639-file
iso639-languages-name))
(iso3166-loader (compiled-file-loader iso3166-file
iso3166-territories-name)))
#~(let ((result
(#$(installer-locale-page installer)
#:supported-locales #$locales-loader
#:iso639-languages #$iso639-loader
#:iso3166-territories #$iso3166-loader)))
(#$apply-locale result))))
(define apply-keymap
;; Apply the specified keymap.
#~(match-lambda
((model layout variant)
(kmscon-update-keymap model layout variant))))
(define* (compute-keymap-step installer)
"Return a gexp that runs the keymap-page of INSTALLER and install the
selected keymap."
#~(let ((result
(call-with-values
(lambda ()
(xkb-rules->models+layouts
(string-append #$xkeyboard-config
"/share/X11/xkb/rules/base.xml")))
(lambda (models layouts)
(#$(installer-keymap-page installer)
#:models models
#:layouts layouts)))))
(#$apply-keymap result)))
(define (installer-steps installer)
(let ((locale-step (compute-locale-step
installer
#:locales-name "locales"
#:iso639-languages-name "iso639-languages"
#:iso3166-territories-name "iso3166-territories"))
(keymap-step (compute-keymap-step installer))
(timezone-data #~(string-append #$tzdata
"/share/zoneinfo/zone.tab")))
#~(list
;; Welcome the user and ask him to choose between manual installation
;; and graphical install.
(installer-step
(id 'welcome)
(compute (lambda _
#$(installer-welcome-page installer))))
;; Ask the user to choose a locale among those supported by the glibc.
;; Install the selected locale right away, so that the user may
;; benefit from any available translation for the installer messages.
(installer-step
(id 'locale)
(description (G_ "Locale selection"))
(compute (lambda _
#$locale-step)))
;; Ask the user to select a timezone under glibc format.
(installer-step
(id 'timezone)
(description (G_ "Timezone selection"))
(compute (lambda _
(#$(installer-timezone-page installer)
#$timezone-data))))
;; The installer runs in a kmscon virtual terminal where loadkeys
;; won't work. kmscon uses libxkbcommon as a backend for keyboard
;; input. It is possible to update kmscon current keymap by sending it
;; a keyboard model, layout and variant, in a somehow similar way as
;; what is done with setxkbmap utility.
;;
;; So ask for a keyboard model, layout and variant to update the
;; current kmscon keymap.
(installer-step
(id 'keymap)
(description (G_ "Keyboard mapping selection"))
(compute (lambda _
#$keymap-step)))
;; Ask the user to input a hostname for the system.
(installer-step
(id 'hostname)
(description (G_ "Hostname selection"))
(compute (lambda _
#$(installer-hostname-page installer))))
;; Provide an interface above connmanctl, so that the user can select
;; a network susceptible to acces Internet.
(installer-step
(id 'network)
(description (G_ "Network selection"))
(compute (lambda _
#$(installer-network-page installer))))
;; Prompt for users (name, group and home directory).
(installer-step
(id 'hostname)
(description (G_ "User selection"))
(compute (lambda _
#$(installer-user-page installer)))))))
(define (installer-program installer)
"Return a file-like object that runs the given INSTALLER."
(define init-gettext
;; Initialize gettext support, so that installer messages can be
;; translated.
#~(begin
(bindtextdomain "guix" (string-append #$guix "/share/locale"))
(textdomain "guix")))
(define set-installer-path
;; Add the specified binary to PATH for later use by the installer.
#~(let* ((inputs
'#$(append (list bash connman shadow)
(map canonical-package (list coreutils)))))
(with-output-to-port (%make-void-port "w")
(lambda ()
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)))))
(define installer-builder
(with-extensions (list guile-gcrypt guile-newt guile-json)
(with-imported-modules `(,@(source-module-closure
`(,@(installer-modules installer)
(guix build utils))
#:select? not-config?)
((guix config) => ,(make-config.scm)))
#~(begin
(use-modules (gnu installer keymap)
(gnu installer steps)
(gnu installer locale)
#$@(installer-modules installer)
(guix i18n)
(guix build utils)
(ice-9 match))
;; Initialize gettext support so that installers can use
;; (guix i18n) module.
#$init-gettext
;; Add some binaries used by the installers to PATH.
#$set-installer-path
#$(installer-init installer)
(catch #t
(lambda ()
(run-installer-steps
#:rewind-strategy 'menu
#:menu-proc #$(installer-menu-page installer)
#:steps #$(installer-steps installer)))
(const #f)
(lambda (key . args)
(#$(installer-exit-error installer) key args)
;; Be sure to call newt-finish, to restore the terminal into
;; its original state before printing the error report.
(call-with-output-file "/tmp/error"
(lambda (port)
(display-backtrace (make-stack #t) port)
(print-exception port
(stack-ref (make-stack #t) 1)
key args)))
(primitive-exit 1)))
#$(installer-exit installer)))))
(program-file "installer" installer-builder))

400
gnu/installer/connman.scm
View File

@ -0,0 +1,400 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu installer connman)
#:use-module (gnu installer utils)
#:use-module (guix records)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (<technology>
technology
technology?
technology-name
technology-type
technology-powered?
technology-connected?
<service>
service
service?
service-name
service-type
service-path
service-strength
service-state
&connman-error
connman-error?
connman-error-command
connman-error-output
connman-error-status
&connman-connection-error
connman-connection-error?
connman-connection-error-service
connman-connection-error-output
&connman-password-error
connman-password-error?
&connman-already-connected-error
connman-already-connected-error?
connman-state
connman-technologies
connman-enable-technology
connman-disable-technology
connman-scan-technology
connman-services
connman-connect
connman-disconnect
connman-online?
connman-connect-with-auth))
;;; Commentary:
;;;
;;; This module provides procedures for talking with the connman daemon.
;;; The best approach would have been using connman dbus interface.
;;; However, as Guile dbus bindings are not available yet, the console client
;;; "connmanctl" is used to talk with the daemon.
;;;
;;;
;;; Technology record.
;;;
;; The <technology> record encapsulates the "Technology" object of connman.
;; Technology type will be typically "ethernet", "wifi" or "bluetooth".
(define-record-type* <technology>
technology make-technology
technology?
(name technology-name) ; string
(type technology-type) ; string
(powered? technology-powered?) ; boolean
(connected? technology-connected?)) ; boolean
;;;
;;; Service record.
;;;
;; The <service> record encapsulates the "Service" object of connman.
;; Service type is the same as the technology it is associated to, path is a
;; unique identifier given by connman, strength describes the signal quality
;; if applicable. Finally, state is "idle", "failure", "association",
;; "configuration", "ready", "disconnect" or "online".
(define-record-type* <service>
service make-service
service?
(name service-name) ; string
(type service-type) ; string
(path service-path) ; string
(strength service-strength) ; integer
(state service-state)) ; string
;;;
;;; Condition types.
;;;
(define-condition-type &connman-error &error
connman-error?
(command connman-error-command)
(output connman-error-output)
(status connman-error-status))
(define-condition-type &connman-connection-error &error
connman-connection-error?
(service connman-connection-error-service)
(output connman-connection-error-output))
(define-condition-type &connman-password-error &connman-connection-error
connman-password-error?)
(define-condition-type &connman-already-connected-error
&connman-connection-error connman-already-connected-error?)
;;;
;;; Procedures.
;;;
(define (connman-run command env arguments)
"Run the given COMMAND, with the specified ENV and ARGUMENTS. The error
output is discarded and &connman-error condition is raised if the command
returns a non zero exit code."
(let* ((command `("env" ,env ,command ,@arguments "2>" "/dev/null"))
(command-string (string-join command " "))
(pipe (open-input-pipe command-string))
(output (read-lines pipe))
(ret (close-pipe pipe)))
(case (status:exit-val ret)
((0) output)
(else (raise (condition (&connman-error
(command command)
(output output)
(status ret))))))))
(define (connman . arguments)
"Run connmanctl with the specified ARGUMENTS. Set the LANG environment
variable to C because the command output will be parsed and we don't want it
to be translated."
(connman-run "connmanctl" "LANG=C" arguments))
(define (parse-keys keys)
"Parse the given list of strings KEYS, under the following format:
'((\"KEY = VALUE\") (\"KEY2 = VALUE2\") ...)
Return the corresponding association list of '((KEY . VALUE) (KEY2 . VALUE2)
...) elements."
(let ((key-regex (make-regexp "([^ ]+) = ([^$]+)")))
(map (lambda (key)
(let ((match-key (regexp-exec key-regex key)))
(cons (match:substring match-key 1)
(match:substring match-key 2))))
keys)))
(define (connman-state)
"Return the state of connman. The nominal states are 'offline, 'idle,
'ready, 'oneline. If an unexpected state is read, 'unknown is
returned. Finally, an error is raised if the comman output could not be
parsed, usually because the connman daemon is not responding."
(let* ((output (connman "state"))
(state-keys (parse-keys output)))
(let ((state (assoc-ref state-keys "State")))
(if state
(cond ((string=? state "offline") 'offline)
((string=? state "idle") 'idle)
((string=? state "ready") 'ready)
((string=? state "online") 'online)
(else 'unknown))
(raise (condition
(&message
(message "Could not determine the state of connman."))))))))
(define (split-technology-list technologies)
"Parse the given strings list TECHNOLOGIES, under the following format:
'((\"/net/connman/technology/xxx\")
(\"KEY = VALUE\")
...
(\"/net/connman/technology/yyy\")
(\"KEY2 = VALUE2\")
...)
Return the corresponding '(((\"KEY = VALUE\") ...) ((\"KEY2 = VALUE2\") ...))
list so that each keys of a given technology are gathered in a separate list."
(let loop ((result '())
(cur-list '())
(input (reverse technologies)))
(if (null? input)
result
(let ((item (car input)))
(if (string-match "/net/connman/technology" item)
(loop (cons cur-list result) '() (cdr input))
(loop result (cons item cur-list) (cdr input)))))))
(define (string->boolean string)
(equal? string "True"))
(define (connman-technologies)
"Return a list of available <technology> records."
(define (technology-output->technology output)
(let ((keys (parse-keys output)))
(technology
(name (assoc-ref keys "Name"))
(type (assoc-ref keys "Type"))
(powered? (string->boolean (assoc-ref keys "Powered")))
(connected? (string->boolean (assoc-ref keys "Connected"))))))
(let* ((output (connman "technologies"))
(technologies (split-technology-list output)))
(map technology-output->technology technologies)))
(define (connman-enable-technology technology)
"Enable the given TECHNOLOGY."
(let ((type (technology-type technology)))
(connman "enable" type)))
(define (connman-disable-technology technology)
"Disable the given TECHNOLOGY."
(let ((type (technology-type technology)))
(connman "disable" type)))
(define (connman-scan-technology technology)
"Run a scan for the given TECHNOLOGY."
(let ((type (technology-type technology)))
(connman "scan" type)))
(define (connman-services)
"Return a list of available <services> records."
(define (service-output->service path output)
(let* ((service-keys
(match output
((_ . rest) rest)))
(keys (parse-keys service-keys)))
(service
(name (assoc-ref keys "Name"))
(type (assoc-ref keys "Type"))
(path path)
(strength (and=> (assoc-ref keys "Strength") string->number))
(state (assoc-ref keys "State")))))
(let* ((out (connman "services"))
(out-filtered (delete "" out))
(services-path (map (lambda (service)
(match (string-split service #\ )
((_ ... path) path)))
out-filtered))
(services-output (map (lambda (service)
(connman "services" service))
services-path)))
(map service-output->service services-path services-output)))
(define (connman-connect service)
"Connect to the given SERVICE."
(let ((path (service-path service)))
(connman "connect" path)))
(define (connman-disconnect service)
"Disconnect from the given SERVICE."
(let ((path (service-path service)))
(connman "disconnect" path)))
(define (connman-online?)
(let ((state (connman-state)))
(eq? state 'online)))
(define (connman-connect-with-auth service password-proc)
"Connect to the given SERVICE with the password returned by calling
PASSWORD-PROC. This is only possible in the interactive mode of connmanctl
because authentication is done by communicating with an agent.
As the open-pipe procedure of Guile do not allow to read from stderr, we have
to merge stdout and stderr using bash redirection. Then error messages are
extracted from connmanctl output using a regexp. This makes the whole
procedure even more unreliable.
Raise &connman-connection-error if an error occured during connection. Raise
&connman-password-error if the given password is incorrect."
(define connman-error-regexp (make-regexp "Error[ ]*([^\n]+)\n"))
(define (match-connman-error str)
(let ((match-error (regexp-exec connman-error-regexp str)))
(and match-error (match:substring match-error 1))))
(define* (read-regexps-or-error port regexps error-handler)
"Read characters from port until an error is detected, or one of the given
REGEXPS is matched. If an error is detected, call ERROR-HANDLER with the error
string as argument. Raise an error if the eof is reached before one of the
regexps is matched."
(let loop ((res ""))
(let ((char (read-char port)))
(cond
((eof-object? char)
(raise (condition
(&message
(message "Unable to find expected regexp.")))))
((match-connman-error res)
=>
(lambda (match)
(error-handler match)))
((or-map (lambda (regexp)
(and (regexp-exec regexp res) regexp))
regexps)
=>
(lambda (match)
match))
(else
(loop (string-append res (string char))))))))
(define* (read-regexp-or-error port regexp error-handler)
"Same as READ-REGEXPS-OR-ERROR above, but with a single REGEXP."
(read-regexps-or-error port (list regexp) error-handler))
(define (connman-error->condition path error)
(cond
((string-match "Already connected" error)
(condition (&connman-already-connected-error
(service path)
(output error))))
(else
(condition (&connman-connection-error
(service path)
(output error))))))
(define (run-connection-sequence pipe)
"Run the connection sequence using PIPE as an opened port to an
interactive connmanctl process."
(let* ((path (service-path service))
(error-handler (lambda (error)
(raise
(connman-error->condition path error)))))
;; Start the agent.
(format pipe "agent on\n")
(read-regexp-or-error pipe (make-regexp "Agent registered") error-handler)
;; Let's try to connect to the service. If the service does not require
;; a password, the connection might succeed right after this call.
;; Otherwise, connmanctl will prompt us for a password.
(format pipe "connect ~a\n" path)
(let* ((connected-regexp (make-regexp (format #f "Connected ~a" path)))
(passphrase-regexp (make-regexp "\nPassphrase\\?[ ]*"))
(regexps (list connected-regexp passphrase-regexp))
(result (read-regexps-or-error pipe regexps error-handler)))
;; A password is required.
(when (eq? result passphrase-regexp)
(format pipe "~a~%" (password-proc))
;; Now, we have to wait for the connection to succeed. If an error
;; occurs, it is most likely because the password is incorrect.
;; In that case, we escape from an eventual retry loop that would
;; add complexity to this procedure, and raise a
;; &connman-password-error condition.
(read-regexp-or-error pipe connected-regexp
(lambda (error)
;; Escape from retry loop.
(format pipe "no\n")
(raise
(condition (&connman-password-error
(service path)
(output error))))))))))
;; XXX: Find a better way to read stderr, like with the "subprocess"
;; procedure of racket that return input ports piped on the process stdin and
;; stderr.
(let ((pipe (open-pipe "connmanctl 2>&1" OPEN_BOTH)))
(dynamic-wind
(const #t)
(lambda ()
(run-connection-sequence pipe)
#t)
(lambda ()
(format pipe "quit\n")
(close-pipe pipe)))))

162
gnu/installer/keymap.scm
View File

@ -0,0 +1,162 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu installer keymap)
#:use-module (guix records)
#:use-module (sxml match)
#:use-module (sxml simple)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:export (<x11-keymap-model>
x11-keymap-model
make-x11-keymap-model
x11-keymap-model?
x11-keymap-model-name
x11-keymap-model-description
<x11-keymap-layout>
x11-keymap-layout
make-x11-keymap-layout
x11-keymap-layout?
x11-keymap-layout-name
x11-keymap-layout-description
x11-keymap-layout-variants
<x11-keymap-variant>
x11-keymap-variant
make-x11-keymap-variant
x11-keymap-variant?
x11-keymap-variant-name
x11-keymap-variant-description
xkb-rules->models+layouts
kmscon-update-keymap))
(define-record-type* <x11-keymap-model>
x11-keymap-model make-x11-keymap-model
x11-keymap-model?
(name x11-keymap-model-name) ;string
(description x11-keymap-model-description)) ;string
(define-record-type* <x11-keymap-layout>
x11-keymap-layout make-x11-keymap-layout
x11-keymap-layout?
(name x11-keymap-layout-name) ;string
(description x11-keymap-layout-description) ;string
(variants x11-keymap-layout-variants)) ;list of <x11-keymap-variant>
(define-record-type* <x11-keymap-variant>
x11-keymap-variant make-x11-keymap-variant
x11-keymap-variant?
(name x11-keymap-variant-name) ;string
(description x11-keymap-variant-description)) ;string
(define (xkb-rules->models+layouts file)
"Parse FILE and return two values, the list of supported X11-KEYMAP-MODEL
and X11-KEYMAP-LAYOUT records. FILE is an XML file from the X Keyboard
Configuration Database, describing possible XKB configurations."
(define (model m)
(sxml-match m
[(model
(configItem
(name ,name)
(description ,description)
. ,rest))
(x11-keymap-model
(name name)
(description description))]))
(define (variant v)
(sxml-match v
[(variant
;; According to xbd-rules DTD, the definition of a
;; configItem is: <!ELEMENT configItem
;; (name,shortDescription*,description*,vendor?,
;; countryList?,languageList?,hwList?)>
;;
;; shortDescription and description are optional elements
;; but sxml-match does not support default values for
;; elements (only attributes). So to avoid writing as many
;; patterns as existing possibilities, gather all the
;; remaining elements but name in REST-VARIANT.
(configItem
(name ,name)
. ,rest-variant))
(x11-keymap-variant
(name name)
(description (car
(assoc-ref rest-variant 'description))))]))
(define (layout l)
(sxml-match l
[(layout
(configItem
(name ,name)
. ,rest-layout)
(variantList ,[variant -> v] ...))
(x11-keymap-layout
(name name)
(description (car
(assoc-ref rest-layout 'description)))
(variants (list v ...)))]
[(layout
(configItem
(name ,name)
. ,rest-layout))
(x11-keymap-layout
(name name)
(description (car
(assoc-ref rest-layout 'description)))
(variants '()))]))
(let ((sxml (call-with-input-file file
(lambda (port)
(xml->sxml port #:trim-whitespace? #t)))))
(match
(sxml-match sxml
[(*TOP*
,pi
(xkbConfigRegistry
(@ . ,ignored)
(modelList ,[model -> m] ...)
(layoutList ,[layout -> l] ...)
. ,rest))
(list
(list m ...)
(list l ...))])
((models layouts)
(values models layouts)))))
(define (kmscon-update-keymap model layout variant)
(let ((keymap-file (getenv "KEYMAP_UPDATE")))
(unless (and keymap-file
(file-exists? keymap-file))
(error "Unable to locate keymap update file"))
(call-with-output-file keymap-file
(lambda (port)
(format port model)
(put-u8 port 0)
(format port layout)
(put-u8 port 0)
(format port variant)
(put-u8 port 0)))))

199
gnu/installer/locale.scm
View File

@ -0,0 +1,199 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu installer locale)
#:use-module (gnu installer utils)
#:use-module (guix records)
#:use-module (json)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:export (locale-language
locale-territory
locale-codeset
locale-modifier
locale->locale-string
supported-locales->locales
iso639->iso639-languages
language-code->language-name
iso3166->iso3166-territories
territory-code->territory-name))
;;;
;;; Locale.
;;;
;; A glibc locale string has the following format:
;; language[_territory[.codeset][@modifier]].
(define locale-regexp "^([^_@]+)(_([^\\.@]+))?(\\.([^@]+))?(@([^$]+))?$")
;; LOCALE will be better expressed in a (guix record) that in an association
;; list. However, loading large files containing records does not scale
;; well. The same thing goes for ISO639 and ISO3166 association lists used
;; later in this module.
(define (locale-language assoc)
(assoc-ref assoc 'language))
(define (locale-territory assoc)
(assoc-ref assoc 'territory))
(define (locale-codeset assoc)
(assoc-ref assoc 'codeset))
(define (locale-modifier assoc)
(assoc-ref assoc 'modifier))
(define (locale-string->locale string)
"Return the locale association list built from the parsing of STRING."
(let ((matches (string-match locale-regexp string)))
`((language . ,(match:substring matches 1))
(territory . ,(match:substring matches 3))
(codeset . ,(match:substring matches 5))
(modifier . ,(match:substring matches 7)))))
(define (locale->locale-string locale)
"Reverse operation of locale-string->locale."
(let ((language (locale-language locale))
(territory (locale-territory locale))
(codeset (locale-codeset locale))
(modifier (locale-modifier locale)))
(apply string-append
`(,language
,@(if territory
`("_" ,territory)
'())
,@(if codeset
`("." ,codeset)
'())
,@(if modifier
`("@" ,modifier)
'())))))
(define (supported-locales->locales supported-locales)
"Parse the SUPPORTED-LOCALES file from the glibc and return the matching
list of LOCALE association lists."
(call-with-input-file supported-locales
(lambda (port)
(let ((lines (read-lines port)))
(map (lambda (line)
(match (string-split line #\ )
((locale-string codeset)
(let ((line-locale (locale-string->locale locale-string)))
(assoc-set! line-locale 'codeset codeset)))))
lines)))))
;;;
;;; Language.
;;;
(define (iso639-language-alpha2 assoc)
(assoc-ref assoc 'alpha2))
(define (iso639-language-alpha3 assoc)
(assoc-ref assoc 'alpha3))
(define (iso639-language-name assoc)
(assoc-ref assoc 'name))
(define (supported-locale? locales alpha2 alpha3)
"Find a locale in LOCALES whose alpha2 field matches ALPHA-2 or alpha3 field
matches ALPHA-3. The ISO639 standard specifies that ALPHA-2 is optional. Thus,
if ALPHA-2 is #f, only consider ALPHA-3. Return #f if not matching locale was
found."
(find (lambda (locale)
(let ((language (locale-language locale)))
(or (and=> alpha2
(lambda (code)
(string=? language code)))
(string=? language alpha3))))
locales))
(define (iso639->iso639-languages locales iso639-3 iso639-5)
"Return a list of ISO639 association lists created from the parsing of
ISO639-3 and ISO639-5 files."
(call-with-input-file iso639-3
(lambda (port-iso639-3)
(call-with-input-file iso639-5
(lambda (port-iso639-5)
(filter-map
(lambda (hash)
(let ((alpha2 (hash-ref hash "alpha_2"))
(alpha3 (hash-ref hash "alpha_3"))
(name (hash-ref hash "name")))
(and (supported-locale? locales alpha2 alpha3)
`((alpha2 . ,alpha2)
(alpha3 . ,alpha3)
(name . ,name)))))
(append
(hash-ref (json->scm port-iso639-3) "639-3")
(hash-ref (json->scm port-iso639-5) "639-5"))))))))
(define (language-code->language-name languages language-code)
"Using LANGUAGES as a list of ISO639 association lists, return the language
name corresponding to the given LANGUAGE-CODE."
(let ((iso639-language
(find (lambda (language)
(or
(and=> (iso639-language-alpha2 language)
(lambda (alpha2)
(string=? alpha2 language-code)))
(string=? (iso639-language-alpha3 language)
language-code)))
languages)))
(iso639-language-name iso639-language)))
;;;
;;; Territory.
;;;
(define (iso3166-territory-alpha2 assoc)
(assoc-ref assoc 'alpha2))
(define (iso3166-territory-alpha3 assoc)
(assoc-ref assoc 'alpha3))
(define (iso3166-territory-name assoc)
(assoc-ref assoc 'name))
(define (iso3166->iso3166-territories iso3166)
"Return a list of ISO3166 association lists created from the parsing of
ISO3166 file."
(call-with-input-file iso3166
(lambda (port)
(map (lambda (hash)
`((alpha2 . ,(hash-ref hash "alpha_2"))
(alpha3 . ,(hash-ref hash "alpha_3"))
(name . ,(hash-ref hash "name"))))
(hash-ref (json->scm port) "3166-1")))))
(define (territory-code->territory-name territories territory-code)
"Using TERRITORIES as a list of ISO3166 association lists return the
territory name corresponding to the given TERRITORY-CODE."
(let ((iso3166-territory
(find (lambda (territory)
(or
(and=> (iso3166-territory-alpha2 territory)
(lambda (alpha2)
(string=? alpha2 territory-code)))
(string=? (iso3166-territory-alpha3 territory)
territory-code)))
territories)))
(iso3166-territory-name iso3166-territory)))

102
gnu/installer/newt.scm
View File

@ -0,0 +1,102 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu installer newt)
#:use-module (gnu installer)
#:use-module (guix discovery)
#:use-module (guix gexp)
#:use-module (guix ui)
#:export (newt-installer))
(define (modules)
(cons '(newt)
(map module-name
(scheme-modules