futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

gnu: Add graphical installer support.

Browse Source 
* 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.
This commit is contained in:
Mathieu Othacehe 2018-11-16 20:43:55 +09:00 committed by Ludovic Courtès
parent 08af580bde
commit d0f3a672dc
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
28 changed files with 3888 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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 Normal file
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 Normal file
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 Normal file
View File

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

290
gnu/installer/build-installer.scm Normal file
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 Normal file
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 Normal file
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 Normal file
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 Normal file
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
(dirname (search-path %load-path "guix.scm"))
"gnu/installer/newt"
#:warn warn-about-load-error))))
(define init
#~(begin
(newt-init)
(clear-screen)
(set-screen-size!)))
(define exit
#~(begin
(newt-finish)))
(define exit-error
#~(lambda (key args)
(newt-finish)))
(define locale-page
#~(lambda* (#:key
supported-locales
iso639-languages
iso3166-territories)
(run-locale-page
#:supported-locales supported-locales
#:iso639-languages iso639-languages
#:iso3166-territories iso3166-territories)))
(define timezone-page
#~(lambda* (zonetab)
(run-timezone-page zonetab)))
(define logo
(string-append
(dirname (search-path %load-path "guix.scm"))
"/gnu/installer/aux-files/logo.txt"))
(define welcome-page
#~(run-welcome-page #$(local-file logo)))
(define menu-page
#~(lambda (steps)
(run-menu-page steps)))
(define keymap-page
#~(lambda* (#:key models layouts)
(run-keymap-page #:models models
#:layouts layouts)))
(define network-page
#~(run-network-page))
(define hostname-page
#~(run-hostname-page))
(define user-page
#~(run-user-page))
(define newt-installer
(installer
(name 'newt)
(modules (modules))
(init init)
(exit exit)
(exit-error exit-error)
(keymap-page keymap-page)
(locale-page locale-page)
(menu-page menu-page)
(network-page network-page)
(timezone-page timezone-page)
(hostname-page hostname-page)
(user-page user-page)
(welcome-page welcome-page)))

80
gnu/installer/newt/ethernet.scm Normal file
View File

@ -0,0 +1,80 @@
;;; 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 ethernet)
#:use-module (gnu installer connman)
#:use-module (gnu installer steps)
#:use-module (gnu installer newt utils)
#:use-module (gnu installer newt page)
#:use-module (guix i18n)
#:use-module (ice-9 format)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (newt)
#:export (run-ethernet-page))
(define (ethernet-services)
"Return all the connman services of ethernet type."
(let ((services (connman-services)))
(filter (lambda (service)
(and (string=? (service-type service) "ethernet")
(not (string-null? (service-name service)))))
services)))
(define (ethernet-service->text service)
"Return a string describing the given ethernet SERVICE."
(let* ((name (service-name service))
(path (service-path service))
(full-name (string-append name "-" path))
(state (service-state service))
(connected? (or (string=? state "online")
(string=? state "ready"))))
(format #f "~c ~a~%"
(if connected? #\* #\ )
full-name)))
(define (connect-ethernet-service service)
"Connect to the given ethernet SERVICE. Display a connecting page while the
connection is pending."
(let* ((service-name (service-name service))
(form (draw-connecting-page service-name)))
(connman-connect service)
(destroy-form-and-pop form)))
(define (run-ethernet-page)
(let ((services (ethernet-services)))
(if (null? services)
(begin
(run-error-page
(G_ "No ethernet service available, please try again.")
(G_ "No service"))
(raise
(condition
(&installer-step-abort))))
(run-listbox-selection-page
#:info-text (G_ "Please select an ethernet network.")
#:title (G_ "Ethernet connection")
#:listbox-items services
#:listbox-item->text ethernet-service->text
#:button-text (G_ "Cancel")
#:button-callback-procedure
(lambda _
(raise
(condition
(&installer-step-abort))))
#:listbox-callback-procedure connect-ethernet-service))))

26
gnu/installer/newt/hostname.scm Normal file
View File

@ -0,0 +1,26 @@
;;; 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 hostname)
#:use-module (gnu installer newt page)
#:use-module (guix i18n)
#:export (run-hostname-page))
(define (run-hostname-page)
(run-input-page (G_ "Please enter the system hostname")
(G_ "Hostname selection")))

132
gnu/installer/newt/keymap.scm Normal file
View File

@ -0,0 +1,132 @@
;;; 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 keymap)
#:use-module (gnu installer keymap)
#:use-module (gnu installer steps)
#:use-module (gnu installer newt page)
#:use-module (guix i18n)
#:use-module (guix records)
#:use-module (newt)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (run-keymap-page))
(define (run-layout-page layouts layout->text)
(let ((title (G_ "Layout selection")))
(run-listbox-selection-page
#:title title
#:info-text (G_ "Please choose your keyboard layout.")
#:listbox-items layouts
#:listbox-item->text layout->text
#:button-text (G_ "Cancel")
#:button-callback-procedure
(lambda _
(raise
(condition
(&installer-step-abort)))))))
(define (run-variant-page variants variant->text)
(let ((title (G_ "Variant selection")))
(run-listbox-selection-page
#:title title
#:info-text (G_ "Please choose a variant for your keyboard layout.")
#:listbox-items variants
#:listbox-item->text variant->text
#:button-text (G_ "Back")
#:button-callback-procedure
(lambda _
(raise
(condition
(&installer-step-abort)))))))
(define (run-model-page models model->text)
(let ((title (G_ "Keyboard model selection")))
(run-listbox-selection-page
#:title title
#:info-text (G_ "Please choose your keyboard model.")
#:listbox-items models
#:listbox-item->text model->text
#:listbox-default-item (find (lambda (model)
(string=? (x11-keymap-model-name model)
"pc105"))
models)
#:sort-listbox-items? #f
#:button-text (G_ "Back")
#:button-callback-procedure
(lambda _
(raise
(condition
(&installer-step-abort)))))))
(define* (run-keymap-page #:key models layouts)
"Run a page asking the user to select a keyboard model, layout and
variant. MODELS and LAYOUTS are lists of supported X11-KEYMAP-MODEL and
X11-KEYMAP-LAYOUT. Return a list of three elements, the names of the selected
keyboard model, layout and variant."
(define keymap-steps
(list
(installer-step
(id 'model)
(compute
(lambda _
;; TODO: Understand why (run-model-page models x11-keymap-model-name)
;; fails with: warning: possibly unbound variable
;; `%x11-keymap-model-description-procedure.
(run-model-page models (lambda (model)
(x11-keymap-model-description
model))))))
(installer-step
(id 'layout)
(compute
(lambda _
(let* ((layout (run-layout-page
layouts
(lambda (layout)
(x11-keymap-layout-description layout)))))
(if (null? (x11-keymap-layout-variants layout))
;; Break if this layout does not have any variant.
(raise
(condition
(&installer-step-break)))
layout)))))
;; Propose the user to select a variant among those supported by the
;; previously selected layout.
(installer-step
(id 'variant)
(compute
(lambda (result)
(let ((variants (x11-keymap-layout-variants
(result-step result 'layout))))
(run-variant-page variants
(lambda (variant)
(x11-keymap-variant-description
variant)))))))))
(define (format-result result)
(let ((model (x11-keymap-model-name
(result-step result 'model)))
(layout (x11-keymap-layout-name
(result-step result 'layout)))
(variant (and=> (result-step result 'variant)
(lambda (variant)
(x11-keymap-variant-name variant)))))
(list model layout (or variant ""))))
(format-result
(run-installer-steps #:steps keymap-steps)))

193
gnu/installer/newt/locale.scm Normal file
View File

@ -0,0 +1,193 @@
;;; 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 locale)
#:use-module (gnu installer locale)
#:use-module (gnu installer steps)
#:use-module (gnu installer newt page)
#:use-module (guix i18n)
#:use-module (newt)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 match)
#:export (run-locale-page))
(define (run-language-page languages language->text)
(let ((title (G_ "Language selection")))
(run-listbox-selection-page
#:title title
#:info-text (G_ "Choose the language to be used for the installation \
process. The selected language will also be the default \
language for the installed system.")
#:listbox-items languages
#:listbox-item->text language->text
#:button-text (G_ "Cancel")
#:button-callback-procedure
(lambda _
(raise
(condition
(&installer-step-abort)))))))
(define (run-territory-page territories territory->text)
(let ((title (G_ "Location selection")))
(run-listbox-selection-page
#:title title
#:info-text (G_ "Choose your location. This is a shortlist of locations \
based on the language you selected.")
#:listbox-items territories
#:listbox-item->text territory->text
#:button-text (G_ "Back")
#:button-callback-procedure
(lambda _
(raise
(condition
(&installer-step-abort)))))))
(define (run-codeset-page codesets)
(let ((title (G_ "Codeset selection")))
(run-listbox-selection-page
#:title title
#:info-text (G_ "Choose your codeset. If UTF-8 is available, it should be \
preferred.")
#:listbox-items codesets
#:listbox-item->text identity
#:listbox-default-item "UTF-8"
#:button-text (G_ "Back")
#:button-callback-procedure
(lambda _
(raise
(condition
(&installer-step-abort)))))))
(define (run-modifier-page modifiers modifier->text)
(let ((title (G_ "Modifier selection")))
(run-listbox-selection-page
#:title title
#:info-text (G_ "Choose your modifier.")
#:listbox-items modifiers
#:listbox-item->text modifier->text
#:button-text (G_ "Back")
#:button-callback-procedure
(lambda _
(raise
(condition
(&installer-step-abort)))))))
(define* (run-locale-page #:key
supported-locales
iso639-languages
iso3166-territories)
(define (break-on-locale-found locales)
"Raise the &installer-step-break condition if LOCALES contains exactly one
element."
(and (= (length locales) 1)
(raise
(condition (&installer-step-break)))))
(define (filter-locales locales result)
"Filter the list of locale records LOCALES using the RESULT returned by
the installer-steps defined below."
(filter
(lambda (locale)
(and-map identity
`(,(string=? (locale-language locale)
(result-step result 'language))
,@(if (result-step-done? result 'territory)
(list (equal? (locale-territory locale)
(result-step result 'territory)))
'())
,@(if (result-step-done? result 'codeset)
(list (equal? (locale-codeset locale)
(result-step result 'codeset)))
'())
,@(if (result-step-done? result 'modifier)
(list (equal? (locale-modifier locale)
(result-step result 'modifier)))
'()))))
locales))
(define (result->locale-string locales result)
"Supposing that LOCALES contains exactly one locale record, turn it into a
glibc locale string and return it."
(match (filter-locales locales result)
((locale)
(locale->locale-string locale))))
(define locale-steps
(list
(installer-step
(id 'language)
(compute
(lambda _
(run-language-page
(delete-duplicates (map locale-language supported-locales))
(cut language-code->language-name iso639-languages <>)))))
(installer-step
(id 'territory)
(compute
(lambda (result)
(let ((locales (filter-locales supported-locales result)))
;; Stop the process if the language returned by the previous step
;; is matching one and only one supported locale.
(break-on-locale-found locales)
;; Otherwise, ask the user to select a territory among those
;; supported by the previously selected language.
(run-territory-page
(delete-duplicates (map locale-territory locales))
(lambda (territory-code)
(if territory-code
(territory-code->territory-name iso3166-territories
territory-code)
(G_ "No location"))))))))
(installer-step
(id 'codeset)
(compute
(lambda (result)
(let ((locales (filter-locales supported-locales result)))
;; Same as above but we now have a language and a territory to
;; narrow down the search of a locale.
(break-on-locale-found locales)
;; Otherwise, ask for a codeset.
(run-codeset-page
(delete-duplicates (map locale-codeset locales)))))))
(installer-step
(id 'modifier)
(compute
(lambda (result)
(let ((locales (filter-locales supported-locales result)))
;; Same thing with a language, a territory and a codeset this time.
(break-on-locale-found locales)
;; Otherwise, ask for a modifier.
(run-modifier-page
(delete-duplicates (map locale-modifier locales))
(lambda (modifier)
(or modifier (G_ "No modifier"))))))))))
;; If run-installer-steps returns locally, it means that the user had to go
;; through all steps (language, territory, codeset and modifier) to select a
;; locale. In that case, like if we exited by raising &installer-step-break
;; condition, turn the result into a glibc locale string and return it.
(result->locale-string
supported-locales
(run-installer-steps #:steps locale-steps)))

44
gnu/installer/newt/menu.scm Normal file
View File

@ -0,0 +1,44 @@
;;; 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 menu)
#:use-module (gnu installer steps)
#:use-module (gnu installer newt page)
#:use-module (guix i18n)
#:use-module (newt)
#:export (run-menu-page))
(define (run-menu-page steps)
"Run a menu page, asking the user to select where to resume the install
process from."
(define (steps->items steps)
(filter (lambda (step)
(installer-step-description step))
steps))
(run-listbox-selection-page
#:info-text (G_ "Choose where you want to resume the install.\
You can also abort the installion by pressing the button.")
#:title (G_ "Installation menu")
#:listbox-items (steps->items steps)
#:listbox-item->text installer-step-description
#:sort-listbox-items? #f
#:button-text (G_ "Abort")
#:button-callback-procedure (lambda ()
(newt-finish)
(primitive-exit 1))))

159
gnu/installer/newt/network.scm Normal file
View File

@ -0,0 +1,159 @@
;;; 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 network)
#:use-module (gnu installer connman)
#:use-module (gnu installer steps)
#:use-module (gnu installer utils)
#:use-module (gnu installer newt ethernet)
#:use-module (gnu installer newt page)
#:use-module (gnu installer newt wifi)
#:use-module (guix i18n)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (newt)
#:export (run-network-page))
;; Maximum length of a technology name.
(define technology-name-max-length (make-parameter 20))
(define (technology->text technology)
"Return a string describing the given TECHNOLOGY."
(let* ((name (technology-name technology))
(padded-name (string-pad-right name
(technology-name-max-length))))
(format #f "~a~%" padded-name)))
(define (run-technology-page)
"Run a page to ask the user which technology shall be used to access
Internet and return the selected technology. For now, only technologies with
\"ethernet\" or \"wifi\" types are supported."
(define (technology-items)
(filter (lambda (technology)
(let ((type (technology-type technology)))
(or
(string=? type "ethernet")
(string=? type "wifi"))))
(connman-technologies)))
(run-listbox-selection-page
#:info-text (G_ "The install process requires an internet access.\
Please select a network technology.")
#:title (G_ "Technology selection")
#:listbox-items (technology-items)
#:listbox-item->text technology->text
#:button-text (G_ "Cancel")
#:button-callback-procedure
(lambda _
(raise
(condition
(&installer-step-abort))))))
(define (find-technology-by-type technologies type)
"Find and return a technology with the given TYPE in TECHNOLOGIES list."
(find (lambda (technology)
(string=? (technology-type technology)
type))
technologies))
(define (wait-technology-powered technology)
"Wait and display a progress bar until the given TECHNOLOGY is powered."
(let ((name (technology-name technology))
(full-value 5))
(run-scale-page
#:title (G_ "Powering technology")
#:info-text (format #f "Waiting for technology ~a to be powered." name)
#:scale-full-value full-value
#:scale-update-proc
(lambda (value)
(let* ((technologies (connman-technologies))
(type (technology-type technology))
(updated-technology
(find-technology-by-type technologies type))
(technology-powered? updated-technology))
(sleep 1)
(if technology-powered?
full-value
(+ value 1)))))))
(define (wait-service-online)
"Display a newt scale until connman detects an Internet access. Do
FULL-VALUE tentatives, spaced by 1 second."
(let* ((full-value 5))
(run-scale-page
#:title (G_ "Checking connectivity")
#:info-text (G_ "Waiting internet access is established")
#:scale-full-value full-value
#:scale-update-proc
(lambda (value)
(sleep 1)
(if (connman-online?)
full-value
(+ value 1))))
(unless (connman-online?)
(run-error-page
(G_ "The selected network does not provide an Internet \
access, please try again.")
(G_ "Connection error"))
(raise
(condition
(&installer-step-abort))))))
(define (run-network-page)
"Run a page to allow the user to configure connman so that it can access the
Internet."
(define network-steps
(list
;; Ask the user to choose between ethernet and wifi technologies.
(installer-step
(id 'select-technology)
(compute
(lambda _
(run-technology-page))))
;; Enable the previously selected technology.
(installer-step
(id 'power-technology)
(compute
(lambda (result)
(let ((technology (result-step result 'select-technology)))
(connman-enable-technology technology)
(wait-technology-powered technology)))))
;; Propose the user to connect to one of the service available for the
;; previously selected technology.
(installer-step
(id 'connect-service)
(compute
(lambda (result)
(let* ((technology (result-step result 'select-technology))
(type (technology-type technology)))
(cond
((string=? "wifi" type)
(run-wifi-page))
((string=? "ethernet" type)
(run-ethernet-page)))))))
;; Wait for connman status to switch to 'online, which means it can
;; access Internet.
(installer-step
(id 'wait-online)
(compute (lambda _
(wait-service-online))))))
(run-installer-steps
#:steps network-steps
#:rewind-strategy 'start))

313
gnu/installer/newt/page.scm Normal file
View File

@ -0,0 +1,313 @@
;;; 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 page)
#:use-module (gnu installer newt utils)
#:use-module (guix i18n)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (newt)
#:export (draw-info-page
draw-connecting-page
run-input-page
run-error-page
run-listbox-selection-page
run-scale-page))
;;; Commentary:
;;;
;;; Some helpers around guile-newt to draw or run generic pages. The
;;; difference between 'draw' and 'run' terms comes from newt library. A page
;;; is drawn when the form it contains does not expect any user
;;; interaction. In that case, it is necessary to call (newt-refresh) to force
;;; the page to be displayed. When a form is 'run', it is blocked waiting for
;;; any action from the user (press a button, input some text, ...).
;;;
;;; Code:
(define (draw-info-page text title)
"Draw an informative page with the given TEXT as content. Set the title of
this page to TITLE."
(let* ((text-box
(make-reflowed-textbox -1 -1 text 40
#:flags FLAG-BORDER))
(grid (make-grid 1 1))
(form (make-form)))
(set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box)
(add-component-to-form form text-box)
(make-wrapped-grid-window grid title)
(draw-form form)
;; This call is imperative, otherwise the form won't be displayed. See the
;; explanation in the above commentary.
(newt-refresh)
form))
(define (draw-connecting-page service-name)
"Draw a page to indicate a connection in in progress."
(draw-info-page
(format #f (G_ "Connecting to ~a, please wait.") service-name)
(G_ "Connection in progress")))
(define* (run-input-page text title
#:key
(allow-empty-input? #f)
(input-field-width 40))
"Run a page to prompt user for an input. The given TEXT will be displayed
above the input field. The page title is set to TITLE. Unless
allow-empty-input? is set to #t, an error page will be displayed if the user
enters an empty input."
(let* ((text-box
(make-reflowed-textbox -1 -1 text
input-field-width
#:flags FLAG-BORDER))
(grid (make-grid 1 3))
(input-entry (make-entry -1 -1 20))
(ok-button (make-button -1 -1 (G_ "Ok")))
(form (make-form)))
(set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box)
(set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT input-entry
#:pad-top 1)
(set-grid-field grid 0 2 GRID-ELEMENT-COMPONENT ok-button
#:pad-top 1)
(add-components-to-form form text-box input-entry ok-button)
(make-wrapped-grid-window grid title)
(let ((error-page (lambda ()
(run-error-page (G_ "Please enter a non empty input")
(G_ "Empty input")))))
(let loop ()
(receive (exit-reason argument)
(run-form form)
(let ((input (entry-value input-entry)))
(if (and (not allow-empty-input?)
(eq? exit-reason 'exit-component)
(string=? input ""))
(begin
;; Display the error page.
(error-page)
;; Set the focus back to the input input field.
(set-current-component form input-entry)
(loop))
(begin
(destroy-form-and-pop form)
input))))))))
(define (run-error-page text title)
"Run a page to inform the user of an error. The page contains the given TEXT
to explain the error and an \"OK\" button to acknowledge the error. The title
of the page is set to TITLE."
(let* ((text-box
(make-reflowed-textbox -1 -1 text 40
#:flags FLAG-BORDER))
(grid (make-grid 1 2))
(ok-button (make-button -1 -1 "Ok"))
(form (make-form)))
(set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box)
(set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT ok-button
#:pad-top 1)
;; Set the background color to red to indicate something went wrong.
(newt-set-color COLORSET-ROOT "white" "red")
(add-components-to-form form text-box ok-button)
(make-wrapped-grid-window grid title)
(run-form form)
;; Restore the background to its original color.
(newt-set-color COLORSET-ROOT "white" "blue")
(destroy-form-and-pop form)))
(define* (run-listbox-selection-page #:key
info-text
title
(info-textbox-width 50)
listbox-items
listbox-item->text
(listbox-height 20)
(listbox-default-item #f)
(listbox-allow-multiple? #f)
(sort-listbox-items? #t)
button-text
(button-callback-procedure
(const #t))
(listbox-callback-procedure
(const #t)))
"Run a page asking the user to select an item in a listbox. The page
contains, stacked vertically from the top to the bottom, an informative text
set to INFO-TEXT, a listbox and a button. The listbox will be filled with
LISTBOX-ITEMS converted to text by applying the procedure LISTBOX-ITEM->TEXT
on every item. The selected item from LISTBOX-ITEMS is returned. The button
text is set to BUTTON-TEXT and the procedure BUTTON-CALLBACK-PROCEDURE called
when it is pressed. The procedure LISTBOX-CALLBACK-PROCEDURE is called when an
item from the listbox is selected (by pressing the <ENTER> key).
INFO-TEXTBOX-WIDTH is the width of the textbox where INFO-TEXT will be
displayed. LISTBOX-HEIGHT is the height of the listbox.
If LISTBOX-DEFAULT-ITEM is set to the value of one of the items in
LISTBOX-ITEMS, it will be selected by default. Otherwise, the first element of
the listbox is selected.
If LISTBOX-ALLOW-MULTIPLE? is set to #t, multiple items from the listbox can
be selected (using the <SPACE> key). It that case, a list containing the
selected items will be returned.
If SORT-LISTBOX-ITEMS? is set to #t, the listbox items are sorted using
'string<=' procedure (after being converted to text)."
(define (fill-listbox listbox items)
"Append the given ITEMS to LISTBOX, once they have been converted to text
with LISTBOX-ITEM->TEXT. Each item appended to the LISTBOX is given a key by
newt. Save this key by returning an association list under the form:
((NEWT-LISTBOX-KEY . ITEM) ...)
where NEWT-LISTBOX-KEY is the key returned by APPEND-ENTRY-TO-LISTBOX, when
ITEM was inserted into LISTBOX."
(map (lambda (item)
(let* ((text (listbox-item->text item))
(key (append-entry-to-listbox listbox text)))
(cons key item)))
items))
(define (sort-listbox-items listbox-items)
"Return LISTBOX-ITEMS sorted using the 'string<=' procedure on the text
corresponding to each item in the list."
(let* ((items (map (lambda (item)
(cons item (listbox-item->text item)))
listbox-items))
(sorted-items
(sort items (lambda (a b)
(let ((text-a (cdr a))
(text-b (cdr b)))
(string<= text-a text-b))))))
(map car sorted-items)))
(define (set-default-item listbox listbox-keys default-item)
"Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the
association list returned by the FILL-LISTBOX procedure. It is used because
the current listbox item has to be selected by key."
(for-each (match-lambda
((key . item)
(when (equal? item default-item)
(set-current-listbox-entry-by-key listbox key))))
listbox-keys))
(let* ((listbox (make-listbox
-1 -1
listbox-height
(logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT
(if listbox-allow-multiple?
FLAG-MULTIPLE
0))))
(form (make-form))
(info-textbox
(make-reflowed-textbox -1 -1 info-text
info-textbox-width
#:flags FLAG-BORDER))
(button (make-button -1 -1 button-text))
(grid (vertically-stacked-grid
GRID-ELEMENT-COMPONENT info-textbox
GRID-ELEMENT-COMPONENT listbox
GRID-ELEMENT-COMPONENT button))
(sorted-items (if sort-listbox-items?
(sort-listbox-items listbox-items)
listbox-items))
(keys (fill-listbox listbox sorted-items)))
(when listbox-default-item
(set-default-item listbox keys listbox-default-item))
(add-form-to-grid grid form #t)
(make-wrapped-grid-window grid title)
(receive (exit-reason argument)
(run-form form)
(dynamic-wind
(const #t)
(lambda ()
(when (eq? exit-reason 'exit-component)
(cond
((components=? argument button)
(button-callback-procedure))
((components=? argument listbox)
(if listbox-allow-multiple?
(let* ((entries (listbox-selection listbox))
(items (map (lambda (entry)
(assoc-ref keys entry))
entries)))
(listbox-callback-procedure items)
items)
(let* ((entry (current-listbox-entry listbox))
(item (assoc-ref keys entry)))
(listbox-callback-procedure item)
item))))))
(lambda ()
(destroy-form-and-pop form))))))
(define* (run-scale-page #:key
title
info-text
(info-textbox-width 50)
(scale-width 40)
(scale-full-value 100)
scale-update-proc
(max-scale-update 5))
"Run a page with a progress bar (called 'scale' in newt). The given
INFO-TEXT is displayed in a textbox above the scale. The width of the textbox
is set to INFO-TEXTBOX-WIDTH. The width of the scale is set to
SCALE-WIDTH. SCALE-FULL-VALUE indicates the value that correspond to 100% of
the scale.
The procedure SCALE-UPDATE-PROC shall return a new scale
value. SCALE-UPDATE-PROC will be called until the returned value is superior
or equal to SCALE-FULL-VALUE, but no more than MAX-SCALE-UPDATE times. An
error is raised if the MAX-SCALE-UPDATE limit is reached."
(let* ((info-textbox
(make-reflowed-textbox -1 -1 info-text
info-textbox-width
#:flags FLAG-BORDER))
(scale (make-scale -1 -1 scale-width scale-full-value))
(grid (vertically-stacked-grid
GRID-ELEMENT-COMPONENT info-textbox
GRID-ELEMENT-COMPONENT scale))
(form (make-form)))
(add-form-to-grid grid form #t)
(make-wrapped-grid-window grid title)
(draw-form form)
;; This call is imperative, otherwise the form won't be displayed. See the
;; explanation in the above commentary.
(newt-refresh)
(dynamic-wind
(const #t)
(lambda ()
(let loop ((i max-scale-update)
(last-value 0))
(let ((value (scale-update-proc last-value)))
(set-scale-value scale value)
;; Same as above.
(newt-refresh)
(unless (>= value scale-full-value)
(if (> i 0)
(loop (- i 1) value)
(error "Max scale updates reached."))))))
(lambda ()
(destroy-form-and-pop form)))))

83
gnu/installer/newt/timezone.scm Normal file
View File

@ -0,0 +1,83 @@
;;; 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 timezone)
#:use-module (gnu installer steps)
#:use-module (gnu installer timezone)
#:use-module (gnu installer newt page)
#:use-module (guix i18n)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (newt)
#:export (run-timezone-page))
;; Heigth of the listbox displaying timezones.
(define timezone-listbox-heigth (make-parameter 20))
;; Information textbox width.
(define info-textbox-width (make-parameter 40))
(define (fill-timezones listbox timezones)
"Fill the given LISTBOX with TIMEZONES. Return an association list
correlating listbox keys with timezones."
(map (lambda (timezone)
(let ((key (append-entry-to-listbox listbox timezone)))
(cons key timezone)))
timezones))
(define (run-timezone-page zonetab)
"Run a page displaying available timezones, grouped by regions. The user is
invited to select a timezone. The selected timezone, under Posix format is
returned."
(define (all-but-last list)
(reverse (cdr (reverse list))))
(define (run-page timezone-tree)
(define (loop path)
(let ((timezones (locate-childrens timezone-tree path)))
(run-listbox-selection-page
#:title (G_ "Timezone selection")
#:info-text (G_ "Please select a timezone.")
#:listbox-items timezones
#:listbox-item->text identity
#:button-text (if (null? path)
(G_ "Cancel")
(G_ "Back"))
#:button-callback-procedure
(if (null? path)
(lambda _
(raise
(condition
(&installer-step-abort))))
(lambda _
(loop (all-but-last path))))
#:listbox-callback-procedure
(lambda (timezone)
(let* ((timezone* (append path (list timezone)))
(tz (timezone->posix-tz timezone*)))
(if (timezone-has-child? timezone-tree timezone*)
(loop timezone*)
tz))))))
(loop '()))
(let ((timezone-tree (zonetab->timezone-tree zonetab)))
(run-page timezone-tree)))

181
gnu/installer/newt/user.scm Normal file
View File

@ -0,0 +1,181 @@
;;; 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 user)
#:use-module (gnu installer newt page)
#:use-module (gnu installer newt utils)
#:use-module (guix i18n)
#:use-module (newt)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (run-user-page))
(define (run-user-add-page)
(define (pad-label label)
(string-pad-right label 20))
(let* ((label-name
(make-label -1 -1 (pad-label (G_ "Name"))))
(label-group
(make-label -1 -1 (pad-label (G_ "Group"))))
(label-home-directory
(make-label -1 -1 (pad-label (G_ "Home directory"))))
(entry-width 30)
(entry-name (make-entry -1 -1 entry-width))
(entry-group (make-entry -1 -1 entry-width
#:initial-value "users"))
(entry-home-directory (make-entry -1 -1 entry-width))
(entry-grid (make-grid 2 3))
(button-grid (make-grid 1 1))
(ok-button (make-button -1 -1 (G_ "Ok")))
(grid (make-grid 1 2))
(title (G_ "User creation"))
(set-entry-grid-field
(cut set-grid-field entry-grid <> <> GRID-ELEMENT-COMPONENT <>))
(form (make-form)))
(set-entry-grid-field 0 0 label-name)
(set-entry-grid-field 1 0 entry-name)
(set-entry-grid-field 0 1 label-group)
(set-entry-grid-field 1 1 entry-group)
(set-entry-grid-field 0 2 label-home-directory)
(set-entry-grid-field 1 2 entry-home-directory)
(set-grid-field button-grid 0 0 GRID-ELEMENT-COMPONENT ok-button)
(add-component-callback
entry-name
(lambda (component)
(set-entry-text entry-home-directory
(string-append "/home/" (entry-value entry-name)))))
(add-components-to-form form
label-name label-group label-home-directory
entry-name entry-group entry-home-directory
ok-button)
(make-wrapped-grid-window (vertically-stacked-grid
GRID-ELEMENT-SUBGRID entry-grid
GRID-ELEMENT-SUBGRID button-grid)
title)
(let ((error-page
(lambda ()
(run-error-page (G_ "Empty inputs are not allowed")
(G_ "Empty input")))))
(receive (exit-reason argument)
(run-form form)
(dynamic-wind
(const #t)
(lambda ()
(when (eq? exit-reason 'exit-component)
(cond
((components=? argument ok-button)
(let ((name (entry-value entry-name))
(group (entry-value entry-group))
(home-directory (entry-value entry-home-directory)))
(if (or (string=? name "")
(string=? group "")
(string=? home-directory ""))
(begin
(error-page)
(run-user-add-page))
`((name . ,name)
(group . ,group)
(home-directory . ,home-directory))))))))
(lambda ()
(destroy-form-and-pop form)))))))
(define (run-user-page)
(define (run users)
(let* ((listbox (make-listbox
-1 -1 10
(logior FLAG-SCROLL FLAG-BORDER)))
(info-textbox
(make-reflowed-textbox
-1 -1
(G_ "Please add at least one user to system\
using the 'Add' button.")
40 #:flags FLAG-BORDER))
(add-button (make-compact-button -1 -1 (G_ "Add")))
(del-button (make-compact-button -1 -1 (G_ "Delete")))
(listbox-button-grid
(apply
vertically-stacked-grid
GRID-ELEMENT-COMPONENT add-button
`(,@(if (null? users)
'()
(list GRID-ELEMENT-COMPONENT del-button)))))
(ok-button (make-button -1 -1 (G_ "Ok")))
(cancel-button (make-button -1 -1 (G_ "Cancel")))
(title "User selection")
(grid
(vertically-stacked-grid
GRID-ELEMENT-COMPONENT info-textbox
GRID-ELEMENT-SUBGRID (horizontal-stacked-grid
GRID-ELEMENT-COMPONENT listbox
GRID-ELEMENT-SUBGRID listbox-button-grid)
GRID-ELEMENT-SUBGRID (horizontal-stacked-grid
GRID-ELEMENT-COMPONENT ok-button
GRID-ELEMENT-COMPONENT cancel-button)))
(sorted-users (sort users (lambda (a b)
(string<= (assoc-ref a 'name)
(assoc-ref b 'name)))))
(listbox-elements
(map
(lambda (user)
`((key . ,(append-entry-to-listbox listbox
(assoc-ref user 'name)))
(user . ,user)))
sorted-users))
(form (make-form)))
(add-form-to-grid grid form #t)
(make-wrapped-grid-window grid title)
(if (null? users)
(set-current-component form add-button)
(set-current-component form ok-button))
(receive (exit-reason argument)
(run-form form)
(dynamic-wind
(const #t)
(lambda ()
(when (eq? exit-reason 'exit-component)
(cond
((components=? argument add-button)
(run (cons (run-user-add-page) users)))
((components=? argument del-button)
(let* ((current-user-key (current-listbox-entry listbox))
(users
(map (cut assoc-ref <> 'user)
(remove (lambda (element)
(equal? (assoc-ref element 'key)
current-user-key))
listbox-elements))))
(run users)))
((components=? argument ok-button)
(when (null? users)
(run-error-page (G_ "Please create at least one user.")
(G_ "No user"))
(run users))))))
(lambda ()
(destroy-form-and-pop form))))))
(run '()))

43
gnu/installer/newt/utils.scm Normal file
View File

@ -0,0 +1,43 @@
;;; 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 utils)
#:use-module (ice-9 receive)
#:use-module (newt)
#:export (screen-columns
screen-rows
destroy-form-and-pop
set-screen-size!))
;; Number of columns and rows of the terminal.
(define screen-columns (make-parameter 0))
(define screen-rows (make-parameter 0))
(define (destroy-form-and-pop form)
"Destory the given FORM and pop the current window."
(destroy-form form)
(pop-window))
(define (set-screen-size!)
"Set the parameters 'screen-columns' and 'screen-rows' to the number of
columns and rows respectively of the current terminal."
(receive (columns rows)
(screen-size)
(screen-columns columns)
(screen-rows rows)))

122
gnu/installer/newt/welcome.scm Normal file
View File

@ -0,0 +1,122 @@
;;; 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
;;;
;;; 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 welcome)
#:use-module (gnu installer utils)
#:use-module (gnu installer newt utils)
#:use-module (guix build syscalls)
#:use-module (guix i18n)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (newt)
#:export (run-welcome-page))
;; Margin between screen border and newt root window.
(define margin-left (make-parameter 3))
(define margin-top (make-parameter 3))
;; Expected width and height for the logo.
(define logo-width (make-parameter 50))
(define logo-height (make-parameter 23))
(define (nearest-exact-integer x)
"Given a real number X, return the nearest exact integer, with ties going to
the nearest exact even integer."
(inexact->exact (round x)))
(define* (run-menu-page title logo
#:key
listbox-items
listbox-item->text)
"Run a page with the given TITLE, to ask the user to choose between
LISTBOX-ITEMS displayed in a listbox. The listbox items are converted to text
using LISTBOX-ITEM->TEXT procedure. Display the textual LOGO in the center of
the page. Contrary to other pages, we cannot resort to grid layouts, because
we want this page to occupy all the screen space available."
(define (fill-listbox listbox items)
(map (lambda (item)
(let* ((text (listbox-item->text item))
(key (append-entry-to-listbox listbox text)))
(cons key item)))
items))
(let* ((windows
(make-window (margin-left)
(margin-top)
(- (screen-columns) (* 2 (margin-left)))
(- (screen-rows) (* 2 (margin-top)))
title))
(logo-textbox
(make-textbox (nearest-exact-integer
(- (/ (screen-columns) 2)
(+ (/ (logo-width) 2) (margin-left))))
(margin-top) (logo-width) (logo-height) 0))
(text (set-textbox-text logo-textbox
(read-all logo)))
(options-listbox
(make-listbox (margin-left)
(+ (logo-height) (margin-top))
(- (screen-rows) (+ (logo-height)
(* (margin-top) 4)))
(logior FLAG-BORDER FLAG-RETURNEXIT)))
(keys (fill-listbox options-listbox listbox-items))
(form (make-form)))
(set-listbox-width options-listbox (- (screen-columns)
(* (margin-left) 4)))
(add-components-to-form form logo-textbox options-listbox)
(receive (exit-reason argument)
(run-form form)
(dynamic-wind
(const #t)
(lambda ()
(when (eq? exit-reason 'exit-component)
(cond
((components=? argument options-listbox)
(let* ((entry (current-listbox-entry options-listbox))
(item (assoc-ref keys entry)))
(match item
((text . proc)
(proc))))))))
(lambda ()
(destroy-form-and-pop form))))))
(define (run-welcome-page logo)
"Run a welcome page with the given textual LOGO displayed at the center of
the page. Ask the user to choose between manual installation, graphical
installation and reboot."
(run-menu-page
(G_ "GNU GuixSD install")
logo
#:listbox-items
`((,(G_ "Install using the unguided shell based process")
.
,(lambda ()
(clear-screen)
(newt-suspend)
(system* "bash" "-l")
(newt-resume)))
(,(G_ "Graphical install using a guided terminal based interface")
.
,(const #t))
(,(G_ "Reboot")
.
,(lambda ()
(newt-finish)
(reboot))))
#:listbox-item->text car))

243
gnu/installer/newt/wifi.scm Normal file
View File

@ -0,0 +1,243 @@
;;; 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 wifi)
#:use-module (gnu installer connman)
#:use-module (gnu installer steps)
#:use-module (gnu installer newt utils)
#:use-module (gnu installer newt page)
#:use-module (guix i18n)
#:use-module (guix records)
#:use-module (ice-9 format)
#:use-module (ice-9 popen)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (newt)
#:export (run-wifi-page))
;; This record associates a connman service to its key the listbox.
(define-record-type* <service-item>
service-item make-service-item
service-item?
(service service-item-service) ; connman <service>
(key service-item-key)) ; newt listbox-key
(define (strength->string strength)
"Convert STRENGTH as an integer percentage into a text printable strength
bar using unicode characters. Taken from NetworkManager's
nmc_wifi_strength_bars."
(let ((quarter #\x2582)
(half #\x2584)
(three-quarter #\x2586)
(full #\x2588))
(cond
((> strength 80)
;; ▂▄▆█
(string quarter half three-quarter full))
((> strength 55)
;; ▂▄▆_
(string quarter half three-quarter #\_))
((> strength 30)
;; ▂▄__
(string quarter half #\_ #\_))
((> strength 5)
;; ▂___
(string quarter #\_ #\_ #\_))
(else
;; ____
(string quarter #\_ #\_ #\_ #\_)))))
(define (force-wifi-scan)
"Force a wifi scan. Raise a condition if no wifi technology is available."
(let* ((technologies (connman-technologies))
(wifi-technology
(find (lambda (technology)
(string=? (technology-type technology) "wifi"))
technologies)))
(if wifi-technology
(connman-scan-technology wifi-technology)
(raise (condition
(&message
(message (G_ "Unable to find a wifi technology"))))))))
(define (draw-scanning-page)
"Draw a page to indicate a wifi scan in in progress."
(draw-info-page (G_ "Scanning wifi for available networks, please wait.")
(G_ "Scan in progress")))
(define (run-wifi-password-page)
"Run a page prompting user for a password and return it."
(run-input-page (G_ "Please enter the wifi password")
(G_ "Password required")))
(define (run-wrong-password-page service-name)
"Run a page to inform user of a wrong password input."
(run-error-page
(format #f (G_ "The password you entered for ~a is incorrect.")
service-name)
(G_ "Wrong password")))
(define (run-unknown-error-page service-name)
"Run a page to inform user that a connection error happened."
(run-error-page
(format #f
(G_ "An error occured while trying to connect to ~a, please retry.")
service-name)
(G_ "Connection error")))
(define (password-callback)
(run-wifi-password-page))
(define (connect-wifi-service listbox service-items)
"Connect to the wifi service selected in LISTBOX. SERVICE-ITEMS is the list
of <service-item> records present in LISTBOX."
(let* ((listbox-key (current-listbox-entry listbox))
(item (find (lambda (item)
(eq? (service-item-key item) listbox-key))
service-items))
(service (service-item-service item))
(service-name (service-name service))
(form (draw-connecting-page service-name)))
(dynamic-wind
(const #t)
(lambda ()
(guard (c ((connman-password-error? c)
(run-wrong-password-page service-name)
#f)
((connman-already-connected-error? c)
#t)
((connman-connection-error? c)
(run-unknown-error-page service-name)
#f))
(connman-connect-with-auth service password-callback)))
(lambda ()
(destroy-form-and-pop form)))))
(define (run-wifi-scan-page)
"Force a wifi scan and draw a page during the operation."
(let ((form (draw-scanning-page)))
(force-wifi-scan)
(destroy-form-and-pop form)))
(define (wifi-services)
"Return all the connman services of wifi type."
(let ((services (connman-services)))
(filter (lambda (service)
(and (string=? (service-type service) "wifi")
(not (string-null? (service-name service)))))
services)))
(define* (fill-wifi-services listbox wifi-services)
"Append all the services in WIFI-SERVICES to the given LISTBOX."
(clear-listbox listbox)
(map (lambda (service)
(let* ((text (service->text service))
(key (append-entry-to-listbox listbox text)))
(service-item
(service service)
(key key))))
wifi-services))
;; Maximum length of a wifi service name.
(define service-name-max-length (make-parameter 20))
;; Heigth of the listbox displaying wifi services.
(define wifi-listbox-heigth (make-parameter 20))
;; Information textbox width.
(define info-textbox-width (make-parameter 40))
(define (service->text service)
"Return a string composed of the name and the strength of the given
SERVICE. A '*' preceding the service name indicates that it is connected."
(let* ((name (service-name service))
(padded-name (string-pad-right name
(service-name-max-length)))
(strength (service-strength service))
(strength-string (strength->string strength))
(state (service-state service))
(connected? (or (string=? state "online")
(string=? state "ready"))))
(format #f "~c ~a ~a~%"
(if connected? #\* #\ )
padded-name
strength-string)))
(define (run-wifi-page)
"Run a page displaying available wifi networks in a listbox. Connect to the
network when the corresponding listbox entry is selected. A button allow to
force a wifi scan."
(let* ((listbox (make-listbox
-1 -1
(wifi-listbox-heigth)
(logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT)))
(form (make-form))
(buttons-grid (make-grid 1 1))
(middle-grid (make-grid 2 1))
(info-text (G_ "Please select a wifi network."))
(info-textbox
(make-reflowed-textbox -1 -1 info-text
(info-textbox-width)
#:flags FLAG-BORDER))
(cancel-button (make-button -1 -1 (G_ "Cancel")))
(scan-button (make-button -1 -1 (G_ "Scan")))
(services (wifi-services))
(service-items '()))
(if (null? services)
(append-entry-to-listbox listbox (G_ "No wifi detected"))
(set! service-items (fill-wifi-services listbox services)))
(set-grid-field middle-grid 0 0 GRID-ELEMENT-COMPONENT listbox)
(set-grid-field middle-grid 1 0 GRID-ELEMENT-COMPONENT scan-button
#:anchor ANCHOR-TOP
#:pad-left 2)
(set-grid-field buttons-grid 0 0 GRID-ELEMENT-COMPONENT cancel-button)
(add-components-to-form form
info-textbox
listbox scan-button
cancel-button)
(make-wrapped-grid-window
(basic-window-grid info-textbox middle-grid buttons-grid)
(G_ "Wifi selection"))
(receive (exit-reason argument)
(run-form form)
(dynamic-wind
(const #t)
(lambda ()
(when (eq? exit-reason 'exit-component)
(cond
((components=? argument scan-button)
(run-wifi-scan-page)
(run-wifi-page))
((components=? argument cancel-button)
(raise
(condition
(&installer-step-abort))))
((components=? argument listbox)
(let ((result (connect-wifi-service listbox service-items)))
(unless result
(run-wifi-page)))))))
(lambda ()
(destroy-form-and-pop form))))))

187
gnu/installer/steps.scm Normal file
View File

@ -0,0 +1,187 @@
;;; 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 steps)
#:use-module (guix records)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (&installer-step-abort
installer-step-abort?
&installer-step-break
installer-step-break?
<installer-step>
installer-step
make-installer-step
installer-step?
installer-step-id
installer-step-description
installer-step-compute
installer-step-configuration-proc
run-installer-steps
find-step-by-id
result->step-ids
result-step
result-step-done?))
;; This condition may be raised to abort the current step.
(define-condition-type &installer-step-abort &condition
installer-step-abort?)
;; This condition may be raised to break out from the steps execution.
(define-condition-type &installer-step-break &condition
installer-step-break?)
;; An installer-step record is basically an id associated to a compute
;; procedure. The COMPUTE procedure takes exactly one argument, an association
;; list containing the results of previously executed installer-steps (see
;; RUN-INSTALLER-STEPS description). The value returned by the COMPUTE
;; procedure will be stored in the results list passed to the next
;; installer-step and so on.
(define-record-type* <installer-step>
installer-step make-installer-step
installer-step?
(id installer-step-id) ;symbol
(description installer-step-description ;string
(default #f))
(compute installer-step-compute) ;procedure
(configuration-format-proc installer-step-configuration-proc ;procedure
(default #f)))
(define* (run-installer-steps #:key
steps
(rewind-strategy 'previous)
(menu-proc (const #f)))
"Run the COMPUTE procedure of all <installer-step> records in STEPS
sequencially. If the &installer-step-abort condition is raised, fallback to a
previous install-step, accordingly to the specified REWIND-STRATEGY.
REWIND-STRATEGY possible values are 'previous, 'menu and 'start. If 'previous
is selected, the execution will resume at the previous installer-step. If
'menu is selected, the MENU-PROC procedure will be called. Its return value
has to be an installer-step ID to jump to. The ID has to be the one of a
previously executed step. It is impossible to jump forward. Finally if 'start
is selected, the execution will resume at the first installer-step.
The result of every COMPUTE procedures is stored in an association list, under
the form:
'((STEP-ID . COMPUTE-RESULT) ...)
where STEP-ID is the ID field of the installer-step and COMPUTE-RESULT the
result of the associated COMPUTE procedure. This result association list is
passed as argument of every COMPUTE procedure. It is finally returned when the
computation is over.
If the &installer-step-break condition is raised, stop the computation and
return the accumalated result so far."
(define (pop-result list)
(cdr list))
(define (first-step? steps step)
(match steps
((first-step . rest-steps)
(equal? first-step step))))
(define* (skip-to-step step result
#:key todo-steps done-steps)
(match (list todo-steps done-steps)
(((todo . rest-todo) (prev-done ... last-done))
(if (eq? (installer-step-id todo)
(installer-step-id step))
(run result
#:todo-steps todo-steps
#:done-steps done-steps)
(skip-to-step step (pop-result result)
#:todo-steps (cons last-done todo-steps)
#:done-steps prev-done)))))
(define* (run result #:key todo-steps done-steps)
(match todo-steps
(() (reverse result))
((step . rest-steps)
(guard (c ((installer-step-abort? c)
(case rewind-strategy
((previous)
(match done-steps
(()
;; We cannot go previous the first step. So re-raise
;; the exception. It might be useful in the case of
;; nested run-installer-steps. Abort to 'raise-above
;; prompt to prevent the condition from being catched
;; by one of the previously installed guard.
(abort-to-prompt 'raise-above c))
((prev-done ... last-done)
(run (pop-result result)
#:todo-steps (cons last-done todo-steps)
#:done-steps prev-done))))
((menu)
(let ((goto-step (menu-proc
(append done-steps (list step)))))
(if (eq? goto-step step)
(run result
#:todo-steps todo-steps
#:done-steps done-steps)
(skip-to-step goto-step result
#:todo-steps todo-steps
#:done-steps done-steps))))
((start)
(if (null? done-steps)
;; Same as above, it makes no sense to jump to start
;; when we are at the first installer-step. Abort to
;; 'raise-above prompt to re-raise the condition.
(abort-to-prompt 'raise-above c)
(run '()
#:todo-steps steps
#:done-steps '())))))
((installer-step-break? c)
(reverse result)))
(let* ((id (installer-step-id step))
(compute (installer-step-compute step))
(res (compute result)))
(run (alist-cons id res result)
#:todo-steps rest-steps
#:done-steps (append done-steps (list step))))))))
(call-with-prompt 'raise-above
(lambda ()
(run '()
#:todo-steps steps
#:done-steps '()))
(lambda (k condition)
(raise condition))))
(define (find-step-by-id steps id)
"Find and return the step in STEPS whose id is equal to ID."
(find (lambda (step)
(eq? (installer-step-id step) id))
steps))
(define (result-step results step-id)
"Return the result of the installer-step specified by STEP-ID in
RESULTS."
(assoc-ref results step-id))
(define (result-step-done? results step-id)
"Return #t if the installer-step specified by STEP-ID has a COMPUTE value
stored in RESULTS. Return #f otherwise."
(and (assoc step-id results) #t))

117
gnu/installer/timezone.scm Normal file
View File

@ -0,0 +1,117 @@
;;; 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 timezone)
#:use-module (gnu installer utils)
#:use-module (guix i18n)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:export (locate-childrens
timezone->posix-tz
timezone-has-child?
zonetab->timezone-tree))
(define %not-blank
(char-set-complement char-set:blank))
(define (posix-tz->timezone tz)
"Convert given TZ in Posix format like \"Europe/Paris\" into a list like
(\"Europe\" \"Paris\")."
(string-split tz #\/))
(define (timezone->posix-tz timezone)
"Convert given TIMEZONE like (\"Europe\" \"Paris\") into a Posix timezone
like \"Europe/Paris\"."
(string-join timezone "/"))
(define (zonetab->timezones zonetab)
"Parse ZONETAB file and return the corresponding list of timezones."
(define (zonetab-line->posix-tz line)
(let ((tokens (string-tokenize line %not-blank)))
(match tokens
((code coordinates tz _ ...)
tz))))
(call-with-input-file zonetab
(lambda (port)
(let* ((lines (read-lines port))
;; Filter comment lines starting with '#' character.
(tz-lines (filter (lambda (line)
(not (eq? (string-ref line 0)
#\#)))
lines)))
(map (lambda (line)
(posix-tz->timezone
(zonetab-line->posix-tz line)))
tz-lines)))))
(define (timezones->timezone-tree timezones)
"Convert the list of timezones, TIMEZONES into a tree under the form:
(\"America\" (\"North_Dakota\" \"New_Salem\" \"Center\"))
representing America/North_Dakota/New_Salem and America/North_Dakota/Center
timezones."
(define (remove-first lists)
"Remove the first element of every sublists in the argument LISTS."
(map (lambda (list)
(if (null? list) list (cdr list)))
lists))
(let loop ((cur-timezones timezones))
(match cur-timezones
(() '())
(((region . rest-region) . rest-timezones)
(if (null? rest-region)
(cons (list region) (loop rest-timezones))
(receive (same-region other-region)
(partition (lambda (timezone)
(string=? (car timezone) region))
cur-timezones)
(acons region
(loop (remove-first same-region))
(loop other-region))))))))
(define (locate-childrens tree path)
"Return the childrens of the timezone indicated by PATH in the given
TREE. Raise a condition if the PATH could not be found."
(let ((extract-proc (cut map car <>)))
(match path
(() (sort (extract-proc tree) string<?))
((region . rest)
(or (and=> (assoc-ref tree region)
(cut locate-childrens <> rest))
(raise
(condition
(&message
(message
(format #f (G_ "Unable to locate path: ~a.") path))))))))))
(define (timezone-has-child? tree timezone)
"Return #t if the given TIMEZONE any child in TREE and #f otherwise."
(not (null? (locate-childrens tree timezone))))
(define* (zonetab->timezone-tree zonetab)
"Return the timezone tree corresponding to the given ZONETAB file."
(timezones->timezone-tree (zonetab->timezones zonetab)))

37
gnu/installer/utils.scm Normal file
View File

@ -0,0 +1,37 @@
;;; 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 utils)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 textual-ports)
#:export (read-lines
read-all))
(define* (read-lines #:optional (port (current-input-port)))
"Read lines from PORT and return them as a list."
(let loop ((line (read-line port))
(lines '()))
(if (eof-object? line)
(reverse lines)
(loop (read-line port)
(cons line lines)))))
(define (read-all file)
"Return the content of the given FILE as a string."
(call-with-input-file file
get-string-all))

22
gnu/local.mk
View File

@ -543,6 +543,28 @@ GNU_SYSTEM_MODULES = \
%D%/build/marionette.scm \
%D%/build/vm.scm \
\
%D%/installer.scm \
%D%/installer/build-installer.scm \
%D%/installer/connman.scm \
%D%/installer/keymap.scm \
%D%/installer/locale.scm \
%D%/installer/newt.scm \
%D%/installer/steps.scm \
%D%/installer/timezone.scm \
%D%/installer/utils.scm \
\
%D%/installer/newt/ethernet.scm \
%D%/installer/newt/hostname.scm \
%D%/installer/newt/keymap.scm \
%D%/installer/newt/locale.scm \
%D%/installer/newt/menu.scm \
%D%/installer/newt/network.scm \
%D%/installer/newt/page.scm \
%D%/installer/newt/timezone.scm \
%D%/installer/newt/utils.scm \
%D%/installer/newt/welcome.scm \
%D%/installer/newt/wifi.scm \
\
%D%/tests.scm \
%D%/tests/audio.scm \
%D%/tests/base.scm \

1
gnu/system.scm
View File

@ -119,6 +119,7 @@
boot-parameters->menu-entry
local-host-aliases
%root-account
%setuid-programs
%base-packages
%base-firmware))

214
gnu/system/install.scm
View File

@ -22,16 +22,23 @@
(define-module (gnu system install)
#:use-module (gnu)
#:use-module (gnu system)
#:use-module (gnu bootloader u-boot)
#:use-module (guix gexp)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module ((guix store) #:select (%store-prefix))
#:use-module (gnu installer newt)
#:use-module (gnu installer build-installer)
#:use-module (gnu services dbus)
#:use-module (gnu services networking)
#:use-module (gnu services shepherd)
#:use-module (gnu services ssh)
#:use-module (gnu packages admin)
#:use-module (gnu packages bash)
#:use-module (gnu packages bootloaders)
#:use-module (gnu packages fonts)
#:use-module (gnu packages fontutils)
#:use-module (gnu packages guile)
#:use-module (gnu packages linux)
#:use-module (gnu packages ssh)
@ -202,120 +209,114 @@ the user's target storage device rather than on the RAM disk."
(persistent? #f)
(max-database-size (* 5 (expt 2 20)))))) ;5 MiB
(define (normal-tty tty)
(service kmscon-service-type
(kmscon-configuration
(virtual-terminal tty)
(auto-login "root"))))
(define bare-bones-os
(load "examples/bare-bones.tmpl"))
(define %installation-services
;; List of services of the installation system.
(let ((motd (plain-file "motd" "
\x1b[1;37mWelcome to the installation of the Guix System Distribution!\x1b[0m
(list (login-service (login-configuration
;; The motd is overlapped by the graphical installer,
;; so make sure it is not printed.
(motd #f)))
\x1b[2mThere is NO WARRANTY, to the extent permitted by law. In particular, you may
LOSE ALL YOUR DATA as a side effect of the installation process. Furthermore,
it is 'beta' software, so it may contain bugs.
;; This will be the active virtual terminal at boot. The graphical
;; installer is launched as the 'shell' program of the root
;; user-account. Thanks to auto-login, it will be started
;; automatically. Another option would have been to set the graphical
;; installer as a login program. However, it is preferable to wait
;; for the login phase to be over, so that the environnment variables
;; of /etc/environment like LANG are loaded by PAM.
(normal-tty "tty1")
You have been warned. Thanks for being so brave.\x1b[0m
")))
(define (normal-tty tty)
(mingetty-service (mingetty-configuration (tty tty)
(auto-login "root")
(login-pause? #t))))
;; Documentation.
(service kmscon-service-type
(kmscon-configuration
(virtual-terminal "tty2")
(login-program (log-to-info))
(auto-login "guest")))
(define bare-bones-os
(load "examples/bare-bones.tmpl"))
;; Documentation add-on.
%configuration-template-service
(list (service virtual-terminal-service-type)
;; A bunch of 'root' ttys.
(normal-tty "tty3")
(normal-tty "tty4")
(normal-tty "tty5")
(normal-tty "tty6")
(mingetty-service (mingetty-configuration
(tty "tty1")
(auto-login "root")))
;; The usual services.
(syslog-service)
(login-service (login-configuration
(motd motd)))
;; The build daemon. Register the hydra.gnu.org key as trusted.
;; This allows the installation process to use substitutes by
;; default.
(service guix-service-type
(guix-configuration (authorize-key? #t)))
;; Documentation. The manual is in UTF-8, but
;; 'console-font-service' sets up Unicode support and loads a font
;; with all the useful glyphs like em dash and quotation marks.
(mingetty-service (mingetty-configuration
(tty "tty2")
(auto-login "guest")
(login-program (log-to-info))))
;; Start udev so that useful device nodes are available.
;; Use device-mapper rules for cryptsetup & co; enable the CRDA for
;; regulations-compliant WiFi access.
(udev-service #:rules (list lvm2 crda))
;; Documentation add-on.
%configuration-template-service
;; Add the 'cow-store' service, which users have to start manually
;; since it takes the installation directory as an argument.
(cow-store-service)
;; A bunch of 'root' ttys.
(normal-tty "tty3")
(normal-tty "tty4")
(normal-tty "tty5")
(normal-tty "tty6")
;; To facilitate copy/paste.
(service gpm-service-type)
;; The usual services.
(syslog-service)
;; Add an SSH server to facilitate remote installs.
(service openssh-service-type
(openssh-configuration
(port-number 22)
(permit-root-login #t)
;; The root account is passwordless, so make sure
;; a password is set before allowing logins.
(allow-empty-passwords? #f)
(password-authentication? #t)
;; The build daemon. Register the official server keys as trusted.
;; This allows the installation process to use substitutes by
;; default.
(service guix-service-type
(guix-configuration (authorize-key? #t)))
;; Don't start it upfront.
(%auto-start? #f)))
;; Start udev so that useful device nodes are available.
;; Use device-mapper rules for cryptsetup & co; enable the CRDA for
;; regulations-compliant WiFi access.
(udev-service #:rules (list lvm2 crda))
;; Since this is running on a USB stick with a overlayfs as the root
;; file system, use an appropriate cache configuration.
(nscd-service (nscd-configuration
(caches %nscd-minimal-caches)))
;; Add the 'cow-store' service, which users have to start manually
;; since it takes the installation directory as an argument.
(cow-store-service)
;; Having /bin/sh is a good idea. In particular it allows Tramp
;; connections to this system to work.
(service special-files-service-type
`(("/bin/sh" ,(file-append (canonical-package bash)
"/bin/sh"))))
;; Install Unicode support and a suitable font. Use a font that
;; doesn't have more than 256 glyphs so that we can use colors with
;; varying brightness levels (see note in setfont(8)).
(service console-font-service-type
(map (lambda (tty)
(cons tty "lat9u-16"))
'("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))
;; Loopback device, needed by OpenSSH notably.
(service static-networking-service-type
(list (static-networking (interface "lo")
(ip "127.0.0.1")
(requirement '())
(provision '(loopback)))))
;; To facilitate copy/paste.
(service gpm-service-type)
(service wpa-supplicant-service-type)
(dbus-service)
(service connman-service-type
(connman-configuration
(disable-vpn? #t)))
;; Add an SSH server to facilitate remote installs.
(service openssh-service-type
(openssh-configuration
(port-number 22)
(permit-root-login #t)
;; The root account is passwordless, so make sure
;; a password is set before allowing logins.
(allow-empty-passwords? #f)
(password-authentication? #t)
;; Don't start it upfront.
(%auto-start? #f)))
;; Since this is running on a USB stick with a overlayfs as the root
;; file system, use an appropriate cache configuration.
(nscd-service (nscd-configuration
(caches %nscd-minimal-caches)))
;; Having /bin/sh is a good idea. In particular it allows Tramp
;; connections to this system to work.
(service special-files-service-type
`(("/bin/sh" ,(file-append (canonical-package bash)
"/bin/sh"))))
;; Loopback device, needed by OpenSSH notably.
(service static-networking-service-type
(list (static-networking (interface "lo")
(ip "127.0.0.1")
(requirement '())
(provision '(loopback)))))
;; Keep a reference to BARE-BONES-OS to make sure it can be
;; installed without downloading/building anything. Also keep the
;; things needed by 'profile-derivation' to minimize the amount of
;; download.
(service gc-root-service-type
(list bare-bones-os
glibc-utf8-locales
texinfo
(canonical-package guile-2.2))))))
;; Keep a reference to BARE-BONES-OS to make sure it can be
;; installed without downloading/building anything. Also keep the
;; things needed by 'profile-derivation' to minimize the amount of
;; download.
(service gc-root-service-type
(list bare-bones-os
glibc-utf8-locales
texinfo
(canonical-package guile-2.2)))))
(define %issue
;; Greeting.
@ -360,13 +361,18 @@ You have been warned. Thanks for being so brave.\x1b[0m
%shared-memory-file-system
%immutable-store)))
(users (list (user-account
(name "guest")
(group "users")
(supplementary-groups '("wheel")) ; allow use of sudo
(password "")
(comment "Guest of GNU")
(home-directory "/home/guest"))))
(users (list
(user-account
(inherit %root-account)
;; Launch the graphical installer.
(shell (installer-program newt-installer)))
(user-account
(name "guest")
(group "users")
(supplementary-groups '("wheel")) ; allow use of sudo
(password "")
(comment "Guest of GNU")
(home-directory "/home/guest"))))
(issue %issue)
(services %installation-services)
@ -381,6 +387,8 @@ You have been warned. Thanks for being so brave.\x1b[0m
(packages (cons* (canonical-package glibc) ;for 'tzselect' & co.
parted gptfdisk ddrescue
fontconfig
font-dejavu font-gnu-unifont
grub ;mostly so xrefs to its manual work
cryptsetup
mdadm

21
po/guix/POTFILES.in
View File

@ -8,6 +8,27 @@ gnu/services/shepherd.scm
gnu/system/mapped-devices.scm
gnu/system/shadow.scm
guix/import/opam.scm
gnu/installer.scm
gnu/installer/build-installer.scm
gnu/installer/connman.scm
gnu/installer/keymap.scm
gnu/installer/locale.scm
gnu/installer/newt.scm
gnu/installer/newt/ethernet.scm
gnu/installer/newt/hostname.scm
gnu/installer/newt/keymap.scm
gnu/installer/newt/locale.scm
gnu/installer/newt/menu.scm
gnu/installer/newt/network.scm
gnu/installer/newt/page.scm
gnu/installer/newt/timezone.scm
gnu/installer/newt/user.scm
gnu/installer/newt/utils.scm
gnu/installer/newt/welcome.scm
gnu/installer/newt/wifi.scm
gnu/installer/steps.scm
gnu/installer/timezone.scm
gnu/installer/utils.scm
guix/scripts.scm
guix/scripts/build.scm
guix/discovery.scm