diff options
Diffstat (limited to 'gnu/installer')
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)))) |