diff options
Diffstat (limited to 'gnu')
26 files changed, 3877 insertions, 119 deletions
diff --git a/gnu/installer.scm b/gnu/installer.scm new file mode 100644 index 0000000000..f3323ea3bc --- /dev/null +++ b/gnu/installer.scm @@ -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))) diff --git a/gnu/installer/aux-files/SUPPORTED b/gnu/installer/aux-files/SUPPORTED new file mode 100644 index 0000000000..24aae1e089 --- /dev/null +++ b/gnu/installer/aux-files/SUPPORTED @@ -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 diff --git a/gnu/installer/aux-files/logo.txt b/gnu/installer/aux-files/logo.txt new file mode 100644 index 0000000000..52418d88c1 --- /dev/null +++ b/gnu/installer/aux-files/logo.txt @@ -0,0 +1,19 @@ + ░░░ ░░░ + ░░▒▒░░░░░░░░░ ░░░░░░░░░▒▒░░ + ░░▒▒▒▒▒░░░░░░░ ░░░░░░░▒▒▒▒▒░ + ░▒▒▒░░▒▒▒▒▒ ░░░░░░░▒▒░ + ░▒▒▒▒░ ░░░░░░ + ▒▒▒▒▒ ░░░░░░ + ▒▒▒▒▒ ░░░░░ + ░▒▒▒▒▒ ░░░░░ + ▒▒▒▒▒ ░░░░░ + ▒▒▒▒▒ ░░░░░ + ░▒▒▒▒▒░░░░░ + ▒▒▒▒▒▒░░░ + ▒▒▒▒▒▒░ + _____ _ _ _ _ _____ _ + / ____| \ | | | | | / ____| (_) +| | __| \| | | | | | | __ _ _ ___ __ +| | |_ | . ' | | | | | | |_ | | | | \ \/ / +| |__| | |\ | |__| | | |__| | |_| | |> < + \_____|_| \_|\____/ \_____|\__,_|_/_/\_\ diff --git a/gnu/installer/build-installer.scm b/gnu/installer/build-installer.scm new file mode 100644 index 0000000000..1a084bc3dc --- /dev/null +++ b/gnu/installer/build-installer.scm @@ -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)) diff --git a/gnu/installer/connman.scm b/gnu/installer/connman.scm new file mode 100644 index 0000000000..740df7424a --- /dev/null +++ b/gnu/installer/connman.scm @@ -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))))) diff --git a/gnu/installer/keymap.scm b/gnu/installer/keymap.scm new file mode 100644 index 0000000000..78065aa6c6 --- /dev/null +++ b/gnu/installer/keymap.scm @@ -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))))) diff --git a/gnu/installer/locale.scm b/gnu/installer/locale.scm new file mode 100644 index 0000000000..504070d41d --- /dev/null +++ b/gnu/installer/locale.scm @@ -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))) diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm new file mode 100644 index 0000000000..abf752959b --- /dev/null +++ b/gnu/installer/newt.scm @@ -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))) diff --git a/gnu/installer/newt/ethernet.scm b/gnu/installer/newt/ethernet.scm new file mode 100644 index 0000000000..2cbbfddacd --- /dev/null +++ b/gnu/installer/newt/ethernet.scm @@ -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)))) diff --git a/gnu/installer/newt/hostname.scm b/gnu/installer/newt/hostname.scm new file mode 100644 index 0000000000..acbee64a6a --- /dev/null +++ b/gnu/installer/newt/hostname.scm @@ -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"))) diff --git a/gnu/installer/newt/keymap.scm b/gnu/installer/newt/keymap.scm new file mode 100644 index 0000000000..219ac3f8e2 --- /dev/null +++ b/gnu/installer/newt/keymap.scm @@ -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))) diff --git a/gnu/installer/newt/locale.scm b/gnu/installer/newt/locale.scm new file mode 100644 index 0000000000..5444a07598 --- /dev/null +++ b/gnu/installer/newt/locale.scm @@ -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))) diff --git a/gnu/installer/newt/menu.scm b/gnu/installer/newt/menu.scm new file mode 100644 index 0000000000..756b582a50 --- /dev/null +++ b/gnu/installer/newt/menu.scm @@ -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)))) diff --git a/gnu/installer/newt/network.scm b/gnu/installer/newt/network.scm new file mode 100644 index 0000000000..c6ba69d4e8 --- /dev/null +++ b/gnu/installer/newt/network.scm @@ -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)) diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm new file mode 100644 index 0000000000..bcede3e333 --- /dev/null +++ b/gnu/installer/newt/page.scm @@ -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))))) diff --git a/gnu/installer/newt/timezone.scm b/gnu/installer/newt/timezone.scm new file mode 100644 index 0000000000..a2c9b458f5 --- /dev/null +++ b/gnu/installer/newt/timezone.scm @@ -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))) diff --git a/gnu/installer/newt/user.scm b/gnu/installer/newt/user.scm new file mode 100644 index 0000000000..f342caae04 --- /dev/null +++ b/gnu/installer/newt/user.scm @@ -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 '())) diff --git a/gnu/installer/newt/utils.scm b/gnu/installer/newt/utils.scm new file mode 100644 index 0000000000..1c2ce4e628 --- /dev/null +++ b/gnu/installer/newt/utils.scm @@ -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))) diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm new file mode 100644 index 0000000000..8ed9f68918 --- /dev/null +++ b/gnu/installer/newt/welcome.scm @@ -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)) diff --git a/gnu/installer/newt/wifi.scm b/gnu/installer/newt/wifi.scm new file mode 100644 index 0000000000..6cac54399a --- /dev/null +++ b/gnu/installer/newt/wifi.scm @@ -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)))))) diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm new file mode 100644 index 0000000000..5fd54356dd --- /dev/null +++ b/gnu/installer/steps.scm @@ -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)) diff --git a/gnu/installer/timezone.scm b/gnu/installer/timezone.scm new file mode 100644 index 0000000000..061e8c2e48 --- /dev/null +++ b/gnu/installer/timezone.scm @@ -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))) diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm new file mode 100644 index 0000000000..5087683715 --- /dev/null +++ b/gnu/installer/utils.scm @@ -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)) diff --git a/gnu/local.mk b/gnu/local.mk index 1268e0c600..3e6d30d8e9 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -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 \ diff --git a/gnu/system.scm b/gnu/system.scm index 09ee88d433..e6c86cb9ba 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -119,6 +119,7 @@ boot-parameters->menu-entry local-host-aliases + %root-account %setuid-programs %base-packages %base-firmware)) diff --git a/gnu/system/install.scm b/gnu/system/install.scm index 3aded93f38..05f3795b81 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -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 - -\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. - -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)))) - - (define bare-bones-os - (load "examples/bare-bones.tmpl")) - - (list (service virtual-terminal-service-type) - - (mingetty-service (mingetty-configuration - (tty "tty1") - (auto-login "root"))) - - (login-service (login-configuration - (motd motd))) - - ;; 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)))) - - ;; Documentation add-on. - %configuration-template-service - - ;; A bunch of 'root' ttys. - (normal-tty "tty3") - (normal-tty "tty4") - (normal-tty "tty5") - (normal-tty "tty6") - - ;; The usual services. - (syslog-service) - - ;; 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))) - - ;; 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)) - - ;; Add the 'cow-store' service, which users have to start manually - ;; since it takes the installation directory as an argument. - (cow-store-service) - - ;; 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"))) - - ;; To facilitate copy/paste. - (service gpm-service-type) - - ;; 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)))))) + (list (login-service (login-configuration + ;; The motd is overlapped by the graphical installer, + ;; so make sure it is not printed. + (motd #f))) + + ;; 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") + + ;; Documentation. + (service kmscon-service-type + (kmscon-configuration + (virtual-terminal "tty2") + (login-program (log-to-info)) + (auto-login "guest"))) + + ;; Documentation add-on. + %configuration-template-service + + ;; A bunch of 'root' ttys. + (normal-tty "tty3") + (normal-tty "tty4") + (normal-tty "tty5") + (normal-tty "tty6") + + ;; The usual services. + (syslog-service) + + ;; 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))) + + ;; 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)) + + ;; Add the 'cow-store' service, which users have to start manually + ;; since it takes the installation directory as an argument. + (cow-store-service) + + ;; To facilitate copy/paste. + (service gpm-service-type) + + ;; 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))))) + + (service wpa-supplicant-service-type) + (dbus-service) + (service connman-service-type + (connman-configuration + (disable-vpn? #t))) + + ;; 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 |