aboutsummaryrefslogtreecommitdiff
path: root/gnu/installer
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-01-20 22:12:10 +0100
committerLudovic Courtès <ludo@gnu.org>2019-01-20 22:12:10 +0100
commit3e2d4e69c340c3520f546f8c7e21e52383058d1c (patch)
tree0bc92edb753cfdf9a9e7ef763ebc19f0cd2d528c /gnu/installer
parentad79ae7e2d7505292b11e87302b08f4db0f934e9 (diff)
parente5ad2cdf172eecc7edef37a500593b1941af013c (diff)
downloadguix-3e2d4e69c340c3520f546f8c7e21e52383058d1c.tar
guix-3e2d4e69c340c3520f546f8c7e21e52383058d1c.tar.gz
Merge branch 'master' into staging
Diffstat (limited to 'gnu/installer')
-rw-r--r--gnu/installer/aux-files/SUPPORTED484
-rw-r--r--gnu/installer/aux-files/logo.txt19
-rw-r--r--gnu/installer/connman.scm400
-rw-r--r--gnu/installer/final.scm36
-rw-r--r--gnu/installer/hostname.scm23
-rw-r--r--gnu/installer/keymap.scm172
-rw-r--r--gnu/installer/locale.scm210
-rw-r--r--gnu/installer/newt.scm128
-rw-r--r--gnu/installer/newt/ethernet.scm81
-rw-r--r--gnu/installer/newt/final.scm86
-rw-r--r--gnu/installer/newt/hostname.scm26
-rw-r--r--gnu/installer/newt/keymap.scm122
-rw-r--r--gnu/installer/newt/locale.scm217
-rw-r--r--gnu/installer/newt/menu.scm44
-rw-r--r--gnu/installer/newt/network.scm173
-rw-r--r--gnu/installer/newt/page.scm530
-rw-r--r--gnu/installer/newt/partition.scm766
-rw-r--r--gnu/installer/newt/services.scm48
-rw-r--r--gnu/installer/newt/timezone.scm83
-rw-r--r--gnu/installer/newt/user.scm175
-rw-r--r--gnu/installer/newt/utils.scm43
-rw-r--r--gnu/installer/newt/welcome.scm118
-rw-r--r--gnu/installer/newt/wifi.scm243
-rw-r--r--gnu/installer/parted.scm1312
-rw-r--r--gnu/installer/record.scm84
-rw-r--r--gnu/installer/services.scm59
-rw-r--r--gnu/installer/steps.scm237
-rw-r--r--gnu/installer/timezone.scm127
-rw-r--r--gnu/installer/user.scm50
-rw-r--r--gnu/installer/utils.scm63
30 files changed, 6159 insertions, 0 deletions
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/connman.scm b/gnu/installer/connman.scm
new file mode 100644
index 0000000000..740df7424a
--- /dev/null
+++ b/gnu/installer/connman.scm
@@ -0,0 +1,400 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer connman)
+ #:use-module (gnu installer utils)
+ #:use-module (guix records)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 regex)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:export (<technology>
+ technology
+ technology?
+ technology-name
+ technology-type
+ technology-powered?
+ technology-connected?
+
+ <service>
+ service
+ service?
+ service-name
+ service-type
+ service-path
+ service-strength
+ service-state
+
+ &connman-error
+ connman-error?
+ connman-error-command
+ connman-error-output
+ connman-error-status
+
+ &connman-connection-error
+ connman-connection-error?
+ connman-connection-error-service
+ connman-connection-error-output
+
+ &connman-password-error
+ connman-password-error?
+
+ &connman-already-connected-error
+ connman-already-connected-error?
+
+ connman-state
+ connman-technologies
+ connman-enable-technology
+ connman-disable-technology
+ connman-scan-technology
+ connman-services
+ connman-connect
+ connman-disconnect
+ connman-online?
+ connman-connect-with-auth))
+
+;;; Commentary:
+;;;
+;;; This module provides procedures for talking with the connman daemon.
+;;; The best approach would have been using connman dbus interface.
+;;; However, as Guile dbus bindings are not available yet, the console client
+;;; "connmanctl" is used to talk with the daemon.
+;;;
+
+
+;;;
+;;; Technology record.
+;;;
+
+;; The <technology> record encapsulates the "Technology" object of connman.
+;; Technology type will be typically "ethernet", "wifi" or "bluetooth".
+
+(define-record-type* <technology>
+ technology make-technology
+ technology?
+ (name technology-name) ; string
+ (type technology-type) ; string
+ (powered? technology-powered?) ; boolean
+ (connected? technology-connected?)) ; boolean
+
+
+;;;
+;;; Service record.
+;;;
+
+;; The <service> record encapsulates the "Service" object of connman.
+;; Service type is the same as the technology it is associated to, path is a
+;; unique identifier given by connman, strength describes the signal quality
+;; if applicable. Finally, state is "idle", "failure", "association",
+;; "configuration", "ready", "disconnect" or "online".
+
+(define-record-type* <service>
+ service make-service
+ service?
+ (name service-name) ; string
+ (type service-type) ; string
+ (path service-path) ; string
+ (strength service-strength) ; integer
+ (state service-state)) ; string
+
+
+;;;
+;;; Condition types.
+;;;
+
+(define-condition-type &connman-error &error
+ connman-error?
+ (command connman-error-command)
+ (output connman-error-output)
+ (status connman-error-status))
+
+(define-condition-type &connman-connection-error &error
+ connman-connection-error?
+ (service connman-connection-error-service)
+ (output connman-connection-error-output))
+
+(define-condition-type &connman-password-error &connman-connection-error
+ connman-password-error?)
+
+(define-condition-type &connman-already-connected-error
+ &connman-connection-error connman-already-connected-error?)
+
+
+;;;
+;;; Procedures.
+;;;
+
+(define (connman-run command env arguments)
+ "Run the given COMMAND, with the specified ENV and ARGUMENTS. The error
+output is discarded and &connman-error condition is raised if the command
+returns a non zero exit code."
+ (let* ((command `("env" ,env ,command ,@arguments "2>" "/dev/null"))
+ (command-string (string-join command " "))
+ (pipe (open-input-pipe command-string))
+ (output (read-lines pipe))
+ (ret (close-pipe pipe)))
+ (case (status:exit-val ret)
+ ((0) output)
+ (else (raise (condition (&connman-error
+ (command command)
+ (output output)
+ (status ret))))))))
+
+(define (connman . arguments)
+ "Run connmanctl with the specified ARGUMENTS. Set the LANG environment
+variable to C because the command output will be parsed and we don't want it
+to be translated."
+ (connman-run "connmanctl" "LANG=C" arguments))
+
+(define (parse-keys keys)
+ "Parse the given list of strings KEYS, under the following format:
+
+ '((\"KEY = VALUE\") (\"KEY2 = VALUE2\") ...)
+
+Return the corresponding association list of '((KEY . VALUE) (KEY2 . VALUE2)
+...) elements."
+ (let ((key-regex (make-regexp "([^ ]+) = ([^$]+)")))
+ (map (lambda (key)
+ (let ((match-key (regexp-exec key-regex key)))
+ (cons (match:substring match-key 1)
+ (match:substring match-key 2))))
+ keys)))
+
+(define (connman-state)
+ "Return the state of connman. The nominal states are 'offline, 'idle,
+'ready, 'oneline. If an unexpected state is read, 'unknown is
+returned. Finally, an error is raised if the comman output could not be
+parsed, usually because the connman daemon is not responding."
+ (let* ((output (connman "state"))
+ (state-keys (parse-keys output)))
+ (let ((state (assoc-ref state-keys "State")))
+ (if state
+ (cond ((string=? state "offline") 'offline)
+ ((string=? state "idle") 'idle)
+ ((string=? state "ready") 'ready)
+ ((string=? state "online") 'online)
+ (else 'unknown))
+ (raise (condition
+ (&message
+ (message "Could not determine the state of connman."))))))))
+
+(define (split-technology-list technologies)
+ "Parse the given strings list TECHNOLOGIES, under the following format:
+
+ '((\"/net/connman/technology/xxx\")
+ (\"KEY = VALUE\")
+ ...
+ (\"/net/connman/technology/yyy\")
+ (\"KEY2 = VALUE2\")
+ ...)
+ Return the corresponding '(((\"KEY = VALUE\") ...) ((\"KEY2 = VALUE2\") ...))
+list so that each keys of a given technology are gathered in a separate list."
+ (let loop ((result '())
+ (cur-list '())
+ (input (reverse technologies)))
+ (if (null? input)
+ result
+ (let ((item (car input)))
+ (if (string-match "/net/connman/technology" item)
+ (loop (cons cur-list result) '() (cdr input))
+ (loop result (cons item cur-list) (cdr input)))))))
+
+(define (string->boolean string)
+ (equal? string "True"))
+
+(define (connman-technologies)
+ "Return a list of available <technology> records."
+
+ (define (technology-output->technology output)
+ (let ((keys (parse-keys output)))
+ (technology
+ (name (assoc-ref keys "Name"))
+ (type (assoc-ref keys "Type"))
+ (powered? (string->boolean (assoc-ref keys "Powered")))
+ (connected? (string->boolean (assoc-ref keys "Connected"))))))
+
+ (let* ((output (connman "technologies"))
+ (technologies (split-technology-list output)))
+ (map technology-output->technology technologies)))
+
+(define (connman-enable-technology technology)
+ "Enable the given TECHNOLOGY."
+ (let ((type (technology-type technology)))
+ (connman "enable" type)))
+
+(define (connman-disable-technology technology)
+ "Disable the given TECHNOLOGY."
+ (let ((type (technology-type technology)))
+ (connman "disable" type)))
+
+(define (connman-scan-technology technology)
+ "Run a scan for the given TECHNOLOGY."
+ (let ((type (technology-type technology)))
+ (connman "scan" type)))
+
+(define (connman-services)
+ "Return a list of available <services> records."
+
+ (define (service-output->service path output)
+ (let* ((service-keys
+ (match output
+ ((_ . rest) rest)))
+ (keys (parse-keys service-keys)))
+ (service
+ (name (assoc-ref keys "Name"))
+ (type (assoc-ref keys "Type"))
+ (path path)
+ (strength (and=> (assoc-ref keys "Strength") string->number))
+ (state (assoc-ref keys "State")))))
+
+ (let* ((out (connman "services"))
+ (out-filtered (delete "" out))
+ (services-path (map (lambda (service)
+ (match (string-split service #\ )
+ ((_ ... path) path)))
+ out-filtered))
+ (services-output (map (lambda (service)
+ (connman "services" service))
+ services-path)))
+ (map service-output->service services-path services-output)))
+
+(define (connman-connect service)
+ "Connect to the given SERVICE."
+ (let ((path (service-path service)))
+ (connman "connect" path)))
+
+(define (connman-disconnect service)
+ "Disconnect from the given SERVICE."
+ (let ((path (service-path service)))
+ (connman "disconnect" path)))
+
+(define (connman-online?)
+ (let ((state (connman-state)))
+ (eq? state 'online)))
+
+(define (connman-connect-with-auth service password-proc)
+ "Connect to the given SERVICE with the password returned by calling
+PASSWORD-PROC. This is only possible in the interactive mode of connmanctl
+because authentication is done by communicating with an agent.
+
+As the open-pipe procedure of Guile do not allow to read from stderr, we have
+to merge stdout and stderr using bash redirection. Then error messages are
+extracted from connmanctl output using a regexp. This makes the whole
+procedure even more unreliable.
+
+Raise &connman-connection-error if an error occured during connection. Raise
+&connman-password-error if the given password is incorrect."
+
+ (define connman-error-regexp (make-regexp "Error[ ]*([^\n]+)\n"))
+
+ (define (match-connman-error str)
+ (let ((match-error (regexp-exec connman-error-regexp str)))
+ (and match-error (match:substring match-error 1))))
+
+ (define* (read-regexps-or-error port regexps error-handler)
+ "Read characters from port until an error is detected, or one of the given
+REGEXPS is matched. If an error is detected, call ERROR-HANDLER with the error
+string as argument. Raise an error if the eof is reached before one of the
+regexps is matched."
+ (let loop ((res ""))
+ (let ((char (read-char port)))
+ (cond
+ ((eof-object? char)
+ (raise (condition
+ (&message
+ (message "Unable to find expected regexp.")))))
+ ((match-connman-error res)
+ =>
+ (lambda (match)
+ (error-handler match)))
+ ((or-map (lambda (regexp)
+ (and (regexp-exec regexp res) regexp))
+ regexps)
+ =>
+ (lambda (match)
+ match))
+ (else
+ (loop (string-append res (string char))))))))
+
+ (define* (read-regexp-or-error port regexp error-handler)
+ "Same as READ-REGEXPS-OR-ERROR above, but with a single REGEXP."
+ (read-regexps-or-error port (list regexp) error-handler))
+
+ (define (connman-error->condition path error)
+ (cond
+ ((string-match "Already connected" error)
+ (condition (&connman-already-connected-error
+ (service path)
+ (output error))))
+ (else
+ (condition (&connman-connection-error
+ (service path)
+ (output error))))))
+
+ (define (run-connection-sequence pipe)
+ "Run the connection sequence using PIPE as an opened port to an
+interactive connmanctl process."
+ (let* ((path (service-path service))
+ (error-handler (lambda (error)
+ (raise
+ (connman-error->condition path error)))))
+ ;; Start the agent.
+ (format pipe "agent on\n")
+ (read-regexp-or-error pipe (make-regexp "Agent registered") error-handler)
+
+ ;; Let's try to connect to the service. If the service does not require
+ ;; a password, the connection might succeed right after this call.
+ ;; Otherwise, connmanctl will prompt us for a password.
+ (format pipe "connect ~a\n" path)
+ (let* ((connected-regexp (make-regexp (format #f "Connected ~a" path)))
+ (passphrase-regexp (make-regexp "\nPassphrase\\?[ ]*"))
+ (regexps (list connected-regexp passphrase-regexp))
+ (result (read-regexps-or-error pipe regexps error-handler)))
+
+ ;; A password is required.
+ (when (eq? result passphrase-regexp)
+ (format pipe "~a~%" (password-proc))
+
+ ;; Now, we have to wait for the connection to succeed. If an error
+ ;; occurs, it is most likely because the password is incorrect.
+ ;; In that case, we escape from an eventual retry loop that would
+ ;; add complexity to this procedure, and raise a
+ ;; &connman-password-error condition.
+ (read-regexp-or-error pipe connected-regexp
+ (lambda (error)
+ ;; Escape from retry loop.
+ (format pipe "no\n")
+ (raise
+ (condition (&connman-password-error
+ (service path)
+ (output error))))))))))
+
+ ;; XXX: Find a better way to read stderr, like with the "subprocess"
+ ;; procedure of racket that return input ports piped on the process stdin and
+ ;; stderr.
+ (let ((pipe (open-pipe "connmanctl 2>&1" OPEN_BOTH)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (run-connection-sequence pipe)
+ #t)
+ (lambda ()
+ (format pipe "quit\n")
+ (close-pipe pipe)))))
diff --git a/gnu/installer/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 <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer 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/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 <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer hostname)
+ #:export (hostname->configuration))
+
+(define (hostname->configuration hostname)
+ `((host-name ,hostname)))
diff --git a/gnu/installer/keymap.scm b/gnu/installer/keymap.scm
new file mode 100644
index 0000000000..d66b376d9c
--- /dev/null
+++ b/gnu/installer/keymap.scm
@@ -0,0 +1,172 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer keymap)
+ #:use-module (guix records)
+ #:use-module (sxml match)
+ #:use-module (sxml simple)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 ftw)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:export (<x11-keymap-model>
+ x11-keymap-model
+ make-x11-keymap-model
+ x11-keymap-model?
+ x11-keymap-model-name
+ x11-keymap-model-description
+
+ <x11-keymap-layout>
+ x11-keymap-layout
+ make-x11-keymap-layout
+ x11-keymap-layout?
+ x11-keymap-layout-name
+ x11-keymap-layout-description
+ x11-keymap-layout-variants
+
+ <x11-keymap-variant>
+ x11-keymap-variant
+ make-x11-keymap-variant
+ x11-keymap-variant?
+ x11-keymap-variant-name
+ x11-keymap-variant-description
+
+ default-keyboard-model
+ xkb-rules->models+layouts
+ kmscon-update-keymap))
+
+(define-record-type* <x11-keymap-model>
+ x11-keymap-model make-x11-keymap-model
+ x11-keymap-model?
+ (name x11-keymap-model-name) ;string
+ (description x11-keymap-model-description)) ;string
+
+(define-record-type* <x11-keymap-layout>
+ x11-keymap-layout make-x11-keymap-layout
+ x11-keymap-layout?
+ (name x11-keymap-layout-name) ;string
+ (description x11-keymap-layout-description) ;string
+ (variants x11-keymap-layout-variants)) ;list of <x11-keymap-variant>
+
+(define-record-type* <x11-keymap-variant>
+ x11-keymap-variant make-x11-keymap-variant
+ x11-keymap-variant?
+ (name x11-keymap-variant-name) ;string
+ (description x11-keymap-variant-description)) ;string
+
+;; 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
+Configuration Database, describing possible XKB configurations."
+ (define (model m)
+ (sxml-match m
+ [(model
+ (configItem
+ (name ,name)
+ (description ,description)
+ . ,rest))
+ (x11-keymap-model
+ (name name)
+ (description description))]))
+
+ (define (variant v)
+ (sxml-match v
+ [(variant
+ ;; According to xbd-rules DTD, the definition of a
+ ;; configItem is: <!ELEMENT configItem
+ ;; (name,shortDescription*,description*,vendor?,
+ ;; countryList?,languageList?,hwList?)>
+ ;;
+ ;; shortDescription and description are optional elements
+ ;; but sxml-match does not support default values for
+ ;; elements (only attributes). So to avoid writing as many
+ ;; patterns as existing possibilities, gather all the
+ ;; remaining elements but name in REST-VARIANT.
+ (configItem
+ (name ,name)
+ . ,rest-variant))
+ (x11-keymap-variant
+ (name name)
+ (description (car
+ (assoc-ref rest-variant 'description))))]))
+
+ (define (layout l)
+ (sxml-match l
+ [(layout
+ (configItem
+ (name ,name)
+ . ,rest-layout)
+ (variantList ,[variant -> v] ...))
+ (x11-keymap-layout
+ (name name)
+ (description (car
+ (assoc-ref rest-layout 'description)))
+ (variants (list v ...)))]
+ [(layout
+ (configItem
+ (name ,name)
+ . ,rest-layout))
+ (x11-keymap-layout
+ (name name)
+ (description (car
+ (assoc-ref rest-layout 'description)))
+ (variants '()))]))
+
+ (let ((sxml (call-with-input-file file
+ (lambda (port)
+ (xml->sxml port #:trim-whitespace? #t)))))
+ (match
+ (sxml-match sxml
+ [(*TOP*
+ ,pi
+ (xkbConfigRegistry
+ (@ . ,ignored)
+ (modelList ,[model -> m] ...)
+ (layoutList ,[layout -> l] ...)
+ . ,rest))
+ (list
+ (list m ...)
+ (list l ...))])
+ ((models layouts)
+ (values models layouts)))))
+
+(define (kmscon-update-keymap model layout variant)
+ "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))))))
diff --git a/gnu/installer/locale.scm b/gnu/installer/locale.scm
new file mode 100644
index 0000000000..2b45b2200a
--- /dev/null
+++ b/gnu/installer/locale.scm
@@ -0,0 +1,210 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer locale)
+ #:use-module (gnu installer utils)
+ #:use-module (guix records)
+ #:use-module (json)
+ #:use-module (srfi srfi-1)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:export (locale-language
+ locale-territory
+ locale-codeset
+ locale-modifier
+
+ locale->locale-string
+ supported-locales->locales
+
+ iso639->iso639-languages
+ language-code->language-name
+
+ iso3166->iso3166-territories
+ territory-code->territory-name
+
+ locale->configuration))
+
+
+;;;
+;;; 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)))
+
+
+;;;
+;;; 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
new file mode 100644
index 0000000000..6c44b4acf6
--- /dev/null
+++ b/gnu/installer/newt.scm
@@ -0,0 +1,128 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt)
+ #:use-module (gnu installer record)
+ #:use-module (gnu installer utils)
+ #: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)
+ #: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)
+ #: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 config)
+ #:use-module (guix discovery)
+ #:use-module (guix i18n)
+ #:use-module (srfi srfi-26)
+ #:use-module (newt)
+ #:export (newt-installer))
+
+(define (init)
+ (newt-init)
+ (clear-screen)
+ (set-screen-size!))
+
+(define (exit)
+ (newt-finish)
+ (clear-screen))
+
+(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)
+ (clear-screen))
+
+(define (final-page result prev-steps)
+ (run-final-page result prev-steps))
+
+(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 (timezone-page zonetab)
+ (run-timezone-page zonetab))
+
+(define (welcome-page logo)
+ (run-welcome-page logo))
+
+(define (menu-page steps)
+ (run-menu-page steps))
+
+(define* (keymap-page layouts)
+ (run-keymap-page layouts))
+
+(define (network-page)
+ (run-network-page))
+
+(define (hostname-page)
+ (run-hostname-page))
+
+(define (user-page)
+ (run-user-page))
+
+(define (partition-page)
+ (run-partioning-page))
+
+(define (services-page)
+ (run-services-page))
+
+(define newt-installer
+ (installer
+ (name 'newt)
+ (init init)
+ (exit exit)
+ (exit-error exit-error)
+ (final-page final-page)
+ (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)
+ (partition-page partition-page)
+ (services-page services-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..d1f357243b
--- /dev/null
+++ b/gnu/installer/newt/ethernet.scm
@@ -0,0 +1,81 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt ethernet)
+ #:use-module (gnu installer connman)
+ #:use-module (gnu installer steps)
+ #:use-module (gnu installer newt utils)
+ #:use-module (gnu installer newt page)
+ #:use-module (guix i18n)
+ #:use-module (ice-9 format)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (newt)
+ #:export (run-ethernet-page))
+
+(define (ethernet-services)
+ "Return all the connman services of ethernet type."
+ (let ((services (connman-services)))
+ (filter (lambda (service)
+ (and (string=? (service-type service) "ethernet")
+ (not (string-null? (service-name service)))))
+ services)))
+
+(define (ethernet-service->text service)
+ "Return a string describing the given ethernet SERVICE."
+ (let* ((name (service-name service))
+ (path (service-path service))
+ (full-name (string-append name "-" path))
+ (state (service-state service))
+ (connected? (or (string=? state "online")
+ (string=? state "ready"))))
+ (format #f "~c ~a~%"
+ (if connected? #\* #\ )
+ full-name)))
+
+(define (connect-ethernet-service service)
+ "Connect to the given ethernet SERVICE. Display a connecting page while the
+connection is pending."
+ (let* ((service-name (service-name service))
+ (form (draw-connecting-page service-name)))
+ (connman-connect service)
+ (destroy-form-and-pop form)
+ service))
+
+(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_ "Exit")
+ #:button-callback-procedure
+ (lambda _
+ (raise
+ (condition
+ (&installer-step-abort))))
+ #:listbox-callback-procedure connect-ethernet-service))))
diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm
new file mode 100644
index 0000000000..645c1e8689
--- /dev/null
+++ b/gnu/installer/newt/final.scm
@@ -0,0 +1,86 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt 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_ "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
+ #:file-textbox-width width
+ #:file-textbox-height height
+ #:exit-button-callback-procedure
+ (lambda ()
+ (raise
+ (condition
+ (&installer-step-abort)))))))
+
+(define (run-install-success-page)
+ (message-window
+ (G_ "Installation complete")
+ (G_ "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 \
+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/newt/hostname.scm b/gnu/installer/newt/hostname.scm
new file mode 100644
index 0000000000..7783fa6360
--- /dev/null
+++ b/gnu/installer/newt/hostname.scm
@@ -0,0 +1,26 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt hostname)
+ #:use-module (gnu installer newt page)
+ #:use-module (guix i18n)
+ #:export (run-hostname-page))
+
+(define (run-hostname-page)
+ (run-input-page (G_ "Please enter the system hostname.")
+ (G_ "Hostname")))
diff --git a/gnu/installer/newt/keymap.scm b/gnu/installer/newt/keymap.scm
new file mode 100644
index 0000000000..6211af2bc5
--- /dev/null
+++ b/gnu/installer/newt/keymap.scm
@@ -0,0 +1,122 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt keymap)
+ #:use-module (gnu installer keymap)
+ #:use-module (gnu installer steps)
+ #:use-module (gnu installer newt page)
+ #:use-module (guix i18n)
+ #:use-module (guix records)
+ #:use-module (newt)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #: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")))
+ (run-listbox-selection-page
+ #:title title
+ #: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 _
+ (raise
+ (condition
+ (&installer-step-abort)))))))
+
+(define (run-variant-page variants variant->text)
+ (let ((title (G_ "Variant")))
+ (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
+ #:sort-listbox-items? #f
+ #:button-text (G_ "Back")
+ #:button-callback-procedure
+ (lambda _
+ (raise
+ (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
+names of the selected keyboard layout and variant."
+ (define keymap-steps
+ (list
+ (installer-step
+ (id 'layout)
+ (compute
+ (lambda _
+ (run-layout-page
+ (sort-layouts 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* ((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
+ (sort-variants variants)
+ (lambda (variant)
+ (x11-keymap-variant-description
+ variant))))))))))
+
+ (define (format-result result)
+ (let ((layout (x11-keymap-layout-name
+ (result-step result 'layout)))
+ (variant (and=> (result-step result 'variant)
+ (lambda (variant)
+ (x11-keymap-variant-name 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
new file mode 100644
index 0000000000..4fa07df81e
--- /dev/null
+++ b/gnu/installer/newt/locale.scm
@@ -0,0 +1,217 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt locale)
+ #:use-module (gnu installer locale)
+ #:use-module (gnu installer steps)
+ #:use-module (gnu installer newt page)
+ #:use-module (guix i18n)
+ #:use-module (newt)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (ice-9 match)
+ #:export (run-locale-page))
+
+(define (run-language-page languages language->text)
+ (let ((title (G_ "Locale language")))
+ (run-listbox-selection-page
+ #:title title
+ #: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_ "Exit")
+ #:button-callback-procedure
+ (lambda _
+ (raise
+ (condition
+ (&installer-step-abort)))))))
+
+(define (run-territory-page territories territory->text)
+ (let ((title (G_ "Locale location")))
+ (run-listbox-selection-page
+ #:title title
+ #: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")
+ #:button-callback-procedure
+ (lambda _
+ (raise
+ (condition
+ (&installer-step-abort)))))))
+
+(define (run-codeset-page codesets)
+ (let ((title (G_ "Locale codeset")))
+ (run-listbox-selection-page
+ #:title title
+ #: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"
+ #:button-text (G_ "Back")
+ #:button-callback-procedure
+ (lambda _
+ (raise
+ (condition
+ (&installer-step-abort)))))))
+
+(define (run-modifier-page modifiers modifier->text)
+ (let ((title (G_ "Locale modifier")))
+ (run-listbox-selection-page
+ #:title title
+ #: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")
+ #:button-callback-procedure
+ (lambda _
+ (raise
+ (condition
+ (&installer-step-abort)))))))
+
+(define* (run-locale-page #:key
+ 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
+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 (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
+ (id 'language)
+ (compute
+ (lambda _
+ (run-language-page
+ (sort-languages
+ (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..161266a94a
--- /dev/null
+++ b/gnu/installer/newt/menu.scm
@@ -0,0 +1,44 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt menu)
+ #:use-module (gnu installer steps)
+ #:use-module (gnu installer newt page)
+ #:use-module (guix i18n)
+ #:use-module (newt)
+ #:export (run-menu-page))
+
+(define (run-menu-page steps)
+ "Run a menu page, asking the user to select where to resume the install
+process from."
+ (define (steps->items steps)
+ (filter (lambda (step)
+ (installer-step-description step))
+ steps))
+
+ (run-listbox-selection-page
+ #:info-text (G_ "Choose where you want to resume the install.\
+You can also abort the installation by pressing the Abort 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..f263b7df9d
--- /dev/null
+++ b/gnu/installer/newt/network.scm
@@ -0,0 +1,173 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt network)
+ #:use-module (gnu installer connman)
+ #:use-module (gnu installer steps)
+ #:use-module (gnu installer utils)
+ #:use-module (gnu installer newt ethernet)
+ #:use-module (gnu installer newt page)
+ #:use-module (gnu installer newt wifi)
+ #:use-module (guix i18n)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (newt)
+ #:export (run-network-page))
+
+;; Maximum length of a technology name.
+(define technology-name-max-length (make-parameter 20))
+
+(define (technology->text technology)
+ "Return a string describing the given TECHNOLOGY."
+ (let* ((name (technology-name technology))
+ (padded-name (string-pad-right name
+ (technology-name-max-length))))
+ (format #f "~a~%" padded-name)))
+
+(define (run-technology-page)
+ "Run a page to ask the user which technology shall be used to access
+Internet and return the selected technology. For now, only technologies with
+\"ethernet\" or \"wifi\" types are supported."
+ (define (technology-items)
+ (filter (lambda (technology)
+ (let ((type (technology-type technology)))
+ (or
+ (string=? type "ethernet")
+ (string=? type "wifi"))))
+ (connman-technologies)))
+
+ (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."
+ (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..edf0b8c999
--- /dev/null
+++ b/gnu/installer/newt/page.scm
@@ -0,0 +1,530 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt page)
+ #:use-module (gnu installer 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-checkbox-tree-page
+ run-file-textbox-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)
+ (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
+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)))
+
+ (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)
+ (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)
+ (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
+set to INFO-TEXT, a listbox and a button. The listbox will be filled with
+LISTBOX-ITEMS converted to text by applying the procedure LISTBOX-ITEM->TEXT
+on every item. The selected item from LISTBOX-ITEMS is returned. The button
+text is set to BUTTON-TEXT and the procedure BUTTON-CALLBACK-PROCEDURE called
+when it is pressed. The procedure LISTBOX-CALLBACK-PROCEDURE is called when an
+item from the listbox is selected (by pressing the <ENTER> key).
+
+INFO-TEXTBOX-WIDTH is the width of the textbox where INFO-TEXT will be
+displayed. LISTBOX-HEIGHT is the height of the listbox.
+
+If LISTBOX-DEFAULT-ITEM is set to the value of one of the items in
+LISTBOX-ITEMS, it will be selected by default. Otherwise, the first element of
+the listbox is selected.
+
+If LISTBOX-ALLOW-MULTIPLE? is set to #t, multiple items from the listbox can
+be selected (using the <SPACE> key). It that case, a list containing the
+selected items will be returned.
+
+If SORT-LISTBOX-ITEMS? is set to #t, the listbox items are sorted using
+'string<=' procedure (after being converted to text).
+
+If ALLOW-DELETE? is #t, the form will return if the <DELETE> 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
+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)))
+
+ ;; 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
+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))
+ (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-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)
+
+ (receive (exit-reason argument)
+ (run-form form)
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (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))))))
+
+(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)))))
+
+(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))
+ (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 'Exit'. 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.
+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
+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")))
+ (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 exit-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 exit-button)
+ (exit-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)
+ (exit-button? #t)
+ (ok-button-callback-procedure
+ (const #t))
+ (exit-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")))
+ (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
+ (apply
+ horizontal-stacked-grid
+ GRID-ELEMENT-COMPONENT ok-button
+ `(,@(if exit-button?
+ (list GRID-ELEMENT-COMPONENT exit-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))
+ ((and exit-button?
+ (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
new file mode 100644
index 0000000000..d4c91edc66
--- /dev/null
+++ b/gnu/installer/newt/partition.scm
@@ -0,0 +1,766 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt 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-exit-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_ "Exit")
+ #:button-callback-procedure button-exit-action)))
+ (car result)))
+
+(define (draw-formatting-page)
+ "Draw a page to indicate partitions are being formated."
+ (draw-info-page
+ (format #f (G_ "Partition formatting 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_ "Exit")
+ #:button-callback-procedure button-exit-action))
+ (device (car result)))
+ device))
+
+(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. \
+Be careful, all data on the disk will be lost.")
+ #:title (G_ "Partition table")
+ #:listbox-items '("msdos" "gpt")
+ #:listbox-item->text identity
+ #:button-text button-text
+ #: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_ "Exit")
+ #:button-callback-procedure button-exit-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_ "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
+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 (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))
+ (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).") file-name crypt-label)
+ (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
+ (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))
+
+(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)
+ "")))))
+ ((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-formatting? #t)
+ (crypt-label new-label))))
+ ((need-formatting?)
+ (user-partition
+ (inherit target-user-partition)
+ (need-formatting?
+ (not (user-partition-need-formatting?
+ 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-formatting? #t)
+ (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))))
+
+ (let* ((items (user-partition-description target-user-partition))
+ (partition (user-partition-parted-object
+ target-user-partition))
+ (disk (partition-disk partition))
+ (device (disk-device disk))
+ (file-name (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 file-name))
+ (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 '())
+ #:key (guided? #f))
+ "Run a page allowing to edit the partition tables of the given DISKS. If
+specified, USER-PARTITIONS is a list of <user-partition> 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 <user-partition> 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 <user-partition> 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 (G_ "Back") (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))
+ (file-name (device-path device))
+ (info-text
+ (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_ "Exit")
+ 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_ "Exit")
+ 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* ((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 '/'."))
+ (guided-info-text (format #f (G_ "This is the proposed \
+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
+ #:info-text (if guided?
+ (string-append guided-info-text info-text)
+ info-text)
+
+ #:title (if guided?
+ (G_ "Guided partitioning")
+ (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_ "Exit")
+ #:button2-callback-procedure button-exit-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
+ #:guided? guided?)))
+ (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
+ #:guided? guided?)))))
+
+(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")
+ (entire-encrypted . "Guided - using the entire disk with encryption")
+ (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_ "Exit")
+ #:button-callback-procedure button-exit-action))
+ (method (car result)))
+ (cond
+ ((or (eq? method 'entire)
+ (eq? method 'entire-encrypted))
+ (let* ((device (run-device-page devices))
+ (disk-type (disk-probe device))
+ (disk (if disk-type
+ (disk-new device)
+ (let* ((label (run-label-page
+ (G_ "Exit")
+ button-exit-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
+ #:guided? #t)))
+ ((eq? method 'manual)
+ (let* ((disks (filter-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))
+ (user-partitions-with-pass (prompt-luks-passwords
+ user-partitions))
+ (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)
+ user-partitions))
diff --git a/gnu/installer/newt/services.scm b/gnu/installer/newt/services.scm
new file mode 100644
index 0000000000..6bcb6244ae
--- /dev/null
+++ b/gnu/installer/newt/services.scm
@@ -0,0 +1,48 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt 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
+ #:exit-button-callback-procedure
+ (lambda ()
+ (raise
+ (condition
+ (&installer-step-abort))))))
+
+(define (run-services-page)
+ (run-desktop-environments-cbt-page))
diff --git a/gnu/installer/newt/timezone.scm b/gnu/installer/newt/timezone.scm
new file mode 100644
index 0000000000..6c96ee55b1
--- /dev/null
+++ b/gnu/installer/newt/timezone.scm
@@ -0,0 +1,83 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt timezone)
+ #:use-module (gnu installer steps)
+ #:use-module (gnu installer timezone)
+ #:use-module (gnu installer newt page)
+ #:use-module (guix i18n)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 receive)
+ #:use-module (newt)
+ #:export (run-timezone-page))
+
+;; Heigth of the listbox displaying timezones.
+(define timezone-listbox-heigth (make-parameter 20))
+
+;; Information textbox width.
+(define info-textbox-width (make-parameter 40))
+
+(define (fill-timezones listbox timezones)
+ "Fill the given LISTBOX with TIMEZONES. Return an association list
+correlating listbox keys with timezones."
+ (map (lambda (timezone)
+ (let ((key (append-entry-to-listbox listbox timezone)))
+ (cons key timezone)))
+ timezones))
+
+(define (run-timezone-page zonetab)
+ "Run a page displaying available timezones, grouped by regions. The user is
+invited to select a timezone. The selected timezone, under Posix format is
+returned."
+ (define (all-but-last list)
+ (reverse (cdr (reverse list))))
+
+ (define (run-page timezone-tree)
+ (define (loop path)
+ (let ((timezones (locate-childrens timezone-tree path)))
+ (run-listbox-selection-page
+ #:title (G_ "Timezone")
+ #:info-text (G_ "Please select a timezone.")
+ #:listbox-items timezones
+ #:listbox-item->text identity
+ #:button-text (if (null? path)
+ (G_ "Exit")
+ (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..59b1913cfc
--- /dev/null
+++ b/gnu/installer/newt/user.scm
@@ -0,0 +1,175 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt user)
+ #:use-module (gnu installer 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-home-directory
+ (make-label -1 -1 (pad-label (G_ "Home directory"))))
+ (entry-width 30)
+ (entry-name (make-entry -1 -1 entry-width))
+ (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")))
+ (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-home-directory)
+ (set-entry-grid-field 1 1 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-home-directory
+ entry-name 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))
+ (home-directory (entry-value entry-home-directory)))
+ (if (or (string=? name "")
+ (string=? home-directory ""))
+ (begin
+ (error-page)
+ (run-user-add-page))
+ (user
+ (name name)
+ (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")))
+ (exit-button (make-button -1 -1 (G_ "Exit")))
+ (title "User creation")
+ (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 exit-button)))
+ (sorted-users (sort users (lambda (a b)
+ (string<= (user-name a)
+ (user-name b)))))
+ (listbox-elements
+ (map
+ (lambda (user)
+ `((key . ,(append-entry-to-listbox listbox
+ (user-name user)))
+ (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))
+ users))))
+ (lambda ()
+ (destroy-form-and-pop form))))))
+ (run '()))
diff --git a/gnu/installer/newt/utils.scm b/gnu/installer/newt/utils.scm
new file mode 100644
index 0000000000..1c2ce4e628
--- /dev/null
+++ b/gnu/installer/newt/utils.scm
@@ -0,0 +1,43 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt utils)
+ #:use-module (ice-9 receive)
+ #:use-module (newt)
+ #:export (screen-columns
+ screen-rows
+
+ destroy-form-and-pop
+ set-screen-size!))
+
+;; Number of columns and rows of the terminal.
+(define screen-columns (make-parameter 0))
+(define screen-rows (make-parameter 0))
+
+(define (destroy-form-and-pop form)
+ "Destory the given FORM and pop the current window."
+ (destroy-form form)
+ (pop-window))
+
+(define (set-screen-size!)
+ "Set the parameters 'screen-columns' and 'screen-rows' to the number of
+columns and rows respectively of the current terminal."
+ (receive (columns rows)
+ (screen-size)
+ (screen-columns columns)
+ (screen-rows rows)))
diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm
new file mode 100644
index 0000000000..eec98e291a
--- /dev/null
+++ b/gnu/installer/newt/welcome.scm
@@ -0,0 +1,118 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt welcome)
+ #:use-module (gnu installer utils)
+ #:use-module (gnu installer newt utils)
+ #:use-module (guix build syscalls)
+ #:use-module (guix i18n)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 receive)
+ #:use-module (newt)
+ #:export (run-welcome-page))
+
+;; Expected width and height for the logo.
+(define logo-width (make-parameter 43))
+(define logo-height (make-parameter 19))
+
+(define info-textbox-width (make-parameter 70))
+(define options-listbox-height (make-parameter 5))
+
+(define* (run-menu-page title info-text 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* ((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 -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-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)
+ (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")
+ (G_ "Welcome to GNU GuixSD installer!
+
+Please note that the present graphical installer is still under heavy \
+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_ "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_ "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..59e40e327e
--- /dev/null
+++ b/gnu/installer/newt/wifi.scm
@@ -0,0 +1,243 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt wifi)
+ #:use-module (gnu installer connman)
+ #:use-module (gnu installer steps)
+ #:use-module (gnu installer newt utils)
+ #:use-module (gnu installer newt page)
+ #:use-module (guix i18n)
+ #:use-module (guix records)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 rdelim)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (newt)
+ #:export (run-wifi-page))
+
+;; This record associates a connman service to its key the listbox.
+(define-record-type* <service-item>
+ service-item make-service-item
+ service-item?
+ (service service-item-service) ; connman <service>
+ (key service-item-key)) ; newt listbox-key
+
+(define (strength->string strength)
+ "Convert STRENGTH as an integer percentage into a text printable strength
+bar using unicode characters. Taken from NetworkManager's
+nmc_wifi_strength_bars."
+ (let ((quarter #\x2582)
+ (half #\x2584)
+ (three-quarter #\x2586)
+ (full #\x2588))
+ (cond
+ ((> strength 80)
+ ;; ▂▄▆█
+ (string quarter half three-quarter full))
+ ((> strength 55)
+ ;; ▂▄▆_
+ (string quarter half three-quarter #\_))
+ ((> strength 30)
+ ;; ▂▄__
+ (string quarter half #\_ #\_))
+ ((> strength 5)
+ ;; ▂___
+ (string quarter #\_ #\_ #\_))
+ (else
+ ;; ____
+ (string quarter #\_ #\_ #\_ #\_)))))
+
+(define (force-wifi-scan)
+ "Force a wifi scan. Raise a condition if no wifi technology is available."
+ (let* ((technologies (connman-technologies))
+ (wifi-technology
+ (find (lambda (technology)
+ (string=? (technology-type technology) "wifi"))
+ technologies)))
+ (if wifi-technology
+ (connman-scan-technology wifi-technology)
+ (raise (condition
+ (&message
+ (message (G_ "Unable to find a wifi technology"))))))))
+
+(define (draw-scanning-page)
+ "Draw a page to indicate a wifi scan in in progress."
+ (draw-info-page (G_ "Scanning wifi for available networks, please wait.")
+ (G_ "Scan in progress")))
+
+(define (run-wifi-password-page)
+ "Run a page prompting user for a password and return it."
+ (run-input-page (G_ "Please enter the wifi password.")
+ (G_ "Password required")))
+
+(define (run-wrong-password-page service-name)
+ "Run a page to inform user of a wrong password input."
+ (run-error-page
+ (format #f (G_ "The password you entered for ~a is incorrect.")
+ service-name)
+ (G_ "Wrong password")))
+
+(define (run-unknown-error-page service-name)
+ "Run a page to inform user that a connection error happened."
+ (run-error-page
+ (format #f
+ (G_ "An error occured while trying to connect to ~a, please retry.")
+ service-name)
+ (G_ "Connection error")))
+
+(define (password-callback)
+ (run-wifi-password-page))
+
+(define (connect-wifi-service listbox service-items)
+ "Connect to the wifi service selected in LISTBOX. SERVICE-ITEMS is the list
+of <service-item> records present in LISTBOX."
+ (let* ((listbox-key (current-listbox-entry listbox))
+ (item (find (lambda (item)
+ (eq? (service-item-key item) listbox-key))
+ service-items))
+ (service (service-item-service item))
+ (service-name (service-name service))
+ (form (draw-connecting-page service-name)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (guard (c ((connman-password-error? c)
+ (run-wrong-password-page service-name)
+ #f)
+ ((connman-already-connected-error? c)
+ #t)
+ ((connman-connection-error? c)
+ (run-unknown-error-page service-name)
+ #f))
+ (connman-connect-with-auth service password-callback)))
+ (lambda ()
+ (destroy-form-and-pop form)))))
+
+(define (run-wifi-scan-page)
+ "Force a wifi scan and draw a page during the operation."
+ (let ((form (draw-scanning-page)))
+ (force-wifi-scan)
+ (destroy-form-and-pop form)))
+
+(define (wifi-services)
+ "Return all the connman services of wifi type."
+ (let ((services (connman-services)))
+ (filter (lambda (service)
+ (and (string=? (service-type service) "wifi")
+ (not (string-null? (service-name service)))))
+ services)))
+
+(define* (fill-wifi-services listbox wifi-services)
+ "Append all the services in WIFI-SERVICES to the given LISTBOX."
+ (clear-listbox listbox)
+ (map (lambda (service)
+ (let* ((text (service->text service))
+ (key (append-entry-to-listbox listbox text)))
+ (service-item
+ (service service)
+ (key key))))
+ wifi-services))
+
+;; Maximum length of a wifi service name.
+(define service-name-max-length (make-parameter 20))
+
+;; Heigth of the listbox displaying wifi services.
+(define wifi-listbox-heigth (make-parameter 20))
+
+;; Information textbox width.
+(define info-textbox-width (make-parameter 40))
+
+(define (service->text service)
+ "Return a string composed of the name and the strength of the given
+SERVICE. A '*' preceding the service name indicates that it is connected."
+ (let* ((name (service-name service))
+ (padded-name (string-pad-right name
+ (service-name-max-length)))
+ (strength (service-strength service))
+ (strength-string (strength->string strength))
+ (state (service-state service))
+ (connected? (or (string=? state "online")
+ (string=? state "ready"))))
+ (format #f "~c ~a ~a~%"
+ (if connected? #\* #\ )
+ padded-name
+ strength-string)))
+
+(define (run-wifi-page)
+ "Run a page displaying available wifi networks in a listbox. Connect to the
+network when the corresponding listbox entry is selected. A button allow to
+force a wifi scan."
+ (let* ((listbox (make-listbox
+ -1 -1
+ (wifi-listbox-heigth)
+ (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT)))
+ (form (make-form))
+ (buttons-grid (make-grid 1 1))
+ (middle-grid (make-grid 2 1))
+ (info-text (G_ "Please select a wifi network."))
+ (info-textbox
+ (make-reflowed-textbox -1 -1 info-text
+ (info-textbox-width)
+ #:flags FLAG-BORDER))
+ (exit-button (make-button -1 -1 (G_ "Exit")))
+ (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 exit-button)
+
+ (add-components-to-form form
+ info-textbox
+ listbox scan-button
+ exit-button)
+ (make-wrapped-grid-window
+ (basic-window-grid info-textbox middle-grid buttons-grid)
+ (G_ "Wifi"))
+
+ (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 exit-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/parted.scm b/gnu/installer/parted.scm
new file mode 100644
index 0000000000..187311e633
--- /dev/null
+++ b/gnu/installer/parted.scm
@@ -0,0 +1,1312 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer 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
+ read-luks-partition-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 (ice-9 regex)
+ #:use-module (rnrs io ports)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:export (<user-partition>
+ user-partition
+ make-user-partition
+ user-partition?
+ user-partition-name
+ user-partition-type
+ user-partition-file-name
+ user-partition-disk-file-name
+ user-partition-crypt-label
+ user-partition-crypt-password
+ 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-formatting?
+ 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-file-name
+ 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>
+ user-partition make-user-partition
+ user-partition?
+ (name user-partition-name ;string
+ (default #f))
+ (type user-partition-type
+ (default 'normal)) ; 'normal | 'logical | 'extended
+ (file-name user-partition-file-name
+ (default #f))
+ (disk-file-name user-partition-disk-file-name
+ (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?
+ (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-formatting? user-partition-need-formatting? ; boolean
+ (default #f))
+ (parted-object user-partition-parted-object ; <partition> 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
+<user-partition> 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 <user-partition> 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 <user-partition> 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))
+ (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)
+ (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 <user-partition> 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 <user-partition> 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? 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."
+ ;; 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."
+ (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 ((file-name (device-path device)))
+ (or (device-is-busy? device)
+ (with-delay-device-in-use? file-name))))
+ (devices)))
+
+
+;;
+;; Disk and partition printing.
+;;
+
+(define* (device-description device #:optional disk)
+ "Return a string describing the given DEVICE."
+ (let* ((type (device-type device))
+ (file-name (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 ")")))
+ ,file-name
+ ,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."
+ (if (and string (not (string=? string "")))
+ (string-pad-right 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)))
+ (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
+ (user-partition-mount-point user-partition))))
+ `(,(or number "")
+ ,@(if has-extended?
+ (list part-type)
+ '())
+ ,size
+ ,(or fs-type-name "")
+ ,(or flags "")
+ ,(or mount-point "")
+ ,(or crypt-label "")
+ ,(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-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)))
+ `(,@(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 (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))
+ '()
+ `((need-formatting?
+ . ,(string-append "Format the partition? : "
+ (if need-formatting? "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)
+ (file-name (partition-get-path new-partition))
+ (disk-file-name (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-formatting user-partitions)
+ "Set the NEED-FORMATING? fields to #t on all <user-partition> records of
+USER-PARTITIONS list and return the updated list."
+ (map (lambda (p)
+ (user-partition
+ (inherit p)
+ (need-formatting? #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
+ (cond
+ ((or (eq? scheme 'entire-root)
+ (eq? scheme 'entire-encrypted-root))
+ (let ((encrypted? (eq? scheme 'entire-encrypted-root)))
+ `(,@(if start-partition
+ `(,start-partition)
+ '())
+ ,@(if encrypted?
+ '()
+ `(,(user-partition
+ (fs-type 'swap)
+ (size swap-size))))
+ ,(user-partition
+ (fs-type 'ext4)
+ (bootable? has-extended?)
+ (crypt-label (and encrypted? "cryptroot"))
+ (size "100%")
+ (mount-point "/")))))
+ ((or (eq? scheme 'entire-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 encrypted? "cryptroot"))
+ (size "33%")
+ (mount-point "/"))
+ ,@(if has-extended?
+ `(,(user-partition
+ (type 'extended)
+ (size "100%")))
+ '())
+ ,@(if encrypted?
+ '()
+ `(,(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 encrypted? "crypthome"))
+ (size "100%")
+ (mount-point "/home")))))))
+ (new-partitions* (force-user-partitions-formatting
+ 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 <user-partition> 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-file-name user-partitions)
+ "Set the partition file-name of <user-partition> records in USER-PARTITIONS
+list and return the updated list."
+ (map (lambda (p)
+ (let* ((partition (user-partition-parted-object p))
+ (file-name (partition-get-path partition)))
+ (user-partition
+ (inherit p)
+ (file-name file-name))))
+ 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 file-name."
+ (with-null-output-ports
+ (invoke "mkfs.ext4" "-F" partition)))
+
+(define (create-fat32-file-system partition)
+ "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 file-name."
+ (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-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))
+ (file-name (user-partition-file-name user-partition)))
+ (if crypt-label
+ (string-append "/dev/mapper/" crypt-label)
+ file-name)))
+
+(define (luks-format-and-open user-partition)
+ "Format and open the encrypted partition pointed by 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" file-name key-file)
+ (system* "cryptsetup" "open" "--type" "luks"
+ "--key-file" key-file file-name label)))))
+
+(define (luks-close user-partition)
+ "Close the encrypted 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 <user-partition> records in USER-PARTITIONS list with
+NEED-FORMATING? field set to #t."
+ (for-each
+ (lambda (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))
+ (fs-type (user-partition-fs-type user-partition)))
+ (when crypt-label
+ (luks-format-and-open user-partition))
+
+ (case fs-type
+ ((ext4)
+ (and need-formatting?
+ (not (eq? type 'extended))
+ (create-ext4-file-system file-name)))
+ ((fat32)
+ (and need-formatting?
+ (not (eq? type 'extended))
+ (create-fat32-file-system file-name)))
+ ((swap)
+ (create-swap-partition file-name))
+ (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 <user-partition> records in USER-PARTITIONS list on their
+respective mount-points."
+ (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))
+ (crypt-label
+ (user-partition-crypt-label user-partition))
+ (mount-type
+ (user-fs-type->mount-type fs-type))
+ (file-name
+ (user-partition-upper-file-name user-partition)))
+ (mkdir-p target)
+ (mount file-name target mount-type)))
+ sorted-partitions)))
+
+(define (umount-user-partitions user-partitions)
+ "Unmount all the <user-partition> 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))
+ (crypt-label
+ (user-partition-crypt-label user-partition))
+ (target
+ (string-append (%installer-target-dir)
+ mount-point)))
+ (umount target)
+ (when crypt-label
+ (luks-close user-partition))))
+ (reverse sorted-partitions))))
+
+(define (find-swap-user-partitions user-partitions)
+ "Return the subset of <user-partition> 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 <user-partition> records with FS-TYPE equal to 'swap."
+ (let* ((swap-user-partitions (find-swap-user-partitions 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 <user-partition> records with FS-TYPE equal to 'swap."
+ (let* ((swap-user-partitions (find-swap-user-partitions 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 ...)
+ "Mount USER-PARTITIONS and start swapping within the dynamic extent of EXP."
+ (dynamic-wind
+ (lambda ()
+ (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)
+ "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))
+ (crypt-label (user-partition-crypt-label user-partition))
+ (mount-type (user-fs-type->mount-type fs-type))
+ (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 file-name) fs-type))))
+ `(file-system
+ (mount-point ,mount-point)
+ (device ,@(if crypt-label
+ `(,upper-file-name)
+ `((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 <user-partition> records into a
+list of <file-system> 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 (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))
+ (file-name (user-partition-file-name user-partition)))
+ `(mapped-device
+ (source (uuid ,(uuid->string
+ (read-luks-partition-uuid file-name)
+ 'luks)))
+ (target ,label)
+ (type luks-device-mapping))))
+
+(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-file-name 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-file-name swap-user-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? encrypted-partitions)
+ '()
+ `((mapped-devices
+ (list ,@(map user-partition->mapped-device
+ encrypted-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: 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
+ ;; 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-file-names (map device-path devices)))
+ (for-each force-device-sync devices)
+ (free-all-devices)
+ (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.")
+ file-name)))))
+ device-file-names)))
diff --git a/gnu/installer/record.scm b/gnu/installer/record.scm
new file mode 100644
index 0000000000..edf73b6215
--- /dev/null
+++ b/gnu/installer/record.scm
@@ -0,0 +1,84 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer record)
+ #:use-module (guix records)
+ #:use-module (srfi srfi-1)
+ #:export (<installer>
+ installer
+ make-installer
+ installer?
+ installer-name
+ installer-init
+ installer-exit
+ installer-exit-error
+ installer-final-page
+ installer-keymap-page
+ installer-locale-page
+ installer-menu-page
+ installer-network-page
+ installer-timezone-page
+ installer-hostname-page
+ installer-user-page
+ installer-partition-page
+ installer-services-page
+ installer-welcome-page))
+
+
+;;;
+;;; Installer record.
+;;;
+
+;; The <installer> record contains pages that will be run to prompt the user
+;; for the system configuration. The goal of the installer is to produce a
+;; complete <operating-system> record and install it.
+
+(define-record-type* <installer>
+ installer make-installer
+ installer?
+ ;; symbol
+ (name installer-name)
+ ;; procedure: void -> void
+ (init installer-init)
+ ;; procedure: void -> void
+ (exit installer-exit)
+ ;; procedure (key arguments) -> void
+ (exit-error installer-exit-error)
+ ;; 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
+ (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 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/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 <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer services)
+ #:use-module (guix records)
+ #:export (<desktop-environment>
+ desktop-environment
+ make-desktop-environment
+ desktop-environment-name
+ desktop-environment-snippet
+
+ %desktop-environments
+ desktop-environments->configuration))
+
+(define-record-type* <desktop-environment>
+ 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/installer/steps.scm b/gnu/installer/steps.scm
new file mode 100644
index 0000000000..3f0bdad4f7
--- /dev/null
+++ b/gnu/installer/steps.scm
@@ -0,0 +1,237 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer steps)
+ #:use-module (guix records)
+ #:use-module (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?
+
+ &installer-step-break
+ installer-step-break?
+
+ <installer-step>
+ installer-step
+ make-installer-step
+ installer-step?
+ installer-step-id
+ installer-step-description
+ installer-step-compute
+ installer-step-configuration-formatter
+
+ run-installer-steps
+ find-step-by-id
+ result->step-ids
+ result-step
+ 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
+ installer-step-abort?)
+
+;; This condition may be raised to break out from the steps execution.
+(define-condition-type &installer-step-break &condition
+ installer-step-break?)
+
+;; An installer-step record is basically an id associated to a compute
+;; procedure. The COMPUTE procedure takes exactly one argument, an association
+;; list containing the results of previously executed installer-steps (see
+;; RUN-INSTALLER-STEPS description). The value returned by the COMPUTE
+;; procedure will be stored in the results list passed to the next
+;; installer-step and so on.
+(define-record-type* <installer-step>
+ installer-step make-installer-step
+ installer-step?
+ (id installer-step-id) ;symbol
+ (description installer-step-description ;string
+ (default #f))
+ (compute installer-step-compute) ;procedure
+ (configuration-formatter installer-step-configuration-formatter ;procedure
+ (default #f)))
+
+(define* (run-installer-steps #:key
+ steps
+ (rewind-strategy 'previous)
+ (menu-proc (const #f)))
+ "Run the COMPUTE procedure of all <installer-step> records in STEPS
+sequencially. If the &installer-step-abort condition is raised, fallback to a
+previous install-step, accordingly to the specified REWIND-STRATEGY.
+
+REWIND-STRATEGY possible values are 'previous, 'menu and 'start. If 'previous
+is selected, the execution will resume at the previous installer-step. If
+'menu is selected, the MENU-PROC procedure will be called. Its return value
+has to be an installer-step ID to jump to. The ID has to be the one of a
+previously executed step. It is impossible to jump forward. Finally if 'start
+is selected, the execution will resume at the first installer-step.
+
+The result of every COMPUTE procedures is stored in an association list, under
+the form:
+
+ '((STEP-ID . COMPUTE-RESULT) ...)
+
+where STEP-ID is the ID field of the installer-step and COMPUTE-RESULT the
+result of the associated COMPUTE procedure. This result association list is
+passed as argument of every COMPUTE procedure. It is finally returned when the
+computation is over.
+
+If the &installer-step-break condition is raised, stop the computation and
+return the accumalated result so far."
+ (define (pop-result list)
+ (cdr list))
+
+ (define (first-step? steps step)
+ (match steps
+ ((first-step . rest-steps)
+ (equal? first-step step))))
+
+ (define* (skip-to-step step result
+ #:key todo-steps done-steps)
+ (match (list todo-steps done-steps)
+ (((todo . rest-todo) (prev-done ... last-done))
+ (if (eq? (installer-step-id todo)
+ (installer-step-id step))
+ (run result
+ #:todo-steps todo-steps
+ #:done-steps done-steps)
+ (skip-to-step step (pop-result result)
+ #:todo-steps (cons last-done todo-steps)
+ #:done-steps prev-done)))))
+
+ (define* (run result #:key todo-steps done-steps)
+ (match todo-steps
+ (() (reverse result))
+ ((step . rest-steps)
+ (guard (c ((installer-step-abort? c)
+ (case rewind-strategy
+ ((previous)
+ (match done-steps
+ (()
+ ;; We cannot go previous the first step. So re-raise
+ ;; the exception. It might be useful in the case of
+ ;; nested run-installer-steps. Abort to 'raise-above
+ ;; prompt to prevent the condition from being catched
+ ;; by one of the previously installed guard.
+ (abort-to-prompt 'raise-above c))
+ ((prev-done ... last-done)
+ (run (pop-result result)
+ #:todo-steps (cons last-done todo-steps)
+ #:done-steps prev-done))))
+ ((menu)
+ (let ((goto-step (menu-proc
+ (append done-steps (list step)))))
+ (if (eq? goto-step step)
+ (run result
+ #:todo-steps todo-steps
+ #:done-steps done-steps)
+ (skip-to-step goto-step result
+ #:todo-steps todo-steps
+ #:done-steps done-steps))))
+ ((start)
+ (if (null? done-steps)
+ ;; Same as above, it makes no sense to jump to start
+ ;; when we are at the first installer-step. Abort to
+ ;; 'raise-above prompt to re-raise the condition.
+ (abort-to-prompt 'raise-above c)
+ (run '()
+ #:todo-steps steps
+ #:done-steps '())))))
+ ((installer-step-break? c)
+ (reverse result)))
+ (let* ((id (installer-step-id step))
+ (compute (installer-step-compute step))
+ (res (compute result done-steps)))
+ (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))
+
+(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 <installer-step> 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
new file mode 100644
index 0000000000..32bc2ed6bb
--- /dev/null
+++ b/gnu/installer/timezone.scm
@@ -0,0 +1,127 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer timezone)
+ #:use-module (gnu installer utils)
+ #:use-module (guix i18n)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 receive)
+ #:export (locate-childrens
+ timezone->posix-tz
+ timezone-has-child?
+ zonetab->timezone-tree
+ posix-tz->configuration))
+
+(define %not-blank
+ (char-set-complement char-set:blank))
+
+(define (posix-tz->timezone tz)
+ "Convert given TZ in Posix format like \"Europe/Paris\" into a list like
+(\"Europe\" \"Paris\")."
+ (string-split tz #\/))
+
+(define (timezone->posix-tz timezone)
+ "Convert given TIMEZONE like (\"Europe\" \"Paris\") into a Posix timezone
+like \"Europe/Paris\"."
+ (string-join timezone "/"))
+
+(define (zonetab->timezones zonetab)
+ "Parse ZONETAB file and return the corresponding list of timezones."
+
+ (define (zonetab-line->posix-tz line)
+ (let ((tokens (string-tokenize line %not-blank)))
+ (match tokens
+ ((code coordinates tz _ ...)
+ tz))))
+
+ (call-with-input-file zonetab
+ (lambda (port)
+ (let* ((lines (read-lines port))
+ ;; Filter comment lines starting with '#' character.
+ (tz-lines (filter (lambda (line)
+ (not (eq? (string-ref line 0)
+ #\#)))
+ lines)))
+ (map (lambda (line)
+ (posix-tz->timezone
+ (zonetab-line->posix-tz line)))
+ tz-lines)))))
+
+(define (timezones->timezone-tree timezones)
+ "Convert the list of timezones, TIMEZONES into a tree under the form:
+
+ (\"America\" (\"North_Dakota\" \"New_Salem\" \"Center\"))
+
+representing America/North_Dakota/New_Salem and America/North_Dakota/Center
+timezones."
+
+ (define (remove-first lists)
+ "Remove the first element of every sublists in the argument LISTS."
+ (map (lambda (list)
+ (if (null? list) list (cdr list)))
+ lists))
+
+ (let loop ((cur-timezones timezones))
+ (match cur-timezones
+ (() '())
+ (((region . rest-region) . rest-timezones)
+ (if (null? rest-region)
+ (cons (list region) (loop rest-timezones))
+ (receive (same-region other-region)
+ (partition (lambda (timezone)
+ (string=? (car timezone) region))
+ cur-timezones)
+ (acons region
+ (loop (remove-first same-region))
+ (loop other-region))))))))
+
+(define (locate-childrens tree path)
+ "Return the childrens of the timezone indicated by PATH in the given
+TREE. Raise a condition if the PATH could not be found."
+ (let ((extract-proc (cut map car <>)))
+ (match path
+ (() (sort (extract-proc tree) string<?))
+ ((region . rest)
+ (or (and=> (assoc-ref tree region)
+ (cut locate-childrens <> rest))
+ (raise
+ (condition
+ (&message
+ (message
+ (format #f (G_ "Unable to locate path: ~a.") path))))))))))
+
+(define (timezone-has-child? tree timezone)
+ "Return #t if the given TIMEZONE any child in TREE and #f otherwise."
+ (not (null? (locate-childrens tree timezone))))
+
+(define* (zonetab->timezone-tree zonetab)
+ "Return the timezone tree corresponding to the given ZONETAB file."
+ (timezones->timezone-tree (zonetab->timezones zonetab)))
+
+
+;;;
+;;; Configuration formatter.
+;;;
+
+(define (posix-tz->configuration timezone)
+ "Return the configuration field for TIMEZONE."
+ `((timezone ,timezone)))
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 <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer user)
+ #:use-module (guix records)
+ #:export (<user>
+ user
+ make-user
+ user-name
+ user-group
+ user-home-directory
+
+ users->configuration))
+
+(define-record-type* <user>
+ 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/installer/utils.scm b/gnu/installer/utils.scm
new file mode 100644
index 0000000000..e91f90a84d
--- /dev/null
+++ b/gnu/installer/utils.scm
@@ -0,0 +1,63 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer utils)
+ #:use-module (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
+ 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."
+ (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))
+
+(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))))