From d0f3a672dcbdfefd3556b6a21985ff0e35eed3be Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 16 Nov 2018 20:43:55 +0900 Subject: gnu: Add graphical installer support. * configure.ac: Require that guile-newt is available. * gnu/installer.scm: New file. * gnu/installer/aux-files/logo.txt: New file. * gnu/installer/build-installer.scm: New file. * gnu/installer/connman.scm: New file. * gnu/installer/keymap.scm: New file. * gnu/installer/locale.scm: New file. * gnu/installer/newt.scm: New file. * gnu/installer/newt/ethernet.scm: New file. * gnu/installer/newt/hostname.scm: New file. * gnu/installer/newt/keymap.scm: New file. * gnu/installer/newt/locale.scm: New file. * gnu/installer/newt/menu.scm: New file. * gnu/installer/newt/network.scm: New file. * gnu/installer/newt/page.scm: New file. * gnu/installer/newt/timezone.scm: New file. * gnu/installer/newt/user.scm: New file. * gnu/installer/newt/utils.scm: New file. * gnu/installer/newt/welcome.scm: New file. * gnu/installer/newt/wifi.scm: New file. * gnu/installer/steps.scm: New file. * gnu/installer/timezone.scm: New file. * gnu/installer/utils.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add previous files. * gnu/system.scm: Export %root-account. * gnu/system/install.scm (%installation-services): Use kmscon instead of linux VT for all tty. (installation-os)[users]: Add the graphical installer as shell of the root account. [packages]: Add font related packages. * po/guix/POTFILES.in: Add installer files. --- gnu/installer/aux-files/SUPPORTED | 484 ++++++++++++++++++++++++++++++++++++++ gnu/installer/aux-files/logo.txt | 19 ++ gnu/installer/build-installer.scm | 290 +++++++++++++++++++++++ gnu/installer/connman.scm | 400 +++++++++++++++++++++++++++++++ gnu/installer/keymap.scm | 162 +++++++++++++ gnu/installer/locale.scm | 199 ++++++++++++++++ gnu/installer/newt.scm | 102 ++++++++ gnu/installer/newt/ethernet.scm | 80 +++++++ gnu/installer/newt/hostname.scm | 26 ++ gnu/installer/newt/keymap.scm | 132 +++++++++++ gnu/installer/newt/locale.scm | 193 +++++++++++++++ gnu/installer/newt/menu.scm | 44 ++++ gnu/installer/newt/network.scm | 159 +++++++++++++ gnu/installer/newt/page.scm | 313 ++++++++++++++++++++++++ gnu/installer/newt/timezone.scm | 83 +++++++ gnu/installer/newt/user.scm | 181 ++++++++++++++ gnu/installer/newt/utils.scm | 43 ++++ gnu/installer/newt/welcome.scm | 122 ++++++++++ gnu/installer/newt/wifi.scm | 243 +++++++++++++++++++ gnu/installer/steps.scm | 187 +++++++++++++++ gnu/installer/timezone.scm | 117 +++++++++ gnu/installer/utils.scm | 37 +++ 22 files changed, 3616 insertions(+) create mode 100644 gnu/installer/aux-files/SUPPORTED create mode 100644 gnu/installer/aux-files/logo.txt create mode 100644 gnu/installer/build-installer.scm create mode 100644 gnu/installer/connman.scm create mode 100644 gnu/installer/keymap.scm create mode 100644 gnu/installer/locale.scm create mode 100644 gnu/installer/newt.scm create mode 100644 gnu/installer/newt/ethernet.scm create mode 100644 gnu/installer/newt/hostname.scm create mode 100644 gnu/installer/newt/keymap.scm create mode 100644 gnu/installer/newt/locale.scm create mode 100644 gnu/installer/newt/menu.scm create mode 100644 gnu/installer/newt/network.scm create mode 100644 gnu/installer/newt/page.scm create mode 100644 gnu/installer/newt/timezone.scm create mode 100644 gnu/installer/newt/user.scm create mode 100644 gnu/installer/newt/utils.scm create mode 100644 gnu/installer/newt/welcome.scm create mode 100644 gnu/installer/newt/wifi.scm create mode 100644 gnu/installer/steps.scm create mode 100644 gnu/installer/timezone.scm create mode 100644 gnu/installer/utils.scm (limited to 'gnu/installer') 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 +;;; +;;; 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 . + +(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 +;;; +;;; 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 . + +(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-name + technology-type + technology-powered? + technology-connected? + + + 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 record encapsulates the "Technology" object of connman. +;; Technology type will be typically "ethernet", "wifi" or "bluetooth". + +(define-record-type* + technology make-technology + technology? + (name technology-name) ; string + (type technology-type) ; string + (powered? technology-powered?) ; boolean + (connected? technology-connected?)) ; boolean + + +;;; +;;; Service record. +;;; + +;; The 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 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 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 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 +;;; +;;; 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 . + +(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 + make-x11-keymap-model + x11-keymap-model? + x11-keymap-model-name + x11-keymap-model-description + + + 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 + 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 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 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 + +(define-record-type* + 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: + ;; + ;; 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 +;;; +;;; 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 . + +(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 +;;; +;;; 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 . + +(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 +;;; +;;; 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 . + +(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 +;;; +;;; 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 . + +(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 +;;; +;;; 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 . + +(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 +;;; +;;; 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 . + +(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 +;;; +;;; 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 . + +(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 +;;; +;;; 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 . + +(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 +;;; +;;; 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 . + +(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 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 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 +;;; +;;; 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 . + +(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 +;;; +;;; 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 . + +(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 +;;; +;;; 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 . + +(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 +;;; +;;; 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 . + +(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 +;;; +;;; 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 . + +(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 make-service-item + service-item? + (service service-item-service) ; connman + (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 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 +;;; +;;; 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 . + +(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 + 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 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 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 +;;; +;;; 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 . + +(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 (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 +;;; +;;; 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 . + +(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)) -- cgit v1.2.3 From ba32109a28e7c67c748838b8f5d406ccc3983e7f Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sun, 18 Nov 2018 12:14:23 +0900 Subject: installer: newt: Use scheme-modules* instead of scheme-modules. * gnu/installer/newt.scm (modules): Use scheme-modules*. --- gnu/installer/newt.scm | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index abf752959b..3d9fd69bee 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -25,11 +25,9 @@ (define (modules) (cons '(newt) - (map module-name - (scheme-modules - (dirname (search-path %load-path "guix.scm")) - "gnu/installer/newt" - #:warn warn-about-load-error)))) + (scheme-modules* + (dirname (search-path %load-path "guix.scm")) + "gnu/installer/newt"))) (define init #~(begin -- cgit v1.2.3 From 9b9a5e3283168463545588f83748bb36411e68fe Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sun, 18 Nov 2018 12:22:50 +0900 Subject: installer: newt: Locate the logo within local-file. * gnu/installer/newt.scm (logo): Remove it, (welcome-page): Use a relative path to locate the logo. --- gnu/installer/newt.scm | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index 3d9fd69bee..23b737ddf0 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -57,13 +57,8 @@ #~(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))) + #~(run-welcome-page #$(local-file "aux-files/logo.txt"))) (define menu-page #~(lambda (steps) -- cgit v1.2.3 From a79617468e98c4c30ce2c972ae198feda4760c6e Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 23 Nov 2018 23:18:59 +0900 Subject: gnu: installer: Launch the installer as kmscon login-program. Source /etc/environment just before starting the installer. The login program is supposed to load the environment variables of this file through PAM, but as we replace it by the installer, they are no longer available. This is mostly useful for the LANG environment variable. * gnu/installer/build-installer.scm (installer-program-launcher): New exported procedure. * gnu/system/install.scm (%installation-services): Restore most of the origin code. kmscon is only started on TTY1, and the graphical installer is the login-program. --- gnu/installer/build-installer.scm | 34 +++++- gnu/system/install.scm | 245 ++++++++++++++++++++------------------ 2 files changed, 160 insertions(+), 119 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/build-installer.scm b/gnu/installer/build-installer.scm index 1a084bc3dc..c7f439b35f 100644 --- a/gnu/installer/build-installer.scm +++ b/gnu/installer/build-installer.scm @@ -37,7 +37,8 @@ #:use-module (gnu packages xorg) #:use-module (ice-9 match) #:use-module (srfi srfi-1) - #:export (installer-program)) + #:export (installer-program + installer-program-launcher)) (define not-config? ;; Select (guix …) and (gnu …) modules, except (guix config). @@ -288,3 +289,34 @@ selected keymap." #$(installer-exit installer))))) (program-file "installer" installer-builder)) + +;; We want the installer to honor the LANG environment variable, so that the +;; locale is correctly installed when the installer is launched, and the +;; welcome page is possibly translated. The /etc/environment file (containing +;; LANG) is supposed to be loaded using PAM by the login program. As the +;; installer replaces the login program, read this file and set all the +;; variables it contains before starting the installer. This is a dirty hack, +;; we might want to find a better way to do it in the future. +(define (installer-program-launcher installer) + "Return a file-like object that set the variables in /etc/environment and +run the given INSTALLER." + (define load-environment + #~(call-with-input-file "/etc/environment" + (lambda (port) + (let ((lines (read-lines port))) + (map (lambda (line) + (match (string-split line #\=) + ((name value) + (setenv name value)))) + lines))))) + + (define wrapper + (with-imported-modules '((gnu installer utils)) + #~(begin + (use-modules (gnu installer utils) + (ice-9 match)) + + #$load-environment + (system #$(installer-program installer))))) + + (program-file "installer-launcher" wrapper)) diff --git a/gnu/system/install.scm b/gnu/system/install.scm index 05f3795b81..aef083506c 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -209,114 +209,128 @@ 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. - (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))))) + (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) + + (service kmscon-service-type + (kmscon-configuration + (virtual-terminal "tty1") + (login-program (installer-program-launcher + newt-installer)))) + + (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 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) + + ;; 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))))) + + (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. @@ -361,18 +375,13 @@ the user's target storage device rather than on the RAM disk." %shared-memory-file-system %immutable-store))) - (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")))) + (users (list (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) -- cgit v1.2.3 From 113bdf6ae1819022d8c0d640b78a37c7d6b52723 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 23 Nov 2018 23:23:45 +0900 Subject: installer: Rewrite welcome page. The welcome page is the only page using absolute positioning for the newt components, so that the page occupies all the screen space. This is becoming too hard to manage, so switch to grid management like elsewhere, even if the result is less appealing. Also add an info text to the page with a mention on how to switch back to the original installer. * gnu/installer/newt/welcome.scm (run-menu-page): Use a vertically stacked grid instead of hard window placement. --- gnu/installer/newt/welcome.scm | 58 ++++++++++++++++++++---------------------- 1 file changed, 27 insertions(+), 31 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm index 8ed9f68918..3a0e45e198 100644 --- a/gnu/installer/newt/welcome.scm +++ b/gnu/installer/newt/welcome.scm @@ -26,20 +26,14 @@ #: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 logo-width (make-parameter 43)) +(define logo-height (make-parameter 19)) -(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 info-textbox-width (make-parameter 70)) +(define options-listbox-height (make-parameter 5)) -(define* (run-menu-page title logo +(define* (run-menu-page title info-text logo #:key listbox-items listbox-item->text) @@ -55,30 +49,27 @@ we want this page to occupy all the screen space available." (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))) + (let* ((logo-textbox + (make-textbox -1 -1 (logo-width) (logo-height) 0)) + (info-textbox + (make-reflowed-textbox -1 -1 + info-text + (info-textbox-width))) (options-listbox - (make-listbox (margin-left) - (+ (logo-height) (margin-top)) - (- (screen-rows) (+ (logo-height) - (* (margin-top) 4))) + (make-listbox -1 -1 + (options-listbox-height) (logior FLAG-BORDER FLAG-RETURNEXIT))) (keys (fill-listbox options-listbox listbox-items)) + (grid (vertically-stacked-grid + GRID-ELEMENT-COMPONENT logo-textbox + GRID-ELEMENT-COMPONENT info-textbox + GRID-ELEMENT-COMPONENT options-listbox)) (form (make-form))) - (set-listbox-width options-listbox (- (screen-columns) - (* (margin-left) 4))) - (add-components-to-form form logo-textbox options-listbox) + + (set-textbox-text logo-textbox (read-all logo)) + + (add-form-to-grid grid form #t) + (make-wrapped-grid-window grid title) (receive (exit-reason argument) (run-form form) @@ -102,6 +93,11 @@ the page. Ask the user to choose between manual installation, graphical installation and reboot." (run-menu-page (G_ "GNU GuixSD install") + (G_ "Welcome to GNU GuixSD installer! + +Please note that the present graphical installer is still under heavy \ +development, so you might want to fallback to the classical installer by \ +pressing CTRL-ALT-F3.") logo #:listbox-items `((,(G_ "Install using the unguided shell based process") -- cgit v1.2.3 From a49d633c0c65975263270f5ac0050482ca6a5513 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sat, 24 Nov 2018 12:25:03 +0900 Subject: installer: Move everything to the build side. * gnu/installer.scm: Rename to ... * gnu/installer/record.scm: ... this. * gnu/installer/build-installer.scm: Move everything to the build side and rename to gnu/installer.scm. * gnu/installer/newt.scm: Remove all the gexps and add depencies to newt modules as this code will only be used on the build side by now. * gnu/local.mk (GNU_SYSTEM_MODULES): Adapt it, (dist_installer_DATA): New rule to install installer's aux-files. * gnu/system/install.scm (%installation-services): Use only 'installer-program' from (gnu installer). The installer is now choosen on the build side. * guix/self.scm (*system-modules*): Restore previous behaviour and add all installer files to #:extra-files field of the scheme-node. * po/guix/POTFILES.in: Adapt it. --- gnu/installer.scm | 363 +++++++++++++++++++++++++++++--------- gnu/installer/build-installer.scm | 322 --------------------------------- gnu/installer/newt.scm | 94 +++++----- gnu/installer/record.scm | 75 ++++++++ gnu/local.mk | 7 +- gnu/system/install.scm | 6 +- guix/self.scm | 10 +- po/guix/POTFILES.in | 2 +- 8 files changed, 409 insertions(+), 470 deletions(-) delete mode 100644 gnu/installer/build-installer.scm create mode 100644 gnu/installer/record.scm (limited to 'gnu/installer') diff --git a/gnu/installer.scm b/gnu/installer.scm index f3323ea3bc..9e773ee8f0 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -17,95 +17,282 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu installer) - #:use-module (guix discovery) - #:use-module (guix records) + #: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 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 - 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. -;;; + #:export (installer-program)) -;; The 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 record and install it. - -(define-record-type* - 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 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 #: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 "installer/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))) + #~(lambda (current-installer) + (let ((result + ((installer-locale-page current-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) + "Return a gexp that runs the keymap-page of INSTALLER and install the +selected keymap." + #~(lambda (current-installer) + (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 current-installer) + #:models models + #:layouts layouts))))) + (#$apply-keymap result)))) + +(define (installer-steps) + (let ((locale-step (compute-locale-step + #:locales-name "locales" + #:iso639-languages-name "iso639-languages" + #:iso3166-territories-name "iso3166-territories")) + (keymap-step (compute-keymap-step)) + (timezone-data #~(string-append #$tzdata + "/share/zoneinfo/zone.tab"))) + #~(lambda (current-installer) + (list + ;; Welcome the user and ask him to choose between manual installation + ;; and graphical install. + (installer-step + (id 'welcome) + (compute (lambda _ + ((installer-welcome-page current-installer) + #$(local-file "installer/aux-files/logo.txt"))))) + + ;; 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 current-installer)))) + + ;; Ask the user to select a timezone under glibc format. + (installer-step + (id 'timezone) + (description (G_ "Timezone selection")) + (compute (lambda _ + ((installer-timezone-page current-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 current-installer)))) + + ;; Ask the user to input a hostname for the system. + (installer-step + (id 'hostname) + (description (G_ "Hostname selection")) + (compute (lambda _ + ((installer-hostname-page current-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 current-installer))))) + + ;; Prompt for users (name, group and home directory). + (installer-step + (id 'hostname) + (description (G_ "User selection")) + (compute (lambda _ + ((installer-user-page current-installer))))))))) + +(define (installer-program) + "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 steps (installer-steps)) + + (define installer-builder + (with-extensions (list guile-gcrypt guile-newt guile-json) + (with-imported-modules `(,@(source-module-closure + '((gnu installer newt) + (guix build utils)) + #:select? not-config?) + ((guix config) => ,(make-config.scm))) + #~(begin + (use-modules (gnu installer record) + (gnu installer keymap) + (gnu installer steps) + (gnu installer locale) + (gnu installer newt) + (guix i18n) + (guix build utils) + (ice-9 match)) + + ;; Set the default locale to install unicode support. + (setlocale LC_ALL "en_US.utf8") + + ;; 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 + + (let ((current-installer newt-installer)) + ((installer-init current-installer)) + + (catch #t + (lambda () + (run-installer-steps + #:rewind-strategy 'menu + #:menu-proc (installer-menu-page current-installer) + #:steps (#$steps current-installer))) + (const #f) + (lambda (key . args) + ((installer-exit-error current-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 current-installer)))))) -(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))) + (program-file "installer" installer-builder)) diff --git a/gnu/installer/build-installer.scm b/gnu/installer/build-installer.scm deleted file mode 100644 index c7f439b35f..0000000000 --- a/gnu/installer/build-installer.scm +++ /dev/null @@ -1,322 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Mathieu Othacehe -;;; -;;; 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 . - -(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 - installer-program-launcher)) - -(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)) - -;; We want the installer to honor the LANG environment variable, so that the -;; locale is correctly installed when the installer is launched, and the -;; welcome page is possibly translated. The /etc/environment file (containing -;; LANG) is supposed to be loaded using PAM by the login program. As the -;; installer replaces the login program, read this file and set all the -;; variables it contains before starting the installer. This is a dirty hack, -;; we might want to find a better way to do it in the future. -(define (installer-program-launcher installer) - "Return a file-like object that set the variables in /etc/environment and -run the given INSTALLER." - (define load-environment - #~(call-with-input-file "/etc/environment" - (lambda (port) - (let ((lines (read-lines port))) - (map (lambda (line) - (match (string-split line #\=) - ((name value) - (setenv name value)))) - lines))))) - - (define wrapper - (with-imported-modules '((gnu installer utils)) - #~(begin - (use-modules (gnu installer utils) - (ice-9 match)) - - #$load-environment - (system #$(installer-program installer))))) - - (program-file "installer-launcher" wrapper)) diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index 23b737ddf0..db57c732d1 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -17,71 +17,69 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu installer newt) - #:use-module (gnu installer) + #:use-module (gnu installer record) + #:use-module (gnu installer newt ethernet) + #:use-module (gnu installer newt hostname) + #:use-module (gnu installer newt keymap) + #:use-module (gnu installer newt locale) + #:use-module (gnu installer newt menu) + #:use-module (gnu installer newt network) + #:use-module (gnu installer newt timezone) + #:use-module (gnu installer newt user) + #:use-module (gnu installer newt utils) + #:use-module (gnu installer newt welcome) + #:use-module (gnu installer newt wifi) #:use-module (guix discovery) - #:use-module (guix gexp) - #:use-module (guix ui) + #:use-module (guix i18n) + #:use-module (srfi srfi-26) + #:use-module (newt) #:export (newt-installer)) -(define (modules) - (cons '(newt) - (scheme-modules* - (dirname (search-path %load-path "guix.scm")) - "gnu/installer/newt"))) +(define (init) + (newt-init) + (clear-screen) + (set-screen-size!)) -(define init - #~(begin - (newt-init) - (clear-screen) - (set-screen-size!))) +(define (exit) + (newt-finish)) -(define exit - #~(begin - (newt-finish))) +(define (exit-error key . args) + (newt-finish)) -(define exit-error - #~(lambda (key args) - (newt-finish))) +(define* (locale-page #:key + supported-locales + iso639-languages + iso3166-territories) + (run-locale-page + #:supported-locales supported-locales + #:iso639-languages iso639-languages + #:iso3166-territories iso3166-territories)) -(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 zonetab) + (run-timezone-page zonetab)) -(define timezone-page - #~(lambda* (zonetab) - (run-timezone-page zonetab))) +(define (welcome-page logo) + (run-welcome-page logo)) -(define welcome-page - #~(run-welcome-page #$(local-file "aux-files/logo.txt"))) +(define (menu-page steps) + (run-menu-page steps)) -(define menu-page - #~(lambda (steps) - (run-menu-page steps))) +(define* (keymap-page #:key models layouts) + (run-keymap-page #:models models + #:layouts layouts)) -(define keymap-page - #~(lambda* (#:key models layouts) - (run-keymap-page #:models models - #:layouts layouts))) +(define (network-page) + (run-network-page)) -(define network-page - #~(run-network-page)) +(define (hostname-page) + (run-hostname-page)) -(define hostname-page - #~(run-hostname-page)) - -(define user-page - #~(run-user-page)) +(define (user-page) + (run-user-page)) (define newt-installer (installer (name 'newt) - (modules (modules)) (init init) (exit exit) (exit-error exit-error) diff --git a/gnu/installer/record.scm b/gnu/installer/record.scm new file mode 100644 index 0000000000..9c10c65758 --- /dev/null +++ b/gnu/installer/record.scm @@ -0,0 +1,75 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Mathieu Othacehe +;;; +;;; 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 . + +(define-module (gnu installer record) + #:use-module (guix records) + #:use-module (srfi srfi-1) + #:export ( + installer + make-installer + installer? + installer-name + 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)) + + +;;; +;;; Installer record. +;;; + +;; The 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 record and install it. + +(define-record-type* + installer make-installer + installer? + ;; symbol + (name installer-name) + ;; 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)) diff --git a/gnu/local.mk b/gnu/local.mk index 665721bec1..b0ec16de34 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -567,7 +567,7 @@ if ENABLE_INSTALLER GNU_SYSTEM_MODULES += \ %D%/installer.scm \ - %D%/installer/build-installer.scm \ + %D%/installer/record.scm \ %D%/installer/connman.scm \ %D%/installer/keymap.scm \ %D%/installer/locale.scm \ @@ -588,6 +588,11 @@ GNU_SYSTEM_MODULES += \ %D%/installer/newt/welcome.scm \ %D%/installer/newt/wifi.scm +installerdir = $(guilemoduledir)/%D%/installer +dist_installer_DATA = \ + %D%/installer/aux-files/logo.txt \ + %D%/installer/aux-files/SUPPORTED + endif ENABLE_INSTALLER # Modules that do not need to be compiled. diff --git a/gnu/system/install.scm b/gnu/system/install.scm index aef083506c..880a8be32d 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -28,8 +28,7 @@ #: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 installer) #:use-module (gnu services dbus) #:use-module (gnu services networking) #:use-module (gnu services shepherd) @@ -233,8 +232,7 @@ You have been warned. Thanks for being so brave.\x1b[0m (service kmscon-service-type (kmscon-configuration (virtual-terminal "tty1") - (login-program (installer-program-launcher - newt-installer)))) + (login-program (installer-program)))) (login-service (login-configuration (motd motd))) diff --git a/guix/self.scm b/guix/self.scm index 2698596387..4df4f6506e 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -604,11 +604,7 @@ Info manual." (scheme-node "guix-system" `((gnu system) (gnu services) - ,@(filter-map - (match-lambda - (('gnu 'system 'install) #f) - (name name)) - (scheme-modules* source "gnu/system")) + ,@(scheme-modules* source "gnu/system") ,@(scheme-modules* source "gnu/services")) (list *core-package-modules* *package-modules* *extra-modules* *core-modules*) @@ -616,7 +612,9 @@ Info manual." #:extra-files (append (file-imports source "gnu/system/examples" (const #t)) - + ;; All the installer code is on the build-side. + (file-imports source "gnu/installer/" + (const #t)) ;; Build-side code that we don't build. Some of ;; these depend on guile-rsvg, the Shepherd, etc. (file-imports source "gnu/build" (const #t))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 585ceeb5c2..1378b33e0e 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -9,7 +9,7 @@ gnu/system/mapped-devices.scm gnu/system/shadow.scm guix/import/opam.scm gnu/installer.scm -gnu/installer/build-installer.scm +gnu/installer/record.scm gnu/installer/connman.scm gnu/installer/keymap.scm gnu/installer/locale.scm -- cgit v1.2.3 From 5cdb6bd2db0b465fa616a9fd36760b14844d5c48 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 14:19:28 +0900 Subject: installer: Remove "selection" from all titles. * gnu/installer/newt/hostname.scm (run-hostname-page): Remove selection from page title, (run-variant-page): ditto. * gnu/installer/newt/keymap.scm (run-layout-page): Ditto. * gnu/installer/newt/locale.scm (run-layout-page): Ditto, (run-territory-page): ditto, (run-codeset-page): ditto, (run-modifier-page): ditto * gnu/installer/newt/network.scm (run-territory-page): Ditto. * gnu/installer/newt/timezone.scm (run-timezone-page): Ditto. * gnu/installer/newt/wifi.scm (run-wifi-page): Ditto. --- gnu/installer/newt/hostname.scm | 2 +- gnu/installer/newt/keymap.scm | 4 ++-- gnu/installer/newt/locale.scm | 8 ++++---- gnu/installer/newt/network.scm | 2 +- gnu/installer/newt/timezone.scm | 2 +- gnu/installer/newt/wifi.scm | 2 +- 6 files changed, 10 insertions(+), 10 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/hostname.scm b/gnu/installer/newt/hostname.scm index acbee64a6a..a8209bc2de 100644 --- a/gnu/installer/newt/hostname.scm +++ b/gnu/installer/newt/hostname.scm @@ -23,4 +23,4 @@ (define (run-hostname-page) (run-input-page (G_ "Please enter the system hostname") - (G_ "Hostname selection"))) + (G_ "Hostname"))) diff --git a/gnu/installer/newt/keymap.scm b/gnu/installer/newt/keymap.scm index 219ac3f8e2..0c9432bba2 100644 --- a/gnu/installer/newt/keymap.scm +++ b/gnu/installer/newt/keymap.scm @@ -29,7 +29,7 @@ #:export (run-keymap-page)) (define (run-layout-page layouts layout->text) - (let ((title (G_ "Layout selection"))) + (let ((title (G_ "Layout"))) (run-listbox-selection-page #:title title #:info-text (G_ "Please choose your keyboard layout.") @@ -43,7 +43,7 @@ (&installer-step-abort))))))) (define (run-variant-page variants variant->text) - (let ((title (G_ "Variant selection"))) + (let ((title (G_ "Variant"))) (run-listbox-selection-page #:title title #:info-text (G_ "Please choose a variant for your keyboard layout.") diff --git a/gnu/installer/newt/locale.scm b/gnu/installer/newt/locale.scm index 5444a07598..599a6b0ecf 100644 --- a/gnu/installer/newt/locale.scm +++ b/gnu/installer/newt/locale.scm @@ -30,7 +30,7 @@ #:export (run-locale-page)) (define (run-language-page languages language->text) - (let ((title (G_ "Language selection"))) + (let ((title (G_ "Language"))) (run-listbox-selection-page #:title title #:info-text (G_ "Choose the language to be used for the installation \ @@ -46,7 +46,7 @@ language for the installed system.") (&installer-step-abort))))))) (define (run-territory-page territories territory->text) - (let ((title (G_ "Location selection"))) + (let ((title (G_ "Location"))) (run-listbox-selection-page #:title title #:info-text (G_ "Choose your location. This is a shortlist of locations \ @@ -61,7 +61,7 @@ based on the language you selected.") (&installer-step-abort))))))) (define (run-codeset-page codesets) - (let ((title (G_ "Codeset selection"))) + (let ((title (G_ "Codeset"))) (run-listbox-selection-page #:title title #:info-text (G_ "Choose your codeset. If UTF-8 is available, it should be \ @@ -77,7 +77,7 @@ preferred.") (&installer-step-abort))))))) (define (run-modifier-page modifiers modifier->text) - (let ((title (G_ "Modifier selection"))) + (let ((title (G_ "Modifier"))) (run-listbox-selection-page #:title title #:info-text (G_ "Choose your modifier.") diff --git a/gnu/installer/newt/network.scm b/gnu/installer/newt/network.scm index c6ba69d4e8..45989ac2ac 100644 --- a/gnu/installer/newt/network.scm +++ b/gnu/installer/newt/network.scm @@ -56,7 +56,7 @@ Internet and return the selected technology. For now, only technologies with (run-listbox-selection-page #:info-text (G_ "The install process requires an internet access.\ Please select a network technology.") - #:title (G_ "Technology selection") + #:title (G_ "Internet access") #:listbox-items (technology-items) #:listbox-item->text technology->text #:button-text (G_ "Cancel") diff --git a/gnu/installer/newt/timezone.scm b/gnu/installer/newt/timezone.scm index a2c9b458f5..874f4a0734 100644 --- a/gnu/installer/newt/timezone.scm +++ b/gnu/installer/newt/timezone.scm @@ -55,7 +55,7 @@ returned." (define (loop path) (let ((timezones (locate-childrens timezone-tree path))) (run-listbox-selection-page - #:title (G_ "Timezone selection") + #:title (G_ "Timezone") #:info-text (G_ "Please select a timezone.") #:listbox-items timezones #:listbox-item->text identity diff --git a/gnu/installer/newt/wifi.scm b/gnu/installer/newt/wifi.scm index 6cac54399a..de443345f6 100644 --- a/gnu/installer/newt/wifi.scm +++ b/gnu/installer/newt/wifi.scm @@ -219,7 +219,7 @@ force a wifi scan." cancel-button) (make-wrapped-grid-window (basic-window-grid info-textbox middle-grid buttons-grid) - (G_ "Wifi selection")) + (G_ "Wifi")) (receive (exit-reason argument) (run-form form) -- cgit v1.2.3 From 3ad8f7757c840de290a6035747578a18ff7279da Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 14:24:04 +0900 Subject: installer: Add new utils. * gnu/installer/utils.scm (nearest-exact-integer): New exported procedure, (read-percentage): ditto, (run-shell-command): ditto. --- gnu/installer/utils.scm | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) (limited to 'gnu/installer') diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm index 5087683715..e91f90a84d 100644 --- a/gnu/installer/utils.scm +++ b/gnu/installer/utils.scm @@ -17,10 +17,16 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu installer utils) + #:use-module (guix utils) + #:use-module (guix build utils) #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) #:use-module (ice-9 textual-ports) #:export (read-lines - read-all)) + read-all + nearest-exact-integer + read-percentage + run-shell-command)) (define* (read-lines #:optional (port (current-input-port))) "Read lines from PORT and return them as a list." @@ -35,3 +41,23 @@ "Return the content of the given FILE as a string." (call-with-input-file file get-string-all)) + +(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 (read-percentage percentage) + "Read PERCENTAGE string and return the corresponding percentage as a +number. If no percentage is found, return #f" + (let ((result (string-match "^([0-9]+)%$" percentage))) + (and result + (string->number (match:substring result 1))))) + +(define (run-shell-command command) + (call-with-temporary-output-file + (lambda (file port) + (format port "~a~%" command) + ;; (format port "exit~%") + (close port) + (invoke "bash" "--init-file" file)))) -- cgit v1.2.3 From dc5f3275ecbddc804875899e9e457299a835d7ab Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 14:30:16 +0900 Subject: installer: Add configuration formatter. * gnu/installer.scm (installer-steps): Add configuration-formatter procedures. * gnu/installer/final.scm: New file. * gnu/installer/locale.scm (locale->configuration): New exported procedure. * gnu/installer/newt.scm (newt-installer): Add final page. * gnu/installer/newt/final.scm: New file. * gnu/installer/record.scm (installer): Add final-page field. * gnu/installer/timezone.scm (posix-tz->configuration): New exported procedure. * gnu/installer/steps.scm (installer-step): Rename configuration-proc field to configuration-formatter. (%installer-configuration-file): New exported parameter, (%installer-target-dir): ditto, (%configuration-file-width): ditto, (format-configuration): new exported procedure, (configuration->file): new exported procedure. --- gnu/installer.scm | 51 +++++++++++++++++++-------- gnu/installer/final.scm | 36 +++++++++++++++++++ gnu/installer/locale.scm | 13 ++++++- gnu/installer/newt.scm | 5 +++ gnu/installer/newt/final.scm | 84 ++++++++++++++++++++++++++++++++++++++++++++ gnu/installer/record.scm | 3 ++ gnu/installer/steps.scm | 68 ++++++++++++++++++++++++++++++----- gnu/installer/timezone.scm | 12 ++++++- gnu/local.mk | 2 ++ 9 files changed, 249 insertions(+), 25 deletions(-) create mode 100644 gnu/installer/final.scm create mode 100644 gnu/installer/newt/final.scm (limited to 'gnu/installer') diff --git a/gnu/installer.scm b/gnu/installer.scm index b3eb2a6b08..e53acb12f4 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -129,7 +129,8 @@ been performed at build time." #:supported-locales #$locales-loader #:iso639-languages #$iso639-loader #:iso3166-territories #$iso3166-loader))) - (#$apply-locale result))))) + (#$apply-locale result) + result)))) (define apply-keymap ;; Apply the specified keymap. @@ -176,17 +177,19 @@ selected keymap." ;; benefit from any available translation for the installer messages. (installer-step (id 'locale) - (description (G_ "Locale selection")) + (description (G_ "Locale")) (compute (lambda _ - (#$locale-step current-installer)))) + (#$locale-step current-installer))) + (configuration-formatter locale->configuration)) ;; Ask the user to select a timezone under glibc format. (installer-step (id 'timezone) - (description (G_ "Timezone selection")) + (description (G_ "Timezone")) (compute (lambda _ ((installer-timezone-page current-installer) - #$timezone-data)))) + #$timezone-data))) + (configuration-formatter posix-tz->configuration)) ;; The installer runs in a kmscon virtual terminal where loadkeys ;; won't work. kmscon uses libxkbcommon as a backend for keyboard @@ -205,9 +208,10 @@ selected keymap." ;; Ask the user to input a hostname for the system. (installer-step (id 'hostname) - (description (G_ "Hostname selection")) + (description (G_ "Hostname")) (compute (lambda _ - ((installer-hostname-page current-installer))))) + ((installer-hostname-page current-installer)))) + (configuration-formatter hostname->configuration)) ;; Provide an interface above connmanctl, so that the user can select ;; a network susceptible to acces Internet. @@ -219,10 +223,22 @@ selected keymap." ;; Prompt for users (name, group and home directory). (installer-step - (id 'hostname) - (description (G_ "User selection")) + (id 'user) + (description (G_ "User creation")) + (compute (lambda _ + ((installer-user-page current-installer)))) + (configuration-formatter users->configuration)) + (compute (lambda _ - ((installer-user-page current-installer))))))))) + ((installer-user-page current-installer))))) + + (installer-step + (id 'final) + (description (G_ "Configuration file")) + (compute + (lambda (result prev-steps) + ((installer-final-page current-installer) + result prev-steps))))))) (define (installer-program) "Return a file-like object that runs the given INSTALLER." @@ -255,7 +271,12 @@ selected keymap." (use-modules (gnu installer record) (gnu installer keymap) (gnu installer steps) + (gnu installer final) (gnu installer locale) + (gnu installer parted) + (gnu installer services) + (gnu installer timezone) + (gnu installer user) (gnu installer newt) (guix i18n) (guix build utils) @@ -268,7 +289,8 @@ selected keymap." ;; Add some binaries used by the installers to PATH. #$set-installer-path - (let ((current-installer newt-installer)) + (let* ((current-installer newt-installer) + (steps (#$steps current-installer))) ((installer-init current-installer)) (catch #t @@ -276,7 +298,7 @@ selected keymap." (run-installer-steps #:rewind-strategy 'menu #:menu-proc (installer-menu-page current-installer) - #:steps (#$steps current-installer))) + #:steps steps)) (const #f) (lambda (key . args) ((installer-exit-error current-installer) key args) @@ -289,8 +311,9 @@ selected keymap." (print-exception port (stack-ref (make-stack #t) 1) key args))) - (primitive-exit 1)))) - ((installer-exit current-installer)))))) + (primitive-exit 1))) + + ((installer-exit current-installer))))))) (program-file "installer" diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm new file mode 100644 index 0000000000..e1c62f5ce0 --- /dev/null +++ b/gnu/installer/final.scm @@ -0,0 +1,36 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Mathieu Othacehe +;;; +;;; 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 . + +(define-module (gnu installer final) + #:use-module (gnu installer newt page) + #:use-module (gnu installer steps) + #:use-module (gnu installer utils) + #:use-module (gnu services herd) + #:use-module (guix build utils) + #:export (install-system)) + +(define (install-system) + "Start COW-STORE service on target directory and launch guix install command +in a subshell." + (let ((install-command + (format #f "guix system init ~a ~a" + (%installer-configuration-file) + (%installer-target-dir)))) + (mkdir-p (%installer-target-dir)) + (start-service 'cow-store (list (%installer-target-dir))) + (false-if-exception (run-shell-command install-command)))) diff --git a/gnu/installer/locale.scm b/gnu/installer/locale.scm index 504070d41d..2b45b2200a 100644 --- a/gnu/installer/locale.scm +++ b/gnu/installer/locale.scm @@ -35,7 +35,9 @@ language-code->language-name iso3166->iso3166-territories - territory-code->territory-name)) + territory-code->territory-name + + locale->configuration)) ;;; @@ -197,3 +199,12 @@ territory name corresponding to the given TERRITORY-CODE." territory-code))) territories))) (iso3166-territory-name iso3166-territory))) + + +;;; +;;; Configuration formatter. +;;; + +(define (locale->configuration locale) + "Return the configuration field for LOCALE." + `((locale ,locale))) diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index db57c732d1..77a7e6dca2 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -19,6 +19,7 @@ (define-module (gnu installer newt) #:use-module (gnu installer record) #:use-module (gnu installer newt ethernet) + #:use-module (gnu installer newt final) #:use-module (gnu installer newt hostname) #:use-module (gnu installer newt keymap) #:use-module (gnu installer newt locale) @@ -46,6 +47,9 @@ (define (exit-error key . args) (newt-finish)) +(define (final-page result prev-steps) + (run-final-page result prev-steps)) + (define* (locale-page #:key supported-locales iso639-languages @@ -83,6 +87,7 @@ (init init) (exit exit) (exit-error exit-error) + (final-page final-page) (keymap-page keymap-page) (locale-page locale-page) (menu-page menu-page) diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm new file mode 100644 index 0000000000..023777cc0a --- /dev/null +++ b/gnu/installer/newt/final.scm @@ -0,0 +1,84 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Mathieu Othacehe +;;; +;;; 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 . + +(define-module (gnu installer newt final) + #:use-module (gnu installer final) + #:use-module (gnu installer parted) + #:use-module (gnu installer steps) + #:use-module (gnu installer utils) + #:use-module (gnu installer newt page) + #:use-module (gnu installer newt utils) + #:use-module (guix i18n) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (newt) + #:export (run-final-page)) + +(define (run-config-display-page) + (let ((width (%configuration-file-width)) + (height (nearest-exact-integer + (/ (screen-rows) 2)))) + (run-file-textbox-page + #:info-text (G_ "Congratulations, the installation is almost over! A \ +system configuration file has been generated, it is displayed just below. The \ +new system will be created from this file when pression the Ok button.") + #:title (G_ "Configuration file") + #:file (%installer-configuration-file) + #:info-textbox-width width + #:file-textbox-width width + #:file-textbox-height height + #:cancel-button-callback-procedure + (lambda () + (raise + (condition + (&installer-step-abort))))))) + +(define (run-install-success-page) + (message-window + (G_ "Installation complete") + (G_ "Reboot") + (G_ "The installation finished with success. You may now remove the device \ +with the installation image and press the button to reboot."))) + +(define (run-install-failed-page) + (choice-window + (G_ "Installation failed") + (G_ "Restart installer") + (G_ "Retry system install") + (G_ "The final system installation step failed. You can retry the \ +last step, or restart the installer."))) + +(define (run-install-shell) + (clear-screen) + (newt-suspend) + (let ((install-ok? (install-system))) + (newt-resume) + install-ok?)) + +(define (run-final-page result prev-steps) + (let* ((configuration (format-configuration prev-steps result)) + (user-partitions (result-step result 'partition)) + (install-ok? + (with-mounted-partitions + user-partitions + (configuration->file configuration) + (run-config-display-page) + (run-install-shell)))) + (if install-ok? + (run-install-success-page) + (run-install-failed-page)))) diff --git a/gnu/installer/record.scm b/gnu/installer/record.scm index 9c10c65758..bf74040699 100644 --- a/gnu/installer/record.scm +++ b/gnu/installer/record.scm @@ -27,6 +27,7 @@ installer-init installer-exit installer-exit-error + installer-final-page installer-keymap-page installer-locale-page installer-menu-page @@ -57,6 +58,8 @@ ;; procedure (key arguments) -> void (exit-error installer-exit-error) ;; procedure (#:key models layouts) -> (list model layout variant) + ;; procedure void -> void + (final-page installer-final-page) (keymap-page installer-keymap-page) ;; procedure: (#:key supported-locales iso639-languages iso3166-territories) ;; -> glibc-locale diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm index 5fd54356dd..3f0bdad4f7 100644 --- a/gnu/installer/steps.scm +++ b/gnu/installer/steps.scm @@ -18,10 +18,13 @@ (define-module (gnu installer steps) #:use-module (guix records) + #:use-module (guix build utils) #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (rnrs io ports) #:export (&installer-step-abort installer-step-abort? @@ -35,13 +38,19 @@ installer-step-id installer-step-description installer-step-compute - installer-step-configuration-proc + installer-step-configuration-formatter run-installer-steps find-step-by-id result->step-ids result-step - result-step-done?)) + result-step-done? + + %installer-configuration-file + %installer-target-dir + %configuration-file-width + format-configuration + configuration->file)) ;; This condition may be raised to abort the current step. (define-condition-type &installer-step-abort &condition @@ -60,12 +69,12 @@ (define-record-type* 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))) + (id installer-step-id) ;symbol + (description installer-step-description ;string + (default #f)) + (compute installer-step-compute) ;procedure + (configuration-formatter installer-step-configuration-formatter ;procedure + (default #f))) (define* (run-installer-steps #:key steps @@ -157,7 +166,7 @@ return the accumalated result so far." (reverse result))) (let* ((id (installer-step-id step)) (compute (installer-step-compute step)) - (res (compute result))) + (res (compute result done-steps))) (run (alist-cons id res result) #:todo-steps rest-steps #:done-steps (append done-steps (list step)))))))) @@ -185,3 +194,44 @@ RESULTS." "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)) + +(define %installer-configuration-file (make-parameter "/mnt/etc/config.scm")) +(define %installer-target-dir (make-parameter "/mnt")) +(define %configuration-file-width (make-parameter 79)) + +(define (format-configuration steps results) + "Return the list resulting from the application of the procedure defined in +CONFIGURATION-FORMATTER field of on the associated result +found in RESULTS." + (let ((configuration + (append-map + (lambda (step) + (let* ((step-id (installer-step-id step)) + (conf-formatter + (installer-step-configuration-formatter step)) + (result-step (result-step results step-id))) + (if (and result-step conf-formatter) + (conf-formatter result-step) + '()))) + steps)) + (modules '((use-modules (gnu)) + (use-service-modules desktop)))) + `(,@modules + () + (operating-system ,@configuration)))) + +(define* (configuration->file configuration + #:key (filename (%installer-configuration-file))) + "Write the given CONFIGURATION to FILENAME." + (mkdir-p (dirname filename)) + (call-with-output-file filename + (lambda (port) + (format port ";; This is an operating system configuration generated~%") + (format port ";; by the graphical installer.~%") + (newline port) + (for-each (lambda (part) + (if (null? part) + (newline port) + (pretty-print part port))) + configuration) + (flush-output-port port)))) diff --git a/gnu/installer/timezone.scm b/gnu/installer/timezone.scm index 061e8c2e48..32bc2ed6bb 100644 --- a/gnu/installer/timezone.scm +++ b/gnu/installer/timezone.scm @@ -28,7 +28,8 @@ #:export (locate-childrens timezone->posix-tz timezone-has-child? - zonetab->timezone-tree)) + zonetab->timezone-tree + posix-tz->configuration)) (define %not-blank (char-set-complement char-set:blank)) @@ -115,3 +116,12 @@ TREE. Raise a condition if the PATH could not be found." (define* (zonetab->timezone-tree zonetab) "Return the timezone tree corresponding to the given ZONETAB file." (timezones->timezone-tree (zonetab->timezones zonetab))) + + +;;; +;;; Configuration formatter. +;;; + +(define (posix-tz->configuration timezone) + "Return the configuration field for TIMEZONE." + `((timezone ,timezone))) diff --git a/gnu/local.mk b/gnu/local.mk index b0ec16de34..d4acb8d2ec 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -569,6 +569,7 @@ GNU_SYSTEM_MODULES += \ %D%/installer.scm \ %D%/installer/record.scm \ %D%/installer/connman.scm \ + %D%/installer/final.scm \ %D%/installer/keymap.scm \ %D%/installer/locale.scm \ %D%/installer/newt.scm \ @@ -577,6 +578,7 @@ GNU_SYSTEM_MODULES += \ %D%/installer/utils.scm \ \ %D%/installer/newt/ethernet.scm \ + %D%/installer/newt/final.scm \ %D%/installer/newt/hostname.scm \ %D%/installer/newt/keymap.scm \ %D%/installer/newt/locale.scm \ -- cgit v1.2.3 From c088b2e47f6675199f1ef545df7d04d4532e64e3 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 14:36:22 +0900 Subject: installer: Do not ask for keyboard model. Suppose that the keyboard model is "pc105". * gnu/installer.scm (apply-keymap): Remove model ... * gnu/installer/newt/keymap.scm (run-keymap-page): passed here. (run-model-page): remove procedure * gnu/installer/record.scm (installer): Edit keymap-page prototype in comment. * gnu/installer/keymap.scm (default-keyboard-model): New exported parameter. --- gnu/installer.scm | 10 +++++----- gnu/installer/keymap.scm | 4 ++++ gnu/installer/newt.scm | 5 ++--- gnu/installer/newt/keymap.scm | 44 ++++++------------------------------------- gnu/installer/newt/locale.scm | 6 +++--- gnu/installer/record.scm | 2 +- 6 files changed, 21 insertions(+), 50 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer.scm b/gnu/installer.scm index e53acb12f4..4a587eb35b 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -133,10 +133,11 @@ been performed at build time." result)))) (define apply-keymap - ;; Apply the specified keymap. + ;; Apply the specified keymap. Use the default keyboard model. #~(match-lambda - ((model layout variant) - (kmscon-update-keymap model layout variant)))) + ((layout variant) + (kmscon-update-keymap (default-keyboard-model) + layout variant)))) (define* (compute-keymap-step) "Return a gexp that runs the keymap-page of INSTALLER and install the @@ -150,8 +151,7 @@ selected keymap." "/share/X11/xkb/rules/base.xml"))) (lambda (models layouts) ((installer-keymap-page current-installer) - #:models models - #:layouts layouts))))) + layouts))))) (#$apply-keymap result)))) (define (installer-steps) diff --git a/gnu/installer/keymap.scm b/gnu/installer/keymap.scm index 78065aa6c6..d9f8656855 100644 --- a/gnu/installer/keymap.scm +++ b/gnu/installer/keymap.scm @@ -46,6 +46,7 @@ x11-keymap-variant-name x11-keymap-variant-description + default-keyboard-model xkb-rules->models+layouts kmscon-update-keymap)) @@ -68,6 +69,9 @@ (name x11-keymap-variant-name) ;string (description x11-keymap-variant-description)) ;string +;; Assume all modern keyboards have this model. +(define default-keyboard-model (make-parameter "pc105")) + (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 diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index 77a7e6dca2..1f51b111a8 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -68,9 +68,8 @@ (define (menu-page steps) (run-menu-page steps)) -(define* (keymap-page #:key models layouts) - (run-keymap-page #:models models - #:layouts layouts)) +(define* (keymap-page layouts) + (run-keymap-page layouts)) (define (network-page) (run-network-page)) diff --git a/gnu/installer/newt/keymap.scm b/gnu/installer/newt/keymap.scm index 0c9432bba2..0c38a79e19 100644 --- a/gnu/installer/newt/keymap.scm +++ b/gnu/installer/newt/keymap.scm @@ -56,42 +56,12 @@ (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* (run-keymap-page layouts) + "Run a page asking the user to select a keyboard layout and variant. LAYOUTS +is a list of supported X11-KEYMAP-LAYOUT. Return a list of two elements, the +names of the selected keyboard 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 @@ -120,13 +90,11 @@ keyboard model, layout and variant." variant))))))))) (define (format-result result) - (let ((model (x11-keymap-model-name - (result-step result 'model))) - (layout (x11-keymap-layout-name + (let ((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 "")))) + (list 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 index 599a6b0ecf..028372c194 100644 --- a/gnu/installer/newt/locale.scm +++ b/gnu/installer/newt/locale.scm @@ -143,7 +143,7 @@ glibc locale string and return it." (installer-step (id 'territory) (compute - (lambda (result) + (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. @@ -161,7 +161,7 @@ glibc locale string and return it." (installer-step (id 'codeset) (compute - (lambda (result) + (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. @@ -173,7 +173,7 @@ glibc locale string and return it." (installer-step (id 'modifier) (compute - (lambda (result) + (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) diff --git a/gnu/installer/record.scm b/gnu/installer/record.scm index bf74040699..ba7625e65a 100644 --- a/gnu/installer/record.scm +++ b/gnu/installer/record.scm @@ -57,9 +57,9 @@ (exit installer-exit) ;; procedure (key arguments) -> void (exit-error installer-exit-error) - ;; procedure (#:key models layouts) -> (list model layout variant) ;; procedure void -> void (final-page installer-final-page) + ;; procedure (layouts) -> (list layout variant) (keymap-page installer-keymap-page) ;; procedure: (#:key supported-locales iso639-languages iso3166-territories) ;; -> glibc-locale -- cgit v1.2.3 From b51bde71a9385f4e81fbea258bfb9e8ff48be119 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 14:41:48 +0900 Subject: installer: Add services page. Add a page to select services, for now only desktop environments choice is available. * gnu/installer.scm (steps): Add services step. * gnu/installer/newt.scm (newt-installer): Add services-page field. * gnu/installer/newt/services.scm: New file. * gnu/installer/record.scm (installer): Add services-page field. * gnu/installer/services.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add new files. * po/guix/POTFILES.in: Add new files. --- gnu/installer.scm | 12 ++++++--- gnu/installer/newt.scm | 5 ++++ gnu/installer/newt/services.scm | 48 +++++++++++++++++++++++++++++++++ gnu/installer/record.scm | 3 +++ gnu/installer/services.scm | 59 +++++++++++++++++++++++++++++++++++++++++ gnu/local.mk | 2 ++ po/guix/POTFILES.in | 2 ++ 7 files changed, 128 insertions(+), 3 deletions(-) create mode 100644 gnu/installer/newt/services.scm create mode 100644 gnu/installer/services.scm (limited to 'gnu/installer') diff --git a/gnu/installer.scm b/gnu/installer.scm index 4a587eb35b..1b9aeaa217 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -229,16 +229,22 @@ selected keymap." ((installer-user-page current-installer)))) (configuration-formatter users->configuration)) + ;; Ask the user to choose one or many desktop environment(s). + (installer-step + (id 'services) + (description (G_ "Services")) (compute (lambda _ - ((installer-user-page current-installer))))) + ((installer-services-page current-installer)))) + (configuration-formatter + desktop-environments->configuration)) - (installer-step + (installer-step (id 'final) (description (G_ "Configuration file")) (compute (lambda (result prev-steps) ((installer-final-page current-installer) - result prev-steps))))))) + result prev-steps)))))))) (define (installer-program) "Return a file-like object that runs the given INSTALLER." diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index 1f51b111a8..3192e55b86 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -25,6 +25,7 @@ #:use-module (gnu installer newt locale) #:use-module (gnu installer newt menu) #:use-module (gnu installer newt network) + #:use-module (gnu installer newt services) #:use-module (gnu installer newt timezone) #:use-module (gnu installer newt user) #:use-module (gnu installer newt utils) @@ -80,6 +81,9 @@ (define (user-page) (run-user-page)) +(define (services-page) + (run-services-page)) + (define newt-installer (installer (name 'newt) @@ -94,4 +98,5 @@ (timezone-page timezone-page) (hostname-page hostname-page) (user-page user-page) + (services-page services-page) (welcome-page welcome-page))) diff --git a/gnu/installer/newt/services.scm b/gnu/installer/newt/services.scm new file mode 100644 index 0000000000..80fac43dc8 --- /dev/null +++ b/gnu/installer/newt/services.scm @@ -0,0 +1,48 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Mathieu Othacehe +;;; +;;; 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 . + +(define-module (gnu installer newt services) + #:use-module (gnu installer services) + #:use-module (gnu installer steps) + #:use-module (gnu installer newt page) + #:use-module (gnu installer newt utils) + #:use-module (guix i18n) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (newt) + #:export (run-services-page)) + +(define (run-desktop-environments-cbt-page) + "Run a page allowing the user to choose between various desktop +environments." + (run-checkbox-tree-page + #:info-text (G_ "Please select the desktop(s) environment(s) you wish to \ +install. If you select multiple desktops environments, we will be able to \ +choose the one to use on the log-in screen with F1.") + #:title (G_ "Desktop environment") + #:items %desktop-environments + #:item->text desktop-environment-name + #:checkbox-tree-height 5 + #:cancel-button-callback-procedure + (lambda () + (raise + (condition + (&installer-step-abort)))))) + +(define (run-services-page) + (run-desktop-environments-cbt-page)) diff --git a/gnu/installer/record.scm b/gnu/installer/record.scm index ba7625e65a..3ef0a101d3 100644 --- a/gnu/installer/record.scm +++ b/gnu/installer/record.scm @@ -35,6 +35,7 @@ installer-timezone-page installer-hostname-page installer-user-page + installer-services-page installer-welcome-page)) @@ -74,5 +75,7 @@ (hostname-page installer-hostname-page) ;; procedure void -> void (user-page installer-user-page) + ;; procedure void -> void + (services-page installer-services-page) ;; procedure (logo) -> void (welcome-page installer-welcome-page)) diff --git a/gnu/installer/services.scm b/gnu/installer/services.scm new file mode 100644 index 0000000000..ed44b87682 --- /dev/null +++ b/gnu/installer/services.scm @@ -0,0 +1,59 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Mathieu Othacehe +;;; +;;; 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 . + +(define-module (gnu installer services) + #:use-module (guix records) + #:export ( + desktop-environment + make-desktop-environment + desktop-environment-name + desktop-environment-snippet + + %desktop-environments + desktop-environments->configuration)) + +(define-record-type* + desktop-environment make-desktop-environment + desktop-environment? + (name desktop-environment-name) ;string + (snippet desktop-environment-snippet)) ;symbol + +;; This is the list of desktop environments supported as services. +(define %desktop-environments + (list + (desktop-environment + (name "GNOME") + (snippet '(gnome-desktop-service))) + (desktop-environment + (name "Xfce") + (snippet '(xfce-desktop-service))) + (desktop-environment + (name "MATE") + (snippet '(mate-desktop-service))) + (desktop-environment + (name "Enlightenment") + (snippet '(service enlightenment-desktop-service-type))))) + +(define (desktop-environments->configuration desktop-environments) + "Return the configuration field for DESKTOP-ENVIRONMENTS." + (let ((snippets + (map desktop-environment-snippet desktop-environments))) + `(,@(if (null? snippets) + '() + `((services (cons* ,@snippets + %desktop-services))))))) diff --git a/gnu/local.mk b/gnu/local.mk index d4acb8d2ec..15a43406a4 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -573,6 +573,7 @@ GNU_SYSTEM_MODULES += \ %D%/installer/keymap.scm \ %D%/installer/locale.scm \ %D%/installer/newt.scm \ + %D%/installer/services.scm \ %D%/installer/steps.scm \ %D%/installer/timezone.scm \ %D%/installer/utils.scm \ @@ -585,6 +586,7 @@ GNU_SYSTEM_MODULES += \ %D%/installer/newt/menu.scm \ %D%/installer/newt/network.scm \ %D%/installer/newt/page.scm \ + %D%/installer/newt/services.scm \ %D%/installer/newt/timezone.scm \ %D%/installer/newt/utils.scm \ %D%/installer/newt/welcome.scm \ diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 1378b33e0e..16d9c9e4ae 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -21,11 +21,13 @@ gnu/installer/newt/locale.scm gnu/installer/newt/menu.scm gnu/installer/newt/network.scm gnu/installer/newt/page.scm +gnu/installer/newt/services.scm gnu/installer/newt/timezone.scm gnu/installer/newt/user.scm gnu/installer/newt/utils.scm gnu/installer/newt/welcome.scm gnu/installer/newt/wifi.scm +gnu/installer/services.scm gnu/installer/steps.scm gnu/installer/timezone.scm gnu/installer/utils.scm -- cgit v1.2.3 From b4658c258eaf7731dbb45409aedef58afc5de93a Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 14:45:53 +0900 Subject: installer: Add hostname. * gnu/installer/hostname.scm: New file. * gnu/installer.scm (installer-program): Use new module above. * gnu/local.mk (GNU_SYSTEM_MODULES): Add new file. * po/guix/POTFILES.in: Add new file. --- gnu/installer.scm | 1 + gnu/installer/hostname.scm | 23 +++++++++++++++++++++++ gnu/local.mk | 1 + po/guix/POTFILES.in | 1 + 4 files changed, 26 insertions(+) create mode 100644 gnu/installer/hostname.scm (limited to 'gnu/installer') diff --git a/gnu/installer.scm b/gnu/installer.scm index 1b9aeaa217..7e023ce18f 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -278,6 +278,7 @@ selected keymap." (gnu installer keymap) (gnu installer steps) (gnu installer final) + (gnu installer hostname) (gnu installer locale) (gnu installer parted) (gnu installer services) diff --git a/gnu/installer/hostname.scm b/gnu/installer/hostname.scm new file mode 100644 index 0000000000..b8e823d0a8 --- /dev/null +++ b/gnu/installer/hostname.scm @@ -0,0 +1,23 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Mathieu Othacehe +;;; +;;; 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 . + +(define-module (gnu installer hostname) + #:export (hostname->configuration)) + +(define (hostname->configuration hostname) + `((host-name ,hostname))) diff --git a/gnu/local.mk b/gnu/local.mk index 15a43406a4..bcb5e5f679 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -570,6 +570,7 @@ GNU_SYSTEM_MODULES += \ %D%/installer/record.scm \ %D%/installer/connman.scm \ %D%/installer/final.scm \ + %D%/installer/hostname.scm \ %D%/installer/keymap.scm \ %D%/installer/locale.scm \ %D%/installer/newt.scm \ diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 16d9c9e4ae..df7459a4b7 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -11,6 +11,7 @@ guix/import/opam.scm gnu/installer.scm gnu/installer/record.scm gnu/installer/connman.scm +gnu/installer/hostname.scm gnu/installer/keymap.scm gnu/installer/locale.scm gnu/installer/newt.scm -- cgit v1.2.3 From 29d8d9196bcf7a87eeb891bfb35eb2447836bbeb Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 14:47:49 +0900 Subject: installer: Add new pages. * gnu/installer/newt/page.scm (run-scale-page): New exported procedure, (run-checkbox-tree-page): ditto, (run-file-textbox-page): ditto. --- gnu/installer/newt/page.scm | 250 ++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 231 insertions(+), 19 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm index bcede3e333..10849b81eb 100644 --- a/gnu/installer/newt/page.scm +++ b/gnu/installer/newt/page.scm @@ -17,17 +17,22 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu installer newt page) + #:use-module (gnu installer utils) #:use-module (gnu installer newt utils) #:use-module (guix i18n) #:use-module (ice-9 match) #:use-module (ice-9 receive) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (newt) #:export (draw-info-page draw-connecting-page run-input-page run-error-page run-listbox-selection-page - run-scale-page)) + run-scale-page + run-checkbox-tree-page + run-file-textbox-page)) ;;; Commentary: ;;; @@ -66,6 +71,7 @@ this page to TITLE." (define* (run-input-page text title #:key (allow-empty-input? #f) + (default-text #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 @@ -80,6 +86,9 @@ enters an empty input." (ok-button (make-button -1 -1 (G_ "Ok"))) (form (make-form))) + (when default-text + (set-entry-text input-entry default-text)) + (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) @@ -142,10 +151,18 @@ of the page is set to TITLE." (listbox-default-item #f) (listbox-allow-multiple? #f) (sort-listbox-items? #t) + (allow-delete? #f) + (skip-item-procedure? + (const #f)) button-text (button-callback-procedure (const #t)) + (button2-text #f) + (button2-callback-procedure + (const #t)) (listbox-callback-procedure + identity) + (hotkey-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 @@ -168,7 +185,15 @@ be selected (using the 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)." +'string<=' procedure (after being converted to text). + +If ALLOW-DELETE? is #t, the form will return if the key is pressed, +otherwise nothing will happend. + +Each time the listbox current item changes, call SKIP-ITEM-PROCEDURE? with the +current listbox item as argument. If it returns #t, skip the element and jump +to the next/previous one depending on the previous item, otherwise do +nothing." (define (fill-listbox listbox items) "Append the given ITEMS to LISTBOX, once they have been converted to text @@ -198,6 +223,21 @@ corresponding to each item in the list." (string<= text-a text-b)))))) (map car sorted-items))) + ;; Store the last selected listbox item's key. + (define last-listbox-key (make-parameter #f)) + + (define (previous-key keys key) + (let ((index (list-index (cut eq? key <>) keys))) + (and index + (> index 0) + (list-ref keys (- index 1))))) + + (define (next-key keys key) + (let ((index (list-index (cut eq? key <>) keys))) + (and index + (< index (- (length keys) 1)) + (list-ref keys (+ index 1))))) + (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 @@ -221,18 +261,55 @@ the current listbox item has to be selected by key." info-textbox-width #:flags FLAG-BORDER)) (button (make-button -1 -1 button-text)) + (button2 (and button2-text + (make-button -1 -1 button2-text))) (grid (vertically-stacked-grid GRID-ELEMENT-COMPONENT info-textbox GRID-ELEMENT-COMPONENT listbox - GRID-ELEMENT-COMPONENT button)) + GRID-ELEMENT-SUBGRID + (apply + horizontal-stacked-grid + GRID-ELEMENT-COMPONENT button + `(,@(if button2 + (list GRID-ELEMENT-COMPONENT button2) + '()))))) (sorted-items (if sort-listbox-items? (sort-listbox-items listbox-items) listbox-items)) (keys (fill-listbox listbox sorted-items))) + ;; On every listbox element change, check if we need to skip it. If yes, + ;; depending on the 'last-listbox-key', jump forward or backward. If no, + ;; do nothing. + (add-component-callback + listbox + (lambda (component) + (let* ((current-key (current-listbox-entry listbox)) + (listbox-keys (map car keys)) + (last-key (last-listbox-key)) + (item (assoc-ref keys current-key)) + (prev-key (previous-key listbox-keys current-key)) + (next-key (next-key listbox-keys current-key))) + ;; Update last-listbox-key before a potential call to + ;; set-current-listbox-entry-by-key, because it will immediately + ;; cause this callback to be called for the new entry. + (last-listbox-key current-key) + (when (skip-item-procedure? item) + (when (eq? prev-key last-key) + (if next-key + (set-current-listbox-entry-by-key listbox next-key) + (set-current-listbox-entry-by-key listbox prev-key))) + (when (eq? next-key last-key) + (if prev-key + (set-current-listbox-entry-by-key listbox prev-key) + (set-current-listbox-entry-by-key listbox next-key))))))) + (when listbox-default-item (set-default-item listbox keys listbox-default-item)) + (when allow-delete? + (form-add-hotkey form KEY-DELETE)) + (add-form-to-grid grid form #t) (make-wrapped-grid-window grid title) @@ -241,22 +318,28 @@ the current listbox item has to be selected by key." (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)))))) + (case exit-reason + ((exit-component) + (cond + ((components=? argument button) + (button-callback-procedure)) + ((and button2 + (components=? argument button2)) + (button2-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)) + (let* ((entry (current-listbox-entry listbox)) + (item (assoc-ref keys entry))) + (listbox-callback-procedure item)))))) + ((exit-hotkey) + (let* ((entry (current-listbox-entry listbox)) + (item (assoc-ref keys entry))) + (hotkey-callback-procedure argument item))))) (lambda () (destroy-form-and-pop form)))))) @@ -311,3 +394,132 @@ error is raised if the MAX-SCALE-UPDATE limit is reached." (error "Max scale updates reached.")))))) (lambda () (destroy-form-and-pop form))))) + +(define* (run-checkbox-tree-page #:key + info-text + title + items + item->text + (info-textbox-width 50) + (checkbox-tree-height 10) + (ok-button-callback-procedure + (const #t)) + (cancel-button-callback-procedure + (const #t))) + "Run a page allowing the user to select one or multiple items among ITEMS in +a checkbox list. The page contains vertically stacked from the top to the +bottom, an informative text set to INFO-TEXT, the checkbox list and two +buttons, 'Ok' and 'Cancel'. The page title's is set to TITLE. ITEMS are +converted to text using ITEM->TEXT before being displayed in the checkbox +list. + +INFO-TEXTBOX-WIDTH is the width of the textbox where INFO-TEXT will be +displayed. CHECKBOX-TREE-HEIGHT is the height of the checkbox list. + +OK-BUTTON-CALLBACK-PROCEDURE is called when the 'Ok' button is pressed. +CANCEL-BUTTON-CALLBACK-PROCEDURE is called when the 'Cancel' button is +pressed. + +This procedure returns the list of checked items in the checkbox list among +ITEMS when 'Ok' is pressed." + (define (fill-checkbox-tree checkbox-tree items) + (map + (lambda (item) + (let* ((item-text (item->text item)) + (key (add-entry-to-checkboxtree checkbox-tree item-text 0))) + (cons key item))) + items)) + + (let* ((checkbox-tree + (make-checkboxtree -1 -1 + checkbox-tree-height + FLAG-BORDER)) + (info-textbox + (make-reflowed-textbox -1 -1 info-text + info-textbox-width + #:flags FLAG-BORDER)) + (ok-button (make-button -1 -1 (G_ "Ok"))) + (cancel-button (make-button -1 -1 (G_ "Cancel"))) + (grid (vertically-stacked-grid + GRID-ELEMENT-COMPONENT info-textbox + GRID-ELEMENT-COMPONENT checkbox-tree + GRID-ELEMENT-SUBGRID + (horizontal-stacked-grid + GRID-ELEMENT-COMPONENT ok-button + GRID-ELEMENT-COMPONENT cancel-button))) + (keys (fill-checkbox-tree checkbox-tree items)) + (form (make-form))) + + (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 () + (case exit-reason + ((exit-component) + (cond + ((components=? argument ok-button) + (let* ((entries (current-checkbox-selection checkbox-tree)) + (current-items (map (lambda (entry) + (assoc-ref keys entry)) + entries))) + (ok-button-callback-procedure) + current-items)) + ((components=? argument cancel-button) + (cancel-button-callback-procedure)))))) + (lambda () + (destroy-form-and-pop form)))))) + +(define* (run-file-textbox-page #:key + info-text + title + file + (info-textbox-width 50) + (file-textbox-width 50) + (file-textbox-height 30) + (ok-button-callback-procedure + (const #t)) + (cancel-button-callback-procedure + (const #t))) + (let* ((info-textbox + (make-reflowed-textbox -1 -1 info-text + info-textbox-width + #:flags FLAG-BORDER)) + (file-text (read-all file)) + (file-textbox + (make-textbox -1 -1 + file-textbox-width + file-textbox-height + (logior FLAG-SCROLL FLAG-BORDER))) + (ok-button (make-button -1 -1 (G_ "Ok"))) + (cancel-button (make-button -1 -1 (G_ "Cancel"))) + (grid (vertically-stacked-grid + GRID-ELEMENT-COMPONENT info-textbox + GRID-ELEMENT-COMPONENT file-textbox + GRID-ELEMENT-SUBGRID + (horizontal-stacked-grid + GRID-ELEMENT-COMPONENT ok-button + GRID-ELEMENT-COMPONENT cancel-button))) + (form (make-form))) + + (set-textbox-text file-textbox file-text) + (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 () + (case exit-reason + ((exit-component) + (cond + ((components=? argument ok-button) + (ok-button-callback-procedure)) + ((components=? argument cancel-button) + (cancel-button-callback-procedure)))))) + (lambda () + (destroy-form-and-pop form)))))) -- cgit v1.2.3 From 6aa625c2f82332f8987247958fc18955bd8078f3 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 14:50:16 +0900 Subject: installer: Redirect to TTY3 root shell for unguided install. * gnu/installer/newt/welcome.scm (run-welcome-page): Switch to TTY3 for unguided shell based install. --- gnu/installer/newt/welcome.scm | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm index 3a0e45e198..658f7bae40 100644 --- a/gnu/installer/newt/welcome.scm +++ b/gnu/installer/newt/welcome.scm @@ -96,18 +96,18 @@ installation and reboot." (G_ "Welcome to GNU GuixSD installer! Please note that the present graphical installer is still under heavy \ -development, so you might want to fallback to the classical installer by \ -pressing CTRL-ALT-F3.") +development, so you might want to prefer using the shell based process. \ +The documentation is accessible at any time by pressing CTRL-ALT-F2.") logo #:listbox-items - `((,(G_ "Install using the unguided shell based process") + `((,(G_ "Install using the shell based process") . ,(lambda () - (clear-screen) - (newt-suspend) - (system* "bash" "-l") - (newt-resume))) - (,(G_ "Graphical install using a guided terminal based interface") + ;; Switch to TTY3, where a root shell is available for shell based + ;; install. The other root TTY's would have been ok too. + (system* "chvt" "3") + (run-welcome-page logo))) + (,(G_ "Graphical install using a terminal based interface") . ,(const #t)) (,(G_ "Reboot") -- cgit v1.2.3 From fb1675cbca68a7ada710640294a26cf0f1b22168 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 14:52:04 +0900 Subject: installer: Fix ethernet connection. * gnu/installer/newt/ethernet.scm (connect-ethernet-service): Return the service passed as parameter. --- gnu/installer/newt/ethernet.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/ethernet.scm b/gnu/installer/newt/ethernet.scm index 2cbbfddacd..2b02653777 100644 --- a/gnu/installer/newt/ethernet.scm +++ b/gnu/installer/newt/ethernet.scm @@ -54,7 +54,8 @@ connection is pending." (let* ((service-name (service-name service)) (form (draw-connecting-page service-name))) (connman-connect service) - (destroy-form-and-pop form))) + (destroy-form-and-pop form) + service)) (define (run-ethernet-page) (let ((services (ethernet-services))) -- cgit v1.2.3 From 47c94801656c7e9ddf1dcfe0189b48d7c57d0a1d Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 14:55:41 +0900 Subject: installer: Add user module. * gnu/installer/user.scm: New file. --- gnu/installer/user.scm | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++ gnu/local.mk | 1 + po/guix/POTFILES.in | 1 + 3 files changed, 52 insertions(+) create mode 100644 gnu/installer/user.scm (limited to 'gnu/installer') diff --git a/gnu/installer/user.scm b/gnu/installer/user.scm new file mode 100644 index 0000000000..1f8d40a011 --- /dev/null +++ b/gnu/installer/user.scm @@ -0,0 +1,50 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Mathieu Othacehe +;;; +;;; 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 . + +(define-module (gnu installer user) + #:use-module (guix records) + #:export ( + user + make-user + user-name + user-group + user-home-directory + + users->configuration)) + +(define-record-type* + user make-user + user? + (name user-name) + (group user-group + (default "users")) + (home-directory user-home-directory)) + +(define (users->configuration users) + "Return the configuration field for USERS." + `((users (cons* + ,@(map (lambda (user) + `(user-account + (name ,(user-name user)) + (group ,(user-group user)) + (home-directory ,(user-home-directory user)) + (supplementary-groups + (quote ("wheel" "netdev" + "audio" "video"))))) + users) + %base-user-accounts)))) diff --git a/gnu/local.mk b/gnu/local.mk index bcb5e5f679..0b5e96afa4 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -577,6 +577,7 @@ GNU_SYSTEM_MODULES += \ %D%/installer/services.scm \ %D%/installer/steps.scm \ %D%/installer/timezone.scm \ + %D%/installer/user.scm \ %D%/installer/utils.scm \ \ %D%/installer/newt/ethernet.scm \ diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index df7459a4b7..48c09a1e3a 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -31,6 +31,7 @@ gnu/installer/newt/wifi.scm gnu/installer/services.scm gnu/installer/steps.scm gnu/installer/timezone.scm +gnu/installer/user.scm gnu/installer/utils.scm guix/scripts.scm guix/scripts/build.scm -- cgit v1.2.3 From 69a934f23ae1bd7dda9ec269a6ce3012e13c9011 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 14:57:28 +0900 Subject: installer: Add partitioning support. * gnu/installer.scm (installer-steps): Add partitioning step. * gnu/installer/newt.scm (newt-installer): Add partition-page field. * gnu/installer/newt/partition.scm: New file. * gnu/installer/parted.scm: New file. * gnu/installer/record (installer): New partition-page field. * gnu/local.mk (GNU_SYSTEM_MODULES): Add new files. * po/guix/POTFILES.in: Add new files. --- gnu/installer.scm | 32 +- gnu/installer/newt.scm | 5 + gnu/installer/newt/partition.scm | 706 ++++++++++++++++++++++ gnu/installer/parted.scm | 1210 ++++++++++++++++++++++++++++++++++++++ gnu/installer/record.scm | 3 + gnu/local.mk | 2 + po/guix/POTFILES.in | 1 + 7 files changed, 1953 insertions(+), 6 deletions(-) create mode 100644 gnu/installer/newt/partition.scm create mode 100644 gnu/installer/parted.scm (limited to 'gnu/installer') diff --git a/gnu/installer.scm b/gnu/installer.scm index 29178cb536..80b5782202 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu installer) + #:use-module (guix discovery) #:use-module (guix packages) #:use-module (guix gexp) #:use-module (guix modules) @@ -27,6 +28,7 @@ #:use-module (gnu packages base) #:use-module (gnu packages bash) #:use-module (gnu packages connman) + #:use-module (gnu packages disk) #:use-module (gnu packages guile) #:autoload (gnu packages gnupg) (guile-gcrypt) #:use-module (gnu packages iso-codes) @@ -172,9 +174,14 @@ selected keymap." ((installer-welcome-page current-installer) #$(local-file "installer/aux-files/logo.txt"))))) - ;; 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. + ;; Run a partitionment tool allowing the user to modify + ;; partition tables, partitions and their mount points. + (installer-step + (id 'partition) + (description (G_ "Partitionment")) + (compute (lambda _ + ((installer-partition-page current-installer)))) + (configuration-formatter user-partitions->configuration)) ;; Ask the user to choose a locale among those supported by ;; the glibc. Install the selected locale right away, so that @@ -263,18 +270,31 @@ selected keymap." (define set-installer-path ;; Add the specified binary to PATH for later use by the installer. #~(let* ((inputs - '#$(append (list bash connman shadow) + '#$(append (list bash ;start subshells + connman ;call connmanctl + dosfstools ;mkfs.fat + e2fsprogs ;mkfs.ext4 + kbd ;chvt + guix ;guix system init call + util-linux ;mkwap + shadow) (map canonical-package (list coreutils))))) (with-output-to-port (%make-void-port "w") (lambda () (set-path-environment-variable "PATH" '("bin" "sbin") inputs))))) (define steps (installer-steps)) + (define modules + (scheme-modules* + (string-append (current-source-directory) "/..") + "gnu/installer")) (define installer-builder - (with-extensions (list guile-gcrypt guile-newt guile-json) + (with-extensions (list guile-gcrypt guile-newt + guile-parted guile-bytestructures + guile-json) (with-imported-modules `(,@(source-module-closure - '((gnu installer newt) + `(,@modules (guix build utils)) #:select? not-config?) ((guix config) => ,(make-config.scm))) diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index 3192e55b86..9d9212173d 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -25,6 +25,7 @@ #:use-module (gnu installer newt locale) #:use-module (gnu installer newt menu) #:use-module (gnu installer newt network) + #:use-module (gnu installer newt partition) #:use-module (gnu installer newt services) #:use-module (gnu installer newt timezone) #:use-module (gnu installer newt user) @@ -81,6 +82,9 @@ (define (user-page) (run-user-page)) +(define (partition-page) + (run-partioning-page)) + (define (services-page) (run-services-page)) @@ -98,5 +102,6 @@ (timezone-page timezone-page) (hostname-page hostname-page) (user-page user-page) + (partition-page partition-page) (services-page services-page) (welcome-page welcome-page))) diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm new file mode 100644 index 0000000000..806337a9cb --- /dev/null +++ b/gnu/installer/newt/partition.scm @@ -0,0 +1,706 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Mathieu Othacehe +;;; +;;; 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 . + +(define-module (gnu installer newt partition) + #:use-module (gnu installer parted) + #:use-module (gnu installer steps) + #:use-module (gnu installer utils) + #:use-module (gnu installer newt page) + #:use-module (gnu installer newt utils) + #:use-module (guix i18n) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (newt) + #:use-module (parted) + #:export (run-partioning-page)) + +(define (button-cancel-action) + "Raise the &installer-step-abort condition." + (raise + (condition + (&installer-step-abort)))) + +(define (run-scheme-page) + "Run a page asking the user for a partitioning scheme." + (let* ((items + '((root . "Everything is one partition") + (root-home . "Separate /home partition"))) + (result (run-listbox-selection-page + #:info-text (G_ "Please select a partitioning scheme.") + #:title (G_ "Partition scheme") + #:listbox-items items + #:listbox-item->text cdr + #:button-text (G_ "Cancel") + #:button-callback-procedure button-cancel-action))) + (car result))) + +(define (draw-formating-page) + "Draw a page to indicate partitions are being formated." + (draw-info-page + (format #f (G_ "Partition formating is in progress, please wait.")) + (G_ "Preparing partitions"))) + +(define (run-device-page devices) + "Run a page asking the user to select a device among those in the given +DEVICES list." + (define (device-items) + (map (lambda (device) + `(,device . ,(device-description device))) + devices)) + + (let* ((result (run-listbox-selection-page + #:info-text (G_ "Please select a disk.") + #:title (G_ "Disk") + #:listbox-items (device-items) + #:listbox-item->text cdr + #:button-text (G_ "Cancel") + #:button-callback-procedure button-cancel-action)) + (device (car result))) + device)) + +(define (run-label-page button-callback) + "Run a page asking the user to select a partition table label." + (run-listbox-selection-page + #:info-text (G_ "Select a new partition table type. \ +Be careful, all data on the disk will be lost.") + #:title (G_ "Partition table") + #:listbox-items '("msdos" "gpt") + #:listbox-item->text identity + #:button-text (G_ "Cancel") + #:button-callback-procedure button-callback)) + +(define (run-type-page partition) + "Run a page asking the user to select a partition type." + (let* ((disk (partition-disk partition)) + (partitions (disk-partitions disk)) + (other-extended-partitions? + (any extended-partition? partitions)) + (items + `(normal ,@(if other-extended-partitions? + '() + '(extended))))) + (run-listbox-selection-page + #:info-text (G_ "Please select a partition type") + #:title (G_ "Partition type") + #:listbox-items items + #:listbox-item->text symbol->string + #:sort-listbox-items? #f + #:button-text (G_ "Cancel") + #:button-callback-procedure button-cancel-action))) + +(define (run-fs-type-page) + "Run a page asking the user to select a file-system type." + (run-listbox-selection-page + #:info-text (G_ "Please select the file-system type for this partition") + #:title (G_ "File-system type") + #:listbox-items '(ext4 btrfs fat32 swap) + #:listbox-item->text user-fs-type-name + #:sort-listbox-items? #f + #:button-text (G_ "Cancel") + #:button-callback-procedure button-cancel-action)) + +(define (inform-can-create-partition? user-partition) + "Return #t if it is possible to create USER-PARTITION. This is determined by +calling CAN-CREATE-PARTITION? procedure. If an exception is raised, catch it +an inform the user with an appropriate error-page and return #f." + (guard (c ((max-primary-exceeded? c) + (run-error-page + (G_ "Primary partitions count exceeded") + (G_ "Creation error")) + #f) + ((extended-creation-error? c) + (run-error-page + (G_ "Extended partition creation error") + (G_ "Creation error")) + #f) + ((logical-creation-error? c) + (run-error-page + (G_ "Logical partition creation error") + (G_ "Creation error")) + #f)) + (can-create-partition? user-partition))) + +(define* (run-partition-page target-user-partition + #:key + (default-item #f)) + "Run a page allowing the user to edit the given TARGET-USER-PARTITION +record. If the argument DEFAULT-ITEM is passed, use it to select the current +listbox item. This is used to avoid the focus to switch back to the first +listbox entry while calling this procedure recursively." + + (define (numeric-size device size) + "Parse the given SIZE on DEVICE and return it." + (call-with-values + (lambda () + (unit-parse size device)) + (lambda (value range) + value))) + + (define (numeric-size-range device size) + "Parse the given SIZE on DEVICE and return the associated RANGE." + (call-with-values + (lambda () + (unit-parse size device)) + (lambda (value range) + range))) + + (define* (fill-user-partition-geom user-part + #:key + device (size #f) start end) + "Return the given USER-PART with the START, END and SIZE fields set to the +eponym arguments. Use UNIT-FORMAT-CUSTOM to format START and END arguments as +sectors on DEVICE." + (user-partition + (inherit user-part) + (size size) + (start (unit-format-custom device start UNIT-SECTOR)) + (end (unit-format-custom device end UNIT-SECTOR)))) + + (define (apply-user-partition-changes user-part) + "Set the name, file-system type and boot flag on the partition specified +by USER-PART, if it is applicable for the partition type." + (let* ((partition (user-partition-parted-object user-part)) + (disk (partition-disk partition)) + (disk-type (disk-disk-type disk)) + (device (disk-device disk)) + (has-name? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-PARTITION-NAME)) + (name (user-partition-name user-part)) + (fs-type (filesystem-type-get + (user-fs-type-name + (user-partition-fs-type user-part)))) + (bootable? (user-partition-bootable? user-part)) + (esp? (user-partition-esp? user-part)) + (flag-bootable? + (partition-is-flag-available? partition PARTITION-FLAG-BOOT)) + (flag-esp? + (partition-is-flag-available? partition PARTITION-FLAG-ESP))) + (when (and has-name? name) + (partition-set-name partition name)) + (partition-set-system partition fs-type) + (when flag-bootable? + (partition-set-flag partition + PARTITION-FLAG-BOOT + (if bootable? 1 0))) + (when flag-esp? + (partition-set-flag partition + PARTITION-FLAG-ESP + (if esp? 1 0))) + #t)) + + (define (listbox-action listbox-item) + (let* ((item (car listbox-item)) + (partition (user-partition-parted-object + target-user-partition)) + (disk (partition-disk partition)) + (device (disk-device disk))) + (list + item + (case item + ((name) + (let* ((old-name (user-partition-name target-user-partition)) + (name + (run-input-page (G_ "Please enter the partition gpt name.") + (G_ "Partition name") + #:default-text old-name))) + (user-partition + (inherit target-user-partition) + (name name)))) + ((type) + (let ((new-type (run-type-page partition))) + (user-partition + (inherit target-user-partition) + (type new-type)))) + ((bootable) + (user-partition + (inherit target-user-partition) + (bootable? (not (user-partition-bootable? + target-user-partition))))) + ((esp?) + (let ((new-esp? (not (user-partition-esp? + target-user-partition)))) + (user-partition + (inherit target-user-partition) + (esp? new-esp?) + (mount-point (if new-esp? + (default-esp-mount-point) + ""))))) + ((need-formating?) + (user-partition + (inherit target-user-partition) + (need-formating? + (not (user-partition-need-formating? + target-user-partition))))) + ((size) + (let* ((old-size (user-partition-size target-user-partition)) + (max-size-value (partition-length partition)) + (max-size (unit-format device max-size-value)) + (start (partition-start partition)) + (size (run-input-page + (format #f (G_ "Please enter the size of the partition.\ + The maximum size is ~a.") max-size) + (G_ "Partition size") + #:default-text (or old-size max-size))) + (size-percentage (read-percentage size)) + (size-value (if size-percentage + (nearest-exact-integer + (/ (* max-size-value size-percentage) + 100)) + (numeric-size device size))) + (end (and size-value + (+ start size-value))) + (size-range (numeric-size-range device size)) + (size-range-ok? (and size-range + (< (+ start + (geometry-start size-range)) + (partition-end partition))))) + (cond + ((and size-percentage (> size-percentage 100)) + (run-error-page + (G_ "The percentage can not be superior to 100.") + (G_ "Size error")) + target-user-partition) + ((not size-value) + (run-error-page + (G_ "The requested size is incorrectly formatted, or too large.") + (G_ "Size error")) + target-user-partition) + ((not (or size-percentage size-range-ok?)) + (run-error-page + (G_ "The request size is superior to the maximum size.") + (G_ "Size error")) + target-user-partition) + (else + (fill-user-partition-geom target-user-partition + #:device device + #:size size + #:start start + #:end end))))) + ((fs-type) + (let ((fs-type (run-fs-type-page))) + (user-partition + (inherit target-user-partition) + (fs-type fs-type)))) + ((mount-point) + (let* ((old-mount (or (user-partition-mount-point + target-user-partition) + "")) + (mount + (run-input-page + (G_ "Please enter the desired mounting point for this \ +partition. Leave this field empty if you don't want to set a mounting point.") + (G_ "Mounting point") + #:default-text old-mount + #:allow-empty-input? #t))) + (user-partition + (inherit target-user-partition) + (mount-point (and (not (string=? mount "")) + mount))))))))) + + (define (button-action) + (let* ((partition (user-partition-parted-object + target-user-partition)) + (prev-part (partition-prev partition)) + (disk (partition-disk partition)) + (device (disk-device disk)) + (creation? (freespace-partition? partition)) + (start (partition-start partition)) + (end (partition-end partition)) + (new-user-partition + (if (user-partition-start target-user-partition) + target-user-partition + (fill-user-partition-geom target-user-partition + #:device device + #:start start + #:end end)))) + ;; It the backend PARTITION has free-space type, it means we are + ;; creating a new partition, otherwise, we are editing an already + ;; existing PARTITION. + (if creation? + (let* ((ok-create-partition? + (inform-can-create-partition? new-user-partition)) + (new-partition + (and ok-create-partition? + (mkpart disk + new-user-partition + #:previous-partition prev-part)))) + (and new-partition + (user-partition + (inherit new-user-partition) + (need-formating? #t) + (path (partition-get-path new-partition)) + (disk-path (device-path device)) + (parted-object new-partition)))) + (and (apply-user-partition-changes new-user-partition) + new-user-partition)))) + + (let* ((items (user-partition-description target-user-partition)) + (partition (user-partition-parted-object + target-user-partition)) + (disk (partition-disk partition)) + (device (disk-device disk)) + (path (device-path device)) + (number-str (partition-print-number partition)) + (type (user-partition-type target-user-partition)) + (type-str (symbol->string type)) + (start (unit-format device (partition-start partition))) + (creation? (freespace-partition? partition)) + (default-item (and default-item + (find (lambda (item) + (eq? (car item) default-item)) + items))) + (result + (run-listbox-selection-page + #:info-text + (if creation? + (G_ (format #f "Creating ~a partition starting at ~a of ~a." + type-str start path)) + (G_ (format #f "You are currently editing partition ~a." + number-str))) + #:title (if creation? + (G_ "Partition creation") + (G_ "Partition edit")) + #:listbox-items items + #:listbox-item->text cdr + #:sort-listbox-items? #f + #:listbox-default-item default-item + #:button-text (G_ "Ok") + #:listbox-callback-procedure listbox-action + #:button-callback-procedure button-action))) + (match result + ((item new-user-partition) + (run-partition-page new-user-partition + #:default-item item)) + (else result)))) + +(define* (run-disk-page disks + #:optional (user-partitions '())) + "Run a page allowing to edit the partition tables of the given DISKS. If +specified, USER-PARTITIONS is a list of records associated to +the partitions on DISKS." + + (define (other-logical-partitions? partitions) + "Return #t if at least one of the partition in PARTITIONS list is a +logical partition, return #f otherwise." + (any logical-partition? partitions)) + + (define (other-non-logical-partitions? partitions) + "Return #t is at least one of the partitions in PARTITIONS list is not a +logical partition, return #f otherwise." + (let ((non-logical-partitions + (remove logical-partition? partitions))) + (or (any normal-partition? non-logical-partitions) + (any freespace-partition? non-logical-partitions)))) + + (define (add-tree-symbols partitions descriptions) + "Concatenate tree symbols to the given DESCRIPTIONS list and return +it. The PARTITIONS list is the list of partitions described in +DESCRIPTIONS. The tree symbols are used to indicate the partition's disk and +for logical partitions, the extended partition which includes them." + (match descriptions + (() '()) + ((description . rest-descriptions) + (match partitions + ((partition . rest-partitions) + (if (null? rest-descriptions) + (list (if (logical-partition? partition) + (string-append " ┗━ " description) + (string-append "┗━ " description))) + (cons (cond + ((extended-partition? partition) + (if (other-non-logical-partitions? rest-partitions) + (string-append "┣┳ " description) + (string-append "┗┳ " description))) + ((logical-partition? partition) + (if (other-logical-partitions? rest-partitions) + (if (other-non-logical-partitions? rest-partitions) + (string-append "┃┣━ " description) + (string-append " ┣━ " description)) + (if (other-non-logical-partitions? rest-partitions) + (string-append "┃┗━ " description) + (string-append " ┗━ " description)))) + (else + (string-append "┣━ " description))) + (add-tree-symbols rest-partitions + rest-descriptions)))))))) + + (define (skip-item? item) + (eq? (car item) 'skip)) + + (define (disk-items) + "Return the list of strings describing DISKS." + (let loop ((disks disks)) + (match disks + (() '()) + ((disk . rest) + (let* ((device (disk-device disk)) + (partitions (disk-partitions disk)) + (partitions* + (filter-map + (lambda (partition) + (and (not (metadata-partition? partition)) + (not (small-freespace-partition? device + partition)) + partition)) + partitions)) + (descriptions (add-tree-symbols + partitions* + (partitions-descriptions partitions* + user-partitions))) + (partition-items (map cons partitions* descriptions))) + (append + `((,disk . ,(device-description device disk)) + ,@partition-items + ,@(if (null? rest) + '() + '((skip . "")))) + (loop rest))))))) + + (define (remove-user-partition-by-partition user-partitions partition) + "Return the USER-PARTITIONS list with the record with the given PARTITION +object removed. If PARTITION is an extended partition, also remove all logical +partitions from USER-PARTITIONS." + (remove (lambda (p) + (let ((cur-partition (user-partition-parted-object p))) + (or (equal? cur-partition partition) + (and (extended-partition? partition) + (logical-partition? cur-partition))))) + user-partitions)) + + (define (remove-user-partition-by-disk user-partitions disk) + "Return the USER-PARTITIONS list with the records located +on given DISK removed." + (remove (lambda (p) + (let* ((partition (user-partition-parted-object p)) + (cur-disk (partition-disk partition))) + (equal? cur-disk disk))) + user-partitions)) + + (define (update-user-partitions user-partitions new-user-partition) + "Update or insert NEW-USER-PARTITION record in USER-PARTITIONS list +depending if one of the record in USER-PARTITIONS has the +same PARTITION object as NEW-USER-PARTITION." + (let* ((partition (user-partition-parted-object new-user-partition)) + (user-partitions* + (remove-user-partition-by-partition user-partitions + partition))) + (cons new-user-partition user-partitions*))) + + (define (button-ok-action) + "Commit the modifications to all DISKS and return #t." + (for-each (lambda (disk) + (disk-commit disk)) + disks) + #t) + + (define (listbox-action listbox-item) + "A disk or a partition has been selected. If it's a disk, ask for a label +to create a new partition table. If it is a partition, propose the user to +edit it." + (let ((item (car listbox-item))) + (cond + ((disk? item) + (let ((label (run-label-page (const #f)))) + (if label + (let* ((device (disk-device item)) + (new-disk (mklabel device label)) + (commit-new-disk (disk-commit new-disk)) + (other-disks (remove (lambda (disk) + (equal? disk item)) + disks)) + (new-user-partitions + (remove-user-partition-by-disk user-partitions item))) + (disk-destroy item) + `((disks . ,(cons new-disk other-disks)) + (user-partitions . ,new-user-partitions))) + `((disks . ,disks) + (user-partitions . ,user-partitions))))) + ((partition? item) + (let* ((partition item) + (disk (partition-disk partition)) + (device (disk-device disk)) + (existing-user-partition + (find-user-partition-by-parted-object user-partitions + partition)) + (edit-user-partition + (or existing-user-partition + (partition->user-partition partition)))) + `((disks . ,disks) + (user-partitions . ,user-partitions) + (edit-user-partition . ,edit-user-partition))))))) + + (define (hotkey-action key listbox-item) + "The DELETE key has been pressed on a disk or a partition item." + (let ((item (car listbox-item)) + (default-result + `((disks . ,disks) + (user-partitions . ,user-partitions)))) + (cond + ((disk? item) + (let* ((device (disk-device item)) + (path (device-path device)) + (info-text + (format #f (G_ "Are you sure you want to delete everything on disk ~a?") + path)) + (result (choice-window (G_ "Delete disk") + (G_ "Ok") + (G_ "Cancel") + info-text))) + (case result + ((1) + (disk-delete-all item) + `((disks . ,disks) + (user-partitions + . ,(remove-user-partition-by-disk user-partitions item)))) + (else + default-result)))) + ((partition? item) + (if (freespace-partition? item) + (run-error-page (G_ "You cannot delete a free space area.") + (G_ "Delete partition")) + (let* ((disk (partition-disk item)) + (number-str (partition-print-number item)) + (info-text + (format #f (G_ "Are you sure you want to delete partition ~a?") + number-str)) + (result (choice-window (G_ "Delete partition") + (G_ "Ok") + (G_ "Cancel") + info-text))) + (case result + ((1) + (let ((new-user-partitions + (remove-user-partition-by-partition user-partitions + item))) + (disk-delete-partition disk item) + `((disks . ,disks) + (user-partitions . ,new-user-partitions)))) + (else + default-result)))))))) + + (let ((result + (run-listbox-selection-page + + #:info-text (G_ "You can change a disk's partition table by \ +selecting it and pressing ENTER. You can also edit a partition by selecting it \ +and pressing ENTER, or remove it by pressing DELETE. To create a new \ +partition, select a free space area and press ENTER. + +At least one partition must have its mounting point set to '/'.") + + #:title (G_ "Manual partitioning") + #:info-textbox-width 70 + #:listbox-items (disk-items) + #:listbox-item->text cdr + #:sort-listbox-items? #f + #:skip-item-procedure? skip-item? + #:allow-delete? #t + #:button-text (G_ "Ok") + #:button-callback-procedure button-ok-action + #:button2-text (G_ "Cancel") + #:button2-callback-procedure button-cancel-action + #:listbox-callback-procedure listbox-action + #:hotkey-callback-procedure hotkey-action))) + (if (eq? result #t) + (let ((user-partitions-ok? + (guard + (c ((no-root-mount-point? c) + (run-error-page + (G_ "No root mount point found") + (G_ "Missing mount point")) + #f)) + (check-user-partitions user-partitions)))) + (if user-partitions-ok? + (begin + (for-each (cut disk-destroy <>) disks) + user-partitions) + (run-disk-page disks user-partitions))) + (let* ((result-disks (assoc-ref result 'disks)) + (result-user-partitions (assoc-ref result + 'user-partitions)) + (edit-user-partition (assoc-ref result + 'edit-user-partition)) + (can-create-partition? + (and edit-user-partition + (inform-can-create-partition? edit-user-partition))) + (new-user-partition (and edit-user-partition + can-create-partition? + (run-partition-page + edit-user-partition))) + (new-user-partitions + (if new-user-partition + (update-user-partitions result-user-partitions + new-user-partition) + result-user-partitions))) + (run-disk-page result-disks new-user-partitions))))) + +(define (run-partioning-page) + "Run a page asking the user for a partitioning method." + (define (run-page devices) + (let* ((items + '((entire . "Guided - using the entire disk") + (manual . "Manual"))) + (result (run-listbox-selection-page + #:info-text (G_ "Please select a partitioning method.") + #:title (G_ "Partitioning method") + #:listbox-items items + #:listbox-item->text cdr + #:button-text (G_ "Cancel") + #:button-callback-procedure button-cancel-action)) + (method (car result))) + (case method + ((entire) + (let* ((device (run-device-page devices)) + (disk-type (disk-probe device)) + (disk (if disk-type + (disk-new device) + (let* ((label (run-label-page + button-cancel-action)) + (disk (mklabel device label))) + (disk-commit disk) + disk))) + (scheme (symbol-append method '- (run-scheme-page))) + (user-partitions (append + (auto-partition disk #:scheme scheme) + (create-special-user-partitions + (disk-partitions disk))))) + (run-disk-page (list disk) user-partitions))) + ((manual) + (let* ((disks (map disk-new devices)) + (user-partitions (append-map + create-special-user-partitions + (map disk-partitions disks))) + (result-user-partitions (run-disk-page disks + user-partitions))) + result-user-partitions))))) + + (init-parted) + (let* ((non-install-devices (non-install-devices)) + (user-partitions (run-page non-install-devices)) + (form (draw-formating-page))) + ;; Make sure the disks are not in use before proceeding to formating. + (free-parted non-install-devices) + (run-error-page (format #f "~a" user-partitions) + "user-partitions") + (format-user-partitions user-partitions) + (destroy-form-and-pop form) + user-partitions)) diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm new file mode 100644 index 0000000000..3fe938124f --- /dev/null +++ b/gnu/installer/parted.scm @@ -0,0 +1,1210 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Mathieu Othacehe +;;; +;;; 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 . + +(define-module (gnu installer parted) + #:use-module (gnu installer steps) + #:use-module (gnu installer utils) + #:use-module (gnu installer newt page) + #:use-module (gnu system uuid) + #:use-module ((gnu build file-systems) + #:select (read-partition-uuid)) + #:use-module (guix build syscalls) + #:use-module (guix build utils) + #:use-module (guix records) + #:use-module (guix i18n) + #:use-module (parted) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:export ( + user-partition + make-user-partition + user-partition? + user-partition-name + user-partition-type + user-partition-path + user-partition-disk-path + user-partition-fs-type + user-partition-bootable? + user-partition-esp? + user-partition-bios-grub? + user-partition-size + user-partition-start + user-partition-end + user-partition-mount-point + user-partition-need-formating? + user-partition-parted-object + + find-esp-partition + data-partition? + metadata-partition? + freespace-partition? + small-freespace-partition? + normal-partition? + extended-partition? + logical-partition? + esp-partition? + boot-partition? + default-esp-mount-point + + with-delay-device-in-use? + force-device-sync + non-install-devices + partition-user-type + user-fs-type-name + partition-filesystem-user-type + partition-get-flags + partition->user-partition + create-special-user-partitions + find-user-partition-by-parted-object + + device-description + partition-end-formatted + partition-print-number + partition-description + partitions-descriptions + user-partition-description + + &max-primary-exceeded + max-primary-exceeded? + &extended-creation-error + extended-creation-error? + &logical-creation-error + logical-creation-error? + + can-create-partition? + mklabel + mkpart + rmpart + + create-adjacent-partitions + auto-partition + + &no-root-mount-point + no-root-mount-point? + + check-user-partitions + set-user-partitions-path + format-user-partitions + mount-user-partitions + umount-user-partitions + with-mounted-partitions + user-partitions->file-systems + user-partitions->configuration + + init-parted + free-parted)) + + +;;; +;;; Partition record. +;;; + +(define-record-type* + user-partition make-user-partition + user-partition? + (name user-partition-name ;string + (default #f)) + (type user-partition-type + (default 'normal)) ; 'normal | 'logical | 'extended + (path user-partition-path + (default #f)) + (disk-path user-partition-disk-path + (default #f)) + (fs-type user-partition-fs-type + (default 'ext4)) + (bootable? user-partition-bootable? + (default #f)) + (esp? user-partition-esp? + (default #f)) + (bios-grub? user-partition-bios-grub? + (default #f)) + (size user-partition-size + (default #f)) + (start user-partition-start ;start as string (e.g. '11MB') + (default #f)) + (end user-partition-end ;same as start + (default #f)) + (mount-point user-partition-mount-point ;string + (default #f)) + (need-formating? user-partition-need-formating? ; boolean + (default #f)) + (parted-object user-partition-parted-object ; from parted + (default #f))) + + +;; +;; Utilities. +;; + +(define (find-esp-partition partitions) + "Find and return the ESP partition among PARTITIONS." + (find esp-partition? partitions)) + +(define (data-partition? partition) + "Return #t if PARTITION is a partition dedicated to data (by opposition to +freespace, metadata and protected partition types), return #f otherwise." + (let ((type (partition-type partition))) + (not (any (lambda (flag) + (member flag type)) + '(free-space metadata protected))))) + +(define (metadata-partition? partition) + "Return #t if PARTITION is a metadata partition, #f otherwise." + (let ((type (partition-type partition))) + (member 'metadata type))) + +(define (freespace-partition? partition) + "Return #t if PARTITION is a free-space partition, #f otherwise." + (let ((type (partition-type partition))) + (member 'free-space type))) + +(define* (small-freespace-partition? device + partition + #:key (max-size MEBIBYTE-SIZE)) + "Return #t is PARTITION is a free-space partition with less a size strictly +inferior to MAX-SIZE, #f otherwise." + (let ((size (partition-length partition)) + (max-sector-size (/ max-size + (device-sector-size device)))) + (< size max-sector-size))) + +(define (normal-partition? partition) + "return #t if partition is a normal partition, #f otherwise." + (let ((type (partition-type partition))) + (member 'normal type))) + +(define (extended-partition? partition) + "return #t if partition is an extended partition, #f otherwise." + (let ((type (partition-type partition))) + (member 'extended type))) + +(define (logical-partition? partition) + "Return #t if PARTITION is a logical partition, #f otherwise." + (let ((type (partition-type partition))) + (member 'logical type))) + +(define (partition-user-type partition) + "Return the type of PARTITION, to be stored in the TYPE field of + record. It can be 'normal, 'extended or 'logical." + (cond ((normal-partition? partition) + 'normal) + ((extended-partition? partition) + 'extended) + ((logical-partition? partition) + 'logical) + (else #f))) + +(define (esp-partition? partition) + "Return #t if partition has the ESP flag, return #f otherwise." + (let* ((disk (partition-disk partition)) + (disk-type (disk-disk-type disk)) + (has-extended? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-EXTENDED))) + (and (data-partition? partition) + (not has-extended?) + (partition-is-flag-available? partition PARTITION-FLAG-ESP) + (partition-get-flag partition PARTITION-FLAG-ESP)))) + +(define (boot-partition? partition) + "Return #t if partition has the boot flag, return #f otherwise." + (and (data-partition? partition) + (partition-is-flag-available? partition PARTITION-FLAG-BOOT) + (partition-get-flag partition PARTITION-FLAG-BOOT))) + + +;; The default mount point for ESP partitions. +(define default-esp-mount-point + (make-parameter "/boot/efi")) + +(define (efi-installation?) + "Return #t if an EFI installation should be performed, #f otherwise." + (file-exists? "/sys/firmware/efi")) + +(define (user-fs-type-name fs-type) + "Return the name of FS-TYPE as specified by libparted." + (case fs-type + ((ext4) "ext4") + ((btrfs) "btrfs") + ((fat32) "fat32") + ((swap) "linux-swap"))) + +(define (user-fs-type->mount-type fs-type) + "Return the mount type of FS-TYPE." + (case fs-type + ((ext4) "ext4") + ((btrfs) "btrfs") + ((fat32) "vfat"))) + +(define (partition-filesystem-user-type partition) + "Return the filesystem type of PARTITION, to be stored in the FS-TYPE field +of record." + (let ((fs-type (partition-fs-type partition))) + (and fs-type + (let ((name (filesystem-type-name fs-type))) + (cond + ((string=? name "ext4") 'ext4) + ((string=? name "btrfs") 'btrfs) + ((string=? name "fat32") 'fat32) + ((or (string=? name "swsusp") + (string=? name "linux-swap(v0)") + (string=? name "linux-swap(v1)")) + 'swap) + (else + (error (format #f "Unhandled ~a fs-type~%" name)))))))) + +(define (partition-get-flags partition) + "Return the list of flags supported by the given PARTITION." + (filter-map (lambda (flag) + (and (partition-get-flag partition flag) + flag)) + (partition-flags partition))) + +(define (partition->user-partition partition) + "Convert PARTITION into a record and return it." + (let* ((disk (partition-disk partition)) + (device (disk-device disk)) + (disk-type (disk-disk-type disk)) + (has-name? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-PARTITION-NAME)) + (name (and has-name? + (data-partition? partition) + (partition-get-name partition)))) + (user-partition + (name (and (and name + (not (string=? name ""))) + name)) + (type (or (partition-user-type partition) + 'normal)) + (path (partition-get-path partition)) + (disk-path (device-path device)) + (fs-type (or (partition-filesystem-user-type partition) + 'ext4)) + (mount-point (and (esp-partition? partition) + (default-esp-mount-point))) + (bootable? (boot-partition? partition)) + (esp? (esp-partition? partition)) + (parted-object partition)))) + +(define (create-special-user-partitions partitions) + "Return a list with a record describing the ESP partition +found in PARTITIONS, if any." + (filter-map (lambda (partition) + (and (esp-partition? partition) + (partition->user-partition partition))) + partitions)) + +(define (find-user-partition-by-parted-object user-partitions + partition) + "Find and return the record in USER-PARTITIONS list which +PARTED-OBJECT field equals PARTITION, return #f if not found." + (find (lambda (user-partition) + (equal? (user-partition-parted-object user-partition) + partition)) + user-partitions)) + + +;; +;; Devices +;; + +(define (with-delay-device-in-use? path) + "Call DEVICE-IN-USE? with a few retries, as the first re-read will often +fail. See rereadpt function in wipefs.c of util-linux for an explanation." + (let loop ((try 4)) + (usleep 250000) + (let ((in-use? (device-in-use? path))) + (if (and in-use? (> try 0)) + (loop (- try 1)) + in-use?)))) + +(define* (force-device-sync device) + "Force a flushing of the given DEVICE." + (device-open device) + (device-sync device) + (device-close device)) + +(define (non-install-devices) + "Return all the available devices, except the busy one, allegedly the +install device. DEVICE-IS-BUSY? is a parted call, checking if the device is +mounted. The install image uses an overlayfs so the install device does not +appear as mounted and won't be considered as busy. So use also DEVICE-IN-USE? +from (guix build syscalls) module, who will try to re-read the device's +partition table to determine whether or not it is already used (like sfdisk +from util-linux)." + (remove (lambda (device) + (let ((path (device-path device))) + (or (device-is-busy? device) + (with-delay-device-in-use? path)))) + (devices))) + + +;; +;; Disk and partition printing. +;; + +(define* (device-description device #:optional disk) + "Return a string describing the given DEVICE." + (let* ((type (device-type device)) + (path (device-path device)) + (model (device-model device)) + (type-str (device-type->string type)) + (disk-type (if disk + (disk-disk-type disk) + (disk-probe device))) + (length (device-length device)) + (sector-size (device-sector-size device)) + (end (unit-format-custom-byte device + (* length sector-size) + UNIT-GIGABYTE))) + (string-join + `(,@(if (string=? model "") + `(,type-str) + `(,model ,(string-append "(" type-str ")"))) + ,path + ,end + ,@(if disk-type + `(,(disk-type-name disk-type)) + '())) + " "))) + +(define (partition-end-formatted device partition) + "Return as a string the end of PARTITION with the relevant unit." + (unit-format-byte + device + (- + (* (+ (partition-end partition) 1) + (device-sector-size device)) + 1))) + +(define (partition-print-number partition) + "Convert the given partition NUMBER to string." + (let ((number (partition-number partition))) + (number->string number))) + +(define (partition-description partition user-partition) + "Return a string describing the given PARTITION, located on the DISK of +DEVICE." + + (define (partition-print-type partition) + "Return the type of PARTITION as a string." + (if (freespace-partition? partition) + (G_ "Free space") + (let ((type (partition-type partition))) + (match type + ((type-symbol) + (symbol->string type-symbol)))))) + + (define (partition-print-flags partition) + "Return the flags of PARTITION as a string of comma separated flags." + (string-join + (filter-map + (lambda (flag) + (and (partition-get-flag partition flag) + (partition-flag-get-name flag))) + (partition-flags partition)) + ",")) + + (define (maybe-string-pad string length) + "Returned a string formatted by padding STRING of LENGTH characters to the +right. If STRING is #f use an empty string." + (string-pad-right (or string "") length)) + + (let* ((disk (partition-disk partition)) + (device (disk-device disk)) + (disk-type (disk-disk-type disk)) + (has-name? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-PARTITION-NAME)) + (has-extended? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-EXTENDED)) + (part-type (partition-print-type partition)) + (number (and (not (freespace-partition? partition)) + (partition-print-number partition))) + (name (and has-name? + (if (freespace-partition? partition) + (G_ "Free space") + (partition-get-name partition)))) + (start (unit-format device + (partition-start partition))) + (end (partition-end-formatted device partition)) + (size (unit-format device (partition-length partition))) + (fs-type (partition-fs-type partition)) + (fs-type-name (and fs-type + (filesystem-type-name fs-type))) + (flags (and (not (freespace-partition? partition)) + (partition-print-flags partition))) + (mount-point (and user-partition + (user-partition-mount-point user-partition)))) + `(,(or number "") + ,@(if has-extended? + (list part-type) + '()) + ,size + ,(or fs-type-name "") + ,(or flags "") + ,(or mount-point "") + ,(maybe-string-pad name 30)))) + +(define (partitions-descriptions partitions user-partitions) + "Return a list of strings describing all the partitions found on +DEVICE. METADATA partitions are not described. The strings are padded to the +right so that they can be displayed as a table." + + (define (max-length-column lists column-index) + "Return the maximum length of the string at position COLUMN-INDEX in the +list of string lists LISTS." + (apply max + (map (lambda (list) + (string-length + (list-ref list column-index))) + lists))) + + (define (pad-descriptions descriptions) + "Return a padded version of the list of string lists DESCRIPTIONS. The +strings are padded to the length of the longer string in a same column, as +determined by MAX-LENGTH-COLUMN procedure." + (let* ((description-length (length (car descriptions))) + (paddings (map (lambda (index) + (max-length-column descriptions index)) + (iota description-length)))) + (map (lambda (description) + (map string-pad-right description paddings)) + descriptions))) + + (let* ((descriptions + (map + (lambda (partition) + (let ((user-partition + (find-user-partition-by-parted-object user-partitions + partition))) + (partition-description partition user-partition))) + partitions)) + (padded-descriptions (if (null? partitions) + '() + (pad-descriptions descriptions)))) + (map (cut string-join <> " ") padded-descriptions))) + +(define (user-partition-description user-partition) + "Return a string describing the given USER-PARTITION record." + (let* ((partition (user-partition-parted-object user-partition)) + (disk (partition-disk partition)) + (disk-type (disk-disk-type disk)) + (device (disk-device disk)) + (has-name? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-PARTITION-NAME)) + (has-extended? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-EXTENDED)) + (name (user-partition-name user-partition)) + (type (user-partition-type user-partition)) + (type-name (symbol->string type)) + (fs-type (user-partition-fs-type user-partition)) + (fs-type-name (user-fs-type-name fs-type)) + (bootable? (user-partition-bootable? user-partition)) + (esp? (user-partition-esp? user-partition)) + (need-formating? (user-partition-need-formating? user-partition)) + (size (user-partition-size user-partition)) + (mount-point (user-partition-mount-point user-partition))) + `(,@(if has-name? + `((name . ,(string-append "Name: " (or name "None")))) + '()) + ,@(if (and has-extended? + (freespace-partition? partition) + (not (eq? type 'logical))) + `((type . ,(string-append "Type: " type-name))) + '()) + ,@(if (eq? type 'extended) + '() + `((fs-type . ,(string-append "Filesystem type: " fs-type-name)))) + ,@(if (or (eq? type 'extended) + (eq? fs-type 'swap) + (not has-extended?)) + '() + `((bootable . ,(string-append "Bootable flag: " + (if bootable? "On" "Off"))))) + ,@(if (and (not has-extended?) + (not (eq? fs-type 'swap))) + `((esp? . ,(string-append "ESP flag: " + (if esp? "On" "Off")))) + '()) + ,@(if (freespace-partition? partition) + (let ((size-formatted + (or size (unit-format device + (partition-length partition))))) + `((size . ,(string-append "Size : " size-formatted)))) + '()) + ,@(if (or (freespace-partition? partition) + (eq? fs-type 'swap)) + '() + `((need-formating? + . ,(string-append "Format the partition? : " + (if need-formating? "Yes" "No"))))) + ,@(if (or (eq? type 'extended) + (eq? fs-type 'swap)) + '() + `((mount-point + . ,(string-append "Mount point : " + (or mount-point + (and esp? (default-esp-mount-point)) + "None")))))))) + + +;; +;; Partition table creation. +;; + +(define (mklabel device type-name) + "Create a partition table on DEVICE. TYPE-NAME is the type of the partition +table, \"msdos\" or \"gpt\"." + (let ((type (disk-type-get type-name))) + (disk-new-fresh device type))) + + +;; +;; Partition creation. +;; + +;; The maximum count of primary partitions is exceeded. +(define-condition-type &max-primary-exceeded &condition + max-primary-exceeded?) + +;; It is not possible to create an extended partition. +(define-condition-type &extended-creation-error &condition + extended-creation-error?) + +;; It is not possible to create a logical partition. +(define-condition-type &logical-creation-error &condition + logical-creation-error?) + +(define (can-create-primary? disk) + "Return #t if it is possible to create a primary partition on DISK, return +#f otherwise." + (let ((max-primary (disk-get-max-primary-partition-count disk))) + (find (lambda (number) + (not (disk-get-partition disk number))) + (iota max-primary 1)))) + +(define (can-create-extended? disk) + "Return #t if it is possible to create an extended partition on DISK, return +#f otherwise." + (let* ((disk-type (disk-disk-type disk)) + (has-extended? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-EXTENDED))) + (and (can-create-primary? disk) + has-extended? + (not (disk-extended-partition disk))))) + +(define (can-create-logical? disk) + "Return #t is it is possible to create a logical partition on DISK, return +#f otherwise." + (let* ((disk-type (disk-disk-type disk)) + (has-extended? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-EXTENDED))) + (and has-extended? + (disk-extended-partition disk)))) + +(define (can-create-partition? user-part) + "Return #t if it is possible to create the given USER-PART record, return #f +otherwise." + (let* ((type (user-partition-type user-part)) + (partition (user-partition-parted-object user-part)) + (disk (partition-disk partition))) + (case type + ((normal) + (or (can-create-primary? disk) + (raise + (condition (&max-primary-exceeded))))) + ((extended) + (or (can-create-extended? disk) + (raise + (condition (&extended-creation-error))))) + ((logical) + (or (can-create-logical? disk) + (raise + (condition (&logical-creation-error)))))))) + +(define* (mkpart disk user-partition + #:key (previous-partition #f)) + "Create the given USER-PARTITION on DISK. The PREVIOUS-PARTITION argument as +to be set to the partition preceeding USER-PARTITION if any." + + (define (parse-start-end start end) + "Parse start and end strings as positions on DEVICE expressed with a unit, +like '100GB' or '12.2KiB'. Return a list of 4 elements, the start sector, its +range (1 unit large area centered on start sector), the end sector and its +range." + (let ((device (disk-device disk))) + (call-with-values + (lambda () + (unit-parse start device)) + (lambda (start-sector start-range) + (call-with-values + (lambda () + (unit-parse end device)) + (lambda (end-sector end-range) + (list start-sector start-range + end-sector end-range))))))) + + (define* (extend-ranges! start-range end-range + #:key (offset 0)) + "Try to extend START-RANGE by 1 MEBIBYTE to the right and END-RANGE by 1 +MEBIBYTE to the left. This way, if the disk is aligned on 2048 sectors of +512KB (like frequently), we will have a chance for the +'optimal-align-constraint' to succeed. Do not extend ranges if that would +cause them to cross." + (let* ((device (disk-device disk)) + (start-range-end (geometry-end start-range)) + (end-range-start (geometry-start end-range)) + (mebibyte-sector-size (/ MEBIBYTE-SIZE + (device-sector-size device))) + (new-start-range-end + (+ start-range-end mebibyte-sector-size offset)) + (new-end-range-start + (- end-range-start mebibyte-sector-size offset))) + (when (< new-start-range-end new-end-range-start) + (geometry-set-end start-range new-start-range-end) + (geometry-set-start end-range new-end-range-start)))) + + (match (parse-start-end (user-partition-start user-partition) + (user-partition-end user-partition)) + ((start-sector start-range end-sector end-range) + (let* ((prev-end (if previous-partition + (partition-end previous-partition) + 0)) + (start-distance (- start-sector prev-end)) + (type (user-partition-type user-partition)) + ;; There should be at least 2 unallocated sectors in front of each + ;; logical partition, otherwise parted will fail badly: + ;; https://gparted.org/h2-fix-msdos-pt.php#apply-action-fail. + (start-offset (if previous-partition + (- 3 start-distance) + 0)) + (start-sector* (if (and (eq? type 'logical) + (< start-distance 3)) + (+ start-sector start-offset) + start-sector))) + ;; This is a hackery but parted almost always fails to create optimally + ;; aligned partitions (unless specifiying percentages) because, the + ;; default range of 1MB centered on the start sector is not enough when + ;; the optimal alignment is 2048 sectors of 512KB. + (extend-ranges! start-range end-range #:offset start-offset) + + (let* ((device (disk-device disk)) + (disk-type (disk-disk-type disk)) + (length (device-length device)) + (name (user-partition-name user-partition)) + (filesystem-type + (filesystem-type-get + (user-fs-type-name + (user-partition-fs-type user-partition)))) + (flags `(,@(if (user-partition-bootable? user-partition) + `(,PARTITION-FLAG-BOOT) + '()) + ,@(if (user-partition-esp? user-partition) + `(,PARTITION-FLAG-ESP) + '()) + ,@(if (user-partition-bios-grub? user-partition) + `(,PARTITION-FLAG-BIOS-GRUB) + '()))) + (has-name? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-PARTITION-NAME)) + (partition-type (partition-type->int type)) + (partition (partition-new disk + #:type partition-type + #:filesystem-type filesystem-type + #:start start-sector* + #:end end-sector)) + (user-constraint (constraint-new + #:start-align 'any + #:end-align 'any + #:start-range start-range + #:end-range end-range + #:min-size 1 + #:max-size length)) + (dev-constraint + (device-get-optimal-aligned-constraint device)) + (final-constraint (constraint-intersect user-constraint + dev-constraint)) + (no-constraint (constraint-any device)) + ;; Try to create a partition with an optimal alignment + ;; constraint. If it fails, fallback to creating a partition with + ;; no specific constraint. + (partition-ok? + (or (disk-add-partition disk partition final-constraint) + (disk-add-partition disk partition no-constraint)))) + ;; Set the partition name if supported. + (when (and partition-ok? has-name? name) + (partition-set-name partition name)) + + ;; Set flags is required. + (for-each (lambda (flag) + (and (partition-is-flag-available? partition flag) + (partition-set-flag partition flag 1))) + flags) + + (and partition-ok? + (partition-set-system partition filesystem-type) + partition)))))) + + +;; +;; Partition destruction. +;; + +(define (rmpart disk number) + "Remove the partition with the given NUMBER on DISK." + (let ((partition (disk-get-partition disk number))) + (disk-remove-partition disk partition))) + + +;; +;; Auto partitionning. +;; + +(define* (create-adjacent-partitions disk partitions + #:key (last-partition-end 0)) + "Create the given PARTITIONS on DISK. LAST-PARTITION-END is the sector from +which we want to start creating partitions. The START and END of each created +partition are computed from its SIZE value and the position of the last +partition." + (let ((device (disk-device disk))) + (let loop ((partitions partitions) + (remaining-space (- (device-length device) + last-partition-end)) + (start last-partition-end)) + (match partitions + (() '()) + ((partition . rest) + (let* ((size (user-partition-size partition)) + (percentage-size (and (string? size) + (read-percentage size))) + (sector-size (device-sector-size device)) + (partition-size (if percentage-size + (exact->inexact + (* (/ percentage-size 100) + remaining-space)) + size)) + (end-partition (min (- (device-length device) 1) + (nearest-exact-integer + (+ start partition-size 1)))) + (name (user-partition-name partition)) + (type (user-partition-type partition)) + (fs-type (user-partition-fs-type partition)) + (start-formatted (unit-format-custom device + start + UNIT-SECTOR)) + (end-formatted (unit-format-custom device + end-partition + UNIT-SECTOR)) + (new-user-partition (user-partition + (inherit partition) + (start start-formatted) + (end end-formatted))) + (new-partition + (mkpart disk new-user-partition))) + (if new-partition + (cons (user-partition + (inherit new-user-partition) + (path (partition-get-path new-partition)) + (disk-path (device-path device)) + (parted-object new-partition)) + (loop rest + (if (eq? type 'extended) + remaining-space + (- remaining-space + (partition-length new-partition))) + (if (eq? type 'extended) + (+ start 1) + (+ (partition-end new-partition) 1)))) + (error + (format #f "Unable to create partition ~a~%" name))))))))) + +(define (force-user-partitions-formating user-partitions) + "Set the NEED-FORMATING? fields to #t on all records of +USER-PARTITIONS list and return the updated list." + (map (lambda (p) + (user-partition + (inherit p) + (need-formating? #t))) + user-partitions)) + +(define* (auto-partition disk + #:key (scheme 'entire-root)) + "Automatically create partitions on DISK. All the previous +partitions (except the ESP on a GPT disk, if present) are wiped. SCHEME is the +desired partitioning scheme. It can be 'entire-root or +'entire-root-home. 'entire-root will create a swap partition and a root +partition occupying all the remaining space. 'entire-root-home will create a +swap partition, a root partition and a home partition." + (let* ((device (disk-device disk)) + (disk-type (disk-disk-type disk)) + (has-extended? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-EXTENDED)) + (partitions (filter data-partition? (disk-partitions disk))) + (esp-partition (find-esp-partition partitions)) + ;; According to + ;; https://wiki.archlinux.org/index.php/EFI_system_partition, the ESP + ;; size should be at least 550MiB. + (new-esp-size (nearest-exact-integer + (/ (* 550 MEBIBYTE-SIZE) + (device-sector-size device)))) + (end-esp-partition (and esp-partition + (partition-end esp-partition))) + (non-boot-partitions (remove esp-partition? partitions)) + (bios-grub-size (/ (* 3 MEBIBYTE-SIZE) + (device-sector-size device))) + (five-percent-disk (nearest-exact-integer + (* 0.05 (device-length device)))) + (default-swap-size (nearest-exact-integer + (/ (* 4 GIGABYTE-SIZE) + (device-sector-size device)))) + ;; Use a 4GB size for the swap if it represents less than 5% of the + ;; disk space. Otherwise, set the swap size to 5% of the disk space. + (swap-size (min default-swap-size five-percent-disk))) + + (if has-extended? + ;; msdos - remove everything. + (disk-delete-all disk) + ;; gpt - remove everything but esp if it exists. + (for-each + (lambda (partition) + (and (data-partition? partition) + (disk-remove-partition disk partition))) + non-boot-partitions)) + + (let* ((start-partition + (and (not has-extended?) + (not esp-partition) + (if (efi-installation?) + (user-partition + (fs-type 'fat32) + (esp? #t) + (size new-esp-size) + (mount-point (default-esp-mount-point))) + (user-partition + (fs-type 'ext4) + (bootable? #t) + (bios-grub? #t) + (size bios-grub-size))))) + (new-partitions + (case scheme + ((entire-root) + `(,@(if start-partition + `(,start-partition) + '()) + ,(user-partition + (fs-type 'swap) + (size swap-size)) + ,(user-partition + (fs-type 'ext4) + (bootable? has-extended?) + (size "100%") + (mount-point "/")))) + ((entire-root-home) + `(,@(if start-partition + `(,start-partition) + '()) + ,(user-partition + (fs-type 'ext4) + (bootable? has-extended?) + (size "33%") + (mount-point "/")) + ,@(if has-extended? + `(,(user-partition + (type 'extended) + (size "100%"))) + '()) + ,(user-partition + (type (if has-extended? + 'logical + 'normal)) + (fs-type 'swap) + (size swap-size)) + ,(user-partition + (type (if has-extended? + 'logical + 'normal)) + (fs-type 'ext4) + (size "100%") + (mount-point "/home")))))) + (new-partitions* (force-user-partitions-formating + new-partitions))) + (create-adjacent-partitions disk + new-partitions* + #:last-partition-end + (or end-esp-partition 0))))) + + +;; +;; Convert user-partitions. +;; + +;; No root mount point found. +(define-condition-type &no-root-mount-point &condition + no-root-mount-point?) + +(define (check-user-partitions user-partitions) + "Return #t if the USER-PARTITIONS lists contains one record +with a mount-point set to '/', raise &no-root-mount-point condition +otherwise." + (let ((mount-points + (map user-partition-mount-point user-partitions))) + (or (member "/" mount-points) + (raise + (condition (&no-root-mount-point)))))) + +(define (set-user-partitions-path user-partitions) + "Set the partition path of records in USER-PARTITIONS list +and return the updated list." + (map (lambda (p) + (let* ((partition (user-partition-parted-object p)) + (path (partition-get-path partition))) + (user-partition + (inherit p) + (path path)))) + user-partitions)) + +(define-syntax-rule (with-null-output-ports exp ...) + "Evaluate EXP with both the output port and the error port pointing to the +bit bucket." + (with-output-to-port (%make-void-port "w") + (lambda () + (with-error-to-port (%make-void-port "w") + (lambda () exp ...))))) + +(define (create-ext4-file-system partition) + "Create an ext4 file-system for PARTITION path." + (with-null-output-ports + (invoke "mkfs.ext4" "-F" partition))) + +(define (create-fat32-file-system partition) + "Create an ext4 file-system for PARTITION path." + (with-null-output-ports + (invoke "mkfs.fat" "-F32" partition))) + +(define (create-swap-partition partition) + "Set up swap area on PARTITION path." + (with-null-output-ports + (invoke "mkswap" "-f" partition))) + +(define (start-swaping partition) + "Start swaping on PARTITION path." + (with-null-output-ports + (invoke "swapon" partition))) + +(define (stop-swaping partition) + "Stop swaping on PARTITION path." + (with-null-output-ports + (invoke "swapoff" partition))) + +(define (format-user-partitions user-partitions) + "Format the records in USER-PARTITIONS list with +NEED-FORMATING? field set to #t." + (for-each + (lambda (user-partition) + (let* ((need-formating? + (user-partition-need-formating? user-partition)) + (type (user-partition-type user-partition)) + (path (user-partition-path user-partition)) + (fs-type (user-partition-fs-type user-partition))) + (case fs-type + ((ext4) + (and need-formating? + (not (eq? type 'extended)) + (create-ext4-file-system path))) + ((fat32) + (and need-formating? + (not (eq? type 'extended)) + (create-fat32-file-system path))) + ((swap) + (create-swap-partition path)) + (else + ;; TODO: Add support for other file-system types. + #t)))) + user-partitions)) + +(define (sort-partitions user-partitions) + "Sort USER-PARTITIONS by mount-points, so that the more nested mount-point +comes last. This is useful to mount/umount partitions in a coherent order." + (sort user-partitions + (lambda (a b) + (let ((mount-point-a (user-partition-mount-point a)) + (mount-point-b (user-partition-mount-point b))) + (string-prefix? mount-point-a mount-point-b))))) + +(define (mount-user-partitions user-partitions) + "Mount the records in USER-PARTITIONS list on their +respective mount-points. Also start swaping on records with +FS-TYPE equal to 'swap." + (let* ((mount-partitions (filter user-partition-mount-point user-partitions)) + (sorted-partitions (sort-partitions mount-partitions))) + (for-each (lambda (user-partition) + (let* ((mount-point + (user-partition-mount-point user-partition)) + (target + (string-append (%installer-target-dir) + mount-point)) + (fs-type + (user-partition-fs-type user-partition)) + (mount-type + (user-fs-type->mount-type fs-type)) + (path (user-partition-path user-partition))) + (case fs-type + ((swap) + (start-swaping path)) + (else + (mkdir-p target) + (mount path target mount-type))))) + sorted-partitions))) + +(define (umount-user-partitions user-partitions) + "Unmount all the records in USER-PARTITIONS list. Also stop +swaping on with FS-TYPE set to 'swap." + (let* ((mount-partitions (filter user-partition-mount-point user-partitions)) + (sorted-partitions (sort-partitions mount-partitions))) + (for-each (lambda (user-partition) + (let* ((mount-point + (user-partition-mount-point user-partition)) + (fs-type + (user-partition-fs-type user-partition)) + (path (user-partition-path user-partition)) + (target + (string-append (%installer-target-dir) + mount-point))) + (case fs-type + ((swap) + (stop-swaping path)) + (else + (umount target))))) + (reverse sorted-partitions)))) + +(define-syntax-rule (with-mounted-partitions user-partitions exp ...) + "Mount USER-PARTITIONS within the dynamic extent of EXP." + (dynamic-wind + (lambda () + (mount-user-partitions user-partitions)) + (lambda () + exp ...) + (lambda () + (umount-user-partitions user-partitions) + #f))) + +(define (user-partition->file-system user-partition) + "Convert the given USER-PARTITION record in a FILE-SYSTEM record from +(gnu system file-systems) module and return it." + (let* ((mount-point (user-partition-mount-point user-partition)) + (fs-type (user-partition-fs-type user-partition)) + (mount-type (user-fs-type->mount-type fs-type)) + (path (user-partition-path user-partition)) + (uuid (uuid->string (read-partition-uuid path) + fs-type))) + `(file-system + (mount-point ,mount-point) + (device (uuid ,uuid (quote ,fs-type))) + (type ,mount-type)))) + +(define (user-partitions->file-systems user-partitions) + "Convert the given USER-PARTITIONS list of records into a +list of records." + (filter-map + (lambda (user-partition) + (let ((mount-point + (user-partition-mount-point user-partition))) + (and mount-point + (user-partition->file-system user-partition)))) + user-partitions)) + +(define (find-swap-user-partitions user-partitions) + "Return the subset of records in USER-PARTITIONS list with +the FS-TYPE field set to 'swap, return the empty list if none found." + (filter (lambda (user-partition) + (let ((fs-type (user-partition-fs-type user-partition))) + (eq? fs-type 'swap))) + user-partitions)) + +(define (bootloader-configuration user-partitions) + "Return the bootloader configuration field for USER-PARTITIONS." + (let* ((root-partition + (find (lambda (user-partition) + (let ((mount-point + (user-partition-mount-point user-partition))) + (and mount-point + (string=? mount-point "/")))) + user-partitions)) + (root-partition-disk (user-partition-disk-path root-partition))) + `((bootloader-configuration + ,@(if (efi-installation?) + `((bootloader grub-efi-bootloader) + (target ,(default-esp-mount-point))) + `((bootloader grub-bootloader) + (target ,root-partition-disk))))))) + +(define (user-partitions->configuration user-partitions) + "Return the configuration field for USER-PARTITIONS." + (let* ((swap-user-partitions (find-swap-user-partitions user-partitions)) + (swap-devices (map user-partition-path swap-user-partitions))) + `(,@(if (null? swap-devices) + '() + `((swap-devices (list ,@swap-devices)))) + (bootloader ,@(bootloader-configuration user-partitions)) + (file-systems (cons* + ,@(user-partitions->file-systems user-partitions) + %base-file-systems))))) + + +;; +;; Initialization. +;; + +(define (init-parted) + "Initialize libparted support." + (probe-all-devices) + (exception-set-handler (lambda (exception) + EXCEPTION-OPTION-UNHANDLED))) + +(define (free-parted devices) + "Deallocate memory used for DEVICES in parted, force sync them and wait for +the devices not to be used before returning." + ;; XXX: Formating and further operations on disk partition table may fail + ;; because the partition table changes are not synced, or because the device + ;; is still in use, even if parted should have finished editing + ;; partitions. This is not well understood, but syncing devices and waiting + ;; them to stop returning EBUSY to BLKRRPART ioctl seems to be enough. The + ;; same kind of issue is described here: + ;; https://mail.gnome.org/archives/commits-list/2013-March/msg18423.html. + (let ((device-paths (map device-path devices))) + (for-each force-device-sync devices) + (free-all-devices) + (for-each (lambda (path) + (let ((in-use? (with-delay-device-in-use? path))) + (and in-use? + (error + (format #f (G_ "Device ~a is still in use.") + path))))) + device-paths))) diff --git a/gnu/installer/record.scm b/gnu/installer/record.scm index 3ef0a101d3..edf73b6215 100644 --- a/gnu/installer/record.scm +++ b/gnu/installer/record.scm @@ -35,6 +35,7 @@ installer-timezone-page installer-hostname-page installer-user-page + installer-partition-page installer-services-page installer-welcome-page)) @@ -76,6 +77,8 @@ ;; procedure void -> void (user-page installer-user-page) ;; procedure void -> void + (partition-page installer-partition-page) + ;; procedure void -> void (services-page installer-services-page) ;; procedure (logo) -> void (welcome-page installer-welcome-page)) diff --git a/gnu/local.mk b/gnu/local.mk index 0b5e96afa4..63859a3b67 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -574,6 +574,7 @@ GNU_SYSTEM_MODULES += \ %D%/installer/keymap.scm \ %D%/installer/locale.scm \ %D%/installer/newt.scm \ + %D%/installer/parted.scm \ %D%/installer/services.scm \ %D%/installer/steps.scm \ %D%/installer/timezone.scm \ @@ -588,6 +589,7 @@ GNU_SYSTEM_MODULES += \ %D%/installer/newt/menu.scm \ %D%/installer/newt/network.scm \ %D%/installer/newt/page.scm \ + %D%/installer/newt/partition.scm \ %D%/installer/newt/services.scm \ %D%/installer/newt/timezone.scm \ %D%/installer/newt/utils.scm \ diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 48c09a1e3a..8327bf6c9e 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -28,6 +28,7 @@ gnu/installer/newt/user.scm gnu/installer/newt/utils.scm gnu/installer/newt/welcome.scm gnu/installer/newt/wifi.scm +gnu/installer/parted.scm gnu/installer/services.scm gnu/installer/steps.scm gnu/installer/timezone.scm -- cgit v1.2.3 From 35e99a23b5819c888a80279d048d4915f0fcf78b Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 14:48:38 +0900 Subject: installer: Remove group selection in user page. Assume that the user's group is always "users". * gnu/installer/newt/user.scm (run-user-add-page): Remove group fields, (run-user-page): ditto. --- gnu/installer/newt/user.scm | 36 +++++++++++++++--------------------- 1 file changed, 15 insertions(+), 21 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/user.scm b/gnu/installer/newt/user.scm index f342caae04..8337d628ae 100644 --- a/gnu/installer/newt/user.scm +++ b/gnu/installer/newt/user.scm @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu installer newt user) + #:use-module (gnu installer user) #:use-module (gnu installer newt page) #:use-module (gnu installer newt utils) #:use-module (guix i18n) @@ -33,16 +34,12 @@ (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)) + (entry-grid (make-grid 2 2)) (button-grid (make-grid 1 1)) (ok-button (make-button -1 -1 (G_ "Ok"))) (grid (make-grid 1 2)) @@ -53,10 +50,8 @@ (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-entry-grid-field 0 1 label-home-directory) + (set-entry-grid-field 1 1 entry-home-directory) (set-grid-field button-grid 0 0 GRID-ELEMENT-COMPONENT ok-button) @@ -67,8 +62,8 @@ (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 + label-name label-home-directory + entry-name entry-home-directory ok-button) (make-wrapped-grid-window (vertically-stacked-grid @@ -88,17 +83,15 @@ (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)))))))) + (user + (name name) + (home-directory home-directory)))))))) (lambda () (destroy-form-and-pop form))))))) @@ -124,7 +117,7 @@ (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") + (title "User creation") (grid (vertically-stacked-grid GRID-ELEMENT-COMPONENT info-textbox @@ -135,13 +128,13 @@ 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))))) + (string<= (user-name a) + (user-name b))))) (listbox-elements (map (lambda (user) `((key . ,(append-entry-to-listbox listbox - (assoc-ref user 'name))) + (user-name user))) (user . ,user))) sorted-users)) (form (make-form))) @@ -175,7 +168,8 @@ (when (null? users) (run-error-page (G_ "Please create at least one user.") (G_ "No user")) - (run users)))))) + (run users)) + users)))) (lambda () (destroy-form-and-pop form)))))) (run '())) -- cgit v1.2.3 From 54754efc91e4862f5a904d53a82fcc59e19646a2 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 17:48:36 +0900 Subject: installer: Fix compute calls. * gnu/installer/newt/keymap.scm (run-keymap-page): Add missing argument to compute procedure. * gnu/installer/newt/network.scm (run-network-page): Ditto. --- gnu/installer/newt/keymap.scm | 2 +- gnu/installer/newt/network.scm | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/keymap.scm b/gnu/installer/newt/keymap.scm index 0c38a79e19..4bdae51340 100644 --- a/gnu/installer/newt/keymap.scm +++ b/gnu/installer/newt/keymap.scm @@ -81,7 +81,7 @@ names of the selected keyboard layout and variant." (installer-step (id 'variant) (compute - (lambda (result) + (lambda (result _) (let ((variants (x11-keymap-layout-variants (result-step result 'layout)))) (run-variant-page variants diff --git a/gnu/installer/newt/network.scm b/gnu/installer/newt/network.scm index 45989ac2ac..4912959147 100644 --- a/gnu/installer/newt/network.scm +++ b/gnu/installer/newt/network.scm @@ -131,7 +131,7 @@ Internet." (installer-step (id 'power-technology) (compute - (lambda (result) + (lambda (result _) (let ((technology (result-step result 'select-technology))) (connman-enable-technology technology) (wait-technology-powered technology))))) @@ -140,7 +140,7 @@ Internet." (installer-step (id 'connect-service) (compute - (lambda (result) + (lambda (result _) (let* ((technology (result-step result 'select-technology)) (type (technology-type technology))) (cond -- cgit v1.2.3 From 30b4df8627b0ecf1ee15e832b7adcf5640f09d3c Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 19:27:31 +0900 Subject: installer: locale: Make clear that the point is to select a glibc locale. * gnu/installer/newt/locale.scm (run-language-page): Be more specific about what is a locale and what are the different steps involved in the info messages. --- gnu/installer/newt/locale.scm | 39 +++++++++++++++++++++++++++------------ 1 file changed, 27 insertions(+), 12 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/locale.scm b/gnu/installer/newt/locale.scm index 028372c194..0389416459 100644 --- a/gnu/installer/newt/locale.scm +++ b/gnu/installer/newt/locale.scm @@ -30,14 +30,21 @@ #:export (run-locale-page)) (define (run-language-page languages language->text) - (let ((title (G_ "Language"))) + (let ((title (G_ "Locale language"))) (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.") + #:info-text (G_ "Choose the locale's language to be used for the \ +installation process. A locale is a regional variant of your language \ +encompassing number, date and currency format, among other details. + +Based on the language you choose, you will possibly be asked to \ +select a locale's territory, codeset and modifier in the next \ +steps. The locale will also be used as the default one for the \ +installed system.") + #:info-textbox-width 70 #:listbox-items languages #:listbox-item->text language->text + #:sort-listbox-items? #f #:button-text (G_ "Cancel") #:button-callback-procedure (lambda _ @@ -46,11 +53,11 @@ language for the installed system.") (&installer-step-abort))))))) (define (run-territory-page territories territory->text) - (let ((title (G_ "Location"))) + (let ((title (G_ "Locale location"))) (run-listbox-selection-page #:title title - #:info-text (G_ "Choose your location. This is a shortlist of locations \ -based on the language you selected.") + #:info-text (G_ "Choose your locale's 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") @@ -61,11 +68,11 @@ based on the language you selected.") (&installer-step-abort))))))) (define (run-codeset-page codesets) - (let ((title (G_ "Codeset"))) + (let ((title (G_ "Locale codeset"))) (run-listbox-selection-page #:title title - #:info-text (G_ "Choose your codeset. If UTF-8 is available, it should be \ -preferred.") + #:info-text (G_ "Choose your locale's codeset. If UTF-8 is available, \ + it should be preferred.") #:listbox-items codesets #:listbox-item->text identity #:listbox-default-item "UTF-8" @@ -77,10 +84,12 @@ preferred.") (&installer-step-abort))))))) (define (run-modifier-page modifiers modifier->text) - (let ((title (G_ "Modifier"))) + (let ((title (G_ "Locale modifier"))) (run-listbox-selection-page #:title title - #:info-text (G_ "Choose your modifier.") + #:info-text (G_ "Choose your locale's modifier. The most frequent \ +modifier is euro. It indicates that you want to use Euro as the currency \ +symbol.") #:listbox-items modifiers #:listbox-item->text modifier->text #:button-text (G_ "Back") @@ -94,6 +103,12 @@ preferred.") supported-locales iso639-languages iso3166-territories) + "Run a page asking the user to select a locale language and possibly +territory, codeset and modifier. Use SUPPORTED-LOCALES as the list of glibc +available locales. ISO639-LANGUAGES is an association list associating a +locale code to a locale name. ISO3166-TERRITORIES is an association list +associating a territory code with a territory name. The formated locale, under +glibc format is returned." (define (break-on-locale-found locales) "Raise the &installer-step-break condition if LOCALES contains exactly one -- cgit v1.2.3 From 30cf5e04264e18b2fd0dcc73cbce2ef4324563e1 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 19:29:54 +0900 Subject: installer: locale: Set English as the default language. * gnu/installer/newt/locale.scm (sort-languages): New procedure ... (run-locale-page)[locale-steps]: ... used here to make english the default language. --- gnu/installer/newt/locale.scm | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/locale.scm b/gnu/installer/newt/locale.scm index 0389416459..4de78f3330 100644 --- a/gnu/installer/newt/locale.scm +++ b/gnu/installer/newt/locale.scm @@ -146,6 +146,14 @@ glibc locale string and return it." ((locale) (locale->locale-string locale)))) + (define (sort-languages languages) + "Extract some languages from LANGUAGES list and place them ahead." + (let* ((first-languages '("en")) + (other-languages (lset-difference equal? + languages + first-languages))) + `(,@first-languages ,@other-languages))) + (define locale-steps (list (installer-step @@ -153,7 +161,8 @@ glibc locale string and return it." (compute (lambda _ (run-language-page - (delete-duplicates (map locale-language supported-locales)) + (sort-languages + (delete-duplicates (map locale-language supported-locales))) (cut language-code->language-name iso639-languages <>))))) (installer-step (id 'territory) -- cgit v1.2.3 From 7d812901daf0259d5d381199168d6d2994ce00ac Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 19:50:17 +0900 Subject: installer: Turn "Cancel" buttons into "Exit" buttons. This change and previous ones were, Suggested-by: Thorsten Wilms here: https://lists.gnu.org/archive/html/guix-devel/2018-11/msg00330.html gnu/installer/newt/ethernet.scm: Turn cancel into exit. gnu/installer/newt/final.scm: Ditto. gnu/installer/newt/keymap.scm: Ditto. gnu/installer/newt/locale.scm: Ditto. gnu/installer/newt/network.scm: Ditto. gnu/installer/newt/page.scm: Ditto. gnu/installer/newt/partition.scm: Ditto. gnu/installer/newt/services.scm: Ditto. gnu/installer/newt/timezone.scm: Ditto. gnu/installer/newt/user.scm: Ditto. gnu/installer/newt/wifi.scm: Ditto. --- gnu/installer/newt/ethernet.scm | 2 +- gnu/installer/newt/final.scm | 2 +- gnu/installer/newt/keymap.scm | 2 +- gnu/installer/newt/locale.scm | 2 +- gnu/installer/newt/network.scm | 2 +- gnu/installer/newt/page.scm | 24 ++++++++++++------------ gnu/installer/newt/partition.scm | 34 +++++++++++++++++----------------- gnu/installer/newt/services.scm | 2 +- gnu/installer/newt/timezone.scm | 2 +- gnu/installer/newt/user.scm | 4 ++-- gnu/installer/newt/wifi.scm | 8 ++++---- 11 files changed, 42 insertions(+), 42 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/ethernet.scm b/gnu/installer/newt/ethernet.scm index 2b02653777..d1f357243b 100644 --- a/gnu/installer/newt/ethernet.scm +++ b/gnu/installer/newt/ethernet.scm @@ -72,7 +72,7 @@ connection is pending." #:title (G_ "Ethernet connection") #:listbox-items services #:listbox-item->text ethernet-service->text - #:button-text (G_ "Cancel") + #:button-text (G_ "Exit") #:button-callback-procedure (lambda _ (raise diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm index 023777cc0a..81af949de1 100644 --- a/gnu/installer/newt/final.scm +++ b/gnu/installer/newt/final.scm @@ -42,7 +42,7 @@ new system will be created from this file when pression the Ok button.") #:info-textbox-width width #:file-textbox-width width #:file-textbox-height height - #:cancel-button-callback-procedure + #:exit-button-callback-procedure (lambda () (raise (condition diff --git a/gnu/installer/newt/keymap.scm b/gnu/installer/newt/keymap.scm index 4bdae51340..9178a4341a 100644 --- a/gnu/installer/newt/keymap.scm +++ b/gnu/installer/newt/keymap.scm @@ -35,7 +35,7 @@ #:info-text (G_ "Please choose your keyboard layout.") #:listbox-items layouts #:listbox-item->text layout->text - #:button-text (G_ "Cancel") + #:button-text (G_ "Exit") #:button-callback-procedure (lambda _ (raise diff --git a/gnu/installer/newt/locale.scm b/gnu/installer/newt/locale.scm index 4de78f3330..4fa07df81e 100644 --- a/gnu/installer/newt/locale.scm +++ b/gnu/installer/newt/locale.scm @@ -45,7 +45,7 @@ installed system.") #:listbox-items languages #:listbox-item->text language->text #:sort-listbox-items? #f - #:button-text (G_ "Cancel") + #:button-text (G_ "Exit") #:button-callback-procedure (lambda _ (raise diff --git a/gnu/installer/newt/network.scm b/gnu/installer/newt/network.scm index 4912959147..ee6af0674e 100644 --- a/gnu/installer/newt/network.scm +++ b/gnu/installer/newt/network.scm @@ -59,7 +59,7 @@ Internet and return the selected technology. For now, only technologies with #:title (G_ "Internet access") #:listbox-items (technology-items) #:listbox-item->text technology->text - #:button-text (G_ "Cancel") + #:button-text (G_ "Exit") #:button-callback-procedure (lambda _ (raise diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm index 10849b81eb..98cbbb9c05 100644 --- a/gnu/installer/newt/page.scm +++ b/gnu/installer/newt/page.scm @@ -404,12 +404,12 @@ error is raised if the MAX-SCALE-UPDATE limit is reached." (checkbox-tree-height 10) (ok-button-callback-procedure (const #t)) - (cancel-button-callback-procedure + (exit-button-callback-procedure (const #t))) "Run a page allowing the user to select one or multiple items among ITEMS in a checkbox list. The page contains vertically stacked from the top to the bottom, an informative text set to INFO-TEXT, the checkbox list and two -buttons, 'Ok' and 'Cancel'. The page title's is set to TITLE. ITEMS are +buttons, 'Ok' and 'Exit'. The page title's is set to TITLE. ITEMS are converted to text using ITEM->TEXT before being displayed in the checkbox list. @@ -417,7 +417,7 @@ INFO-TEXTBOX-WIDTH is the width of the textbox where INFO-TEXT will be displayed. CHECKBOX-TREE-HEIGHT is the height of the checkbox list. OK-BUTTON-CALLBACK-PROCEDURE is called when the 'Ok' button is pressed. -CANCEL-BUTTON-CALLBACK-PROCEDURE is called when the 'Cancel' button is +EXIT-BUTTON-CALLBACK-PROCEDURE is called when the 'Exit' button is pressed. This procedure returns the list of checked items in the checkbox list among @@ -439,14 +439,14 @@ ITEMS when 'Ok' is pressed." info-textbox-width #:flags FLAG-BORDER)) (ok-button (make-button -1 -1 (G_ "Ok"))) - (cancel-button (make-button -1 -1 (G_ "Cancel"))) + (exit-button (make-button -1 -1 (G_ "Exit"))) (grid (vertically-stacked-grid GRID-ELEMENT-COMPONENT info-textbox GRID-ELEMENT-COMPONENT checkbox-tree GRID-ELEMENT-SUBGRID (horizontal-stacked-grid GRID-ELEMENT-COMPONENT ok-button - GRID-ELEMENT-COMPONENT cancel-button))) + GRID-ELEMENT-COMPONENT exit-button))) (keys (fill-checkbox-tree checkbox-tree items)) (form (make-form))) @@ -468,8 +468,8 @@ ITEMS when 'Ok' is pressed." entries))) (ok-button-callback-procedure) current-items)) - ((components=? argument cancel-button) - (cancel-button-callback-procedure)))))) + ((components=? argument exit-button) + (exit-button-callback-procedure)))))) (lambda () (destroy-form-and-pop form)))))) @@ -482,7 +482,7 @@ ITEMS when 'Ok' is pressed." (file-textbox-height 30) (ok-button-callback-procedure (const #t)) - (cancel-button-callback-procedure + (exit-button-callback-procedure (const #t))) (let* ((info-textbox (make-reflowed-textbox -1 -1 info-text @@ -495,14 +495,14 @@ ITEMS when 'Ok' is pressed." file-textbox-height (logior FLAG-SCROLL FLAG-BORDER))) (ok-button (make-button -1 -1 (G_ "Ok"))) - (cancel-button (make-button -1 -1 (G_ "Cancel"))) + (exit-button (make-button -1 -1 (G_ "Exit"))) (grid (vertically-stacked-grid GRID-ELEMENT-COMPONENT info-textbox GRID-ELEMENT-COMPONENT file-textbox GRID-ELEMENT-SUBGRID (horizontal-stacked-grid GRID-ELEMENT-COMPONENT ok-button - GRID-ELEMENT-COMPONENT cancel-button))) + GRID-ELEMENT-COMPONENT exit-button))) (form (make-form))) (set-textbox-text file-textbox file-text) @@ -519,7 +519,7 @@ ITEMS when 'Ok' is pressed." (cond ((components=? argument ok-button) (ok-button-callback-procedure)) - ((components=? argument cancel-button) - (cancel-button-callback-procedure)))))) + ((components=? argument exit-button) + (exit-button-callback-procedure)))))) (lambda () (destroy-form-and-pop form)))))) diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index 806337a9cb..1d5e4538e4 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -32,7 +32,7 @@ #:use-module (parted) #:export (run-partioning-page)) -(define (button-cancel-action) +(define (button-exit-action) "Raise the &installer-step-abort condition." (raise (condition @@ -48,8 +48,8 @@ #:title (G_ "Partition scheme") #:listbox-items items #:listbox-item->text cdr - #:button-text (G_ "Cancel") - #:button-callback-procedure button-cancel-action))) + #:button-text (G_ "Exit") + #:button-callback-procedure button-exit-action))) (car result))) (define (draw-formating-page) @@ -71,8 +71,8 @@ DEVICES list." #:title (G_ "Disk") #:listbox-items (device-items) #:listbox-item->text cdr - #:button-text (G_ "Cancel") - #:button-callback-procedure button-cancel-action)) + #:button-text (G_ "Exit") + #:button-callback-procedure button-exit-action)) (device (car result))) device)) @@ -84,7 +84,7 @@ Be careful, all data on the disk will be lost.") #:title (G_ "Partition table") #:listbox-items '("msdos" "gpt") #:listbox-item->text identity - #:button-text (G_ "Cancel") + #:button-text (G_ "Exit") #:button-callback-procedure button-callback)) (define (run-type-page partition) @@ -103,8 +103,8 @@ Be careful, all data on the disk will be lost.") #:listbox-items items #:listbox-item->text symbol->string #:sort-listbox-items? #f - #:button-text (G_ "Cancel") - #:button-callback-procedure button-cancel-action))) + #:button-text (G_ "Exit") + #:button-callback-procedure button-exit-action))) (define (run-fs-type-page) "Run a page asking the user to select a file-system type." @@ -114,8 +114,8 @@ Be careful, all data on the disk will be lost.") #:listbox-items '(ext4 btrfs fat32 swap) #:listbox-item->text user-fs-type-name #:sort-listbox-items? #f - #:button-text (G_ "Cancel") - #:button-callback-procedure button-cancel-action)) + #:button-text (G_ "Exit") + #:button-callback-procedure button-exit-action)) (define (inform-can-create-partition? user-partition) "Return #t if it is possible to create USER-PARTITION. This is determined by @@ -563,7 +563,7 @@ edit it." path)) (result (choice-window (G_ "Delete disk") (G_ "Ok") - (G_ "Cancel") + (G_ "Exit") info-text))) (case result ((1) @@ -584,7 +584,7 @@ edit it." number-str)) (result (choice-window (G_ "Delete partition") (G_ "Ok") - (G_ "Cancel") + (G_ "Exit") info-text))) (case result ((1) @@ -616,8 +616,8 @@ At least one partition must have its mounting point set to '/'.") #:allow-delete? #t #:button-text (G_ "Ok") #:button-callback-procedure button-ok-action - #:button2-text (G_ "Cancel") - #:button2-callback-procedure button-cancel-action + #:button2-text (G_ "Exit") + #:button2-callback-procedure button-exit-action #:listbox-callback-procedure listbox-action #:hotkey-callback-procedure hotkey-action))) (if (eq? result #t) @@ -664,8 +664,8 @@ At least one partition must have its mounting point set to '/'.") #:title (G_ "Partitioning method") #:listbox-items items #:listbox-item->text cdr - #:button-text (G_ "Cancel") - #:button-callback-procedure button-cancel-action)) + #:button-text (G_ "Exit") + #:button-callback-procedure button-exit-action)) (method (car result))) (case method ((entire) @@ -674,7 +674,7 @@ At least one partition must have its mounting point set to '/'.") (disk (if disk-type (disk-new device) (let* ((label (run-label-page - button-cancel-action)) + button-exit-action)) (disk (mklabel device label))) (disk-commit disk) disk))) diff --git a/gnu/installer/newt/services.scm b/gnu/installer/newt/services.scm index 80fac43dc8..6bcb6244ae 100644 --- a/gnu/installer/newt/services.scm +++ b/gnu/installer/newt/services.scm @@ -38,7 +38,7 @@ choose the one to use on the log-in screen with F1.") #:items %desktop-environments #:item->text desktop-environment-name #:checkbox-tree-height 5 - #:cancel-button-callback-procedure + #:exit-button-callback-procedure (lambda () (raise (condition diff --git a/gnu/installer/newt/timezone.scm b/gnu/installer/newt/timezone.scm index 874f4a0734..6c96ee55b1 100644 --- a/gnu/installer/newt/timezone.scm +++ b/gnu/installer/newt/timezone.scm @@ -60,7 +60,7 @@ returned." #:listbox-items timezones #:listbox-item->text identity #:button-text (if (null? path) - (G_ "Cancel") + (G_ "Exit") (G_ "Back")) #:button-callback-procedure (if (null? path) diff --git a/gnu/installer/newt/user.scm b/gnu/installer/newt/user.scm index 8337d628ae..c043f53def 100644 --- a/gnu/installer/newt/user.scm +++ b/gnu/installer/newt/user.scm @@ -116,7 +116,7 @@ '() (list GRID-ELEMENT-COMPONENT del-button))))) (ok-button (make-button -1 -1 (G_ "Ok"))) - (cancel-button (make-button -1 -1 (G_ "Cancel"))) + (exit-button (make-button -1 -1 (G_ "Exit"))) (title "User creation") (grid (vertically-stacked-grid @@ -126,7 +126,7 @@ GRID-ELEMENT-SUBGRID listbox-button-grid) GRID-ELEMENT-SUBGRID (horizontal-stacked-grid GRID-ELEMENT-COMPONENT ok-button - GRID-ELEMENT-COMPONENT cancel-button))) + GRID-ELEMENT-COMPONENT exit-button))) (sorted-users (sort users (lambda (a b) (string<= (user-name a) (user-name b))))) diff --git a/gnu/installer/newt/wifi.scm b/gnu/installer/newt/wifi.scm index de443345f6..c744e826a9 100644 --- a/gnu/installer/newt/wifi.scm +++ b/gnu/installer/newt/wifi.scm @@ -198,7 +198,7 @@ force a wifi scan." (make-reflowed-textbox -1 -1 info-text (info-textbox-width) #:flags FLAG-BORDER)) - (cancel-button (make-button -1 -1 (G_ "Cancel"))) + (exit-button (make-button -1 -1 (G_ "Exit"))) (scan-button (make-button -1 -1 (G_ "Scan"))) (services (wifi-services)) (service-items '())) @@ -211,12 +211,12 @@ force a wifi scan." (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) + (set-grid-field buttons-grid 0 0 GRID-ELEMENT-COMPONENT exit-button) (add-components-to-form form info-textbox listbox scan-button - cancel-button) + exit-button) (make-wrapped-grid-window (basic-window-grid info-textbox middle-grid buttons-grid) (G_ "Wifi")) @@ -231,7 +231,7 @@ force a wifi scan." ((components=? argument scan-button) (run-wifi-scan-page) (run-wifi-page)) - ((components=? argument cancel-button) + ((components=? argument exit-button) (raise (condition (&installer-step-abort)))) -- cgit v1.2.3 From 479414e1c9e13ddce9e0c8741eb9f50dff62e333 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 21:53:40 +0900 Subject: installer: keymap: Do not fail on non-kmscon terminals. kmscon-update-keymap fails on non kmscon terminals because KEYMAP_UPDATE environment variable is not defined. As it is convenient to test the installer on a regular terminal, do nothing if KEYMAP_UPDATE is missing. * gnu/installer/keymap.scm (kmscon-update-keymap): Do nothing if KEYMAP_UPDATE is not defined. --- gnu/installer/keymap.scm | 36 +++++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 15 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/keymap.scm b/gnu/installer/keymap.scm index d9f8656855..d66b376d9c 100644 --- a/gnu/installer/keymap.scm +++ b/gnu/installer/keymap.scm @@ -149,18 +149,24 @@ Configuration Database, describing possible XKB configurations." (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))))) + "Update kmscon keymap with the provided MODEL, LAYOUT and VARIANT." + (and=> + (getenv "KEYMAP_UPDATE") + (lambda (keymap-file) + (unless (file-exists? keymap-file) + (error "Unable to locate keymap update file")) + + ;; See file gnu/packages/patches/kmscon-runtime-keymap-switch.patch. + ;; This dirty hack makes possible to update kmscon keymap at runtime by + ;; writing an X11 keyboard model, layout and variant to a named pipe + ;; referred by KEYMAP_UPDATE environment variable. + (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)))))) -- cgit v1.2.3 From 9e58d4e90e77db150fbc57a559eaa01d85ce03f6 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 21:55:51 +0900 Subject: installer: keymap: Fix keymap selection of layouts with not variant. * gnu/installer/newt/keymap.scm (run-keymap-page): Test if the layout has no variant at 'variant step, instead of raising a condition at 'layout step. --- gnu/installer/newt/keymap.scm | 28 ++++++++++++---------------- 1 file changed, 12 insertions(+), 16 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/keymap.scm b/gnu/installer/newt/keymap.scm index 9178a4341a..55a0aa6bf9 100644 --- a/gnu/installer/newt/keymap.scm +++ b/gnu/installer/newt/keymap.scm @@ -66,28 +66,24 @@ names of the selected keyboard layout and variant." (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))))) + (run-layout-page + layouts + (lambda (layout) + (x11-keymap-layout-description 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))))))))) + (let* ((layout (result-step result 'layout)) + (variants (x11-keymap-layout-variants layout))) + ;; Return #f if the layout does not have any variant. + (and (not (null? variants)) + (run-variant-page variants + (lambda (variant) + (x11-keymap-variant-description + variant)))))))))) (define (format-result result) (let ((layout (x11-keymap-layout-name -- cgit v1.2.3 From 77c00b1e573776643a4cfb81415be52f436d3ef3 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 21:58:26 +0900 Subject: installer: network: Do not show an empty technology list. If no technology is detected, ask the user if he prefers to continue or to exit the installer. * gnu/installer/newt/network.scm (run-technology-page): Run a choice-window if technology-items procedure returns an empty list. --- gnu/installer/newt/network.scm | 38 ++++++++++++++++++++++++++------------ 1 file changed, 26 insertions(+), 12 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/network.scm b/gnu/installer/newt/network.scm index ee6af0674e..64fab2ae9f 100644 --- a/gnu/installer/newt/network.scm +++ b/gnu/installer/newt/network.scm @@ -53,18 +53,32 @@ Internet and return the selected technology. For now, only technologies with (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_ "Internet access") - #:listbox-items (technology-items) - #:listbox-item->text technology->text - #:button-text (G_ "Exit") - #:button-callback-procedure - (lambda _ - (raise - (condition - (&installer-step-abort)))))) + (let ((items (technology-items))) + (if (null? items) + (case (choice-window + (G_ "Internet access") + (G_ "Continue") + (G_ "Exit") + (G_ "The install process requires an internet access, but no \ +network device were found. Do you want to continue anyway?")) + ((1) (raise + (condition + (&installer-step-break)))) + ((2) (raise + (condition + (&installer-step-abort))))) + (run-listbox-selection-page + #:info-text (G_ "The install process requires an internet access.\ + Please select a network device.") + #:title (G_ "Internet access") + #:listbox-items items + #:listbox-item->text technology->text + #:button-text (G_ "Exit") + #: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." -- cgit v1.2.3 From cbeb27025f39694b8d12e07ee7e5ce8031690c4e Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 22:00:15 +0900 Subject: installer: partition: Differenciate Back button from Exit button. * gnu/installer/newt/partition.scm (run-label-page): Pass the button text as an argument, (run-disk-page): Call run-label-page with the appropriate button text. --- gnu/installer/newt/partition.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index 1d5e4538e4..04d6192cd0 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -76,7 +76,7 @@ DEVICES list." (device (car result))) device)) -(define (run-label-page button-callback) +(define (run-label-page button-text button-callback) "Run a page asking the user to select a partition table label." (run-listbox-selection-page #:info-text (G_ "Select a new partition table type. \ @@ -84,7 +84,7 @@ Be careful, all data on the disk will be lost.") #:title (G_ "Partition table") #:listbox-items '("msdos" "gpt") #:listbox-item->text identity - #:button-text (G_ "Exit") + #:button-text button-text #:button-callback-procedure button-callback)) (define (run-type-page partition) @@ -519,7 +519,7 @@ edit it." (let ((item (car listbox-item))) (cond ((disk? item) - (let ((label (run-label-page (const #f)))) + (let ((label (run-label-page (G_ "Back") (const #f)))) (if label (let* ((device (disk-device item)) (new-disk (mklabel device label)) @@ -674,6 +674,7 @@ At least one partition must have its mounting point set to '/'.") (disk (if disk-type (disk-new device) (let* ((label (run-label-page + (G_ "Exit") button-exit-action)) (disk (mklabel device label))) (disk-commit disk) -- cgit v1.2.3 From d700d131be31bd2838206bfc13ddd418affb185b Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 22:08:33 +0900 Subject: installer: Make sure every sentence is dot terminated. gnu/installer/newt/hostname.scm: Finish sentences by a dot. gnu/installer/newt/network.scm: Ditto. gnu/installer/newt/page.scm: Ditto. gnu/installer/newt/partition.scm: Ditto. gnu/installer/newt/user.scm: Ditto. gnu/installer/newt/wifi.scm: Ditto. --- gnu/installer/newt/hostname.scm | 2 +- gnu/installer/newt/network.scm | 2 +- gnu/installer/newt/page.scm | 2 +- gnu/installer/newt/partition.scm | 12 ++++++------ gnu/installer/newt/user.scm | 2 +- gnu/installer/newt/wifi.scm | 2 +- 6 files changed, 11 insertions(+), 11 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/hostname.scm b/gnu/installer/newt/hostname.scm index a8209bc2de..7783fa6360 100644 --- a/gnu/installer/newt/hostname.scm +++ b/gnu/installer/newt/hostname.scm @@ -22,5 +22,5 @@ #:export (run-hostname-page)) (define (run-hostname-page) - (run-input-page (G_ "Please enter the system hostname") + (run-input-page (G_ "Please enter the system hostname.") (G_ "Hostname"))) diff --git a/gnu/installer/newt/network.scm b/gnu/installer/newt/network.scm index 64fab2ae9f..f263b7df9d 100644 --- a/gnu/installer/newt/network.scm +++ b/gnu/installer/newt/network.scm @@ -113,7 +113,7 @@ 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") + #:info-text (G_ "Waiting internet access is established.") #:scale-full-value full-value #:scale-update-proc (lambda (value) diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm index 98cbbb9c05..c6577c8a8c 100644 --- a/gnu/installer/newt/page.scm +++ b/gnu/installer/newt/page.scm @@ -98,7 +98,7 @@ enters an empty input." (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") + (run-error-page (G_ "Please enter a non empty input.") (G_ "Empty input"))))) (let loop () (receive (exit-reason argument) diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index 04d6192cd0..a3d48eef21 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -98,7 +98,7 @@ Be careful, all data on the disk will be lost.") '() '(extended))))) (run-listbox-selection-page - #:info-text (G_ "Please select a partition type") + #:info-text (G_ "Please select a partition type.") #:title (G_ "Partition type") #:listbox-items items #:listbox-item->text symbol->string @@ -109,7 +109,7 @@ Be careful, all data on the disk will be lost.") (define (run-fs-type-page) "Run a page asking the user to select a file-system type." (run-listbox-selection-page - #:info-text (G_ "Please select the file-system type for this partition") + #:info-text (G_ "Please select the file-system type for this partition.") #:title (G_ "File-system type") #:listbox-items '(ext4 btrfs fat32 swap) #:listbox-item->text user-fs-type-name @@ -123,17 +123,17 @@ calling CAN-CREATE-PARTITION? procedure. If an exception is raised, catch it an inform the user with an appropriate error-page and return #f." (guard (c ((max-primary-exceeded? c) (run-error-page - (G_ "Primary partitions count exceeded") + (G_ "Primary partitions count exceeded.") (G_ "Creation error")) #f) ((extended-creation-error? c) (run-error-page - (G_ "Extended partition creation error") + (G_ "Extended partition creation error.") (G_ "Creation error")) #f) ((logical-creation-error? c) (run-error-page - (G_ "Logical partition creation error") + (G_ "Logical partition creation error.") (G_ "Creation error")) #f)) (can-create-partition? user-partition))) @@ -625,7 +625,7 @@ At least one partition must have its mounting point set to '/'.") (guard (c ((no-root-mount-point? c) (run-error-page - (G_ "No root mount point found") + (G_ "No root mount point found.") (G_ "Missing mount point")) #f)) (check-user-partitions user-partitions)))) diff --git a/gnu/installer/newt/user.scm b/gnu/installer/newt/user.scm index c043f53def..f65dbb30e5 100644 --- a/gnu/installer/newt/user.scm +++ b/gnu/installer/newt/user.scm @@ -72,7 +72,7 @@ title) (let ((error-page (lambda () - (run-error-page (G_ "Empty inputs are not allowed") + (run-error-page (G_ "Empty inputs are not allowed.") (G_ "Empty input"))))) (receive (exit-reason argument) (run-form form) diff --git a/gnu/installer/newt/wifi.scm b/gnu/installer/newt/wifi.scm index c744e826a9..59e40e327e 100644 --- a/gnu/installer/newt/wifi.scm +++ b/gnu/installer/newt/wifi.scm @@ -86,7 +86,7 @@ nmc_wifi_strength_bars." (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") + (run-input-page (G_ "Please enter the wifi password.") (G_ "Password required"))) (define (run-wrong-password-page service-name) -- cgit v1.2.3 From 3d0f6a055c366a5414c35262bb4b31c0f602fcd3 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Thu, 6 Dec 2018 11:00:43 +0900 Subject: installer: Make exit button optional for run-file-textbox-page. * gnu/installer/newt/page.scm (run-file-textbox-page)[exit-button?]: New argument. --- gnu/installer/newt/page.scm | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm index c6577c8a8c..c0d7547293 100644 --- a/gnu/installer/newt/page.scm +++ b/gnu/installer/newt/page.scm @@ -480,6 +480,7 @@ ITEMS when 'Ok' is pressed." (info-textbox-width 50) (file-textbox-width 50) (file-textbox-height 30) + (exit-button? #t) (ok-button-callback-procedure (const #t)) (exit-button-callback-procedure @@ -500,9 +501,12 @@ ITEMS when 'Ok' is pressed." GRID-ELEMENT-COMPONENT info-textbox GRID-ELEMENT-COMPONENT file-textbox GRID-ELEMENT-SUBGRID - (horizontal-stacked-grid + (apply + horizontal-stacked-grid GRID-ELEMENT-COMPONENT ok-button - GRID-ELEMENT-COMPONENT exit-button))) + `(,@(if exit-button? + (list GRID-ELEMENT-COMPONENT exit-button) + '()))))) (form (make-form))) (set-textbox-text file-textbox file-text) @@ -519,7 +523,8 @@ ITEMS when 'Ok' is pressed." (cond ((components=? argument ok-button) (ok-button-callback-procedure)) - ((components=? argument exit-button) + ((and exit-button? + (components=? argument exit-button)) (exit-button-callback-procedure)))))) (lambda () (destroy-form-and-pop form)))))) -- cgit v1.2.3 From 133c401f774d803f92933e9cadb6791641913beb Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Thu, 6 Dec 2018 11:11:04 +0900 Subject: installer: Display an eventual backtrace in a page. * gnu/installer.scm (installer-program): Write the backtrace in "/tmp/last-installer-error" and pass the filename to installer-exit-error. * gnu/installer/newt.scm (exit-error): Display the file passed above in a textbox. --- gnu/installer.scm | 19 +++++++++---------- gnu/installer/newt.scm | 21 ++++++++++++++++++++- 2 files changed, 29 insertions(+), 11 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer.scm b/gnu/installer.scm index 586ed29a59..2f01d39d1a 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -333,16 +333,15 @@ selected keymap." #:steps steps)) (const #f) (lambda (key . args) - ((installer-exit-error current-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))) + (let ((error-file "/tmp/last-installer-error")) + (call-with-output-file error-file + (lambda (port) + (display-backtrace (make-stack #t) port) + (print-exception port + (stack-ref (make-stack #t) 1) + key args))) + ((installer-exit-error current-installer) + error-file key args)) (primitive-exit 1))) ((installer-exit current-installer))))))) diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index 9d9212173d..31329b5c0f 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -18,6 +18,7 @@ (define-module (gnu installer newt) #:use-module (gnu installer record) + #:use-module (gnu installer utils) #:use-module (gnu installer newt ethernet) #:use-module (gnu installer newt final) #:use-module (gnu installer newt hostname) @@ -25,6 +26,7 @@ #:use-module (gnu installer newt locale) #:use-module (gnu installer newt menu) #:use-module (gnu installer newt network) + #:use-module (gnu installer newt page) #:use-module (gnu installer newt partition) #:use-module (gnu installer newt services) #:use-module (gnu installer newt timezone) @@ -32,6 +34,7 @@ #:use-module (gnu installer newt utils) #:use-module (gnu installer newt welcome) #:use-module (gnu installer newt wifi) + #:use-module (guix config) #:use-module (guix discovery) #:use-module (guix i18n) #:use-module (srfi srfi-26) @@ -46,7 +49,23 @@ (define (exit) (newt-finish)) -(define (exit-error key . args) +(define (exit-error file key args) + (newt-set-color COLORSET-ROOT "white" "red") + (let ((width (nearest-exact-integer + (* (screen-columns) 0.8))) + (height (nearest-exact-integer + (* (screen-rows) 0.7)))) + (run-file-textbox-page + #:info-text (format #f (G_ "The installer has encountered an unexpected \ +problem. The backtrace is displayed below. Please report it by email to \ +<~a>.") %guix-bug-report-address) + #:title (G_ "Unexpected problem") + #:file file + #:exit-button? #f + #:info-textbox-width width + #:file-textbox-width width + #:file-textbox-height height)) + (newt-set-color COLORSET-ROOT "white" "blue") (newt-finish)) (define (final-page result prev-steps) -- cgit v1.2.3 From ee4004b392c90fc9e25f03c16205615590ea27e6 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Thu, 6 Dec 2018 11:42:45 +0900 Subject: installer: partition: Precise when using Manual/Guided partionment. * gnu/installer/newt/partition.scm (run-disk-page)[guided?]: New argument. Use guided? to determine if we are proceeding to a guided or a manuel partitioning and precise it the title and info-text. --- gnu/installer/newt/partition.scm | 31 +++++++++++++++++++++---------- 1 file changed, 21 insertions(+), 10 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index a3d48eef21..0e1d7b4961 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -393,7 +393,8 @@ partition. Leave this field empty if you don't want to set a mounting point.") (else result)))) (define* (run-disk-page disks - #:optional (user-partitions '())) + #:optional (user-partitions '()) + #:key (guided? #f)) "Run a page allowing to edit the partition tables of the given DISKS. If specified, USER-PARTITIONS is a list of records associated to the partitions on DISKS." @@ -597,17 +598,24 @@ edit it." (else default-result)))))))) - (let ((result - (run-listbox-selection-page - - #:info-text (G_ "You can change a disk's partition table by \ + (let* ((info-text (G_ "You can change a disk's partition table by \ selecting it and pressing ENTER. You can also edit a partition by selecting it \ and pressing ENTER, or remove it by pressing DELETE. To create a new \ partition, select a free space area and press ENTER. -At least one partition must have its mounting point set to '/'.") +At least one partition must have its mounting point set to '/'.")) + (guided-info-text (format (G_ "This is the proposed partitionment. It \ +is still possible to edit it or to go back to install menu by pressing the \ +Exit button.~%~%"))) + (result + (run-listbox-selection-page + #:info-text (if guided? + (string-append guided-info-text info-text) + info-text) - #:title (G_ "Manual partitioning") + #:title (if guided? + (G_ "Guided partitioning") + (G_ "Manual partitioning")) #:info-textbox-width 70 #:listbox-items (disk-items) #:listbox-item->text cdr @@ -633,7 +641,8 @@ At least one partition must have its mounting point set to '/'.") (begin (for-each (cut disk-destroy <>) disks) user-partitions) - (run-disk-page disks user-partitions))) + (run-disk-page disks user-partitions + #:guided? guided?))) (let* ((result-disks (assoc-ref result 'disks)) (result-user-partitions (assoc-ref result 'user-partitions)) @@ -651,7 +660,8 @@ At least one partition must have its mounting point set to '/'.") (update-user-partitions result-user-partitions new-user-partition) result-user-partitions))) - (run-disk-page result-disks new-user-partitions))))) + (run-disk-page result-disks new-user-partitions + #:guided? guided?))))) (define (run-partioning-page) "Run a page asking the user for a partitioning method." @@ -684,7 +694,8 @@ At least one partition must have its mounting point set to '/'.") (auto-partition disk #:scheme scheme) (create-special-user-partitions (disk-partitions disk))))) - (run-disk-page (list disk) user-partitions))) + (run-disk-page (list disk) user-partitions + #:guided? #t))) ((manual) (let* ((disks (map disk-new devices)) (user-partitions (append-map -- cgit v1.2.3 From a7b2a4649fdbc4c9d2e49c6ee3b0e9a94048861c Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Thu, 6 Dec 2018 11:47:52 +0900 Subject: installer: menu: Fix typo. * gnu/installer/newt/menu.scm (run-menu-page): Fix typo. --- gnu/installer/newt/menu.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/menu.scm b/gnu/installer/newt/menu.scm index 756b582a50..161266a94a 100644 --- a/gnu/installer/newt/menu.scm +++ b/gnu/installer/newt/menu.scm @@ -33,7 +33,7 @@ process from." (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.") +You can also abort the installation by pressing the Abort button.") #:title (G_ "Installation menu") #:listbox-items (steps->items steps) #:listbox-item->text installer-step-description -- cgit v1.2.3 From b624206d6bfadd99ea903a35fe1d3e7fc11b5ba3 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Thu, 6 Dec 2018 12:05:42 +0900 Subject: installer: partition: Fix swaping and use syscalls. * gnu/installer/parted.scm (start-swaping): Remove it, (stop-swaping): Remove it, (start-swapping): New procedure using swapon syscall, (stop-swapping): New procedure using swapoff syscall, (with-mounted-partitions): Use previous start-swapping and stop-swapping procedures. --- gnu/installer/parted.scm | 67 +++++++++++++++++++++--------------------------- 1 file changed, 29 insertions(+), 38 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm index 3fe938124f..b0fe672131 100644 --- a/gnu/installer/parted.scm +++ b/gnu/installer/parted.scm @@ -1013,16 +1013,6 @@ bit bucket." (with-null-output-ports (invoke "mkswap" "-f" partition))) -(define (start-swaping partition) - "Start swaping on PARTITION path." - (with-null-output-ports - (invoke "swapon" partition))) - -(define (stop-swaping partition) - "Stop swaping on PARTITION path." - (with-null-output-ports - (invoke "swapoff" partition))) - (define (format-user-partitions user-partitions) "Format the records in USER-PARTITIONS list with NEED-FORMATING? field set to #t." @@ -1060,8 +1050,7 @@ comes last. This is useful to mount/umount partitions in a coherent order." (define (mount-user-partitions user-partitions) "Mount the records in USER-PARTITIONS list on their -respective mount-points. Also start swaping on records with -FS-TYPE equal to 'swap." +respective mount-points." (let* ((mount-partitions (filter user-partition-mount-point user-partitions)) (sorted-partitions (sort-partitions mount-partitions))) (for-each (lambda (user-partition) @@ -1075,44 +1064,54 @@ FS-TYPE equal to 'swap." (mount-type (user-fs-type->mount-type fs-type)) (path (user-partition-path user-partition))) - (case fs-type - ((swap) - (start-swaping path)) - (else - (mkdir-p target) - (mount path target mount-type))))) + (mkdir-p target) + (mount path target mount-type))) sorted-partitions))) (define (umount-user-partitions user-partitions) - "Unmount all the records in USER-PARTITIONS list. Also stop -swaping on with FS-TYPE set to 'swap." + "Unmount all the records in USER-PARTITIONS list." (let* ((mount-partitions (filter user-partition-mount-point user-partitions)) (sorted-partitions (sort-partitions mount-partitions))) (for-each (lambda (user-partition) (let* ((mount-point (user-partition-mount-point user-partition)) - (fs-type - (user-partition-fs-type user-partition)) - (path (user-partition-path user-partition)) (target (string-append (%installer-target-dir) mount-point))) - (case fs-type - ((swap) - (stop-swaping path)) - (else - (umount target))))) + (umount target))) (reverse sorted-partitions)))) +(define (find-swap-user-partitions user-partitions) + "Return the subset of records in USER-PARTITIONS list with +the FS-TYPE field set to 'swap, return the empty list if none found." + (filter (lambda (user-partition) + (let ((fs-type (user-partition-fs-type user-partition))) + (eq? fs-type 'swap))) + user-partitions)) + +(define (start-swapping user-partitions) + "Start swaping on records with FS-TYPE equal to 'swap." + (let* ((swap-user-partitions (find-swap-user-partitions user-partitions)) + (swap-devices (map user-partition-path swap-user-partitions))) + (for-each swapon swap-devices))) + +(define (stop-swapping user-partitions) + "Stop swaping on records with FS-TYPE equal to 'swap." + (let* ((swap-user-partitions (find-swap-user-partitions user-partitions)) + (swap-devices (map user-partition-path swap-user-partitions))) + (for-each swapoff swap-devices))) + (define-syntax-rule (with-mounted-partitions user-partitions exp ...) - "Mount USER-PARTITIONS within the dynamic extent of EXP." + "Mount USER-PARTITIONS and start swapping within the dynamic extent of EXP." (dynamic-wind (lambda () - (mount-user-partitions user-partitions)) + (mount-user-partitions user-partitions) + (start-swapping user-partitions)) (lambda () exp ...) (lambda () (umount-user-partitions user-partitions) + (stop-swapping user-partitions) #f))) (define (user-partition->file-system user-partition) @@ -1140,14 +1139,6 @@ list of records." (user-partition->file-system user-partition)))) user-partitions)) -(define (find-swap-user-partitions user-partitions) - "Return the subset of records in USER-PARTITIONS list with -the FS-TYPE field set to 'swap, return the empty list if none found." - (filter (lambda (user-partition) - (let ((fs-type (user-partition-fs-type user-partition))) - (eq? fs-type 'swap))) - user-partitions)) - (define (bootloader-configuration user-partitions) "Return the bootloader configuration field for USER-PARTITIONS." (let* ((root-partition -- cgit v1.2.3 From 71cd8a5870d11dc5f74c7e9b38db03d6cc633794 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Thu, 6 Dec 2018 12:08:23 +0900 Subject: installer: partition: Fix typo. * gnu/installer/newt/partition.scm (run-disk-page): Fix typo. --- gnu/installer/newt/partition.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index 0e1d7b4961..6aa8bfb598 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -604,9 +604,9 @@ and pressing ENTER, or remove it by pressing DELETE. To create a new \ partition, select a free space area and press ENTER. At least one partition must have its mounting point set to '/'.")) - (guided-info-text (format (G_ "This is the proposed partitionment. It \ -is still possible to edit it or to go back to install menu by pressing the \ -Exit button.~%~%"))) + (guided-info-text (format #f (G_ "This is the proposed \ +partitionment. It is still possible to edit it or to go back to install menu \ +by pressing the Exit button.~%~%"))) (result (run-listbox-selection-page #:info-text (if guided? -- cgit v1.2.3 From bf304dbceadf89c2722168be97d9673f94608aa6 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 7 Dec 2018 14:04:25 +0900 Subject: installer: partionment: Add encryption support. * gnu/installer.scm (set-installer-path): Add cryptsetup. * gnu/installer/newt/partition.scm (prompt-luks-passwords): New procedure, (run-partioning-page): Add the possibility to set encryption to "On" on a partition and choose a label, add a new partition scheme: "Guided - using the entire disk with encryption", prompt for encryption passwords before proceeding to formating. * gnu/installer/parted.scm ()[crypt-label], [crypt-password]: New fields, (partition-description): add the encryption label, (user-partition-description): add an encryption field, (auto-partition): add two partitioning schemes: entire-crypted-root and entire-crypted-root-home, (call-with-luks-key-file): new procedure, (user-partition-upper-path): new procedure, (luks-format-and-open): new procedure, (luks-close): new procedure, (format-user-partitions): format and open luks partitions before creating file-system. (mount-user-partitions): use the path returned by user-partition-upper-path, (umount-user-partitions): close the luks partitions, (user-partition->file-system): set device field to label for luks partitions and to uuid for the rest, (user-partition->mapped-device): new procedure, (user-partitions->configuration): add mapped-devices field. --- gnu/installer.scm | 2 + gnu/installer/newt/partition.scm | 45 ++++++++- gnu/installer/parted.scm | 202 +++++++++++++++++++++++++++++---------- 3 files changed, 195 insertions(+), 54 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer.scm b/gnu/installer.scm index 2f01d39d1a..fd66359cbe 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -28,6 +28,7 @@ #:use-module (gnu packages base) #:use-module (gnu packages bash) #:use-module (gnu packages connman) + #:use-module (gnu packages cryptsetup) #:use-module (gnu packages disk) #:use-module (gnu packages guile) #:autoload (gnu packages gnupg) (guile-gcrypt) @@ -272,6 +273,7 @@ selected keymap." #~(let* ((inputs '#$(append (list bash ;start subshells connman ;call connmanctl + cryptsetup dosfstools ;mkfs.fat e2fsprogs ;mkfs.ext4 kbd ;chvt diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index 6aa8bfb598..f4d1735dda 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -138,6 +138,25 @@ an inform the user with an appropriate error-page and return #f." #f)) (can-create-partition? user-partition))) +(define (prompt-luks-passwords user-partitions) + "Prompt for the luks passwords of the encrypted partitions in +USER-PARTITIONS list. Return this list with password fields filled-in." + (map (lambda (user-part) + (let* ((crypt-label (user-partition-crypt-label user-part)) + (path (user-partition-path user-part)) + (password-page + (lambda () + (run-input-page + (format #f (G_ "Please enter the password for the \ +encryption of partition ~a (label: ~a).") path crypt-label) + (G_ "Password required"))))) + (if crypt-label + (user-partition + (inherit user-part) + (crypt-password (password-page))) + user-part))) + user-partitions)) + (define* (run-partition-page target-user-partition #:key (default-item #f)) @@ -244,6 +263,18 @@ by USER-PART, if it is applicable for the partition type." (mount-point (if new-esp? (default-esp-mount-point) ""))))) + ((crypt-label) + (let* ((label (user-partition-crypt-label + target-user-partition)) + (new-label + (and (not label) + (run-input-page + (G_ "Please enter the encrypted label") + (G_ "Encryption label"))))) + (user-partition + (inherit target-user-partition) + (need-formating? #t) + (crypt-label new-label)))) ((need-formating?) (user-partition (inherit target-user-partition) @@ -668,6 +699,7 @@ by pressing the Exit button.~%~%"))) (define (run-page devices) (let* ((items '((entire . "Guided - using the entire disk") + (entire-crypted . "Guided - using the entire disk with encryption") (manual . "Manual"))) (result (run-listbox-selection-page #:info-text (G_ "Please select a partitioning method.") @@ -677,8 +709,9 @@ by pressing the Exit button.~%~%"))) #:button-text (G_ "Exit") #:button-callback-procedure button-exit-action)) (method (car result))) - (case method - ((entire) + (cond + ((or (eq? method 'entire) + (eq? method 'entire-crypted)) (let* ((device (run-device-page devices)) (disk-type (disk-probe device)) (disk (if disk-type @@ -696,7 +729,7 @@ by pressing the Exit button.~%~%"))) (disk-partitions disk))))) (run-disk-page (list disk) user-partitions #:guided? #t))) - ((manual) + ((eq? method 'manual) (let* ((disks (map disk-new devices)) (user-partitions (append-map create-special-user-partitions @@ -708,11 +741,13 @@ by pressing the Exit button.~%~%"))) (init-parted) (let* ((non-install-devices (non-install-devices)) (user-partitions (run-page non-install-devices)) + (user-partitions-with-pass (prompt-luks-passwords + user-partitions)) (form (draw-formating-page))) ;; Make sure the disks are not in use before proceeding to formating. (free-parted non-install-devices) - (run-error-page (format #f "~a" user-partitions) + (run-error-page (format #f "~a" user-partitions-with-pass) "user-partitions") - (format-user-partitions user-partitions) + (format-user-partitions user-partitions-with-pass) (destroy-form-and-pop form) user-partitions)) diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm index b0fe672131..c56da60550 100644 --- a/gnu/installer/parted.scm +++ b/gnu/installer/parted.scm @@ -22,13 +22,16 @@ #:use-module (gnu installer newt page) #:use-module (gnu system uuid) #:use-module ((gnu build file-systems) - #:select (read-partition-uuid)) + #:select (read-partition-uuid + find-partition-by-luks-uuid)) #:use-module (guix build syscalls) #:use-module (guix build utils) #:use-module (guix records) + #:use-module (guix utils) #:use-module (guix i18n) #:use-module (parted) #:use-module (ice-9 match) + #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -41,6 +44,8 @@ user-partition-type user-partition-path user-partition-disk-path + user-partition-crypt-label + user-partition-crypt-password user-partition-fs-type user-partition-bootable? user-partition-esp? @@ -128,6 +133,10 @@ (default #f)) (disk-path user-partition-disk-path (default #f)) + (crypt-label user-partition-crypt-label + (default #f)) + (crypt-password user-partition-crypt-password + (default #f)) (fs-type user-partition-fs-type (default 'ext4)) (bootable? user-partition-bootable? @@ -427,7 +436,9 @@ DEVICE." (define (maybe-string-pad string length) "Returned a string formatted by padding STRING of LENGTH characters to the right. If STRING is #f use an empty string." - (string-pad-right (or string "") length)) + (if (and string (not (string=? string ""))) + (string-pad-right string length) + "")) (let* ((disk (partition-disk partition)) (device (disk-device disk)) @@ -452,6 +463,8 @@ right. If STRING is #f use an empty string." (fs-type (partition-fs-type partition)) (fs-type-name (and fs-type (filesystem-type-name fs-type))) + (crypt-label (and user-partition + (user-partition-crypt-label user-partition))) (flags (and (not (freespace-partition? partition)) (partition-print-flags partition))) (mount-point (and user-partition @@ -464,6 +477,7 @@ right. If STRING is #f use an empty string." ,(or fs-type-name "") ,(or flags "") ,(or mount-point "") + ,(or crypt-label "") ,(maybe-string-pad name 30)))) (define (partitions-descriptions partitions user-partitions) @@ -525,6 +539,7 @@ determined by MAX-LENGTH-COLUMN procedure." (bootable? (user-partition-bootable? user-partition)) (esp? (user-partition-esp? user-partition)) (need-formating? (user-partition-need-formating? user-partition)) + (crypt-label (user-partition-crypt-label user-partition)) (size (user-partition-size user-partition)) (mount-point (user-partition-mount-point user-partition))) `(,@(if has-name? @@ -555,6 +570,15 @@ determined by MAX-LENGTH-COLUMN procedure." (partition-length partition))))) `((size . ,(string-append "Size : " size-formatted)))) '()) + ,@(if (or (eq? type 'extended) + (eq? fs-type 'swap)) + '() + `((crypt-label + . ,(string-append + "Encryption: " + (if crypt-label + (format #f "Yes (label ~a)" crypt-label) + "No"))))) ,@(if (or (freespace-partition? partition) (eq? fs-type 'swap)) '() @@ -854,7 +878,8 @@ USER-PARTITIONS list and return the updated list." user-partitions)) (define* (auto-partition disk - #:key (scheme 'entire-root)) + #:key + (scheme 'entire-root)) "Automatically create partitions on DISK. All the previous partitions (except the ESP on a GPT disk, if present) are wiped. SCHEME is the desired partitioning scheme. It can be 'entire-root or @@ -913,46 +938,57 @@ swap partition, a root partition and a home partition." (bios-grub? #t) (size bios-grub-size))))) (new-partitions - (case scheme - ((entire-root) - `(,@(if start-partition - `(,start-partition) - '()) - ,(user-partition - (fs-type 'swap) - (size swap-size)) - ,(user-partition - (fs-type 'ext4) - (bootable? has-extended?) - (size "100%") - (mount-point "/")))) - ((entire-root-home) - `(,@(if start-partition - `(,start-partition) - '()) - ,(user-partition - (fs-type 'ext4) - (bootable? has-extended?) - (size "33%") - (mount-point "/")) - ,@(if has-extended? - `(,(user-partition - (type 'extended) - (size "100%"))) - '()) - ,(user-partition - (type (if has-extended? - 'logical - 'normal)) - (fs-type 'swap) - (size swap-size)) - ,(user-partition - (type (if has-extended? - 'logical - 'normal)) - (fs-type 'ext4) - (size "100%") - (mount-point "/home")))))) + (cond + ((or (eq? scheme 'entire-root) + (eq? scheme 'entire-crypted-root)) + (let ((crypted? (eq? scheme 'entire-crypted-root))) + `(,@(if start-partition + `(,start-partition) + '()) + ,@(if crypted? + '() + `(,(user-partition + (fs-type 'swap) + (size swap-size)))) + ,(user-partition + (fs-type 'ext4) + (bootable? has-extended?) + (crypt-label (and crypted? "cryptroot")) + (size "100%") + (mount-point "/"))))) + ((or (eq? scheme 'entire-root-home) + (eq? scheme 'entire-crypted-root-home)) + (let ((crypted? (eq? scheme 'entire-crypted-root-home))) + `(,@(if start-partition + `(,start-partition) + '()) + ,(user-partition + (fs-type 'ext4) + (bootable? has-extended?) + (crypt-label (and crypted? "cryptroot")) + (size "33%") + (mount-point "/")) + ,@(if has-extended? + `(,(user-partition + (type 'extended) + (size "100%"))) + '()) + ,@(if crypted? + '() + `(,(user-partition + (type (if has-extended? + 'logical + 'normal)) + (fs-type 'swap) + (size swap-size)))) + ,(user-partition + (type (if has-extended? + 'logical + 'normal)) + (fs-type 'ext4) + (crypt-label (and crypted? "crypthome")) + (size "100%") + (mount-point "/home"))))))) (new-partitions* (force-user-partitions-formating new-partitions))) (create-adjacent-partitions disk @@ -1013,6 +1049,40 @@ bit bucket." (with-null-output-ports (invoke "mkswap" "-f" partition))) +(define (call-with-luks-key-file password proc) + "Write PASSWORD in a temporary file and pass it to PROC as argument." + (call-with-temporary-output-file + (lambda (file port) + (put-string port password) + (close port) + (proc file)))) + +(define (user-partition-upper-path user-partition) + "Return the path of the virtual block device corresponding to USER-PARTITION +if it is encrypted, or the plain path otherwise." + (let ((crypt-label (user-partition-crypt-label user-partition)) + (path (user-partition-path user-partition))) + (if crypt-label + (string-append "/dev/mapper/" crypt-label) + path))) + +(define (luks-format-and-open user-partition) + "Format and open the crypted partition pointed by USER-PARTITION." + (let* ((path (user-partition-path user-partition)) + (label (user-partition-crypt-label user-partition)) + (password (user-partition-crypt-password user-partition))) + (call-with-luks-key-file + password + (lambda (key-file) + (system* "cryptsetup" "-q" "luksFormat" path key-file) + (system* "cryptsetup" "open" "--type" "luks" + "--key-file" key-file path label))))) + +(define (luks-close user-partition) + "Close the crypted partition pointed by USER-PARTITION." + (let ((label (user-partition-crypt-label user-partition))) + (system* "cryptsetup" "close" label))) + (define (format-user-partitions user-partitions) "Format the records in USER-PARTITIONS list with NEED-FORMATING? field set to #t." @@ -1021,8 +1091,12 @@ NEED-FORMATING? field set to #t." (let* ((need-formating? (user-partition-need-formating? user-partition)) (type (user-partition-type user-partition)) - (path (user-partition-path user-partition)) + (crypt-label (user-partition-crypt-label user-partition)) + (path (user-partition-upper-path user-partition)) (fs-type (user-partition-fs-type user-partition))) + (when crypt-label + (luks-format-and-open user-partition)) + (case fs-type ((ext4) (and need-formating? @@ -1061,9 +1135,11 @@ respective mount-points." mount-point)) (fs-type (user-partition-fs-type user-partition)) + (crypt-label + (user-partition-crypt-label user-partition)) (mount-type (user-fs-type->mount-type fs-type)) - (path (user-partition-path user-partition))) + (path (user-partition-upper-path user-partition))) (mkdir-p target) (mount path target mount-type))) sorted-partitions))) @@ -1075,10 +1151,14 @@ respective mount-points." (for-each (lambda (user-partition) (let* ((mount-point (user-partition-mount-point user-partition)) + (crypt-label + (user-partition-crypt-label user-partition)) (target (string-append (%installer-target-dir) mount-point))) - (umount target))) + (umount target) + (when crypt-label + (luks-close user-partition)))) (reverse sorted-partitions)))) (define (find-swap-user-partitions user-partitions) @@ -1119,14 +1199,21 @@ the FS-TYPE field set to 'swap, return the empty list if none found." (gnu system file-systems) module and return it." (let* ((mount-point (user-partition-mount-point user-partition)) (fs-type (user-partition-fs-type user-partition)) + (crypt-label (user-partition-crypt-label user-partition)) (mount-type (user-fs-type->mount-type fs-type)) (path (user-partition-path user-partition)) + (upper-path (user-partition-upper-path user-partition)) (uuid (uuid->string (read-partition-uuid path) fs-type))) `(file-system (mount-point ,mount-point) - (device (uuid ,uuid (quote ,fs-type))) - (type ,mount-type)))) + (device ,@(if crypt-label + `(,upper-path) + `((uuid ,uuid (quote ,fs-type))))) + (type ,mount-type) + ,@(if crypt-label + '((dependencies mapped-devices)) + '())))) (define (user-partitions->file-systems user-partitions) "Convert the given USER-PARTITIONS list of records into a @@ -1139,6 +1226,16 @@ list of records." (user-partition->file-system user-partition)))) user-partitions)) +(define (user-partition->mapped-device user-partition) + "Convert the given USER-PARTITION record into a MAPPED-DEVICE record +from (gnu system mapped-devices) and return it." + (let ((label (user-partition-crypt-label user-partition)) + (path (user-partition-path user-partition))) + `(mapped-device + (source (uuid ,(uuid->string (read-partition-uuid path)))) + (target ,label) + (type luks-device-mapping)))) + (define (bootloader-configuration user-partitions) "Return the bootloader configuration field for USER-PARTITIONS." (let* ((root-partition @@ -1159,11 +1256,18 @@ list of records." (define (user-partitions->configuration user-partitions) "Return the configuration field for USER-PARTITIONS." (let* ((swap-user-partitions (find-swap-user-partitions user-partitions)) - (swap-devices (map user-partition-path swap-user-partitions))) + (swap-devices (map user-partition-path swap-user-partitions)) + (crypted-partitions + (filter user-partition-crypt-label user-partitions))) `(,@(if (null? swap-devices) '() `((swap-devices (list ,@swap-devices)))) (bootloader ,@(bootloader-configuration user-partitions)) + ,@(if (null? crypted-partitions) + '() + `((mapped-devices + (list ,@(map user-partition->mapped-device + crypted-partitions))))) (file-systems (cons* ,@(user-partitions->file-systems user-partitions) %base-file-systems))))) -- cgit v1.2.3 From df3664f1ec9a8b3c59c0e61f197798c2dda986e3 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sat, 8 Dec 2018 10:37:56 +0900 Subject: installer: Clear screen upon exit. * gnu/installer/newt.scm (exit): Call clear-screen after newt-finish, (exit-error): ditto. --- gnu/installer/newt.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index 31329b5c0f..6c44b4acf6 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -47,7 +47,8 @@ (set-screen-size!)) (define (exit) - (newt-finish)) + (newt-finish) + (clear-screen)) (define (exit-error file key args) (newt-set-color COLORSET-ROOT "white" "red") @@ -66,7 +67,8 @@ problem. The backtrace is displayed below. Please report it by email to \ #:file-textbox-width width #:file-textbox-height height)) (newt-set-color COLORSET-ROOT "white" "blue") - (newt-finish)) + (newt-finish) + (clear-screen)) (define (final-page result prev-steps) (run-final-page result prev-steps)) -- cgit v1.2.3 From 59e8f3c3accb51c9b7dc4e012f40b9235b317efc Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sat, 8 Dec 2018 23:36:07 +0900 Subject: installer: parted: Use read-luks-partition-uuid instead of find-partition-by-luks-uuid. * gnu/installer/parted.scm (user-partition->mapped-device): Replace read-luks-partition-uuid by find-partition-by-luks-uuid, (user-partition->file-system): only compute uuid if the partition is not encrypted. --- gnu/installer/parted.scm | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm index c56da60550..c7be24051d 100644 --- a/gnu/installer/parted.scm +++ b/gnu/installer/parted.scm @@ -23,7 +23,7 @@ #:use-module (gnu system uuid) #:use-module ((gnu build file-systems) #:select (read-partition-uuid - find-partition-by-luks-uuid)) + read-luks-partition-uuid)) #:use-module (guix build syscalls) #:use-module (guix build utils) #:use-module (guix records) @@ -1203,8 +1203,9 @@ the FS-TYPE field set to 'swap, return the empty list if none found." (mount-type (user-fs-type->mount-type fs-type)) (path (user-partition-path user-partition)) (upper-path (user-partition-upper-path user-partition)) - (uuid (uuid->string (read-partition-uuid path) - fs-type))) + ;; Only compute uuid if partition is not encrypted. + (uuid (or crypt-label + (uuid->string (read-partition-uuid path) fs-type)))) `(file-system (mount-point ,mount-point) (device ,@(if crypt-label @@ -1232,7 +1233,9 @@ from (gnu system mapped-devices) and return it." (let ((label (user-partition-crypt-label user-partition)) (path (user-partition-path user-partition))) `(mapped-device - (source (uuid ,(uuid->string (read-partition-uuid path)))) + (source (uuid ,(uuid->string + (read-luks-partition-uuid path) + 'luks))) (target ,label) (type luks-device-mapping)))) -- cgit v1.2.3 From 5737ba841bd8e21e1cb5dc63e1fc5e09d31482bb Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sat, 8 Dec 2018 23:52:13 +0900 Subject: installer: Various renamings. 1. s/partitionment/partitioning/ 2. s/crypted/encrypted/ * gnu/installer.scm (installer-steps): Apply renamings. * gnu/installer/newt/partition.scm (run-disk-page): ditto, * gnu/installer/parted.scm (auto-partition): ditto, (luks-format-and-open): ditto, (luks-close): ditto, (user-partitions->configuration): ditto. --- gnu/installer.scm | 4 ++-- gnu/installer/newt/partition.scm | 2 +- gnu/installer/parted.scm | 28 ++++++++++++++-------------- 3 files changed, 17 insertions(+), 17 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer.scm b/gnu/installer.scm index fd66359cbe..2ae139b13f 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -209,11 +209,11 @@ selected keymap." (compute (lambda _ (#$keymap-step current-installer)))) - ;; Run a partitionment tool allowing the user to modify + ;; Run a partitioning tool allowing the user to modify ;; partition tables, partitions and their mount points. (installer-step (id 'partition) - (description (G_ "Partitionment")) + (description (G_ "Partitioning")) (compute (lambda _ ((installer-partition-page current-installer)))) (configuration-formatter user-partitions->configuration)) diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index f4d1735dda..0bd84be8d9 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -636,7 +636,7 @@ partition, select a free space area and press ENTER. At least one partition must have its mounting point set to '/'.")) (guided-info-text (format #f (G_ "This is the proposed \ -partitionment. It is still possible to edit it or to go back to install menu \ +partitioning. It is still possible to edit it or to go back to install menu \ by pressing the Exit button.~%~%"))) (result (run-listbox-selection-page diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm index c7be24051d..1ff17d39d6 100644 --- a/gnu/installer/parted.scm +++ b/gnu/installer/parted.scm @@ -940,12 +940,12 @@ swap partition, a root partition and a home partition." (new-partitions (cond ((or (eq? scheme 'entire-root) - (eq? scheme 'entire-crypted-root)) - (let ((crypted? (eq? scheme 'entire-crypted-root))) + (eq? scheme 'entire-encrypted-root)) + (let ((encrypted? (eq? scheme 'entire-encrypted-root))) `(,@(if start-partition `(,start-partition) '()) - ,@(if crypted? + ,@(if encrypted? '() `(,(user-partition (fs-type 'swap) @@ -953,19 +953,19 @@ swap partition, a root partition and a home partition." ,(user-partition (fs-type 'ext4) (bootable? has-extended?) - (crypt-label (and crypted? "cryptroot")) + (crypt-label (and encrypted? "cryptroot")) (size "100%") (mount-point "/"))))) ((or (eq? scheme 'entire-root-home) - (eq? scheme 'entire-crypted-root-home)) - (let ((crypted? (eq? scheme 'entire-crypted-root-home))) + (eq? scheme 'entire-encrypted-root-home)) + (let ((encrypted? (eq? scheme 'entire-encrypted-root-home))) `(,@(if start-partition `(,start-partition) '()) ,(user-partition (fs-type 'ext4) (bootable? has-extended?) - (crypt-label (and crypted? "cryptroot")) + (crypt-label (and encrypted? "cryptroot")) (size "33%") (mount-point "/")) ,@(if has-extended? @@ -973,7 +973,7 @@ swap partition, a root partition and a home partition." (type 'extended) (size "100%"))) '()) - ,@(if crypted? + ,@(if encrypted? '() `(,(user-partition (type (if has-extended? @@ -986,7 +986,7 @@ swap partition, a root partition and a home partition." 'logical 'normal)) (fs-type 'ext4) - (crypt-label (and crypted? "crypthome")) + (crypt-label (and encrypted? "crypthome")) (size "100%") (mount-point "/home"))))))) (new-partitions* (force-user-partitions-formating @@ -1067,7 +1067,7 @@ if it is encrypted, or the plain path otherwise." path))) (define (luks-format-and-open user-partition) - "Format and open the crypted partition pointed by USER-PARTITION." + "Format and open the encrypted partition pointed by USER-PARTITION." (let* ((path (user-partition-path user-partition)) (label (user-partition-crypt-label user-partition)) (password (user-partition-crypt-password user-partition))) @@ -1079,7 +1079,7 @@ if it is encrypted, or the plain path otherwise." "--key-file" key-file path label))))) (define (luks-close user-partition) - "Close the crypted partition pointed by USER-PARTITION." + "Close the encrypted partition pointed by USER-PARTITION." (let ((label (user-partition-crypt-label user-partition))) (system* "cryptsetup" "close" label))) @@ -1260,17 +1260,17 @@ from (gnu system mapped-devices) and return it." "Return the configuration field for USER-PARTITIONS." (let* ((swap-user-partitions (find-swap-user-partitions user-partitions)) (swap-devices (map user-partition-path swap-user-partitions)) - (crypted-partitions + (encrypted-partitions (filter user-partition-crypt-label user-partitions))) `(,@(if (null? swap-devices) '() `((swap-devices (list ,@swap-devices)))) (bootloader ,@(bootloader-configuration user-partitions)) - ,@(if (null? crypted-partitions) + ,@(if (null? encrypted-partitions) '() `((mapped-devices (list ,@(map user-partition->mapped-device - crypted-partitions))))) + encrypted-partitions))))) (file-systems (cons* ,@(user-partitions->file-systems user-partitions) %base-file-systems))))) -- cgit v1.2.3 From 44b2d31c2834cae13475a47bbb5a7258358ea03b Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sun, 9 Dec 2018 11:09:43 +0900 Subject: installer: Various renamins follow-up. s/path/file and s/crypt/encrypt. * gnu/installer/newt/partition.scm: Apply renamings. * gnu/installer/parted.scm: Ditto. --- gnu/installer/newt/partition.scm | 20 +++---- gnu/installer/parted.scm | 119 ++++++++++++++++++++------------------- 2 files changed, 70 insertions(+), 69 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index 0bd84be8d9..56e9dafd49 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -143,12 +143,12 @@ an inform the user with an appropriate error-page and return #f." USER-PARTITIONS list. Return this list with password fields filled-in." (map (lambda (user-part) (let* ((crypt-label (user-partition-crypt-label user-part)) - (path (user-partition-path user-part)) + (file-name (user-partition-file-name user-part)) (password-page (lambda () (run-input-page (format #f (G_ "Please enter the password for the \ -encryption of partition ~a (label: ~a).") path crypt-label) +encryption of partition ~a (label: ~a).") file-name crypt-label) (G_ "Password required"))))) (if crypt-label (user-partition @@ -378,8 +378,8 @@ partition. Leave this field empty if you don't want to set a mounting point.") (user-partition (inherit new-user-partition) (need-formating? #t) - (path (partition-get-path new-partition)) - (disk-path (device-path device)) + (file-name (partition-get-path new-partition)) + (disk-file-name (device-path device)) (parted-object new-partition)))) (and (apply-user-partition-changes new-user-partition) new-user-partition)))) @@ -389,7 +389,7 @@ partition. Leave this field empty if you don't want to set a mounting point.") target-user-partition)) (disk (partition-disk partition)) (device (disk-device disk)) - (path (device-path device)) + (file-name (device-path device)) (number-str (partition-print-number partition)) (type (user-partition-type target-user-partition)) (type-str (symbol->string type)) @@ -404,7 +404,7 @@ partition. Leave this field empty if you don't want to set a mounting point.") #:info-text (if creation? (G_ (format #f "Creating ~a partition starting at ~a of ~a." - type-str start path)) + type-str start file-name)) (G_ (format #f "You are currently editing partition ~a." number-str))) #:title (if creation? @@ -589,10 +589,10 @@ edit it." (cond ((disk? item) (let* ((device (disk-device item)) - (path (device-path device)) + (file-name (device-path device)) (info-text (format #f (G_ "Are you sure you want to delete everything on disk ~a?") - path)) + file-name)) (result (choice-window (G_ "Delete disk") (G_ "Ok") (G_ "Exit") @@ -699,7 +699,7 @@ by pressing the Exit button.~%~%"))) (define (run-page devices) (let* ((items '((entire . "Guided - using the entire disk") - (entire-crypted . "Guided - using the entire disk with encryption") + (entire-encrypted . "Guided - using the entire disk with encryption") (manual . "Manual"))) (result (run-listbox-selection-page #:info-text (G_ "Please select a partitioning method.") @@ -711,7 +711,7 @@ by pressing the Exit button.~%~%"))) (method (car result))) (cond ((or (eq? method 'entire) - (eq? method 'entire-crypted)) + (eq? method 'entire-encrypted)) (let* ((device (run-device-page devices)) (disk-type (disk-probe device)) (disk (if disk-type diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm index 1ff17d39d6..ea62d6ad77 100644 --- a/gnu/installer/parted.scm +++ b/gnu/installer/parted.scm @@ -42,8 +42,8 @@ user-partition? user-partition-name user-partition-type - user-partition-path - user-partition-disk-path + user-partition-file-name + user-partition-disk-file-name user-partition-crypt-label user-partition-crypt-password user-partition-fs-type @@ -106,7 +106,7 @@ no-root-mount-point? check-user-partitions - set-user-partitions-path + set-user-partitions-file-name format-user-partitions mount-user-partitions umount-user-partitions @@ -129,9 +129,9 @@ (default #f)) (type user-partition-type (default 'normal)) ; 'normal | 'logical | 'extended - (path user-partition-path + (file-name user-partition-file-name (default #f)) - (disk-path user-partition-disk-path + (disk-file-name user-partition-disk-file-name (default #f)) (crypt-label user-partition-crypt-label (default #f)) @@ -304,8 +304,8 @@ of record." name)) (type (or (partition-user-type partition) 'normal)) - (path (partition-get-path partition)) - (disk-path (device-path device)) + (file-name (partition-get-path partition)) + (disk-file-name (device-path device)) (fs-type (or (partition-filesystem-user-type partition) 'ext4)) (mount-point (and (esp-partition? partition) @@ -336,12 +336,12 @@ PARTED-OBJECT field equals PARTITION, return #f if not found." ;; Devices ;; -(define (with-delay-device-in-use? path) +(define (with-delay-device-in-use? file-name) "Call DEVICE-IN-USE? with a few retries, as the first re-read will often fail. See rereadpt function in wipefs.c of util-linux for an explanation." (let loop ((try 4)) (usleep 250000) - (let ((in-use? (device-in-use? path))) + (let ((in-use? (device-in-use? file-name))) (if (and in-use? (> try 0)) (loop (- try 1)) in-use?)))) @@ -361,9 +361,9 @@ from (guix build syscalls) module, who will try to re-read the device's partition table to determine whether or not it is already used (like sfdisk from util-linux)." (remove (lambda (device) - (let ((path (device-path device))) + (let ((file-name (device-path device))) (or (device-is-busy? device) - (with-delay-device-in-use? path)))) + (with-delay-device-in-use? file-name)))) (devices))) @@ -374,7 +374,7 @@ from util-linux)." (define* (device-description device #:optional disk) "Return a string describing the given DEVICE." (let* ((type (device-type device)) - (path (device-path device)) + (file-name (device-path device)) (model (device-model device)) (type-str (device-type->string type)) (disk-type (if disk @@ -389,7 +389,7 @@ from util-linux)." `(,@(if (string=? model "") `(,type-str) `(,model ,(string-append "(" type-str ")"))) - ,path + ,file-name ,end ,@(if disk-type `(,(disk-type-name disk-type)) @@ -854,8 +854,8 @@ partition." (if new-partition (cons (user-partition (inherit new-user-partition) - (path (partition-get-path new-partition)) - (disk-path (device-path device)) + (file-name (partition-get-path new-partition)) + (disk-file-name (device-path device)) (parted-object new-partition)) (loop rest (if (eq? type 'extended) @@ -946,10 +946,10 @@ swap partition, a root partition and a home partition." `(,start-partition) '()) ,@(if encrypted? - '() - `(,(user-partition - (fs-type 'swap) - (size swap-size)))) + '() + `(,(user-partition + (fs-type 'swap) + (size swap-size)))) ,(user-partition (fs-type 'ext4) (bootable? has-extended?) @@ -1015,15 +1015,15 @@ otherwise." (raise (condition (&no-root-mount-point)))))) -(define (set-user-partitions-path user-partitions) - "Set the partition path of records in USER-PARTITIONS list -and return the updated list." +(define (set-user-partitions-file-name user-partitions) + "Set the partition file-name of records in USER-PARTITIONS +list and return the updated list." (map (lambda (p) (let* ((partition (user-partition-parted-object p)) - (path (partition-get-path partition))) + (file-name (partition-get-path partition))) (user-partition (inherit p) - (path path)))) + (file-name file-name)))) user-partitions)) (define-syntax-rule (with-null-output-ports exp ...) @@ -1035,17 +1035,17 @@ bit bucket." (lambda () exp ...))))) (define (create-ext4-file-system partition) - "Create an ext4 file-system for PARTITION path." + "Create an ext4 file-system for PARTITION file-name." (with-null-output-ports (invoke "mkfs.ext4" "-F" partition))) (define (create-fat32-file-system partition) - "Create an ext4 file-system for PARTITION path." + "Create an ext4 file-system for PARTITION file-name." (with-null-output-ports (invoke "mkfs.fat" "-F32" partition))) (define (create-swap-partition partition) - "Set up swap area on PARTITION path." + "Set up swap area on PARTITION file-name." (with-null-output-ports (invoke "mkswap" "-f" partition))) @@ -1057,26 +1057,26 @@ bit bucket." (close port) (proc file)))) -(define (user-partition-upper-path user-partition) - "Return the path of the virtual block device corresponding to USER-PARTITION -if it is encrypted, or the plain path otherwise." +(define (user-partition-upper-file-name user-partition) + "Return the file-name of the virtual block device corresponding to +USER-PARTITION if it is encrypted, or the plain file-name otherwise." (let ((crypt-label (user-partition-crypt-label user-partition)) - (path (user-partition-path user-partition))) + (file-name (user-partition-file-name user-partition))) (if crypt-label (string-append "/dev/mapper/" crypt-label) - path))) + file-name))) (define (luks-format-and-open user-partition) "Format and open the encrypted partition pointed by USER-PARTITION." - (let* ((path (user-partition-path user-partition)) + (let* ((file-name (user-partition-file-name user-partition)) (label (user-partition-crypt-label user-partition)) (password (user-partition-crypt-password user-partition))) (call-with-luks-key-file password (lambda (key-file) - (system* "cryptsetup" "-q" "luksFormat" path key-file) + (system* "cryptsetup" "-q" "luksFormat" file-name key-file) (system* "cryptsetup" "open" "--type" "luks" - "--key-file" key-file path label))))) + "--key-file" key-file file-name label))))) (define (luks-close user-partition) "Close the encrypted partition pointed by USER-PARTITION." @@ -1092,7 +1092,7 @@ NEED-FORMATING? field set to #t." (user-partition-need-formating? user-partition)) (type (user-partition-type user-partition)) (crypt-label (user-partition-crypt-label user-partition)) - (path (user-partition-upper-path user-partition)) + (file-name (user-partition-upper-file-name user-partition)) (fs-type (user-partition-fs-type user-partition))) (when crypt-label (luks-format-and-open user-partition)) @@ -1101,13 +1101,13 @@ NEED-FORMATING? field set to #t." ((ext4) (and need-formating? (not (eq? type 'extended)) - (create-ext4-file-system path))) + (create-ext4-file-system file-name))) ((fat32) (and need-formating? (not (eq? type 'extended)) - (create-fat32-file-system path))) + (create-fat32-file-system file-name))) ((swap) - (create-swap-partition path)) + (create-swap-partition file-name)) (else ;; TODO: Add support for other file-system types. #t)))) @@ -1139,9 +1139,10 @@ respective mount-points." (user-partition-crypt-label user-partition)) (mount-type (user-fs-type->mount-type fs-type)) - (path (user-partition-upper-path user-partition))) + (file-name + (user-partition-upper-file-name user-partition))) (mkdir-p target) - (mount path target mount-type))) + (mount file-name target mount-type))) sorted-partitions))) (define (umount-user-partitions user-partitions) @@ -1165,20 +1166,20 @@ respective mount-points." "Return the subset of records in USER-PARTITIONS list with the FS-TYPE field set to 'swap, return the empty list if none found." (filter (lambda (user-partition) - (let ((fs-type (user-partition-fs-type user-partition))) - (eq? fs-type 'swap))) - user-partitions)) + (let ((fs-type (user-partition-fs-type user-partition))) + (eq? fs-type 'swap))) + user-partitions)) (define (start-swapping user-partitions) "Start swaping on records with FS-TYPE equal to 'swap." (let* ((swap-user-partitions (find-swap-user-partitions user-partitions)) - (swap-devices (map user-partition-path swap-user-partitions))) + (swap-devices (map user-partition-file-name swap-user-partitions))) (for-each swapon swap-devices))) (define (stop-swapping user-partitions) "Stop swaping on records with FS-TYPE equal to 'swap." (let* ((swap-user-partitions (find-swap-user-partitions user-partitions)) - (swap-devices (map user-partition-path swap-user-partitions))) + (swap-devices (map user-partition-file-name swap-user-partitions))) (for-each swapoff swap-devices))) (define-syntax-rule (with-mounted-partitions user-partitions exp ...) @@ -1201,15 +1202,15 @@ the FS-TYPE field set to 'swap, return the empty list if none found." (fs-type (user-partition-fs-type user-partition)) (crypt-label (user-partition-crypt-label user-partition)) (mount-type (user-fs-type->mount-type fs-type)) - (path (user-partition-path user-partition)) - (upper-path (user-partition-upper-path user-partition)) + (file-name (user-partition-file-name user-partition)) + (upper-file-name (user-partition-upper-file-name user-partition)) ;; Only compute uuid if partition is not encrypted. (uuid (or crypt-label - (uuid->string (read-partition-uuid path) fs-type)))) + (uuid->string (read-partition-uuid file-name) fs-type)))) `(file-system (mount-point ,mount-point) (device ,@(if crypt-label - `(,upper-path) + `(,upper-file-name) `((uuid ,uuid (quote ,fs-type))))) (type ,mount-type) ,@(if crypt-label @@ -1231,10 +1232,10 @@ list of records." "Convert the given USER-PARTITION record into a MAPPED-DEVICE record from (gnu system mapped-devices) and return it." (let ((label (user-partition-crypt-label user-partition)) - (path (user-partition-path user-partition))) + (file-name (user-partition-file-name user-partition))) `(mapped-device (source (uuid ,(uuid->string - (read-luks-partition-uuid path) + (read-luks-partition-uuid file-name) 'luks))) (target ,label) (type luks-device-mapping)))) @@ -1248,7 +1249,7 @@ from (gnu system mapped-devices) and return it." (and mount-point (string=? mount-point "/")))) user-partitions)) - (root-partition-disk (user-partition-disk-path root-partition))) + (root-partition-disk (user-partition-disk-file-name root-partition))) `((bootloader-configuration ,@(if (efi-installation?) `((bootloader grub-efi-bootloader) @@ -1259,7 +1260,7 @@ from (gnu system mapped-devices) and return it." (define (user-partitions->configuration user-partitions) "Return the configuration field for USER-PARTITIONS." (let* ((swap-user-partitions (find-swap-user-partitions user-partitions)) - (swap-devices (map user-partition-path swap-user-partitions)) + (swap-devices (map user-partition-file-name swap-user-partitions)) (encrypted-partitions (filter user-partition-crypt-label user-partitions))) `(,@(if (null? swap-devices) @@ -1296,13 +1297,13 @@ the devices not to be used before returning." ;; them to stop returning EBUSY to BLKRRPART ioctl seems to be enough. The ;; same kind of issue is described here: ;; https://mail.gnome.org/archives/commits-list/2013-March/msg18423.html. - (let ((device-paths (map device-path devices))) + (let ((device-file-names (map device-path devices))) (for-each force-device-sync devices) (free-all-devices) - (for-each (lambda (path) - (let ((in-use? (with-delay-device-in-use? path))) + (for-each (lambda (file-name) + (let ((in-use? (with-delay-device-in-use? file-name))) (and in-use? (error (format #f (G_ "Device ~a is still in use.") - path))))) - device-paths))) + file-name))))) + device-file-names))) -- cgit v1.2.3 From f297c213a1b8a364f60c1de825761f1d9ad7eb5e Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Tue, 1 Jan 2019 19:23:21 +0100 Subject: installer: parted: Do not call BLKRRPART on loop devices. * gnu/installer/parted.scm (with-delay-device-in-use?): Return immediately if the file-name passed as argument designates a loop device. --- gnu/installer/parted.scm | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm index ea62d6ad77..40054c0be2 100644 --- a/gnu/installer/parted.scm +++ b/gnu/installer/parted.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Mathieu Othacehe +;;; Copyright © 2018, 2019 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,6 +31,7 @@ #:use-module (guix i18n) #:use-module (parted) #:use-module (ice-9 match) + #:use-module (ice-9 regex) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -339,12 +340,14 @@ PARTED-OBJECT field equals PARTITION, return #f if not found." (define (with-delay-device-in-use? file-name) "Call DEVICE-IN-USE? with a few retries, as the first re-read will often fail. See rereadpt function in wipefs.c of util-linux for an explanation." - (let loop ((try 4)) - (usleep 250000) - (let ((in-use? (device-in-use? file-name))) - (if (and in-use? (> try 0)) - (loop (- try 1)) - in-use?)))) + ;; Kernel always return EINVAL for BLKRRPART on loopdevices. + (and (not (string-match "/dev/loop*" file-name)) + (let loop ((try 4)) + (usleep 250000) + (let ((in-use? (device-in-use? file-name))) + (if (and in-use? (> try 0)) + (loop (- try 1)) + in-use?))))) (define* (force-device-sync device) "Force a flushing of the given DEVICE." -- cgit v1.2.3 From ebb36deccc84b1d4414a2b54a3e1df7e7ba94cff Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sun, 6 Jan 2019 11:04:14 +0100 Subject: installer: Rename "Ok" buttons to "OK". * gnu/installer/newt/page.scm: s/Ok/OK/. * gnu/installer/newt/partition.scm: Ditto. * gnu/installer/newt/user.scm: Ditto. --- gnu/installer/newt/page.scm | 8 ++++---- gnu/installer/newt/partition.scm | 8 ++++---- gnu/installer/newt/user.scm | 4 ++-- 3 files changed, 10 insertions(+), 10 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm index c0d7547293..edf0b8c999 100644 --- a/gnu/installer/newt/page.scm +++ b/gnu/installer/newt/page.scm @@ -83,7 +83,7 @@ enters an empty input." #:flags FLAG-BORDER)) (grid (make-grid 1 3)) (input-entry (make-entry -1 -1 20)) - (ok-button (make-button -1 -1 (G_ "Ok"))) + (ok-button (make-button -1 -1 (G_ "OK"))) (form (make-form))) (when default-text @@ -125,7 +125,7 @@ of the page is set to TITLE." (make-reflowed-textbox -1 -1 text 40 #:flags FLAG-BORDER)) (grid (make-grid 1 2)) - (ok-button (make-button -1 -1 "Ok")) + (ok-button (make-button -1 -1 "OK")) (form (make-form))) (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box) @@ -438,7 +438,7 @@ ITEMS when 'Ok' is pressed." (make-reflowed-textbox -1 -1 info-text info-textbox-width #:flags FLAG-BORDER)) - (ok-button (make-button -1 -1 (G_ "Ok"))) + (ok-button (make-button -1 -1 (G_ "OK"))) (exit-button (make-button -1 -1 (G_ "Exit"))) (grid (vertically-stacked-grid GRID-ELEMENT-COMPONENT info-textbox @@ -495,7 +495,7 @@ ITEMS when 'Ok' is pressed." file-textbox-width file-textbox-height (logior FLAG-SCROLL FLAG-BORDER))) - (ok-button (make-button -1 -1 (G_ "Ok"))) + (ok-button (make-button -1 -1 (G_ "OK"))) (exit-button (make-button -1 -1 (G_ "Exit"))) (grid (vertically-stacked-grid GRID-ELEMENT-COMPONENT info-textbox diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index 56e9dafd49..84d77c1639 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -414,7 +414,7 @@ partition. Leave this field empty if you don't want to set a mounting point.") #:listbox-item->text cdr #:sort-listbox-items? #f #:listbox-default-item default-item - #:button-text (G_ "Ok") + #:button-text (G_ "OK") #:listbox-callback-procedure listbox-action #:button-callback-procedure button-action))) (match result @@ -594,7 +594,7 @@ edit it." (format #f (G_ "Are you sure you want to delete everything on disk ~a?") file-name)) (result (choice-window (G_ "Delete disk") - (G_ "Ok") + (G_ "OK") (G_ "Exit") info-text))) (case result @@ -615,7 +615,7 @@ edit it." (format #f (G_ "Are you sure you want to delete partition ~a?") number-str)) (result (choice-window (G_ "Delete partition") - (G_ "Ok") + (G_ "OK") (G_ "Exit") info-text))) (case result @@ -653,7 +653,7 @@ by pressing the Exit button.~%~%"))) #:sort-listbox-items? #f #:skip-item-procedure? skip-item? #:allow-delete? #t - #:button-text (G_ "Ok") + #:button-text (G_ "OK") #:button-callback-procedure button-ok-action #:button2-text (G_ "Exit") #:button2-callback-procedure button-exit-action diff --git a/gnu/installer/newt/user.scm b/gnu/installer/newt/user.scm index f65dbb30e5..59b1913cfc 100644 --- a/gnu/installer/newt/user.scm +++ b/gnu/installer/newt/user.scm @@ -41,7 +41,7 @@ (entry-home-directory (make-entry -1 -1 entry-width)) (entry-grid (make-grid 2 2)) (button-grid (make-grid 1 1)) - (ok-button (make-button -1 -1 (G_ "Ok"))) + (ok-button (make-button -1 -1 (G_ "OK"))) (grid (make-grid 1 2)) (title (G_ "User creation")) (set-entry-grid-field @@ -115,7 +115,7 @@ `(,@(if (null? users) '() (list GRID-ELEMENT-COMPONENT del-button))))) - (ok-button (make-button -1 -1 (G_ "Ok"))) + (ok-button (make-button -1 -1 (G_ "OK"))) (exit-button (make-button -1 -1 (G_ "Exit"))) (title "User creation") (grid -- cgit v1.2.3 From a8c4b6828810e88db56ab5f0b83fa80e9c962cfa Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sun, 6 Jan 2019 11:06:51 +0100 Subject: installer: welcome: Put "Graphical installer" ahead. * gnu/installer/newt/welcome.scm (run-welcome-page): Propose "Graphical install" before shell based install. --- gnu/installer/newt/welcome.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm index 658f7bae40..eec98e291a 100644 --- a/gnu/installer/newt/welcome.scm +++ b/gnu/installer/newt/welcome.scm @@ -100,16 +100,16 @@ development, so you might want to prefer using the shell based process. \ The documentation is accessible at any time by pressing CTRL-ALT-F2.") logo #:listbox-items - `((,(G_ "Install using the shell based process") + `((,(G_ "Graphical install using a terminal based interface") + . + ,(const #t)) + (,(G_ "Install using the shell based process") . ,(lambda () ;; Switch to TTY3, where a root shell is available for shell based ;; install. The other root TTY's would have been ok too. (system* "chvt" "3") (run-welcome-page logo))) - (,(G_ "Graphical install using a terminal based interface") - . - ,(const #t)) (,(G_ "Reboot") . ,(lambda () -- cgit v1.2.3 From 513914b59f0a89eb559f3c894d188a4cf98ecdc1 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sun, 6 Jan 2019 11:11:51 +0100 Subject: installer: Remove debug popup. * gnu/installer/newt/partition.scm (run-partioning-page): Remove debug partition popup. --- gnu/installer/newt/partition.scm | 2 -- 1 file changed, 2 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index 84d77c1639..d10e8cd2b7 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -746,8 +746,6 @@ by pressing the Exit button.~%~%"))) (form (draw-formating-page))) ;; Make sure the disks are not in use before proceeding to formating. (free-parted non-install-devices) - (run-error-page (format #f "~a" user-partitions-with-pass) - "user-partitions") (format-user-partitions user-partitions-with-pass) (destroy-form-and-pop form) user-partitions)) -- cgit v1.2.3 From cb614af01146d9d4be40e705f71db4efcbe684e7 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sat, 12 Jan 2019 18:26:11 +0100 Subject: installer: keymap: Put English layout and international variant ahead. * gnu/installer/newt/keymap.scm (sort-layouts): New procedure, (sort-variants): new procedure, (run-keymap-page): use the two procedures above to sort layouts and variants. --- gnu/installer/newt/keymap.scm | 36 +++++++++++++++++++++++++++++++----- 1 file changed, 31 insertions(+), 5 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/keymap.scm b/gnu/installer/newt/keymap.scm index 55a0aa6bf9..6211af2bc5 100644 --- a/gnu/installer/newt/keymap.scm +++ b/gnu/installer/newt/keymap.scm @@ -24,6 +24,7 @@ #:use-module (guix records) #:use-module (newt) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:export (run-keymap-page)) @@ -35,6 +36,7 @@ #:info-text (G_ "Please choose your keyboard layout.") #:listbox-items layouts #:listbox-item->text layout->text + #:sort-listbox-items? #f #:button-text (G_ "Exit") #:button-callback-procedure (lambda _ @@ -49,6 +51,7 @@ #:info-text (G_ "Please choose a variant for your keyboard layout.") #:listbox-items variants #:listbox-item->text variant->text + #:sort-listbox-items? #f #:button-text (G_ "Back") #:button-callback-procedure (lambda _ @@ -56,6 +59,28 @@ (condition (&installer-step-abort))))))) +(define (sort-layouts layouts) + "Sort LAYOUTS list by putting the US layout ahead and return it." + (call-with-values + (lambda () + (partition + (lambda (layout) + (let ((name (x11-keymap-layout-name layout))) + (string=? name "us"))) + layouts)) + (cut append <> <>))) + +(define (sort-variants variants) + "Sort VARIANTS list by putting the internation variant ahead and return it." + (call-with-values + (lambda () + (partition + (lambda (variant) + (let ((name (x11-keymap-variant-name variant))) + (string=? name "altgr-intl"))) + variants)) + (cut append <> <>))) + (define* (run-keymap-page layouts) "Run a page asking the user to select a keyboard layout and variant. LAYOUTS is a list of supported X11-KEYMAP-LAYOUT. Return a list of two elements, the @@ -67,7 +92,7 @@ names of the selected keyboard layout and variant." (compute (lambda _ (run-layout-page - layouts + (sort-layouts layouts) (lambda (layout) (x11-keymap-layout-description layout)))))) ;; Propose the user to select a variant among those supported by the @@ -80,10 +105,11 @@ names of the selected keyboard layout and variant." (variants (x11-keymap-layout-variants layout))) ;; Return #f if the layout does not have any variant. (and (not (null? variants)) - (run-variant-page variants - (lambda (variant) - (x11-keymap-variant-description - variant)))))))))) + (run-variant-page + (sort-variants variants) + (lambda (variant) + (x11-keymap-variant-description + variant)))))))))) (define (format-result result) (let ((layout (x11-keymap-layout-name -- cgit v1.2.3 From f40728f9d65fcff4ca289d5c9642194e60d369d3 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sat, 12 Jan 2019 18:45:58 +0100 Subject: installer: partition: Add encryption password confirmation. * gnu/installer/newt/partition.scm (prompt-luks-passwords): Add password confirmation page. --- gnu/installer/newt/partition.scm | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index d10e8cd2b7..1c3ce80ce5 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -149,11 +149,26 @@ USER-PARTITIONS list. Return this list with password fields filled-in." (run-input-page (format #f (G_ "Please enter the password for the \ encryption of partition ~a (label: ~a).") file-name crypt-label) - (G_ "Password required"))))) + (G_ "Password required")))) + (password-confirm-page + (lambda () + (run-input-page + (format #f (G_ "Please confirm the password for the \ +encryption of partition ~a (label: ~a).") file-name crypt-label) + (G_ "Password confirmation required"))))) (if crypt-label - (user-partition - (inherit user-part) - (crypt-password (password-page))) + (let loop () + (let ((password (password-page)) + (confirmation (password-confirm-page))) + (if (string=? password confirmation) + (user-partition + (inherit user-part) + (crypt-password password)) + (begin + (run-error-page + (G_ "Password mismatch, please try again.") + (G_ "Password error")) + (loop))))) user-part))) user-partitions)) -- cgit v1.2.3 From 938ee975af8f35ae16c15443a7a76be7d31278eb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 16 Jan 2019 18:01:38 +0100 Subject: installer: Adjust messages on the final page. * gnu/installer/newt/final.scm (run-config-display-page) (run-install-success-page, run-install-failed-page): Adjust messages. --- gnu/installer/newt/final.scm | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm index 81af949de1..645c1e8689 100644 --- a/gnu/installer/newt/final.scm +++ b/gnu/installer/newt/final.scm @@ -34,9 +34,10 @@ (height (nearest-exact-integer (/ (screen-rows) 2)))) (run-file-textbox-page - #:info-text (G_ "Congratulations, the installation is almost over! A \ -system configuration file has been generated, it is displayed just below. The \ -new system will be created from this file when pression the Ok button.") + #:info-text (G_ "We're now ready to proceed with the installation! \ +A system configuration file has been generated, it is displayed below. \ +The new system will be created from this file once you've pressed OK. \ +This will take a few minutes.") #:title (G_ "Configuration file") #:file (%installer-configuration-file) #:info-textbox-width width @@ -52,15 +53,16 @@ new system will be created from this file when pression the Ok button.") (message-window (G_ "Installation complete") (G_ "Reboot") - (G_ "The installation finished with success. You may now remove the device \ -with the installation image and press the button to reboot."))) + (G_ "Congratulations! Installation is now complete. \ +You may remove the device containing the installation image and \ +press the button to reboot."))) (define (run-install-failed-page) (choice-window (G_ "Installation failed") (G_ "Restart installer") (G_ "Retry system install") - (G_ "The final system installation step failed. You can retry the \ + (G_ "The final system installation step failed. You can retry the \ last step, or restart the installer."))) (define (run-install-shell) -- cgit v1.2.3 From 85caf5f3239a60039eb4593687eed03ba423e52d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 16 Jan 2019 19:20:26 +0100 Subject: installer: "formating" → "formatting". MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/installer/newt/partition.scm, gnu/installer/parted.scm: Replace "formating" with "formatting". --- gnu/installer/newt/partition.scm | 18 +++++++++--------- gnu/installer/parted.scm | 26 +++++++++++++------------- 2 files changed, 22 insertions(+), 22 deletions(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index 1c3ce80ce5..c22e1c0290 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -52,10 +52,10 @@ #:button-callback-procedure button-exit-action))) (car result))) -(define (draw-formating-page) +(define (draw-formatting-page) "Draw a page to indicate partitions are being formated." (draw-info-page - (format #f (G_ "Partition formating is in progress, please wait.")) + (format #f (G_ "Partition formatting is in progress, please wait.")) (G_ "Preparing partitions"))) (define (run-device-page devices) @@ -288,13 +288,13 @@ by USER-PART, if it is applicable for the partition type." (G_ "Encryption label"))))) (user-partition (inherit target-user-partition) - (need-formating? #t) + (need-formatting? #t) (crypt-label new-label)))) - ((need-formating?) + ((need-formatting?) (user-partition (inherit target-user-partition) - (need-formating? - (not (user-partition-need-formating? + (need-formatting? + (not (user-partition-need-formatting? target-user-partition))))) ((size) (let* ((old-size (user-partition-size target-user-partition)) @@ -392,7 +392,7 @@ partition. Leave this field empty if you don't want to set a mounting point.") (and new-partition (user-partition (inherit new-user-partition) - (need-formating? #t) + (need-formatting? #t) (file-name (partition-get-path new-partition)) (disk-file-name (device-path device)) (parted-object new-partition)))) @@ -758,8 +758,8 @@ by pressing the Exit button.~%~%"))) (user-partitions (run-page non-install-devices)) (user-partitions-with-pass (prompt-luks-passwords user-partitions)) - (form (draw-formating-page))) - ;; Make sure the disks are not in use before proceeding to formating. + (form (draw-formatting-page))) + ;; Make sure the disks are not in use before proceeding to formatting. (free-parted non-install-devices) (format-user-partitions user-partitions-with-pass) (destroy-form-and-pop form) diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm index 40054c0be2..187311e633 100644 --- a/gnu/installer/parted.scm +++ b/gnu/installer/parted.scm @@ -55,7 +55,7 @@ user-partition-start user-partition-end user-partition-mount-point - user-partition-need-formating? + user-partition-need-formatting? user-partition-parted-object find-esp-partition @@ -154,7 +154,7 @@ (default #f)) (mount-point user-partition-mount-point ;string (default #f)) - (need-formating? user-partition-need-formating? ; boolean + (need-formatting? user-partition-need-formatting? ; boolean (default #f)) (parted-object user-partition-parted-object ; from parted (default #f))) @@ -541,7 +541,7 @@ determined by MAX-LENGTH-COLUMN procedure." (fs-type-name (user-fs-type-name fs-type)) (bootable? (user-partition-bootable? user-partition)) (esp? (user-partition-esp? user-partition)) - (need-formating? (user-partition-need-formating? user-partition)) + (need-formatting? (user-partition-need-formatting? user-partition)) (crypt-label (user-partition-crypt-label user-partition)) (size (user-partition-size user-partition)) (mount-point (user-partition-mount-point user-partition))) @@ -585,9 +585,9 @@ determined by MAX-LENGTH-COLUMN procedure." ,@(if (or (freespace-partition? partition) (eq? fs-type 'swap)) '() - `((need-formating? + `((need-formatting? . ,(string-append "Format the partition? : " - (if need-formating? "Yes" "No"))))) + (if need-formatting? "Yes" "No"))))) ,@(if (or (eq? type 'extended) (eq? fs-type 'swap)) '() @@ -871,13 +871,13 @@ partition." (error (format #f "Unable to create partition ~a~%" name))))))))) -(define (force-user-partitions-formating user-partitions) +(define (force-user-partitions-formatting user-partitions) "Set the NEED-FORMATING? fields to #t on all records of USER-PARTITIONS list and return the updated list." (map (lambda (p) (user-partition (inherit p) - (need-formating? #t))) + (need-formatting? #t))) user-partitions)) (define* (auto-partition disk @@ -992,7 +992,7 @@ swap partition, a root partition and a home partition." (crypt-label (and encrypted? "crypthome")) (size "100%") (mount-point "/home"))))))) - (new-partitions* (force-user-partitions-formating + (new-partitions* (force-user-partitions-formatting new-partitions))) (create-adjacent-partitions disk new-partitions* @@ -1091,8 +1091,8 @@ USER-PARTITION if it is encrypted, or the plain file-name otherwise." NEED-FORMATING? field set to #t." (for-each (lambda (user-partition) - (let* ((need-formating? - (user-partition-need-formating? user-partition)) + (let* ((need-formatting? + (user-partition-need-formatting? user-partition)) (type (user-partition-type user-partition)) (crypt-label (user-partition-crypt-label user-partition)) (file-name (user-partition-upper-file-name user-partition)) @@ -1102,11 +1102,11 @@ NEED-FORMATING? field set to #t." (case fs-type ((ext4) - (and need-formating? + (and need-formatting? (not (eq? type 'extended)) (create-ext4-file-system file-name))) ((fat32) - (and need-formating? + (and need-formatting? (not (eq? type 'extended)) (create-fat32-file-system file-name))) ((swap) @@ -1293,7 +1293,7 @@ from (gnu system mapped-devices) and return it." (define (free-parted devices) "Deallocate memory used for DEVICES in parted, force sync them and wait for the devices not to be used before returning." - ;; XXX: Formating and further operations on disk partition table may fail + ;; XXX: Formatting and further operations on disk partition table may fail ;; because the partition table changes are not synced, or because the device ;; is still in use, even if parted should have finished editing ;; partitions. This is not well understood, but syncing devices and waiting -- cgit v1.2.3 From 8cca59ee1234252f1c3fbd594fb552093be968d8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 16 Jan 2019 23:08:20 +0100 Subject: installer: Fix manual partitioning. * gnu/installer/newt/partition.scm (run-partioning-page): When METHOD is 'manual, use 'filter-map' on DEVICES, not 'map', since 'disk-new' can return #f. --- gnu/installer/newt/partition.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gnu/installer') diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index c22e1c0290..d4c91edc66 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -745,7 +745,7 @@ by pressing the Exit button.~%~%"))) (run-disk-page (list disk) user-partitions #:guided? #t))) ((eq? method 'manual) - (let* ((disks (map disk-new devices)) + (let* ((disks (filter-map disk-new devices)) (user-partitions (append-map create-special-user-partitions (map disk-partitions disks))) -- cgit v1.2.3