diff options
| author | Mathieu Othacehe <m.othacehe@gmail.com> | 2018-11-16 20:43:55 +0900 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2019-01-17 14:04:20 +0100 |
| commit | d0f3a672dcbdfefd3556b6a21985ff0e35eed3be (patch) | |
| tree | 6ca7cc2fc874343791a3b555181177be488a3a8a | |
| parent | 08af580bde01ffd8e6968b6f9f9eff14c4f9cc5a (diff) | |
gnu: Add graphical installer support.
* configure.ac: Require that guile-newt is available.
* gnu/installer.scm: New file.
* gnu/installer/aux-files/logo.txt: New file.
* gnu/installer/build-installer.scm: New file.
* gnu/installer/connman.scm: New file.
* gnu/installer/keymap.scm: New file.
* gnu/installer/locale.scm: New file.
* gnu/installer/newt.scm: New file.
* gnu/installer/newt/ethernet.scm: New file.
* gnu/installer/newt/hostname.scm: New file.
* gnu/installer/newt/keymap.scm: New file.
* gnu/installer/newt/locale.scm: New file.
* gnu/installer/newt/menu.scm: New file.
* gnu/installer/newt/network.scm: New file.
* gnu/installer/newt/page.scm: New file.
* gnu/installer/newt/timezone.scm: New file.
* gnu/installer/newt/user.scm: New file.
* gnu/installer/newt/utils.scm: New file.
* gnu/installer/newt/welcome.scm: New file.
* gnu/installer/newt/wifi.scm: New file.
* gnu/installer/steps.scm: New file.
* gnu/installer/timezone.scm: New file.
* gnu/installer/utils.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add previous files.
* gnu/system.scm: Export %root-account.
* gnu/system/install.scm (%installation-services): Use kmscon instead of linux
VT for all tty.
(installation-os)[users]: Add the graphical installer as shell of the root
account.
[packages]: Add font related packages.
* po/guix/POTFILES.in: Add installer files.
28 files changed, 3904 insertions, 119 deletions
diff --git a/configure.ac b/configure.ac index 891fce28ae7..83a9b87d77e 100644 --- a/configure.ac +++ b/configure.ac | |||
| @@ -135,6 +135,12 @@ if test "x$have_guile_gcrypt" != "xyes"; then | |||
| 135 | AC_MSG_ERROR([Guile-Gcrypt could not be found; please install it.]) | 135 | AC_MSG_ERROR([Guile-Gcrypt could not be found; please install it.]) |
| 136 | fi | 136 | fi |
| 137 | 137 | ||
| 138 | dnl Guile-newt is used by the graphical installer. | ||
| 139 | GUILE_MODULE_AVAILABLE([have_guile_newt], [(newt)]) | ||
| 140 | if test "x$have_guile_newt" != "xyes"; then | ||
| 141 | AC_MSG_ERROR([Guile-newt could not be found; please install it.]) | ||
| 142 | fi | ||
| 143 | |||
| 138 | dnl Make sure we have a full-fledged Guile. | 144 | dnl Make sure we have a full-fledged Guile. |
| 139 | GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads]) | 145 | GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads]) |
| 140 | 146 | ||
diff --git a/gnu/installer.scm b/gnu/installer.scm new file mode 100644 index 00000000000..f3323ea3bcd --- /dev/null +++ b/gnu/installer.scm | |||
| @@ -0,0 +1,111 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer) | ||
| 20 | #:use-module (guix discovery) | ||
| 21 | #:use-module (guix records) | ||
| 22 | #:use-module (guix ui) | ||
| 23 | #:use-module (srfi srfi-1) | ||
| 24 | #:export (<installer> | ||
| 25 | installer | ||
| 26 | make-installer | ||
| 27 | installer? | ||
| 28 | installer-name | ||
| 29 | installer-modules | ||
| 30 | installer-init | ||
| 31 | installer-exit | ||
| 32 | installer-exit-error | ||
| 33 | installer-keymap-page | ||
| 34 | installer-locale-page | ||
| 35 | installer-menu-page | ||
| 36 | installer-network-page | ||
| 37 | installer-timezone-page | ||
| 38 | installer-hostname-page | ||
| 39 | installer-user-page | ||
| 40 | installer-welcome-page | ||
| 41 | |||
| 42 | %installers | ||
| 43 | lookup-installer-by-name)) | ||
| 44 | |||
| 45 | |||
| 46 | ;;; | ||
| 47 | ;;; Installer record. | ||
| 48 | ;;; | ||
| 49 | |||
| 50 | ;; The <installer> record contains pages that will be run to prompt the user | ||
| 51 | ;; for the system configuration. The goal of the installer is to produce a | ||
| 52 | ;; complete <operating-system> record and install it. | ||
| 53 | |||
| 54 | (define-record-type* <installer> | ||
| 55 | installer make-installer | ||
| 56 | installer? | ||
| 57 | ;; symbol | ||
| 58 | (name installer-name) | ||
| 59 | ;; list of installer modules | ||
| 60 | (modules installer-modules) | ||
| 61 | ;; procedure: void -> void | ||
| 62 | (init installer-init) | ||
| 63 | ;; procedure: void -> void | ||
| 64 | (exit installer-exit) | ||
| 65 | ;; procedure (key arguments) -> void | ||
| 66 | (exit-error installer-exit-error) | ||
| 67 | ;; procedure (#:key models layouts) -> (list model layout variant) | ||
| 68 | (keymap-page installer-keymap-page) | ||
| 69 | ;; procedure: (#:key supported-locales iso639-languages iso3166-territories) | ||
| 70 | ;; -> glibc-locale | ||
| 71 | (locale-page installer-locale-page) | ||
| 72 | ;; procedure: (steps) -> step-id | ||
| 73 | (menu-page installer-menu-page) | ||
| 74 | ;; procedure void -> void | ||
| 75 | (network-page installer-network-page) | ||
| 76 | ;; procedure (zonetab) -> posix-timezone | ||
| 77 | (timezone-page installer-timezone-page) | ||
| 78 | ;; procedure void -> void | ||
| 79 | (hostname-page installer-hostname-page) | ||
| 80 | ;; procedure void -> void | ||
| 81 | (user-page installer-user-page) | ||
| 82 | ;; procedure (logo) -> void | ||
| 83 | (welcome-page installer-welcome-page)) | ||
| 84 | |||
| 85 | |||
| 86 | ;;; | ||
| 87 | ;;; Installers. | ||
| 88 | ;;; | ||
| 89 | |||
| 90 | (define (installer-top-modules) | ||
| 91 | "Return the list of installer modules." | ||
| 92 | (all-modules (map (lambda (entry) | ||
| 93 | `(,entry . "gnu/installer")) | ||
| 94 | %load-path) | ||
| 95 | #:warn warn-about-load-error)) | ||
| 96 | |||
| 97 | (define %installers | ||
| 98 | ;; The list of publically-known installers. | ||
| 99 | (delay (fold-module-public-variables (lambda (obj result) | ||
| 100 | (if (installer? obj) | ||
| 101 | (cons obj result) | ||
| 102 | result)) | ||
| 103 | '() | ||
| 104 | (installer-top-modules)))) | ||
| 105 | |||
| 106 | (define (lookup-installer-by-name name) | ||
| 107 | "Return the installer called NAME." | ||
| 108 | (or (find (lambda (installer) | ||
| 109 | (eq? name (installer-name installer))) | ||
| 110 | (force %installers)) | ||
| 111 | (leave (G_ "~a: no such installer~%") name))) | ||
diff --git a/gnu/installer/aux-files/SUPPORTED b/gnu/installer/aux-files/SUPPORTED new file mode 100644 index 00000000000..24aae1e089f --- /dev/null +++ b/gnu/installer/aux-files/SUPPORTED | |||
| @@ -0,0 +1,484 @@ | |||
| 1 | aa_DJ.UTF-8 UTF-8 | ||
| 2 | aa_DJ ISO-8859-1 | ||
| 3 | aa_ER UTF-8 | ||
| 4 | aa_ER@saaho UTF-8 | ||
| 5 | aa_ET UTF-8 | ||
| 6 | af_ZA.UTF-8 UTF-8 | ||
| 7 | af_ZA ISO-8859-1 | ||
| 8 | agr_PE UTF-8 | ||
| 9 | ak_GH UTF-8 | ||
| 10 | am_ET UTF-8 | ||
| 11 | an_ES.UTF-8 UTF-8 | ||
| 12 | an_ES ISO-8859-15 | ||
| 13 | anp_IN UTF-8 | ||
| 14 | ar_AE.UTF-8 UTF-8 | ||
| 15 | ar_AE ISO-8859-6 | ||
| 16 | ar_BH.UTF-8 UTF-8 | ||
| 17 | ar_BH ISO-8859-6 | ||
| 18 | ar_DZ.UTF-8 UTF-8 | ||
| 19 | ar_DZ ISO-8859-6 | ||
| 20 | ar_EG.UTF-8 UTF-8 | ||
| 21 | ar_EG ISO-8859-6 | ||
| 22 | ar_IN UTF-8 | ||
| 23 | ar_IQ.UTF-8 UTF-8 | ||
| 24 | ar_IQ ISO-8859-6 | ||
| 25 | ar_JO.UTF-8 UTF-8 | ||
| 26 | ar_JO ISO-8859-6 | ||
| 27 | ar_KW.UTF-8 UTF-8 | ||
| 28 | ar_KW ISO-8859-6 | ||
| 29 | ar_LB.UTF-8 UTF-8 | ||
| 30 | ar_LB ISO-8859-6 | ||
| 31 | ar_LY.UTF-8 UTF-8 | ||
| 32 | ar_LY ISO-8859-6 | ||
| 33 | ar_MA.UTF-8 UTF-8 | ||
| 34 | ar_MA ISO-8859-6 | ||
| 35 | ar_OM.UTF-8 UTF-8 | ||
| 36 | ar_OM ISO-8859-6 | ||
| 37 | ar_QA.UTF-8 UTF-8 | ||
| 38 | ar_QA ISO-8859-6 | ||
| 39 | ar_SA.UTF-8 UTF-8 | ||
| 40 | ar_SA ISO-8859-6 | ||
| 41 | ar_SD.UTF-8 UTF-8 | ||
| 42 | ar_SD ISO-8859-6 | ||
| 43 | ar_SS UTF-8 | ||
| 44 | ar_SY.UTF-8 UTF-8 | ||
| 45 | ar_SY ISO-8859-6 | ||
| 46 | ar_TN.UTF-8 UTF-8 | ||
| 47 | ar_TN ISO-8859-6 | ||
| 48 | ar_YE.UTF-8 UTF-8 | ||
| 49 | ar_YE ISO-8859-6 | ||
| 50 | ayc_PE UTF-8 | ||
| 51 | az_AZ UTF-8 | ||
| 52 | az_IR UTF-8 | ||
| 53 | as_IN UTF-8 | ||
| 54 | ast_ES.UTF-8 UTF-8 | ||
| 55 | ast_ES ISO-8859-15 | ||
| 56 | be_BY.UTF-8 UTF-8 | ||
| 57 | be_BY CP1251 | ||
| 58 | be_BY@latin UTF-8 | ||
| 59 | bem_ZM UTF-8 | ||
| 60 | ber_DZ UTF-8 | ||
| 61 | ber_MA UTF-8 | ||
| 62 | bg_BG.UTF-8 UTF-8 | ||
| 63 | bg_BG CP1251 | ||
| 64 | bhb_IN.UTF-8 UTF-8 | ||
| 65 | bho_IN UTF-8 | ||
| 66 | bho_NP UTF-8 | ||
| 67 | bi_VU UTF-8 | ||
| 68 | bn_BD UTF-8 | ||
| 69 | bn_IN UTF-8 | ||
| 70 | bo_CN UTF-8 | ||
| 71 | bo_IN UTF-8 | ||
| 72 | br_FR.UTF-8 UTF-8 | ||
| 73 | br_FR ISO-8859-1 | ||
| 74 | br_FR@euro ISO-8859-15 | ||
| 75 | brx_IN UTF-8 | ||
| 76 | bs_BA.UTF-8 UTF-8 | ||
| 77 | bs_BA ISO-8859-2 | ||
| 78 | byn_ER UTF-8 | ||
| 79 | ca_AD.UTF-8 UTF-8 | ||
| 80 | ca_AD ISO-8859-15 | ||
| 81 | ca_ES.UTF-8 UTF-8 | ||
| 82 | ca_ES ISO-8859-1 | ||
| 83 | ca_ES@euro ISO-8859-15 | ||
| 84 | ca_ES@valencia UTF-8 | ||
| 85 | ca_FR.UTF-8 UTF-8 | ||
| 86 | ca_FR ISO-8859-15 | ||
| 87 | ca_IT.UTF-8 UTF-8 | ||
| 88 | ca_IT ISO-8859-15 | ||
| 89 | ce_RU UTF-8 | ||
| 90 | chr_US UTF-8 | ||
| 91 | cmn_TW UTF-8 | ||
| 92 | crh_UA UTF-8 | ||
| 93 | cs_CZ.UTF-8 UTF-8 | ||
| 94 | cs_CZ ISO-8859-2 | ||
| 95 | csb_PL UTF-8 | ||
| 96 | cv_RU UTF-8 | ||
| 97 | cy_GB.UTF-8 UTF-8 | ||
| 98 | cy_GB ISO-8859-14 | ||
| 99 | da_DK.UTF-8 UTF-8 | ||
| 100 | da_DK ISO-8859-1 | ||
| 101 | de_AT.UTF-8 UTF-8 | ||
| 102 | de_AT ISO-8859-1 | ||
| 103 | de_AT@euro ISO-8859-15 | ||
| 104 | de_BE.UTF-8 UTF-8 | ||
| 105 | de_BE ISO-8859-1 | ||
| 106 | de_BE@euro ISO-8859-15 | ||
| 107 | de_CH.UTF-8 UTF-8 | ||
| 108 | de_CH ISO-8859-1 | ||
| 109 | de_DE.UTF-8 UTF-8 | ||
| 110 | de_DE ISO-8859-1 | ||
| 111 | de_DE@euro ISO-8859-15 | ||
| 112 | de_IT.UTF-8 UTF-8 | ||
| 113 | de_IT ISO-8859-1 | ||
| 114 | de_LI.UTF-8 UTF-8 | ||
| 115 | de_LU.UTF-8 UTF-8 | ||
| 116 | de_LU ISO-8859-1 | ||
| 117 | de_LU@euro ISO-8859-15 | ||
| 118 | doi_IN UTF-8 | ||
| 119 | dv_MV UTF-8 | ||
| 120 | dz_BT UTF-8 | ||
| 121 | el_GR.UTF-8 UTF-8 | ||
| 122 | el_GR ISO-8859-7 | ||
| 123 | el_GR@euro ISO-8859-7 | ||
| 124 | el_CY.UTF-8 UTF-8 | ||
| 125 | el_CY ISO-8859-7 | ||
| 126 | en_AG UTF-8 | ||
| 127 | en_AU.UTF-8 UTF-8 | ||
| 128 | en_AU ISO-8859-1 | ||
| 129 | en_BW.UTF-8 UTF-8 | ||
| 130 | en_BW ISO-8859-1 | ||
| 131 | en_CA.UTF-8 UTF-8 | ||
| 132 | en_CA ISO-8859-1 | ||
| 133 | en_DK.UTF-8 UTF-8 | ||
| 134 | en_DK ISO-8859-1 | ||
| 135 | en_GB.UTF-8 UTF-8 | ||
| 136 | en_GB ISO-8859-1 | ||
| 137 | en_HK.UTF-8 UTF-8 | ||
| 138 | en_HK ISO-8859-1 | ||
| 139 | en_IE.UTF-8 UTF-8 | ||
| 140 | en_IE ISO-8859-1 | ||
| 141 | en_IE@euro ISO-8859-15 | ||
| 142 | en_IL UTF-8 | ||
| 143 | en_IN UTF-8 | ||
| 144 | en_NG UTF-8 | ||
| 145 | en_NZ.UTF-8 UTF-8 | ||
| 146 | en_NZ ISO-8859-1 | ||
| 147 | en_PH.UTF-8 UTF-8 | ||
| 148 | en_PH ISO-8859-1 | ||
| 149 | en_SC.UTF-8 UTF-8 | ||
| 150 | en_SG.UTF-8 UTF-8 | ||
| 151 | en_SG ISO-8859-1 | ||
| 152 | en_US.UTF-8 UTF-8 | ||
| 153 | en_US ISO-8859-1 | ||
| 154 | en_ZA.UTF-8 UTF-8 | ||
| 155 | en_ZA ISO-8859-1 | ||
| 156 | en_ZM UTF-8 | ||
| 157 | en_ZW.UTF-8 UTF-8 | ||
| 158 | en_ZW ISO-8859-1 | ||
| 159 | eo UTF-8 | ||
| 160 | es_AR.UTF-8 UTF-8 | ||
| 161 | es_AR ISO-8859-1 | ||
| 162 | es_BO.UTF-8 UTF-8 | ||
| 163 | es_BO ISO-8859-1 | ||
| 164 | es_CL.UTF-8 UTF-8 | ||
| 165 | es_CL ISO-8859-1 | ||
| 166 | es_CO.UTF-8 UTF-8 | ||
| 167 | es_CO ISO-8859-1 | ||
| 168 | es_CR.UTF-8 UTF-8 | ||
| 169 | es_CR ISO-8859-1 | ||
| 170 | es_CU UTF-8 | ||
| 171 | es_DO.UTF-8 UTF-8 | ||
| 172 | es_DO ISO-8859-1 | ||
| 173 | es_EC.UTF-8 UTF-8 | ||
| 174 | es_EC ISO-8859-1 | ||
| 175 | es_ES.UTF-8 UTF-8 | ||
| 176 | es_ES ISO-8859-1 | ||
| 177 | es_ES@euro ISO-8859-15 | ||
| 178 | es_GT.UTF-8 UTF-8 | ||
| 179 | es_GT ISO-8859-1 | ||
| 180 | es_HN.UTF-8 UTF-8 | ||
| 181 | es_HN ISO-8859-1 | ||
| 182 | es_MX.UTF-8 UTF-8 | ||
| 183 | es_MX ISO-8859-1 | ||
| 184 | es_NI.UTF-8 UTF-8 | ||
| 185 | es_NI ISO-8859-1 | ||
| 186 | es_PA.UTF-8 UTF-8 | ||
| 187 | es_PA ISO-8859-1 | ||
| 188 | es_PE.UTF-8 UTF-8 | ||
| 189 | es_PE ISO-8859-1 | ||
| 190 | es_PR.UTF-8 UTF-8 | ||
| 191 | es_PR ISO-8859-1 | ||
| 192 | es_PY.UTF-8 UTF-8 | ||
| 193 | es_PY ISO-8859-1 | ||
| 194 | es_SV.UTF-8 UTF-8 | ||
| 195 | es_SV ISO-8859-1 | ||
| 196 | es_US.UTF-8 UTF-8 | ||
| 197 | es_US ISO-8859-1 | ||
| 198 | es_UY.UTF-8 UTF-8 | ||
| 199 | es_UY ISO-8859-1 | ||
| 200 | es_VE.UTF-8 UTF-8 | ||
| 201 | es_VE ISO-8859-1 | ||
| 202 | et_EE.UTF-8 UTF-8 | ||
| 203 | et_EE ISO-8859-1 | ||
| 204 | et_EE.ISO-8859-15 ISO-8859-15 | ||
| 205 | eu_ES.UTF-8 UTF-8 | ||
| 206 | eu_ES ISO-8859-1 | ||
| 207 | eu_ES@euro ISO-8859-15 | ||
| 208 | fa_IR UTF-8 | ||
| 209 | ff_SN UTF-8 | ||
| 210 | fi_FI.UTF-8 UTF-8 | ||
| 211 | fi_FI ISO-8859-1 | ||
| 212 | fi_FI@euro ISO-8859-15 | ||
| 213 | fil_PH UTF-8 | ||
| 214 | fo_FO.UTF-8 UTF-8 | ||
| 215 | fo_FO ISO-8859-1 | ||
| 216 | fr_BE.UTF-8 UTF-8 | ||
| 217 | fr_BE ISO-8859-1 | ||
| 218 | fr_BE@euro ISO-8859-15 | ||
| 219 | fr_CA.UTF-8 UTF-8 | ||
| 220 | fr_CA ISO-8859-1 | ||
| 221 | fr_CH.UTF-8 UTF-8 | ||
| 222 | fr_CH ISO-8859-1 | ||
| 223 | fr_FR.UTF-8 UTF-8 | ||
| 224 | fr_FR ISO-8859-1 | ||
| 225 | fr_FR@euro ISO-8859-15 | ||
| 226 | fr_LU.UTF-8 UTF-8 | ||
| 227 | fr_LU ISO-8859-1 | ||
| 228 | fr_LU@euro ISO-8859-15 | ||
| 229 | fur_IT UTF-8 | ||
| 230 | fy_NL UTF-8 | ||
| 231 | fy_DE UTF-8 | ||
| 232 | ga_IE.UTF-8 UTF-8 | ||
| 233 | ga_IE ISO-8859-1 | ||
| 234 | ga_IE@euro ISO-8859-15 | ||
| 235 | gd_GB.UTF-8 UTF-8 | ||
| 236 | gd_GB ISO-8859-15 | ||
| 237 | gez_ER UTF-8 | ||
| 238 | gez_ER@abegede UTF-8 | ||
| 239 | gez_ET UTF-8 | ||
| 240 | gez_ET@abegede UTF-8 | ||
| 241 | gl_ES.UTF-8 UTF-8 | ||
| 242 | gl_ES ISO-8859-1 | ||
| 243 | gl_ES@euro ISO-8859-15 | ||
| 244 | gu_IN UTF-8 | ||
| 245 | gv_GB.UTF-8 UTF-8 | ||
| 246 | gv_GB ISO-8859-1 | ||
| 247 | ha_NG UTF-8 | ||
| 248 | hak_TW UTF-8 | ||
| 249 | he_IL.UTF-8 UTF-8 | ||
| 250 | he_IL ISO-8859-8 | ||
| 251 | hi_IN UTF-8 | ||
| 252 | hif_FJ UTF-8 | ||
| 253 | hne_IN UTF-8 | ||
| 254 | hr_HR.UTF-8 UTF-8 | ||
| 255 | hr_HR ISO-8859-2 | ||
| 256 | hsb_DE ISO-8859-2 | ||
| 257 | hsb_DE.UTF-8 UTF-8 | ||
| 258 | ht_HT UTF-8 | ||
| 259 | hu_HU.UTF-8 UTF-8 | ||
| 260 | hu_HU ISO-8859-2 | ||
| 261 | hy_AM UTF-8 | ||
| 262 | hy_AM.ARMSCII-8 ARMSCII-8 | ||
| 263 | ia_FR UTF-8 | ||
| 264 | id_ID.UTF-8 UTF-8 | ||
| 265 | id_ID ISO-8859-1 | ||
| 266 | ig_NG UTF-8 | ||
| 267 | ik_CA UTF-8 | ||
| 268 | is_IS.UTF-8 UTF-8 | ||
| 269 | is_IS ISO-8859-1 | ||
| 270 | it_CH.UTF-8 UTF-8 | ||
| 271 | it_CH ISO-8859-1 | ||
| 272 | it_IT.UTF-8 UTF-8 | ||
| 273 | it_IT ISO-8859-1 | ||
| 274 | it_IT@euro ISO-8859-15 | ||
| 275 | iu_CA UTF-8 | ||
| 276 | ja_JP.EUC-JP EUC-JP | ||
| 277 | ja_JP.UTF-8 UTF-8 | ||
| 278 | ka_GE.UTF-8 UTF-8 | ||
| 279 | ka_GE GEORGIAN-PS | ||
| 280 | kab_DZ UTF-8 | ||
| 281 | kk_KZ.UTF-8 UTF-8 | ||
| 282 | kk_KZ PT154 | ||
| 283 | kl_GL.UTF-8 UTF-8 | ||
| 284 | kl_GL ISO-8859-1 | ||
| 285 | km_KH UTF-8 | ||
| 286 | kn_IN UTF-8 | ||
| 287 | ko_KR.EUC-KR EUC-KR | ||
| 288 | ko_KR.UTF-8 UTF-8 | ||
| 289 | kok_IN UTF-8 | ||
| 290 | ks_IN UTF-8 | ||
| 291 | ks_IN@devanagari UTF-8 | ||
| 292 | ku_TR.UTF-8 UTF-8 | ||
| 293 | ku_TR ISO-8859-9 | ||
| 294 | kw_GB.UTF-8 UTF-8 | ||
| 295 | kw_GB ISO-8859-1 | ||
| 296 | ky_KG UTF-8 | ||
| 297 | lb_LU UTF-8 | ||
| 298 | lg_UG.UTF-8 UTF-8 | ||
| 299 | lg_UG ISO-8859-10 | ||
| 300 | li_BE UTF-8 | ||
| 301 | li_NL UTF-8 | ||
| 302 | lij_IT UTF-8 | ||
| 303 | ln_CD UTF-8 | ||
| 304 | lo_LA UTF-8 | ||
| 305 | lt_LT.UTF-8 UTF-8 | ||
| 306 | lt_LT ISO-8859-13 | ||
| 307 | lv_LV.UTF-8 UTF-8 | ||
| 308 | lv_LV ISO-8859-13 | ||
| 309 | lzh_TW UTF-8 | ||
| 310 | mag_IN UTF-8 | ||
| 311 | mai_IN UTF-8 | ||
| 312 | mai_NP UTF-8 | ||
| 313 | mfe_MU UTF-8 | ||
| 314 | mg_MG.UTF-8 UTF-8 | ||
| 315 | mg_MG ISO-8859-15 | ||
| 316 | mhr_RU UTF-8 | ||
| 317 | mi_NZ.UTF-8 UTF-8 | ||
| 318 | mi_NZ ISO-8859-13 | ||
| 319 | miq_NI UTF-8 | ||
| 320 | mjw_IN UTF-8 | ||
| 321 | mk_MK.UTF-8 UTF-8 | ||
| 322 | mk_MK ISO-8859-5 | ||
| 323 | ml_IN UTF-8 | ||
| 324 | mn_MN UTF-8 | ||
| 325 | mni_IN UTF-8 | ||
| 326 | mr_IN UTF-8 | ||
| 327 | ms_MY.UTF-8 UTF-8 | ||
| 328 | ms_MY ISO-8859-1 | ||
| 329 | mt_MT.UTF-8 UTF-8 | ||
| 330 | mt_MT ISO-8859-3 | ||
| 331 | my_MM UTF-8 | ||
| 332 | nan_TW UTF-8 | ||
| 333 | nan_TW@latin UTF-8 | ||
| 334 | nb_NO.UTF-8 UTF-8 | ||
| 335 | nb_NO ISO-8859-1 | ||
| 336 | nds_DE UTF-8 | ||
| 337 | nds_NL UTF-8 | ||
| 338 | ne_NP UTF-8 | ||
| 339 | nhn_MX UTF-8 | ||
| 340 | niu_NU UTF-8 | ||
| 341 | niu_NZ UTF-8 | ||
| 342 | nl_AW UTF-8 | ||
| 343 | nl_BE.UTF-8 UTF-8 | ||
| 344 | nl_BE ISO-8859-1 | ||
| 345 | nl_BE@euro ISO-8859-15 | ||
| 346 | nl_NL.UTF-8 UTF-8 | ||
| 347 | nl_NL ISO-8859-1 | ||
| 348 | nl_NL@euro ISO-8859-15 | ||
| 349 | nn_NO.UTF-8 UTF-8 | ||
| 350 | nn_NO ISO-8859-1 | ||
| 351 | nr_ZA UTF-8 | ||
| 352 | nso_ZA UTF-8 | ||
| 353 | oc_FR.UTF-8 UTF-8 | ||
| 354 | oc_FR ISO-8859-1 | ||
| 355 | om_ET UTF-8 | ||
| 356 | om_KE.UTF-8 UTF-8 | ||
| 357 | om_KE ISO-8859-1 | ||
| 358 | or_IN UTF-8 | ||
| 359 | os_RU UTF-8 | ||
| 360 | pa_IN UTF-8 | ||
| 361 | pa_PK UTF-8 | ||
| 362 | pap_AW UTF-8 | ||
| 363 | pap_CW UTF-8 | ||
| 364 | pl_PL.UTF-8 UTF-8 | ||
| 365 | pl_PL ISO-8859-2 | ||
| 366 | ps_AF UTF-8 | ||
| 367 | pt_BR.UTF-8 UTF-8 | ||
| 368 | pt_BR ISO-8859-1 | ||
| 369 | pt_PT.UTF-8 UTF-8 | ||
| 370 | pt_PT ISO-8859-1 | ||
| 371 | pt_PT@euro ISO-8859-15 | ||
| 372 | quz_PE UTF-8 | ||
| 373 | raj_IN UTF-8 | ||
| 374 | ro_RO.UTF-8 UTF-8 | ||
| 375 | ro_RO ISO-8859-2 | ||
| 376 | ru_RU.KOI8-R KOI8-R | ||
| 377 | ru_RU.UTF-8 UTF-8 | ||
| 378 | ru_RU ISO-8859-5 | ||
| 379 | ru_UA.UTF-8 UTF-8 | ||
| 380 | ru_UA KOI8-U | ||
| 381 | rw_RW UTF-8 | ||
| 382 | sa_IN UTF-8 | ||
| 383 | sat_IN UTF-8 | ||
| 384 | sc_IT UTF-8 | ||
| 385 | sd_IN UTF-8 | ||
| 386 | sd_IN@devanagari UTF-8 | ||
| 387 | se_NO UTF-8 | ||
| 388 | sgs_LT UTF-8 | ||
| 389 | shn_MM UTF-8 | ||
| 390 | shs_CA UTF-8 | ||
| 391 | si_LK UTF-8 | ||
| 392 | sid_ET UTF-8 | ||
| 393 | sk_SK.UTF-8 UTF-8 | ||
| 394 | sk_SK ISO-8859-2 | ||
| 395 | sl_SI.UTF-8 UTF-8 | ||
| 396 | sl_SI ISO-8859-2 | ||
| 397 | sm_WS UTF-8 | ||
| 398 | so_DJ.UTF-8 UTF-8 | ||
| 399 | so_DJ ISO-8859-1 | ||
| 400 | so_ET UTF-8 | ||
| 401 | so_KE.UTF-8 UTF-8 | ||
| 402 | so_KE ISO-8859-1 | ||
| 403 | so_SO.UTF-8 UTF-8 | ||
| 404 | so_SO ISO-8859-1 | ||
| 405 | sq_AL.UTF-8 UTF-8 | ||
| 406 | sq_AL ISO-8859-1 | ||
| 407 | sq_MK UTF-8 | ||
| 408 | sr_ME UTF-8 | ||
| 409 | sr_RS UTF-8 | ||
| 410 | sr_RS@latin UTF-8 | ||
| 411 | ss_ZA UTF-8 | ||
| 412 | st_ZA.UTF-8 UTF-8 | ||
| 413 | st_ZA ISO-8859-1 | ||
| 414 | sv_FI.UTF-8 UTF-8 | ||
| 415 | sv_FI ISO-8859-1 | ||
| 416 | sv_FI@euro ISO-8859-15 | ||
| 417 | sv_SE.UTF-8 UTF-8 | ||
| 418 | sv_SE ISO-8859-1 | ||
| 419 | sw_KE UTF-8 | ||
| 420 | sw_TZ UTF-8 | ||
| 421 | szl_PL UTF-8 | ||
| 422 | ta_IN UTF-8 | ||
| 423 | ta_LK UTF-8 | ||
| 424 | tcy_IN.UTF-8 UTF-8 | ||
| 425 | te_IN UTF-8 | ||
| 426 | tg_TJ.UTF-8 UTF-8 | ||
| 427 | tg_TJ KOI8-T | ||
| 428 | th_TH.UTF-8 UTF-8 | ||
| 429 | th_TH TIS-620 | ||
| 430 | the_NP UTF-8 | ||
| 431 | ti_ER UTF-8 | ||
| 432 | ti_ET UTF-8 | ||
| 433 | tig_ER UTF-8 | ||
| 434 | tk_TM UTF-8 | ||
| 435 | tl_PH.UTF-8 UTF-8 | ||
| 436 | tl_PH ISO-8859-1 | ||
| 437 | tn_ZA UTF-8 | ||
| 438 | to_TO UTF-8 | ||
| 439 | tpi_PG UTF-8 | ||
| 440 | tr_CY.UTF-8 UTF-8 | ||
| 441 | tr_CY ISO-8859-9 | ||
| 442 | tr_TR.UTF-8 UTF-8 | ||
| 443 | tr_TR ISO-8859-9 | ||
| 444 | ts_ZA UTF-8 | ||
| 445 | tt_RU UTF-8 | ||
| 446 | tt_RU@iqtelif UTF-8 | ||
| 447 | ug_CN UTF-8 | ||
| 448 | uk_UA.UTF-8 UTF-8 | ||
| 449 | uk_UA KOI8-U | ||
| 450 | unm_US UTF-8 | ||
| 451 | ur_IN UTF-8 | ||
| 452 | ur_PK UTF-8 | ||
| 453 | uz_UZ.UTF-8 UTF-8 | ||
| 454 | uz_UZ ISO-8859-1 | ||
| 455 | uz_UZ@cyrillic UTF-8 | ||
| 456 | ve_ZA UTF-8 | ||
| 457 | vi_VN UTF-8 | ||
| 458 | wa_BE ISO-8859-1 | ||
| 459 | wa_BE@euro ISO-8859-15 | ||
| 460 | wa_BE.UTF-8 UTF-8 | ||
| 461 | wae_CH UTF-8 | ||
| 462 | wal_ET UTF-8 | ||
| 463 | wo_SN UTF-8 | ||
| 464 | xh_ZA.UTF-8 UTF-8 | ||
| 465 | xh_ZA ISO-8859-1 | ||
| 466 | yi_US.UTF-8 UTF-8 | ||
| 467 | yi_US CP1255 | ||
| 468 | yo_NG UTF-8 | ||
| 469 | yue_HK UTF-8 | ||
| 470 | yuw_PG UTF-8 | ||
| 471 | zh_CN.GB18030 GB18030 | ||
| 472 | zh_CN.GBK GBK | ||
| 473 | zh_CN.UTF-8 UTF-8 | ||
| 474 | zh_CN GB2312 | ||
| 475 | zh_HK.UTF-8 UTF-8 | ||
| 476 | zh_HK BIG5-HKSCS | ||
| 477 | zh_SG.UTF-8 UTF-8 | ||
| 478 | zh_SG.GBK GBK | ||
| 479 | zh_SG GB2312 | ||
| 480 | zh_TW.EUC-TW EUC-TW | ||
| 481 | zh_TW.UTF-8 UTF-8 | ||
| 482 | zh_TW BIG5 | ||
| 483 | zu_ZA.UTF-8 UTF-8 | ||
| 484 | 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 00000000000..52418d88c11 --- /dev/null +++ b/gnu/installer/aux-files/logo.txt | |||
| @@ -0,0 +1,19 @@ | |||
| 1 | ░░░ ░░░ | ||
| 2 | ░░▒▒░░░░░░░░░ ░░░░░░░░░▒▒░░ | ||
| 3 | ░░▒▒▒▒▒░░░░░░░ ░░░░░░░▒▒▒▒▒░ | ||
| 4 | ░▒▒▒░░▒▒▒▒▒ ░░░░░░░▒▒░ | ||
| 5 | ░▒▒▒▒░ ░░░░░░ | ||
| 6 | ▒▒▒▒▒ ░░░░░░ | ||
| 7 | ▒▒▒▒▒ ░░░░░ | ||
| 8 | ░▒▒▒▒▒ ░░░░░ | ||
| 9 | ▒▒▒▒▒ ░░░░░ | ||
| 10 | ▒▒▒▒▒ ░░░░░ | ||
| 11 | ░▒▒▒▒▒░░░░░ | ||
| 12 | ▒▒▒▒▒▒░░░ | ||
| 13 | ▒▒▒▒▒▒░ | ||
| 14 | _____ _ _ _ _ _____ _ | ||
| 15 | / ____| \ | | | | | / ____| (_) | ||
| 16 | | | __| \| | | | | | | __ _ _ ___ __ | ||
| 17 | | | |_ | . ' | | | | | | |_ | | | | \ \/ / | ||
| 18 | | |__| | |\ | |__| | | |__| | |_| | |> < | ||
| 19 | \_____|_| \_|\____/ \_____|\__,_|_/_/\_\ | ||
diff --git a/gnu/installer/build-installer.scm b/gnu/installer/build-installer.scm new file mode 100644 index 00000000000..1a084bc3dc7 --- /dev/null +++ b/gnu/installer/build-installer.scm | |||
| @@ -0,0 +1,290 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer build-installer) | ||
| 20 | #:use-module (guix packages) | ||
| 21 | #:use-module (guix gexp) | ||
| 22 | #:use-module (guix modules) | ||
| 23 | #:use-module (guix utils) | ||
| 24 | #:use-module (guix ui) | ||
| 25 | #:use-module ((guix self) #:select (make-config.scm)) | ||
| 26 | #:use-module (gnu installer) | ||
| 27 | #:use-module (gnu packages admin) | ||
| 28 | #:use-module (gnu packages base) | ||
| 29 | #:use-module (gnu packages bash) | ||
| 30 | #:use-module (gnu packages connman) | ||
| 31 | #:use-module (gnu packages guile) | ||
| 32 | #:autoload (gnu packages gnupg) (guile-gcrypt) | ||
| 33 | #:use-module (gnu packages iso-codes) | ||
| 34 | #:use-module (gnu packages linux) | ||
| 35 | #:use-module (gnu packages ncurses) | ||
| 36 | #:use-module (gnu packages package-management) | ||
| 37 | #:use-module (gnu packages xorg) | ||
| 38 | #:use-module (ice-9 match) | ||
| 39 | #:use-module (srfi srfi-1) | ||
| 40 | #:export (installer-program)) | ||
| 41 | |||
| 42 | (define not-config? | ||
| 43 | ;; Select (guix …) and (gnu …) modules, except (guix config). | ||
| 44 | (match-lambda | ||
| 45 | (('guix 'config) #f) | ||
| 46 | (('guix rest ...) #t) | ||
| 47 | (('gnu rest ...) #t) | ||
| 48 | (rest #f))) | ||
| 49 | |||
| 50 | (define* (build-compiled-file name locale-builder) | ||
| 51 | "Return a file-like object that evalutes the gexp LOCALE-BUILDER and store | ||
| 52 | its result in the scheme file NAME. The derivation will also build a compiled | ||
| 53 | version of this file." | ||
| 54 | (define set-utf8-locale | ||
| 55 | #~(begin | ||
| 56 | (setenv "LOCPATH" | ||
| 57 | #$(file-append glibc-utf8-locales "/lib/locale/" | ||
| 58 | (version-major+minor | ||
| 59 | (package-version glibc-utf8-locales)))) | ||
| 60 | (setlocale LC_ALL "en_US.utf8"))) | ||
| 61 | |||
| 62 | (define builder | ||
| 63 | (with-extensions (list guile-json) | ||
| 64 | (with-imported-modules (source-module-closure | ||
| 65 | '((gnu installer locale))) | ||
| 66 | #~(begin | ||
| 67 | (use-modules (gnu installer locale)) | ||
| 68 | |||
| 69 | ;; The locale files contain non-ASCII characters. | ||
| 70 | #$set-utf8-locale | ||
| 71 | |||
| 72 | (mkdir #$output) | ||
| 73 | (let ((locale-file | ||
| 74 | (string-append #$output "/" #$name ".scm")) | ||
| 75 | (locale-compiled-file | ||
| 76 | (string-append #$output "/" #$name ".go"))) | ||
| 77 | (call-with-output-file locale-file | ||
| 78 | (lambda (port) | ||
| 79 | (write #$locale-builder port))) | ||
| 80 | (compile-file locale-file | ||
| 81 | #:output-file locale-compiled-file)))))) | ||
| 82 | (computed-file name builder)) | ||
| 83 | |||
| 84 | (define apply-locale | ||
| 85 | ;; Install the specified locale. | ||
| 86 | #~(lambda (locale-name) | ||
| 87 | (false-if-exception | ||
| 88 | (setlocale LC_ALL locale-name)))) | ||
| 89 | |||
| 90 | (define* (compute-locale-step installer | ||
| 91 | #:key | ||
| 92 | locales-name | ||
| 93 | iso639-languages-name | ||
| 94 | iso3166-territories-name) | ||
| 95 | "Return a gexp that run the locale-page of INSTALLER, and install the | ||
| 96 | selected locale. The list of locales, languages and territories passed to | ||
| 97 | locale-page are computed in derivations named respectively LOCALES-NAME, | ||
| 98 | ISO639-LANGUAGES-NAME and ISO3166-TERRITORIES-NAME. Those lists are compiled, | ||
| 99 | so that when the installer is run, all the lengthy operations have already | ||
| 100 | been performed at build time." | ||
| 101 | (define (compiled-file-loader file name) | ||
| 102 | #~(load-compiled | ||
| 103 | (string-append #$file "/" #$name ".go"))) | ||
| 104 | |||
| 105 | (let* ((supported-locales #~(supported-locales->locales | ||
| 106 | #$(local-file "aux-files/SUPPORTED"))) | ||
| 107 | (iso-codes #~(string-append #$iso-codes "/share/iso-codes/json/")) | ||
| 108 | (iso639-3 #~(string-append #$iso-codes "iso_639-3.json")) | ||
| 109 | (iso639-5 #~(string-append #$iso-codes "iso_639-5.json")) | ||
| 110 | (iso3166 #~(string-append #$iso-codes "iso_3166-1.json")) | ||
| 111 | (locales-file (build-compiled-file | ||
| 112 | locales-name | ||
| 113 | #~`(quote ,#$supported-locales))) | ||
| 114 | (iso639-file (build-compiled-file | ||
| 115 | iso639-languages-name | ||
| 116 | #~`(quote ,(iso639->iso639-languages | ||
| 117 | #$supported-locales | ||
| 118 | #$iso639-3 #$iso639-5)))) | ||
| 119 | (iso3166-file (build-compiled-file | ||
| 120 | iso3166-territories-name | ||
| 121 | #~`(quote ,(iso3166->iso3166-territories #$iso3166)))) | ||
| 122 | (locales-loader (compiled-file-loader locales-file | ||
| 123 | locales-name)) | ||
| 124 | (iso639-loader (compiled-file-loader iso639-file | ||
| 125 | iso639-languages-name)) | ||
| 126 | (iso3166-loader (compiled-file-loader iso3166-file | ||
| 127 | iso3166-territories-name))) | ||
| 128 | #~(let ((result | ||
| 129 | (#$(installer-locale-page installer) | ||
| 130 | #:supported-locales #$locales-loader | ||
| 131 | #:iso639-languages #$iso639-loader | ||
| 132 | #:iso3166-territories #$iso3166-loader))) | ||
| 133 | (#$apply-locale result)))) | ||
| 134 | |||
| 135 | (define apply-keymap | ||
| 136 | ;; Apply the specified keymap. | ||
| 137 | #~(match-lambda | ||
| 138 | ((model layout variant) | ||
| 139 | (kmscon-update-keymap model layout variant)))) | ||
| 140 | |||
| 141 | (define* (compute-keymap-step installer) | ||
| 142 | "Return a gexp that runs the keymap-page of INSTALLER and install the | ||
| 143 | selected keymap." | ||
| 144 | #~(let ((result | ||
| 145 | (call-with-values | ||
| 146 | (lambda () | ||
| 147 | (xkb-rules->models+layouts | ||
| 148 | (string-append #$xkeyboard-config | ||
| 149 | "/share/X11/xkb/rules/base.xml"))) | ||
| 150 | (lambda (models layouts) | ||
| 151 | (#$(installer-keymap-page installer) | ||
| 152 | #:models models | ||
| 153 | #:layouts layouts))))) | ||
| 154 | (#$apply-keymap result))) | ||
| 155 | |||
| 156 | (define (installer-steps installer) | ||
| 157 | (let ((locale-step (compute-locale-step | ||
| 158 | installer | ||
| 159 | #:locales-name "locales" | ||
| 160 | #:iso639-languages-name "iso639-languages" | ||
| 161 | #:iso3166-territories-name "iso3166-territories")) | ||
| 162 | (keymap-step (compute-keymap-step installer)) | ||
| 163 | (timezone-data #~(string-append #$tzdata | ||
| 164 | "/share/zoneinfo/zone.tab"))) | ||
| 165 | #~(list | ||
| 166 | ;; Welcome the user and ask him to choose between manual installation | ||
| 167 | ;; and graphical install. | ||
| 168 | (installer-step | ||
| 169 | (id 'welcome) | ||
| 170 | (compute (lambda _ | ||
| 171 | #$(installer-welcome-page installer)))) | ||
| 172 | |||
| 173 | ;; Ask the user to choose a locale among those supported by the glibc. | ||
| 174 | ;; Install the selected locale right away, so that the user may | ||
| 175 | ;; benefit from any available translation for the installer messages. | ||
| 176 | (installer-step | ||
| 177 | (id 'locale) | ||
| 178 | (description (G_ "Locale selection")) | ||
| 179 | (compute (lambda _ | ||
| 180 | #$locale-step))) | ||
| 181 | |||
| 182 | ;; Ask the user to select a timezone under glibc format. | ||
| 183 | (installer-step | ||
| 184 | (id 'timezone) | ||
| 185 | (description (G_ "Timezone selection")) | ||
| 186 | (compute (lambda _ | ||
| 187 | (#$(installer-timezone-page installer) | ||
| 188 | #$timezone-data)))) | ||
| 189 | |||
| 190 | ;; The installer runs in a kmscon virtual terminal where loadkeys | ||
| 191 | ;; won't work. kmscon uses libxkbcommon as a backend for keyboard | ||
| 192 | ;; input. It is possible to update kmscon current keymap by sending it | ||
| 193 | ;; a keyboard model, layout and variant, in a somehow similar way as | ||
| 194 | ;; what is done with setxkbmap utility. | ||
| 195 | ;; | ||
| 196 | ;; So ask for a keyboard model, layout and variant to update the | ||
| 197 | ;; current kmscon keymap. | ||
| 198 | (installer-step | ||
| 199 | (id 'keymap) | ||
| 200 | (description (G_ "Keyboard mapping selection")) | ||
| 201 | (compute (lambda _ | ||
| 202 | #$keymap-step))) | ||
| 203 | |||
| 204 | ;; Ask the user to input a hostname for the system. | ||
| 205 | (installer-step | ||
| 206 | (id 'hostname) | ||
| 207 | (description (G_ "Hostname selection")) | ||
| 208 | (compute (lambda _ | ||
| 209 | #$(installer-hostname-page installer)))) | ||
| 210 | |||
| 211 | ;; Provide an interface above connmanctl, so that the user can select | ||
| 212 | ;; a network susceptible to acces Internet. | ||
| 213 | (installer-step | ||
| 214 | (id 'network) | ||
| 215 | (description (G_ "Network selection")) | ||
| 216 | (compute (lambda _ | ||
| 217 | #$(installer-network-page installer)))) | ||
| 218 | |||
| 219 | ;; Prompt for users (name, group and home directory). | ||
| 220 | (installer-step | ||
| 221 | (id 'hostname) | ||
| 222 | (description (G_ "User selection")) | ||
| 223 | (compute (lambda _ | ||
| 224 | #$(installer-user-page installer))))))) | ||
| 225 | |||
| 226 | (define (installer-program installer) | ||
| 227 | "Return a file-like object that runs the given INSTALLER." | ||
| 228 | (define init-gettext | ||
| 229 | ;; Initialize gettext support, so that installer messages can be | ||
| 230 | ;; translated. | ||
| 231 | #~(begin | ||
| 232 | (bindtextdomain "guix" (string-append #$guix "/share/locale")) | ||
| 233 | (textdomain "guix"))) | ||
| 234 | |||
| 235 | (define set-installer-path | ||
| 236 | ;; Add the specified binary to PATH for later use by the installer. | ||
| 237 | #~(let* ((inputs | ||
| 238 | '#$(append (list bash connman shadow) | ||
| 239 | (map canonical-package (list coreutils))))) | ||
| 240 | (with-output-to-port (%make-void-port "w") | ||
| 241 | (lambda () | ||
| 242 | (set-path-environment-variable "PATH" '("bin" "sbin") inputs))))) | ||
| 243 | |||
| 244 | (define installer-builder | ||
| 245 | (with-extensions (list guile-gcrypt guile-newt guile-json) | ||
| 246 | (with-imported-modules `(,@(source-module-closure | ||
| 247 | `(,@(installer-modules installer) | ||
| 248 | (guix build utils)) | ||
| 249 | #:select? not-config?) | ||
| 250 | ((guix config) => ,(make-config.scm))) | ||
| 251 | #~(begin | ||
| 252 | (use-modules (gnu installer keymap) | ||
| 253 | (gnu installer steps) | ||
| 254 | (gnu installer locale) | ||
| 255 | #$@(installer-modules installer) | ||
| 256 | (guix i18n) | ||
| 257 | (guix build utils) | ||
| 258 | (ice-9 match)) | ||
| 259 | |||
| 260 | ;; Initialize gettext support so that installers can use | ||
| 261 | ;; (guix i18n) module. | ||
| 262 | #$init-gettext | ||
| 263 | |||
| 264 | ;; Add some binaries used by the installers to PATH. | ||
| 265 | #$set-installer-path | ||
| 266 | |||
| 267 | #$(installer-init installer) | ||
| 268 | |||
| 269 | (catch #t | ||
| 270 | (lambda () | ||
| 271 | (run-installer-steps | ||
| 272 | #:rewind-strategy 'menu | ||
| 273 | #:menu-proc #$(installer-menu-page installer) | ||
| 274 | #:steps #$(installer-steps installer))) | ||
| 275 | (const #f) | ||
| 276 | (lambda (key . args) | ||
| 277 | (#$(installer-exit-error installer) key args) | ||
| 278 | |||
| 279 | ;; Be sure to call newt-finish, to restore the terminal into | ||
| 280 | ;; its original state before printing the error report. | ||
| 281 | (call-with-output-file "/tmp/error" | ||
| 282 | (lambda (port) | ||
| 283 | (display-backtrace (make-stack #t) port) | ||
| 284 | (print-exception port | ||
| 285 | (stack-ref (make-stack #t) 1) | ||
| 286 | key args))) | ||
| 287 | (primitive-exit 1))) | ||
| 288 | #$(installer-exit installer))))) | ||
| 289 | |||
| 290 | (program-file "installer" installer-builder)) | ||
diff --git a/gnu/installer/connman.scm b/gnu/installer/connman.scm new file mode 100644 index 00000000000..740df7424a1 --- /dev/null +++ b/gnu/installer/connman.scm | |||
| @@ -0,0 +1,400 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer connman) | ||
| 20 | #:use-module (gnu installer utils) | ||
| 21 | #:use-module (guix records) | ||
| 22 | #:use-module (ice-9 match) | ||
| 23 | #:use-module (ice-9 popen) | ||
| 24 | #:use-module (ice-9 regex) | ||
| 25 | #:use-module (srfi srfi-11) | ||
| 26 | #:use-module (srfi srfi-34) | ||
| 27 | #:use-module (srfi srfi-35) | ||
| 28 | #:export (<technology> | ||
| 29 | technology | ||
| 30 | technology? | ||
| 31 | technology-name | ||
| 32 | technology-type | ||
| 33 | technology-powered? | ||
| 34 | technology-connected? | ||
| 35 | |||
| 36 | <service> | ||
| 37 | service | ||
| 38 | service? | ||
| 39 | service-name | ||
| 40 | service-type | ||
| 41 | service-path | ||
| 42 | service-strength | ||
| 43 | service-state | ||
| 44 | |||
| 45 | &connman-error | ||
| 46 | connman-error? | ||
| 47 | connman-error-command | ||
| 48 | connman-error-output | ||
| 49 | connman-error-status | ||
| 50 | |||
| 51 | &connman-connection-error | ||
| 52 | connman-connection-error? | ||
| 53 | connman-connection-error-service | ||
| 54 | connman-connection-error-output | ||
| 55 | |||
| 56 | &connman-password-error | ||
| 57 | connman-password-error? | ||
| 58 | |||
| 59 | &connman-already-connected-error | ||
| 60 | connman-already-connected-error? | ||
| 61 | |||
| 62 | connman-state | ||
| 63 | connman-technologies | ||
| 64 | connman-enable-technology | ||
| 65 | connman-disable-technology | ||
| 66 | connman-scan-technology | ||
| 67 | connman-services | ||
| 68 | connman-connect | ||
| 69 | connman-disconnect | ||
| 70 | connman-online? | ||
| 71 | connman-connect-with-auth)) | ||
| 72 | |||
| 73 | ;;; Commentary: | ||
| 74 | ;;; | ||
| 75 | ;;; This module provides procedures for talking with the connman daemon. | ||
| 76 | ;;; The best approach would have been using connman dbus interface. | ||
| 77 | ;;; However, as Guile dbus bindings are not available yet, the console client | ||
| 78 | ;;; "connmanctl" is used to talk with the daemon. | ||
| 79 | ;;; | ||
| 80 | |||
| 81 | |||
| 82 | ;;; | ||
| 83 | ;;; Technology record. | ||
| 84 | ;;; | ||
| 85 | |||
| 86 | ;; The <technology> record encapsulates the "Technology" object of connman. | ||
| 87 | ;; Technology type will be typically "ethernet", "wifi" or "bluetooth". | ||
| 88 | |||
| 89 | (define-record-type* <technology> | ||
| 90 | technology make-technology | ||
| 91 | technology? | ||
| 92 | (name technology-name) ; string | ||
| 93 | (type technology-type) ; string | ||
| 94 | (powered? technology-powered?) ; boolean | ||
| 95 | (connected? technology-connected?)) ; boolean | ||
| 96 | |||
| 97 | |||
| 98 | ;;; | ||
| 99 | ;;; Service record. | ||
| 100 | ;;; | ||
| 101 | |||
| 102 | ;; The <service> record encapsulates the "Service" object of connman. | ||
| 103 | ;; Service type is the same as the technology it is associated to, path is a | ||
| 104 | ;; unique identifier given by connman, strength describes the signal quality | ||
| 105 | ;; if applicable. Finally, state is "idle", "failure", "association", | ||
| 106 | ;; "configuration", "ready", "disconnect" or "online". | ||
| 107 | |||
| 108 | (define-record-type* <service> | ||
| 109 | service make-service | ||
| 110 | service? | ||
| 111 | (name service-name) ; string | ||
| 112 | (type service-type) ; string | ||
| 113 | (path service-path) ; string | ||
| 114 | (strength service-strength) ; integer | ||
| 115 | (state service-state)) ; string | ||
| 116 | |||
| 117 | |||
| 118 | ;;; | ||
| 119 | ;;; Condition types. | ||
| 120 | ;;; | ||
| 121 | |||
| 122 | (define-condition-type &connman-error &error | ||
| 123 | connman-error? | ||
| 124 | (command connman-error-command) | ||
| 125 | (output connman-error-output) | ||
| 126 | (status connman-error-status)) | ||
| 127 | |||
| 128 | (define-condition-type &connman-connection-error &error | ||
| 129 | connman-connection-error? | ||
| 130 | (service connman-connection-error-service) | ||
| 131 | (output connman-connection-error-output)) | ||
| 132 | |||
| 133 | (define-condition-type &connman-password-error &connman-connection-error | ||
| 134 | connman-password-error?) | ||
| 135 | |||
| 136 | (define-condition-type &connman-already-connected-error | ||
| 137 | &connman-connection-error connman-already-connected-error?) | ||
| 138 | |||
| 139 | |||
| 140 | ;;; | ||
| 141 | ;;; Procedures. | ||
| 142 | ;;; | ||
| 143 | |||
| 144 | (define (connman-run command env arguments) | ||
| 145 | "Run the given COMMAND, with the specified ENV and ARGUMENTS. The error | ||
| 146 | output is discarded and &connman-error condition is raised if the command | ||
| 147 | returns a non zero exit code." | ||
| 148 | (let* ((command `("env" ,env ,command ,@arguments "2>" "/dev/null")) | ||
| 149 | (command-string (string-join command " ")) | ||
| 150 | (pipe (open-input-pipe command-string)) | ||
| 151 | (output (read-lines pipe)) | ||
| 152 | (ret (close-pipe pipe))) | ||
| 153 | (case (status:exit-val ret) | ||
| 154 | ((0) output) | ||
| 155 | (else (raise (condition (&connman-error | ||
| 156 | (command command) | ||
| 157 | (output output) | ||
| 158 | (status ret)))))))) | ||
| 159 | |||
| 160 | (define (connman . arguments) | ||
| 161 | "Run connmanctl with the specified ARGUMENTS. Set the LANG environment | ||
| 162 | variable to C because the command output will be parsed and we don't want it | ||
| 163 | to be translated." | ||
| 164 | (connman-run "connmanctl" "LANG=C" arguments)) | ||
| 165 | |||
| 166 | (define (parse-keys keys) | ||
| 167 | "Parse the given list of strings KEYS, under the following format: | ||
| 168 | |||
| 169 | '((\"KEY = VALUE\") (\"KEY2 = VALUE2\") ...) | ||
| 170 | |||
| 171 | Return the corresponding association list of '((KEY . VALUE) (KEY2 . VALUE2) | ||
| 172 | ...) elements." | ||
| 173 | (let ((key-regex (make-regexp "([^ ]+) = ([^$]+)"))) | ||
| 174 | (map (lambda (key) | ||
| 175 | (let ((match-key (regexp-exec key-regex key))) | ||
| 176 | (cons (match:substring match-key 1) | ||
| 177 | (match:substring match-key 2)))) | ||
| 178 | keys))) | ||
| 179 | |||
| 180 | (define (connman-state) | ||
| 181 | "Return the state of connman. The nominal states are 'offline, 'idle, | ||
| 182 | 'ready, 'oneline. If an unexpected state is read, 'unknown is | ||
| 183 | returned. Finally, an error is raised if the comman output could not be | ||
| 184 | parsed, usually because the connman daemon is not responding." | ||
| 185 | (let* ((output (connman "state")) | ||
| 186 | (state-keys (parse-keys output))) | ||
| 187 | (let ((state (assoc-ref state-keys "State"))) | ||
| 188 | (if state | ||
| 189 | (cond ((string=? state "offline") 'offline) | ||
| 190 | ((string=? state "idle") 'idle) | ||
| 191 | ((string=? state "ready") 'ready) | ||
| 192 | ((string=? state "online") 'online) | ||
| 193 | (else 'unknown)) | ||
| 194 | (raise (condition | ||
| 195 | (&message | ||
| 196 | (message "Could not determine the state of connman.")))))))) | ||
| 197 | |||
| 198 | (define (split-technology-list technologies) | ||
| 199 | "Parse the given strings list TECHNOLOGIES, under the following format: | ||
| 200 | |||
| 201 | '((\"/net/connman/technology/xxx\") | ||
| 202 | (\"KEY = VALUE\") | ||
| 203 | ... | ||
| 204 | (\"/net/connman/technology/yyy\") | ||
| 205 | (\"KEY2 = VALUE2\") | ||
| 206 | ...) | ||
| 207 | Return the corresponding '(((\"KEY = VALUE\") ...) ((\"KEY2 = VALUE2\") ...)) | ||
| 208 | list so that each keys of a given technology are gathered in a separate list." | ||
| 209 | (let loop ((result '()) | ||
| 210 | (cur-list '()) | ||
| 211 | (input (reverse technologies))) | ||
| 212 | (if (null? input) | ||
| 213 | result | ||
| 214 | (let ((item (car input))) | ||
| 215 | (if (string-match "/net/connman/technology" item) | ||
| 216 | (loop (cons cur-list result) '() (cdr input)) | ||
| 217 | (loop result (cons item cur-list) (cdr input))))))) | ||
| 218 | |||
| 219 | (define (string->boolean string) | ||
| 220 | (equal? string "True")) | ||
| 221 | |||
| 222 | (define (connman-technologies) | ||
| 223 | "Return a list of available <technology> records." | ||
| 224 | |||
| 225 | (define (technology-output->technology output) | ||
| 226 | (let ((keys (parse-keys output))) | ||
| 227 | (technology | ||
| 228 | (name (assoc-ref keys "Name")) | ||
| 229 | (type (assoc-ref keys "Type")) | ||
| 230 | (powered? (string->boolean (assoc-ref keys "Powered"))) | ||
| 231 | (connected? (string->boolean (assoc-ref keys "Connected")))))) | ||
| 232 | |||
| 233 | (let* ((output (connman "technologies")) | ||
| 234 | (technologies (split-technology-list output))) | ||
| 235 | (map technology-output->technology technologies))) | ||
| 236 | |||
| 237 | (define (connman-enable-technology technology) | ||
| 238 | "Enable the given TECHNOLOGY." | ||
| 239 | (let ((type (technology-type technology))) | ||
| 240 | (connman "enable" type))) | ||
| 241 | |||
| 242 | (define (connman-disable-technology technology) | ||
| 243 | "Disable the given TECHNOLOGY." | ||
| 244 | (let ((type (technology-type technology))) | ||
| 245 | (connman "disable" type))) | ||
| 246 | |||
| 247 | (define (connman-scan-technology technology) | ||
| 248 | "Run a scan for the given TECHNOLOGY." | ||
| 249 | (let ((type (technology-type technology))) | ||
| 250 | (connman "scan" type))) | ||
| 251 | |||
| 252 | (define (connman-services) | ||
| 253 | "Return a list of available <services> records." | ||
| 254 | |||
| 255 | (define (service-output->service path output) | ||
| 256 | (let* ((service-keys | ||
| 257 | (match output | ||
| 258 | ((_ . rest) rest))) | ||
| 259 | (keys (parse-keys service-keys))) | ||
| 260 | (service | ||
| 261 | (name (assoc-ref keys "Name")) | ||
| 262 | (type (assoc-ref keys "Type")) | ||
| 263 | (path path) | ||
| 264 | (strength (and=> (assoc-ref keys "Strength") string->number)) | ||
| 265 | (state (assoc-ref keys "State"))))) | ||
| 266 | |||
| 267 | (let* ((out (connman "services")) | ||
| 268 | (out-filtered (delete "" out)) | ||
| 269 | (services-path (map (lambda (service) | ||
| 270 | (match (string-split service #\ ) | ||
| 271 | ((_ ... path) path))) | ||
| 272 | out-filtered)) | ||
| 273 | (services-output (map (lambda (service) | ||
| 274 | (connman "services" service)) | ||
| 275 | services-path))) | ||
| 276 | (map service-output->service services-path services-output))) | ||
| 277 | |||
| 278 | (define (connman-connect service) | ||
| 279 | "Connect to the given SERVICE." | ||
| 280 | (let ((path (service-path service))) | ||
| 281 | (connman "connect" path))) | ||
| 282 | |||
| 283 | (define (connman-disconnect service) | ||
| 284 | "Disconnect from the given SERVICE." | ||
| 285 | (let ((path (service-path service))) | ||
| 286 | (connman "disconnect" path))) | ||
| 287 | |||
| 288 | (define (connman-online?) | ||
| 289 | (let ((state (connman-state))) | ||
| 290 | (eq? state 'online))) | ||
| 291 | |||
| 292 | (define (connman-connect-with-auth service password-proc) | ||
| 293 | "Connect to the given SERVICE with the password returned by calling | ||
| 294 | PASSWORD-PROC. This is only possible in the interactive mode of connmanctl | ||
| 295 | because authentication is done by communicating with an agent. | ||
| 296 | |||
| 297 | As the open-pipe procedure of Guile do not allow to read from stderr, we have | ||
| 298 | to merge stdout and stderr using bash redirection. Then error messages are | ||
| 299 | extracted from connmanctl output using a regexp. This makes the whole | ||
| 300 | procedure even more unreliable. | ||
| 301 | |||
| 302 | Raise &connman-connection-error if an error occured during connection. Raise | ||
| 303 | &connman-password-error if the given password is incorrect." | ||
| 304 | |||
| 305 | (define connman-error-regexp (make-regexp "Error[ ]*([^\n]+)\n")) | ||
| 306 | |||
| 307 | (define (match-connman-error str) | ||
| 308 | (let ((match-error (regexp-exec connman-error-regexp str))) | ||
| 309 | (and match-error (match:substring match-error 1)))) | ||
| 310 | |||
| 311 | (define* (read-regexps-or-error port regexps error-handler) | ||
| 312 | "Read characters from port until an error is detected, or one of the given | ||
| 313 | REGEXPS is matched. If an error is detected, call ERROR-HANDLER with the error | ||
| 314 | string as argument. Raise an error if the eof is reached before one of the | ||
| 315 | regexps is matched." | ||
| 316 | (let loop ((res "")) | ||
| 317 | (let ((char (read-char port))) | ||
| 318 | (cond | ||
| 319 | ((eof-object? char) | ||
| 320 | (raise (condition | ||
| 321 | (&message | ||
| 322 | (message "Unable to find expected regexp."))))) | ||
| 323 | ((match-connman-error res) | ||
| 324 | => | ||
| 325 | (lambda (match) | ||
| 326 | (error-handler match))) | ||
| 327 | ((or-map (lambda (regexp) | ||
| 328 | (and (regexp-exec regexp res) regexp)) | ||
| 329 | regexps) | ||
| 330 | => | ||
| 331 | (lambda (match) | ||
| 332 | match)) | ||
| 333 | (else | ||
| 334 | (loop (string-append res (string char)))))))) | ||
| 335 | |||
| 336 | (define* (read-regexp-or-error port regexp error-handler) | ||
| 337 | "Same as READ-REGEXPS-OR-ERROR above, but with a single REGEXP." | ||
| 338 | (read-regexps-or-error port (list regexp) error-handler)) | ||
| 339 | |||
| 340 | (define (connman-error->condition path error) | ||
| 341 | (cond | ||
| 342 | ((string-match "Already connected" error) | ||
| 343 | (condition (&connman-already-connected-error | ||
| 344 | (service path) | ||
| 345 | (output error)))) | ||
| 346 | (else | ||
| 347 | (condition (&connman-connection-error | ||
| 348 | (service path) | ||
| 349 | (output error)))))) | ||
| 350 | |||
| 351 | (define (run-connection-sequence pipe) | ||
| 352 | "Run the connection sequence using PIPE as an opened port to an | ||
| 353 | interactive connmanctl process." | ||
| 354 | (let* ((path (service-path service)) | ||
| 355 | (error-handler (lambda (error) | ||
| 356 | (raise | ||
| 357 | (connman-error->condition path error))))) | ||
| 358 | ;; Start the agent. | ||
| 359 | (format pipe "agent on\n") | ||
| 360 | (read-regexp-or-error pipe (make-regexp "Agent registered") error-handler) | ||
| 361 | |||
| 362 | ;; Let's try to connect to the service. If the service does not require | ||
| 363 | ;; a password, the connection might succeed right after this call. | ||
| 364 | ;; Otherwise, connmanctl will prompt us for a password. | ||
| 365 | (format pipe "connect ~a\n" path) | ||
| 366 | (let* ((connected-regexp (make-regexp (format #f "Connected ~a" path))) | ||
| 367 | (passphrase-regexp (make-regexp "\nPassphrase\\?[ ]*")) | ||
| 368 | (regexps (list connected-regexp passphrase-regexp)) | ||
| 369 | (result (read-regexps-or-error pipe regexps error-handler))) | ||
| 370 | |||
| 371 | ;; A password is required. | ||
| 372 | (when (eq? result passphrase-regexp) | ||
| 373 | (format pipe "~a~%" (password-proc)) | ||
| 374 | |||
| 375 | ;; Now, we have to wait for the connection to succeed. If an error | ||
| 376 | ;; occurs, it is most likely because the password is incorrect. | ||
| 377 | ;; In that case, we escape from an eventual retry loop that would | ||
| 378 | ;; add complexity to this procedure, and raise a | ||
| 379 | ;; &connman-password-error condition. | ||
| 380 | (read-regexp-or-error pipe connected-regexp | ||
| 381 | (lambda (error) | ||
| 382 | ;; Escape from retry loop. | ||
| 383 | (format pipe "no\n") | ||
| 384 | (raise | ||
| 385 | (condition (&connman-password-error | ||
| 386 | (service path) | ||
| 387 | (output error)))))))))) | ||
| 388 | |||
| 389 | ;; XXX: Find a better way to read stderr, like with the "subprocess" | ||
| 390 | ;; procedure of racket that return input ports piped on the process stdin and | ||
| 391 | ;; stderr. | ||
| 392 | (let ((pipe (open-pipe "connmanctl 2>&1" OPEN_BOTH))) | ||
| 393 | (dynamic-wind | ||
| 394 | (const #t) | ||
| 395 | (lambda () | ||
| 396 | (run-connection-sequence pipe) | ||
| 397 | #t) | ||
| 398 | (lambda () | ||
| 399 | (format pipe "quit\n") | ||
| 400 | (close-pipe pipe))))) | ||
diff --git a/gnu/installer/keymap.scm b/gnu/installer/keymap.scm new file mode 100644 index 00000000000..78065aa6c62 --- /dev/null +++ b/gnu/installer/keymap.scm | |||
| @@ -0,0 +1,162 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer keymap) | ||
| 20 | #:use-module (guix records) | ||
| 21 | #:use-module (sxml match) | ||
| 22 | #:use-module (sxml simple) | ||
| 23 | #:use-module (ice-9 binary-ports) | ||
| 24 | #:use-module (ice-9 ftw) | ||
| 25 | #:use-module (ice-9 match) | ||
| 26 | #:use-module (ice-9 regex) | ||
| 27 | #:export (<x11-keymap-model> | ||
| 28 | x11-keymap-model | ||
| 29 | make-x11-keymap-model | ||
| 30 | x11-keymap-model? | ||
| 31 | x11-keymap-model-name | ||
| 32 | x11-keymap-model-description | ||
| 33 | |||
| 34 | <x11-keymap-layout> | ||
| 35 | x11-keymap-layout | ||
| 36 | make-x11-keymap-layout | ||
| 37 | x11-keymap-layout? | ||
| 38 | x11-keymap-layout-name | ||
| 39 | x11-keymap-layout-description | ||
| 40 | x11-keymap-layout-variants | ||
| 41 | |||
| 42 | <x11-keymap-variant> | ||
| 43 | x11-keymap-variant | ||
| 44 | make-x11-keymap-variant | ||
| 45 | x11-keymap-variant? | ||
| 46 | x11-keymap-variant-name | ||
| 47 | x11-keymap-variant-description | ||
| 48 | |||
| 49 | xkb-rules->models+layouts | ||
| 50 | kmscon-update-keymap)) | ||
| 51 | |||
| 52 | (define-record-type* <x11-keymap-model> | ||
| 53 | x11-keymap-model make-x11-keymap-model | ||
| 54 | x11-keymap-model? | ||
| 55 | (name x11-keymap-model-name) ;string | ||
| 56 | (description x11-keymap-model-description)) ;string | ||
| 57 | |||
| 58 | (define-record-type* <x11-keymap-layout> | ||
| 59 | x11-keymap-layout make-x11-keymap-layout | ||
| 60 | x11-keymap-layout? | ||
| 61 | (name x11-keymap-layout-name) ;string | ||
| 62 | (description x11-keymap-layout-description) ;string | ||
| 63 | (variants x11-keymap-layout-variants)) ;list of <x11-keymap-variant> | ||
| 64 | |||
| 65 | (define-record-type* <x11-keymap-variant> | ||
| 66 | x11-keymap-variant make-x11-keymap-variant | ||
| 67 | x11-keymap-variant? | ||
| 68 | (name x11-keymap-variant-name) ;string | ||
| 69 | (description x11-keymap-variant-description)) ;string | ||
| 70 | |||
| 71 | (define (xkb-rules->models+layouts file) | ||
| 72 | "Parse FILE and return two values, the list of supported X11-KEYMAP-MODEL | ||
| 73 | and X11-KEYMAP-LAYOUT records. FILE is an XML file from the X Keyboard | ||
| 74 | Configuration Database, describing possible XKB configurations." | ||
| 75 | (define (model m) | ||
| 76 | (sxml-match m | ||
| 77 | [(model | ||
| 78 | (configItem | ||
| 79 | (name ,name) | ||
| 80 | (description ,description) | ||
| 81 | . ,rest)) | ||
| 82 | (x11-keymap-model | ||
| 83 | (name name) | ||
| 84 | (description description))])) | ||
| 85 | |||
| 86 | (define (variant v) | ||
| 87 | (sxml-match v | ||
| 88 | [(variant | ||
| 89 | ;; According to xbd-rules DTD, the definition of a | ||
| 90 | ;; configItem is: <!ELEMENT configItem | ||
| 91 | ;; (name,shortDescription*,description*,vendor?, | ||
| 92 | ;; countryList?,languageList?,hwList?)> | ||
| 93 | ;; | ||
| 94 | ;; shortDescription and description are optional elements | ||
| 95 | ;; but sxml-match does not support default values for | ||
| 96 | ;; elements (only attributes). So to avoid writing as many | ||
| 97 | ;; patterns as existing possibilities, gather all the | ||
| 98 | ;; remaining elements but name in REST-VARIANT. | ||
| 99 | (configItem | ||
| 100 | (name ,name) | ||
| 101 | . ,rest-variant)) | ||
| 102 | (x11-keymap-variant | ||
| 103 | (name name) | ||
| 104 | (description (car | ||
| 105 | (assoc-ref rest-variant 'description))))])) | ||
| 106 | |||
| 107 | (define (layout l) | ||
| 108 | (sxml-match l | ||
| 109 | [(layout | ||
| 110 | (configItem | ||
| 111 | (name ,name) | ||
| 112 | . ,rest-layout) | ||
| 113 | (variantList ,[variant -> v] ...)) | ||
| 114 | (x11-keymap-layout | ||
| 115 | (name name) | ||
| 116 | (description (car | ||
| 117 | (assoc-ref rest-layout 'description))) | ||
| 118 | (variants (list v ...)))] | ||
| 119 | [(layout | ||
| 120 | (configItem | ||
| 121 | (name ,name) | ||
| 122 | . ,rest-layout)) | ||
| 123 | (x11-keymap-layout | ||
| 124 | (name name) | ||
| 125 | (description (car | ||
| 126 | (assoc-ref rest-layout 'description))) | ||
| 127 | (variants '()))])) | ||
| 128 | |||
| 129 | (let ((sxml (call-with-input-file file | ||
| 130 | (lambda (port) | ||
| 131 | (xml->sxml port #:trim-whitespace? #t))))) | ||
| 132 | (match | ||
| 133 | (sxml-match sxml | ||
| 134 | [(*TOP* | ||
| 135 | ,pi | ||
| 136 | (xkbConfigRegistry | ||
| 137 | (@ . ,ignored) | ||
| 138 | (modelList ,[model -> m] ...) | ||
| 139 | (layoutList ,[layout -> l] ...) | ||
| 140 | . ,rest)) | ||
| 141 | (list | ||
| 142 | (list m ...) | ||
| 143 | (list l ...))]) | ||
| 144 | ((models layouts) | ||
| 145 | (values models layouts))))) | ||
| 146 | |||
| 147 | (define (kmscon-update-keymap model layout variant) | ||
| 148 | (let ((keymap-file (getenv "KEYMAP_UPDATE"))) | ||
| 149 | (unless (and keymap-file | ||
| 150 | (file-exists? keymap-file)) | ||
| 151 | (error "Unable to locate keymap update file")) | ||
| 152 | |||
| 153 | (call-with-output-file keymap-file | ||
| 154 | (lambda (port) | ||
| 155 | (format port model) | ||
| 156 | (put-u8 port 0) | ||
| 157 | |||
| 158 | (format port layout) | ||
| 159 | (put-u8 port 0) | ||
| 160 | |||
| 161 | (format port variant) | ||
| 162 | (put-u8 port 0))))) | ||
diff --git a/gnu/installer/locale.scm b/gnu/installer/locale.scm new file mode 100644 index 00000000000..504070d41d1 --- /dev/null +++ b/gnu/installer/locale.scm | |||
| @@ -0,0 +1,199 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer locale) | ||
| 20 | #:use-module (gnu installer utils) | ||
| 21 | #:use-module (guix records) | ||
| 22 | #:use-module (json) | ||
| 23 | #:use-module (srfi srfi-1) | ||
| 24 | #:use-module (ice-9 match) | ||
| 25 | #:use-module (ice-9 regex) | ||
| 26 | #:export (locale-language | ||
| 27 | locale-territory | ||
| 28 | locale-codeset | ||
| 29 | locale-modifier | ||
| 30 | |||
| 31 | locale->locale-string | ||
| 32 | supported-locales->locales | ||
| 33 | |||
| 34 | iso639->iso639-languages | ||
| 35 | language-code->language-name | ||
| 36 | |||
| 37 | iso3166->iso3166-territories | ||
| 38 | territory-code->territory-name)) | ||
| 39 | |||
| 40 | |||
| 41 | ;;; | ||
| 42 | ;;; Locale. | ||
| 43 | ;;; | ||
| 44 | |||
| 45 | ;; A glibc locale string has the following format: | ||
| 46 | ;; language[_territory[.codeset][@modifier]]. | ||
| 47 | (define locale-regexp "^([^_@]+)(_([^\\.@]+))?(\\.([^@]+))?(@([^$]+))?$") | ||
| 48 | |||
| 49 | ;; LOCALE will be better expressed in a (guix record) that in an association | ||
| 50 | ;; list. However, loading large files containing records does not scale | ||
| 51 | ;; well. The same thing goes for ISO639 and ISO3166 association lists used | ||
| 52 | ;; later in this module. | ||
| 53 | (define (locale-language assoc) | ||
| 54 | (assoc-ref assoc 'language)) | ||
| 55 | (define (locale-territory assoc) | ||
| 56 | (assoc-ref assoc 'territory)) | ||
| 57 | (define (locale-codeset assoc) | ||
| 58 | (assoc-ref assoc 'codeset)) | ||
| 59 | (define (locale-modifier assoc) | ||
| 60 | (assoc-ref assoc 'modifier)) | ||
| 61 | |||
| 62 | (define (locale-string->locale string) | ||
| 63 | "Return the locale association list built from the parsing of STRING." | ||
| 64 | (let ((matches (string-match locale-regexp string))) | ||
| 65 | `((language . ,(match:substring matches 1)) | ||
| 66 | (territory . ,(match:substring matches 3)) | ||
| 67 | (codeset . ,(match:substring matches 5)) | ||
| 68 | (modifier . ,(match:substring matches 7))))) | ||
| 69 | |||
| 70 | (define (locale->locale-string locale) | ||
| 71 | "Reverse operation of locale-string->locale." | ||
| 72 | (let ((language (locale-language locale)) | ||
| 73 | (territory (locale-territory locale)) | ||
| 74 | (codeset (locale-codeset locale)) | ||
| 75 | (modifier (locale-modifier locale))) | ||
| 76 | (apply string-append | ||
| 77 | `(,language | ||
| 78 | ,@(if territory | ||
| 79 | `("_" ,territory) | ||
| 80 | '()) | ||
| 81 | ,@(if codeset | ||
| 82 | `("." ,codeset) | ||
| 83 | '()) | ||
| 84 | ,@(if modifier | ||
| 85 | `("@" ,modifier) | ||
| 86 | '()))))) | ||
| 87 | |||
| 88 | (define (supported-locales->locales supported-locales) | ||
| 89 | "Parse the SUPPORTED-LOCALES file from the glibc and return the matching | ||
| 90 | list of LOCALE association lists." | ||
| 91 | (call-with-input-file supported-locales | ||
| 92 | (lambda (port) | ||
| 93 | (let ((lines (read-lines port))) | ||
| 94 | (map (lambda (line) | ||
| 95 | (match (string-split line #\ ) | ||
| 96 | ((locale-string codeset) | ||
| 97 | (let ((line-locale (locale-string->locale locale-string))) | ||
| 98 | (assoc-set! line-locale 'codeset codeset))))) | ||
| 99 | lines))))) | ||
| 100 | |||
| 101 | |||
| 102 | ;;; | ||
| 103 | ;;; Language. | ||
| 104 | ;;; | ||
| 105 | |||
| 106 | (define (iso639-language-alpha2 assoc) | ||
| 107 | (assoc-ref assoc 'alpha2)) | ||
| 108 | |||
| 109 | (define (iso639-language-alpha3 assoc) | ||
| 110 | (assoc-ref assoc 'alpha3)) | ||
| 111 | |||
| 112 | (define (iso639-language-name assoc) | ||
| 113 | (assoc-ref assoc 'name)) | ||
| 114 | |||
| 115 | (define (supported-locale? locales alpha2 alpha3) | ||
| 116 | "Find a locale in LOCALES whose alpha2 field matches ALPHA-2 or alpha3 field | ||
| 117 | matches ALPHA-3. The ISO639 standard specifies that ALPHA-2 is optional. Thus, | ||
| 118 | if ALPHA-2 is #f, only consider ALPHA-3. Return #f if not matching locale was | ||
| 119 | found." | ||
| 120 | (find (lambda (locale) | ||
| 121 | (let ((language (locale-language locale))) | ||
| 122 | (or (and=> alpha2 | ||
| 123 | (lambda (code) | ||
| 124 | (string=? language code))) | ||
| 125 | (string=? language alpha3)))) | ||
| 126 | locales)) | ||
| 127 | |||
| 128 | (define (iso639->iso639-languages locales iso639-3 iso639-5) | ||
| 129 | "Return a list of ISO639 association lists created from the parsing of | ||
| 130 | ISO639-3 and ISO639-5 files." | ||
| 131 | (call-with-input-file iso639-3 | ||
| 132 | (lambda (port-iso639-3) | ||
| 133 | (call-with-input-file iso639-5 | ||
| 134 | (lambda (port-iso639-5) | ||
| 135 | (filter-map | ||
| 136 | (lambda (hash) | ||
| 137 | (let ((alpha2 (hash-ref hash "alpha_2")) | ||
| 138 | (alpha3 (hash-ref hash "alpha_3")) | ||
| 139 | (name (hash-ref hash "name"))) | ||
| 140 | (and (supported-locale? locales alpha2 alpha3) | ||
| 141 | `((alpha2 . ,alpha2) | ||
| 142 | (alpha3 . ,alpha3) | ||
| 143 | (name . ,name))))) | ||
| 144 | (append | ||
| 145 | (hash-ref (json->scm port-iso639-3) "639-3") | ||
| 146 | (hash-ref (json->scm port-iso639-5) "639-5")))))))) | ||
| 147 | |||
| 148 | (define (language-code->language-name languages language-code) | ||
| 149 | "Using LANGUAGES as a list of ISO639 association lists, return the language | ||
| 150 | name corresponding to the given LANGUAGE-CODE." | ||
| 151 | (let ((iso639-language | ||
| 152 | (find (lambda (language) | ||
| 153 | (or | ||
| 154 | (and=> (iso639-language-alpha2 language) | ||
| 155 | (lambda (alpha2) | ||
| 156 | (string=? alpha2 language-code))) | ||
| 157 | (string=? (iso639-language-alpha3 language) | ||
| 158 | language-code))) | ||
| 159 | languages))) | ||
| 160 | (iso639-language-name iso639-language))) | ||
| 161 | |||
| 162 | |||
| 163 | ;;; | ||
| 164 | ;;; Territory. | ||
| 165 | ;;; | ||
| 166 | |||
| 167 | (define (iso3166-territory-alpha2 assoc) | ||
| 168 | (assoc-ref assoc 'alpha2)) | ||
| 169 | |||
| 170 | (define (iso3166-territory-alpha3 assoc) | ||
| 171 | (assoc-ref assoc 'alpha3)) | ||
| 172 | |||
| 173 | (define (iso3166-territory-name assoc) | ||
| 174 | (assoc-ref assoc 'name)) | ||
| 175 | |||
| 176 | (define (iso3166->iso3166-territories iso3166) | ||
| 177 | "Return a list of ISO3166 association lists created from the parsing of | ||
| 178 | ISO3166 file." | ||
| 179 | (call-with-input-file iso3166 | ||
| 180 | (lambda (port) | ||
| 181 | (map (lambda (hash) | ||
| 182 | `((alpha2 . ,(hash-ref hash "alpha_2")) | ||
| 183 | (alpha3 . ,(hash-ref hash "alpha_3")) | ||
| 184 | (name . ,(hash-ref hash "name")))) | ||
| 185 | (hash-ref (json->scm port) "3166-1"))))) | ||
| 186 | |||
| 187 | (define (territory-code->territory-name territories territory-code) | ||
| 188 | "Using TERRITORIES as a list of ISO3166 association lists return the | ||
| 189 | territory name corresponding to the given TERRITORY-CODE." | ||
| 190 | (let ((iso3166-territory | ||
| 191 | (find (lambda (territory) | ||
| 192 | (or | ||
| 193 | (and=> (iso3166-territory-alpha2 territory) | ||
| 194 | (lambda (alpha2) | ||
| 195 | (string=? alpha2 territory-code))) | ||
| 196 | (string=? (iso3166-territory-alpha3 territory) | ||
| 197 | territory-code))) | ||
| 198 | territories))) | ||
| 199 | (iso3166-territory-name iso3166-territory))) | ||
diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm new file mode 100644 index 00000000000..abf752959b6 --- /dev/null +++ b/gnu/installer/newt.scm | |||
| @@ -0,0 +1,102 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer newt) | ||
| 20 | #:use-module (gnu installer) | ||
| 21 | #:use-module (guix discovery) | ||
| 22 | #:use-module (guix gexp) | ||
| 23 | #:use-module (guix ui) | ||
| 24 | #:export (newt-installer)) | ||
| 25 | |||
| 26 | (define (modules) | ||
| 27 | (cons '(newt) | ||
| 28 | (map module-name | ||
| 29 | (scheme-modules | ||
| 30 | (dirname (search-path %load-path "guix.scm")) | ||
| 31 | "gnu/installer/newt" | ||
| 32 | #:warn warn-about-load-error)))) | ||
| 33 | |||
| 34 | (define init | ||
| 35 | #~(begin | ||
| 36 | (newt-init) | ||
| 37 | (clear-screen) | ||
| 38 | (set-screen-size!))) | ||
| 39 | |||
| 40 | (define exit | ||
| 41 | #~(begin | ||
| 42 | (newt-finish))) | ||
| 43 | |||
| 44 | (define exit-error | ||
| 45 | #~(lambda (key args) | ||
| 46 | (newt-finish))) | ||
| 47 | |||
| 48 | (define locale-page | ||
| 49 | #~(lambda* (#:key | ||
| 50 | supported-locales | ||
| 51 | iso639-languages | ||
| 52 | iso3166-territories) | ||
| 53 | (run-locale-page | ||
| 54 | #:supported-locales supported-locales | ||
| 55 | #:iso639-languages iso639-languages | ||
| 56 | #:iso3166-territories iso3166-territories))) | ||
| 57 | |||
| 58 | (define timezone-page | ||
| 59 | #~(lambda* (zonetab) | ||
| 60 | (run-timezone-page zonetab))) | ||
| 61 | |||
| 62 | (define logo | ||
| 63 | (string-append | ||
| 64 | (dirname (search-path %load-path "guix.scm")) | ||
| 65 | "/gnu/installer/aux-files/logo.txt")) | ||
| 66 | |||
| 67 | (define welcome-page | ||
| 68 | #~(run-welcome-page #$(local-file logo))) | ||
| 69 | |||
| 70 | (define menu-page | ||
| 71 | #~(lambda (steps) | ||
| 72 | (run-menu-page steps))) | ||
| 73 | |||
| 74 | (define keymap-page | ||
| 75 | #~(lambda* (#:key models layouts) | ||
| 76 | (run-keymap-page #:models models | ||
| 77 | #:layouts layouts))) | ||
| 78 | |||
| 79 | (define network-page | ||
| 80 | #~(run-network-page)) | ||
| 81 | |||
| 82 | (define hostname-page | ||
| 83 | #~(run-hostname-page)) | ||
| 84 | |||
| 85 | (define user-page | ||
| 86 | #~(run-user-page)) | ||
| 87 | |||
| 88 | (define newt-installer | ||
| 89 | (installer | ||
| 90 | (name 'newt) | ||
| 91 | (modules (modules)) | ||
| 92 | (init init) | ||
| 93 | (exit exit) | ||
| 94 | (exit-error exit-error) | ||
| 95 | (keymap-page keymap-page) | ||
| 96 | (locale-page locale-page) | ||
| 97 | (menu-page menu-page) | ||
| 98 | (network-page network-page) | ||
| 99 | (timezone-page timezone-page) | ||
| 100 | (hostname-page hostname-page) | ||
| 101 | (user-page user-page) | ||
| 102 | (welcome-page welcome-page))) | ||
diff --git a/gnu/installer/newt/ethernet.scm b/gnu/installer/newt/ethernet.scm new file mode 100644 index 00000000000..2cbbfddacd9 --- /dev/null +++ b/gnu/installer/newt/ethernet.scm | |||
| @@ -0,0 +1,80 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer newt ethernet) | ||
| 20 | #:use-module (gnu installer connman) | ||
| 21 | #:use-module (gnu installer steps) | ||
| 22 | #:use-module (gnu installer newt utils) | ||
| 23 | #:use-module (gnu installer newt page) | ||
| 24 | #:use-module (guix i18n) | ||
| 25 | #:use-module (ice-9 format) | ||
| 26 | #:use-module (srfi srfi-34) | ||
| 27 | #:use-module (srfi srfi-35) | ||
| 28 | #:use-module (newt) | ||
| 29 | #:export (run-ethernet-page)) | ||
| 30 | |||
| 31 | (define (ethernet-services) | ||
| 32 | "Return all the connman services of ethernet type." | ||
| 33 | (let ((services (connman-services))) | ||
| 34 | (filter (lambda (service) | ||
| 35 | (and (string=? (service-type service) "ethernet") | ||
| 36 | (not (string-null? (service-name service))))) | ||
| 37 | services))) | ||
| 38 | |||
| 39 | (define (ethernet-service->text service) | ||
| 40 | "Return a string describing the given ethernet SERVICE." | ||
| 41 | (let* ((name (service-name service)) | ||
| 42 | (path (service-path service)) | ||
| 43 | (full-name (string-append name "-" path)) | ||
| 44 | (state (service-state service)) | ||
| 45 | (connected? (or (string=? state "online") | ||
| 46 | (string=? state "ready")))) | ||
| 47 | (format #f "~c ~a~%" | ||
| 48 | (if connected? #\* #\ ) | ||
| 49 | full-name))) | ||
| 50 | |||
| 51 | (define (connect-ethernet-service service) | ||
| 52 | "Connect to the given ethernet SERVICE. Display a connecting page while the | ||
| 53 | connection is pending." | ||
| 54 | (let* ((service-name (service-name service)) | ||
| 55 | (form (draw-connecting-page service-name))) | ||
| 56 | (connman-connect service) | ||
| 57 | (destroy-form-and-pop form))) | ||
| 58 | |||
| 59 | (define (run-ethernet-page) | ||
| 60 | (let ((services (ethernet-services))) | ||
| 61 | (if (null? services) | ||
| 62 | (begin | ||
| 63 | (run-error-page | ||
| 64 | (G_ "No ethernet service available, please try again.") | ||
| 65 | (G_ "No service")) | ||
| 66 | (raise | ||
| 67 | (condition | ||
| 68 | (&installer-step-abort)))) | ||
| 69 | (run-listbox-selection-page | ||
| 70 | #:info-text (G_ "Please select an ethernet network.") | ||
| 71 | #:title (G_ "Ethernet connection") | ||
| 72 | #:listbox-items services | ||
| 73 | #:listbox-item->text ethernet-service->text | ||
| 74 | #:button-text (G_ "Cancel") | ||
| 75 | #:button-callback-procedure | ||
| 76 | (lambda _ | ||
| 77 | (raise | ||
| 78 | (condition | ||
| 79 | (&installer-step-abort)))) | ||
| 80 | #:listbox-callback-procedure connect-ethernet-service)))) | ||
diff --git a/gnu/installer/newt/hostname.scm b/gnu/installer/newt/hostname.scm new file mode 100644 index 00000000000..acbee64a6a5 --- /dev/null +++ b/gnu/installer/newt/hostname.scm | |||
| @@ -0,0 +1,26 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer newt hostname) | ||
| 20 | #:use-module (gnu installer newt page) | ||
| 21 | #:use-module (guix i18n) | ||
| 22 | #:export (run-hostname-page)) | ||
| 23 | |||
| 24 | (define (run-hostname-page) | ||
| 25 | (run-input-page (G_ "Please enter the system hostname") | ||
| 26 | (G_ "Hostname selection"))) | ||
diff --git a/gnu/installer/newt/keymap.scm b/gnu/installer/newt/keymap.scm new file mode 100644 index 00000000000..219ac3f8e23 --- /dev/null +++ b/gnu/installer/newt/keymap.scm | |||
| @@ -0,0 +1,132 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer newt keymap) | ||
| 20 | #:use-module (gnu installer keymap) | ||
| 21 | #:use-module (gnu installer steps) | ||
| 22 | #:use-module (gnu installer newt page) | ||
| 23 | #:use-module (guix i18n) | ||
| 24 | #:use-module (guix records) | ||
| 25 | #:use-module (newt) | ||
| 26 | #:use-module (srfi srfi-1) | ||
| 27 | #:use-module (srfi srfi-34) | ||
| 28 | #:use-module (srfi srfi-35) | ||
| 29 | #:export (run-keymap-page)) | ||
| 30 | |||
| 31 | (define (run-layout-page layouts layout->text) | ||
| 32 | (let ((title (G_ "Layout selection"))) | ||
| 33 | (run-listbox-selection-page | ||
| 34 | #:title title | ||
| 35 | #:info-text (G_ "Please choose your keyboard layout.") | ||
| 36 | #:listbox-items layouts | ||
| 37 | #:listbox-item->text layout->text | ||
| 38 | #:button-text (G_ "Cancel") | ||
| 39 | #:button-callback-procedure | ||
| 40 | (lambda _ | ||
| 41 | (raise | ||
| 42 | (condition | ||
| 43 | (&installer-step-abort))))))) | ||
| 44 | |||
| 45 | (define (run-variant-page variants variant->text) | ||
| 46 | (let ((title (G_ "Variant selection"))) | ||
| 47 | (run-listbox-selection-page | ||
| 48 | #:title title | ||
| 49 | #:info-text (G_ "Please choose a variant for your keyboard layout.") | ||
| 50 | #:listbox-items variants | ||
| 51 | #:listbox-item->text variant->text | ||
| 52 | #:button-text (G_ "Back") | ||
| 53 | #:button-callback-procedure | ||
| 54 | (lambda _ | ||
| 55 | (raise | ||
| 56 | (condition | ||
| 57 | (&installer-step-abort))))))) | ||
| 58 | |||
| 59 | (define (run-model-page models model->text) | ||
| 60 | (let ((title (G_ "Keyboard model selection"))) | ||
| 61 | (run-listbox-selection-page | ||
| 62 | #:title title | ||
| 63 | #:info-text (G_ "Please choose your keyboard model.") | ||
| 64 | #:listbox-items models | ||
| 65 | #:listbox-item->text model->text | ||
| 66 | #:listbox-default-item (find (lambda (model) | ||
| 67 | (string=? (x11-keymap-model-name model) | ||
| 68 | "pc105")) | ||
| 69 | models) | ||
| 70 | #:sort-listbox-items? #f | ||
| 71 | #:button-text (G_ "Back") | ||
| 72 | #:button-callback-procedure | ||
| 73 | (lambda _ | ||
| 74 | (raise | ||
| 75 | (condition | ||
| 76 | (&installer-step-abort))))))) | ||
| 77 | |||
| 78 | (define* (run-keymap-page #:key models layouts) | ||
| 79 | "Run a page asking the user to select a keyboard model, layout and | ||
| 80 | variant. MODELS and LAYOUTS are lists of supported X11-KEYMAP-MODEL and | ||
| 81 | X11-KEYMAP-LAYOUT. Return a list of three elements, the names of the selected | ||
| 82 | keyboard model, layout and variant." | ||
| 83 | (define keymap-steps | ||
| 84 | (list | ||
| 85 | (installer-step | ||
| 86 | (id 'model) | ||
| 87 | (compute | ||
| 88 | (lambda _ | ||
| 89 | ;; TODO: Understand why (run-model-page models x11-keymap-model-name) | ||
| 90 | ;; fails with: warning: possibly unbound variable | ||
| 91 | ;; `%x11-keymap-model-description-procedure. | ||
| 92 | (run-model-page models (lambda (model) | ||
| 93 | (x11-keymap-model-description | ||
| 94 | model)))))) | ||
| 95 | (installer-step | ||
| 96 | (id 'layout) | ||
| 97 | (compute | ||
| 98 | (lambda _ | ||
| 99 | (let* ((layout (run-layout-page | ||
| 100 | layouts | ||
| 101 | (lambda (layout) | ||
| 102 | (x11-keymap-layout-description layout))))) | ||
| 103 | (if (null? (x11-keymap-layout-variants layout)) | ||
| 104 | ;; Break if this layout does not have any variant. | ||
| 105 | (raise | ||
| 106 | (condition | ||
| 107 | (&installer-step-break))) | ||
| 108 | layout))))) | ||
| 109 | ;; Propose the user to select a variant among those supported by the | ||
| 110 | ;; previously selected layout. | ||
| 111 | (installer-step | ||
| 112 | (id 'variant) | ||
| 113 | (compute | ||
| 114 | (lambda (result) | ||
| 115 | (let ((variants (x11-keymap-layout-variants | ||
| 116 | (result-step result 'layout)))) | ||
| 117 | (run-variant-page variants | ||
| 118 | (lambda (variant) | ||
| 119 | (x11-keymap-variant-description | ||
| 120 | variant))))))))) | ||
| 121 | |||
| 122 | (define (format-result result) | ||
| 123 | (let ((model (x11-keymap-model-name | ||
| 124 | (result-step result 'model))) | ||
| 125 | (layout (x11-keymap-layout-name | ||
| 126 | (result-step result 'layout))) | ||
| 127 | (variant (and=> (result-step result 'variant) | ||
| 128 | (lambda (variant) | ||
| 129 | (x11-keymap-variant-name variant))))) | ||
| 130 | (list model layout (or variant "")))) | ||
| 131 | (format-result | ||
| 132 | (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 00000000000..5444a075984 --- /dev/null +++ b/gnu/installer/newt/locale.scm | |||
| @@ -0,0 +1,193 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer newt locale) | ||
| 20 | #:use-module (gnu installer locale) | ||
| 21 | #:use-module (gnu installer steps) | ||
| 22 | #:use-module (gnu installer newt page) | ||
| 23 | #:use-module (guix i18n) | ||
| 24 | #:use-module (newt) | ||
| 25 | #:use-module (srfi srfi-1) | ||
| 26 | #:use-module (srfi srfi-26) | ||
| 27 | #:use-module (srfi srfi-34) | ||
| 28 | #:use-module (srfi srfi-35) | ||
| 29 | #:use-module (ice-9 match) | ||
| 30 | #:export (run-locale-page)) | ||
| 31 | |||
| 32 | (define (run-language-page languages language->text) | ||
| 33 | (let ((title (G_ "Language selection"))) | ||
| 34 | (run-listbox-selection-page | ||
| 35 | #:title title | ||
| 36 | #:info-text (G_ "Choose the language to be used for the installation \ | ||
| 37 | process. The selected language will also be the default \ | ||
| 38 | language for the installed system.") | ||
| 39 | #:listbox-items languages | ||
| 40 | #:listbox-item->text language->text | ||
| 41 | #:button-text (G_ "Cancel") | ||
| 42 | #:button-callback-procedure | ||
| 43 | (lambda _ | ||
| 44 | (raise | ||
| 45 | (condition | ||
| 46 | (&installer-step-abort))))))) | ||
| 47 | |||
| 48 | (define (run-territory-page territories territory->text) | ||
| 49 | (let ((title (G_ "Location selection"))) | ||
| 50 | (run-listbox-selection-page | ||
| 51 | #:title title | ||
| 52 | #:info-text (G_ "Choose your location. This is a shortlist of locations \ | ||
| 53 | based on the language you selected.") | ||
| 54 | #:listbox-items territories | ||
| 55 | #:listbox-item->text territory->text | ||
| 56 | #:button-text (G_ "Back") | ||
| 57 | #:button-callback-procedure | ||
| 58 | (lambda _ | ||
| 59 | (raise | ||
| 60 | (condition | ||
| 61 | (&installer-step-abort))))))) | ||
| 62 | |||
| 63 | (define (run-codeset-page codesets) | ||
| 64 | (let ((title (G_ "Codeset selection"))) | ||
| 65 | (run-listbox-selection-page | ||
| 66 | #:title title | ||
| 67 | #:info-text (G_ "Choose your codeset. If UTF-8 is available, it should be \ | ||
| 68 | preferred.") | ||
| 69 | #:listbox-items codesets | ||
| 70 | #:listbox-item->text identity | ||
| 71 | #:listbox-default-item "UTF-8" | ||
| 72 | #:button-text (G_ "Back") | ||
| 73 | #:button-callback-procedure | ||
| 74 | (lambda _ | ||
| 75 | (raise | ||
| 76 | (condition | ||
| 77 | (&installer-step-abort))))))) | ||
| 78 | |||
| 79 | (define (run-modifier-page modifiers modifier->text) | ||
| 80 | (let ((title (G_ "Modifier selection"))) | ||
| 81 | (run-listbox-selection-page | ||
| 82 | #:title title | ||
| 83 | #:info-text (G_ "Choose your modifier.") | ||
| 84 | #:listbox-items modifiers | ||
| 85 | #:listbox-item->text modifier->text | ||
| 86 | #:button-text (G_ "Back") | ||
| 87 | #:button-callback-procedure | ||
| 88 | (lambda _ | ||
| 89 | (raise | ||
| 90 | (condition | ||
| 91 | (&installer-step-abort))))))) | ||
| 92 | |||
| 93 | (define* (run-locale-page #:key | ||
| 94 | supported-locales | ||
| 95 | iso639-languages | ||
| 96 | iso3166-territories) | ||
| 97 | |||
| 98 | (define (break-on-locale-found locales) | ||
| 99 | "Raise the &installer-step-break condition if LOCALES contains exactly one | ||
| 100 | element." | ||
| 101 | (and (= (length locales) 1) | ||
| 102 | (raise | ||
| 103 | (condition (&installer-step-break))))) | ||
| 104 | |||
| 105 | (define (filter-locales locales result) | ||
| 106 | "Filter the list of locale records LOCALES using the RESULT returned by | ||
| 107 | the installer-steps defined below." | ||
| 108 | (filter | ||
| 109 | (lambda (locale) | ||
| 110 | (and-map identity | ||
| 111 | `(,(string=? (locale-language locale) | ||
| 112 | (result-step result 'language)) | ||
| 113 | ,@(if (result-step-done? result 'territory) | ||
| 114 | (list (equal? (locale-territory locale) | ||
| 115 | (result-step result 'territory))) | ||
| 116 | '()) | ||
| 117 | ,@(if (result-step-done? result 'codeset) | ||
| 118 | (list (equal? (locale-codeset locale) | ||
| 119 | (result-step result 'codeset))) | ||
| 120 | '()) | ||
| 121 | ,@(if (result-step-done? result 'modifier) | ||
| 122 | (list (equal? (locale-modifier locale) | ||
| 123 | (result-step result 'modifier))) | ||
| 124 | '())))) | ||
| 125 | locales)) | ||
| 126 | |||
| 127 | (define (result->locale-string locales result) | ||
| 128 | "Supposing that LOCALES contains exactly one locale record, turn it into a | ||
| 129 | glibc locale string and return it." | ||
| 130 | (match (filter-locales locales result) | ||
| 131 | ((locale) | ||
| 132 | (locale->locale-string locale)))) | ||
| 133 | |||
| 134 | (define locale-steps | ||
| 135 | (list | ||
| 136 | (installer-step | ||
| 137 | (id 'language) | ||
| 138 | (compute | ||
| 139 | (lambda _ | ||
| 140 | (run-language-page | ||
| 141 | (delete-duplicates (map locale-language supported-locales)) | ||
| 142 | (cut language-code->language-name iso639-languages <>))))) | ||
| 143 | (installer-step | ||
| 144 | (id 'territory) | ||
| 145 | (compute | ||
| 146 | (lambda (result) | ||
| 147 | (let ((locales (filter-locales supported-locales result))) | ||
| 148 | ;; Stop the process if the language returned by the previous step | ||
| 149 | ;; is matching one and only one supported locale. | ||
| 150 | (break-on-locale-found locales) | ||
| 151 | |||
| 152 | ;; Otherwise, ask the user to select a territory among those | ||
| 153 | ;; supported by the previously selected language. | ||
| 154 | (run-territory-page | ||
| 155 | (delete-duplicates (map locale-territory locales)) | ||
| 156 | (lambda (territory-code) | ||
| 157 | (if territory-code | ||
| 158 | (territory-code->territory-name iso3166-territories | ||
| 159 | territory-code) | ||
| 160 | (G_ "No location")))))))) | ||
| 161 | (installer-step | ||
| 162 | (id 'codeset) | ||
| 163 | (compute | ||
| 164 | (lambda (result) | ||
| 165 | (let ((locales (filter-locales supported-locales result))) | ||
| 166 | ;; Same as above but we now have a language and a territory to | ||
| 167 | ;; narrow down the search of a locale. | ||
| 168 | (break-on-locale-found locales) | ||
| 169 | |||
| 170 | ;; Otherwise, ask for a codeset. | ||
| 171 | (run-codeset-page | ||
| 172 | (delete-duplicates (map locale-codeset locales))))))) | ||
| 173 | (installer-step | ||
| 174 | (id 'modifier) | ||
| 175 | (compute | ||
| 176 | (lambda (result) | ||
| 177 | (let ((locales (filter-locales supported-locales result))) | ||
| 178 | ;; Same thing with a language, a territory and a codeset this time. | ||
| 179 | (break-on-locale-found locales) | ||
| 180 | |||
| 181 | ;; Otherwise, ask for a modifier. | ||
| 182 | (run-modifier-page | ||
| 183 | (delete-duplicates (map locale-modifier locales)) | ||
| 184 | (lambda (modifier) | ||
| 185 | (or modifier (G_ "No modifier")))))))))) | ||
| 186 | |||
| 187 | ;; If run-installer-steps returns locally, it means that the user had to go | ||
| 188 | ;; through all steps (language, territory, codeset and modifier) to select a | ||
| 189 | ;; locale. In that case, like if we exited by raising &installer-step-break | ||
| 190 | ;; condition, turn the result into a glibc locale string and return it. | ||
| 191 | (result->locale-string | ||
| 192 | supported-locales | ||
| 193 | (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 00000000000..756b582a500 --- /dev/null +++ b/gnu/installer/newt/menu.scm | |||
| @@ -0,0 +1,44 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer newt menu) | ||
| 20 | #:use-module (gnu installer steps) | ||
| 21 | #:use-module (gnu installer newt page) | ||
| 22 | #:use-module (guix i18n) | ||
| 23 | #:use-module (newt) | ||
| 24 | #:export (run-menu-page)) | ||
| 25 | |||
| 26 | (define (run-menu-page steps) | ||
| 27 | "Run a menu page, asking the user to select where to resume the install | ||
| 28 | process from." | ||
| 29 | (define (steps->items steps) | ||
| 30 | (filter (lambda (step) | ||
| 31 | (installer-step-description step)) | ||
| 32 | steps)) | ||
| 33 | |||
| 34 | (run-listbox-selection-page | ||
| 35 | #:info-text (G_ "Choose where you want to resume the install.\ | ||
| 36 | You can also abort the installion by pressing the button.") | ||
| 37 | #:title (G_ "Installation menu") | ||
| 38 | #:listbox-items (steps->items steps) | ||
| 39 | #:listbox-item->text installer-step-description | ||
| 40 | #:sort-listbox-items? #f | ||
| 41 | #:button-text (G_ "Abort") | ||
| 42 | #:button-callback-procedure (lambda () | ||
| 43 | (newt-finish) | ||
| 44 | (primitive-exit 1)))) | ||
diff --git a/gnu/installer/newt/network.scm b/gnu/installer/newt/network.scm new file mode 100644 index 00000000000..c6ba69d4e88 --- /dev/null +++ b/gnu/installer/newt/network.scm | |||
| @@ -0,0 +1,159 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer newt network) | ||
| 20 | #:use-module (gnu installer connman) | ||
| 21 | #:use-module (gnu installer steps) | ||
| 22 | #:use-module (gnu installer utils) | ||
| 23 | #:use-module (gnu installer newt ethernet) | ||
| 24 | #:use-module (gnu installer newt page) | ||
| 25 | #:use-module (gnu installer newt wifi) | ||
| 26 | #:use-module (guix i18n) | ||
| 27 | #:use-module (srfi srfi-1) | ||
| 28 | #:use-module (srfi srfi-11) | ||
| 29 | #:use-module (srfi srfi-34) | ||
| 30 | #:use-module (srfi srfi-35) | ||
| 31 | #:use-module (newt) | ||
| 32 | #:export (run-network-page)) | ||
| 33 | |||
| 34 | ;; Maximum length of a technology name. | ||
| 35 | (define technology-name-max-length (make-parameter 20)) | ||
| 36 | |||
| 37 | (define (technology->text technology) | ||
| 38 | "Return a string describing the given TECHNOLOGY." | ||
| 39 | (let* ((name (technology-name technology)) | ||
| 40 | (padded-name (string-pad-right name | ||
| 41 | (technology-name-max-length)))) | ||
| 42 | (format #f "~a~%" padded-name))) | ||
| 43 | |||
| 44 | (define (run-technology-page) | ||
| 45 | "Run a page to ask the user which technology shall be used to access | ||
| 46 | Internet and return the selected technology. For now, only technologies with | ||
| 47 | \"ethernet\" or \"wifi\" types are supported." | ||
| 48 | (define (technology-items) | ||
| 49 | (filter (lambda (technology) | ||
| 50 | (let ((type (technology-type technology))) | ||
| 51 | (or | ||
| 52 | (string=? type "ethernet") | ||
| 53 | (string=? type "wifi")))) | ||
| 54 | (connman-technologies))) | ||
| 55 | |||
| 56 | (run-listbox-selection-page | ||
| 57 | #:info-text (G_ "The install process requires an internet access.\ | ||
| 58 | Please select a network technology.") | ||
| 59 | #:title (G_ "Technology selection") | ||
| 60 | #:listbox-items (technology-items) | ||
| 61 | #:listbox-item->text technology->text | ||
| 62 | #:button-text (G_ "Cancel") | ||
| 63 | #:button-callback-procedure | ||
| 64 | (lambda _ | ||
| 65 | (raise | ||
| 66 | (condition | ||
| 67 | (&installer-step-abort)))))) | ||
| 68 | |||
| 69 | (define (find-technology-by-type technologies type) | ||
| 70 | "Find and return a technology with the given TYPE in TECHNOLOGIES list." | ||
| 71 | (find (lambda (technology) | ||
| 72 | (string=? (technology-type technology) | ||
| 73 | type)) | ||
| 74 | technologies)) | ||
| 75 | |||
| 76 | (define (wait-technology-powered technology) | ||
| 77 | "Wait and display a progress bar until the given TECHNOLOGY is powered." | ||
| 78 | (let ((name (technology-name technology)) | ||
| 79 | (full-value 5)) | ||
| 80 | (run-scale-page | ||
| 81 | #:title (G_ "Powering technology") | ||
| 82 | #:info-text (format #f "Waiting for technology ~a to be powered." name) | ||
| 83 | #:scale-full-value full-value | ||
| 84 | #:scale-update-proc | ||
| 85 | (lambda (value) | ||
| 86 | (let* ((technologies (connman-technologies)) | ||
| 87 | (type (technology-type technology)) | ||
| 88 | (updated-technology | ||
| 89 | (find-technology-by-type technologies type)) | ||
| 90 | (technology-powered? updated-technology)) | ||
| 91 | (sleep 1) | ||
| 92 | (if technology-powered? | ||
| 93 | full-value | ||
| 94 | (+ value 1))))))) | ||
| 95 | |||
| 96 | (define (wait-service-online) | ||
| 97 | "Display a newt scale until connman detects an Internet access. Do | ||
| 98 | FULL-VALUE tentatives, spaced by 1 second." | ||
| 99 | (let* ((full-value 5)) | ||
| 100 | (run-scale-page | ||
| 101 | #:title (G_ "Checking connectivity") | ||
| 102 | #:info-text (G_ "Waiting internet access is established") | ||
| 103 | #:scale-full-value full-value | ||
| 104 | #:scale-update-proc | ||
| 105 | (lambda (value) | ||
| 106 | (sleep 1) | ||
| 107 | (if (connman-online?) | ||
| 108 | full-value | ||
| 109 | (+ value 1)))) | ||
| 110 | (unless (connman-online?) | ||
| 111 | (run-error-page | ||
| 112 | (G_ "The selected network does not provide an Internet \ | ||
| 113 | access, please try again.") | ||
| 114 | (G_ "Connection error")) | ||
| 115 | (raise | ||
| 116 | (condition | ||
| 117 | (&installer-step-abort)))))) | ||
| 118 | |||
| 119 | (define (run-network-page) | ||
| 120 | "Run a page to allow the user to configure connman so that it can access the | ||
| 121 | Internet." | ||
| 122 | (define network-steps | ||
| 123 | (list | ||
| 124 | ;; Ask the user to choose between ethernet and wifi technologies. | ||
| 125 | (installer-step | ||
| 126 | (id 'select-technology) | ||
| 127 | (compute | ||
| 128 | (lambda _ | ||
| 129 | (run-technology-page)))) | ||
| 130 | ;; Enable the previously selected technology. | ||
| 131 | (installer-step | ||
| 132 | (id 'power-technology) | ||
| 133 | (compute | ||
| 134 | (lambda (result) | ||
| 135 | (let ((technology (result-step result 'select-technology))) | ||
| 136 | (connman-enable-technology technology) | ||
| 137 | (wait-technology-powered technology))))) | ||
| 138 | ;; Propose the user to connect to one of the service available for the | ||
| 139 | ;; previously selected technology. | ||
| 140 | (installer-step | ||
| 141 | (id 'connect-service) | ||
| 142 | (compute | ||
| 143 | (lambda (result) | ||
| 144 | (let* ((technology (result-step result 'select-technology)) | ||
| 145 | (type (technology-type technology))) | ||
| 146 | (cond | ||
| 147 | ((string=? "wifi" type) | ||
| 148 | (run-wifi-page)) | ||
| 149 | ((string=? "ethernet" type) | ||
| 150 | (run-ethernet-page))))))) | ||
| 151 | ;; Wait for connman status to switch to 'online, which means it can | ||
| 152 | ;; access Internet. | ||
| 153 | (installer-step | ||
| 154 | (id 'wait-online) | ||
| 155 | (compute (lambda _ | ||
| 156 | (wait-service-online)))))) | ||
| 157 | (run-installer-steps | ||
| 158 | #:steps network-steps | ||
| 159 | #:rewind-strategy 'start)) | ||
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm new file mode 100644 index 00000000000..bcede3e333e --- /dev/null +++ b/gnu/installer/newt/page.scm | |||
| @@ -0,0 +1,313 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer newt page) | ||
| 20 | #:use-module (gnu installer newt utils) | ||
| 21 | #:use-module (guix i18n) | ||
| 22 | #:use-module (ice-9 match) | ||
| 23 | #:use-module (ice-9 receive) | ||
| 24 | #:use-module (newt) | ||
| 25 | #:export (draw-info-page | ||
| 26 | draw-connecting-page | ||
| 27 | run-input-page | ||
| 28 | run-error-page | ||
| 29 | run-listbox-selection-page | ||
| 30 | run-scale-page)) | ||
| 31 | |||
| 32 | ;;; Commentary: | ||
| 33 | ;;; | ||
| 34 | ;;; Some helpers around guile-newt to draw or run generic pages. The | ||
| 35 | ;;; difference between 'draw' and 'run' terms comes from newt library. A page | ||
| 36 | ;;; is drawn when the form it contains does not expect any user | ||
| 37 | ;;; interaction. In that case, it is necessary to call (newt-refresh) to force | ||
| 38 | ;;; the page to be displayed. When a form is 'run', it is blocked waiting for | ||
| 39 | ;;; any action from the user (press a button, input some text, ...). | ||
| 40 | ;;; | ||
| 41 | ;;; Code: | ||
| 42 | |||
| 43 | (define (draw-info-page text title) | ||
| 44 | "Draw an informative page with the given TEXT as content. Set the title of | ||
| 45 | this page to TITLE." | ||
| 46 | (let* ((text-box | ||
| 47 | (make-reflowed-textbox -1 -1 text 40 | ||
| 48 | #:flags FLAG-BORDER)) | ||
| 49 | (grid (make-grid 1 1)) | ||
| 50 | (form (make-form))) | ||
| 51 | (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box) | ||
| 52 | (add-component-to-form form text-box) | ||
| 53 | (make-wrapped-grid-window grid title) | ||
| 54 | (draw-form form) | ||
| 55 | ;; This call is imperative, otherwise the form won't be displayed. See the | ||
| 56 | ;; explanation in the above commentary. | ||
| 57 | (newt-refresh) | ||
| 58 | form)) | ||
| 59 | |||
| 60 | (define (draw-connecting-page service-name) | ||
| 61 | "Draw a page to indicate a connection in in progress." | ||
| 62 | (draw-info-page | ||
| 63 | (format #f (G_ "Connecting to ~a, please wait.") service-name) | ||
| 64 | (G_ "Connection in progress"))) | ||
| 65 | |||
| 66 | (define* (run-input-page text title | ||
| 67 | #:key | ||
| 68 | (allow-empty-input? #f) | ||
| 69 | (input-field-width 40)) | ||
| 70 | "Run a page to prompt user for an input. The given TEXT will be displayed | ||
| 71 | above the input field. The page title is set to TITLE. Unless | ||
| 72 | allow-empty-input? is set to #t, an error page will be displayed if the user | ||
| 73 | enters an empty input." | ||
| 74 | (let* ((text-box | ||
| 75 | (make-reflowed-textbox -1 -1 text | ||
| 76 | input-field-width | ||
| 77 | #:flags FLAG-BORDER)) | ||
| 78 | (grid (make-grid 1 3)) | ||
| 79 | (input-entry (make-entry -1 -1 20)) | ||
| 80 | (ok-button (make-button -1 -1 (G_ "Ok"))) | ||
| 81 | (form (make-form))) | ||
| 82 | |||
| 83 | (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box) | ||
| 84 | (set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT input-entry | ||
| 85 | #:pad-top 1) | ||
| 86 | (set-grid-field grid 0 2 GRID-ELEMENT-COMPONENT ok-button | ||
| 87 | #:pad-top 1) | ||
| 88 | |||
| 89 | (add-components-to-form form text-box input-entry ok-button) | ||
| 90 | (make-wrapped-grid-window grid title) | ||
| 91 | (let ((error-page (lambda () | ||
| 92 | (run-error-page (G_ "Please enter a non empty input") | ||
| 93 | (G_ "Empty input"))))) | ||
| 94 | (let loop () | ||
| 95 | (receive (exit-reason argument) | ||
| 96 | (run-form form) | ||
| 97 | (let ((input (entry-value input-entry))) | ||
| 98 | (if (and (not allow-empty-input?) | ||
| 99 | (eq? exit-reason 'exit-component) | ||
| 100 | (string=? input "")) | ||
| 101 | (begin | ||
| 102 | ;; Display the error page. | ||
| 103 | (error-page) | ||
| 104 | ;; Set the focus back to the input input field. | ||
| 105 | (set-current-component form input-entry) | ||
| 106 | (loop)) | ||
| 107 | (begin | ||
| 108 | (destroy-form-and-pop form) | ||
| 109 | input)))))))) | ||
| 110 | |||
| 111 | (define (run-error-page text title) | ||
| 112 | "Run a page to inform the user of an error. The page contains the given TEXT | ||
| 113 | to explain the error and an \"OK\" button to acknowledge the error. The title | ||
| 114 | of the page is set to TITLE." | ||
| 115 | (let* ((text-box | ||
| 116 | (make-reflowed-textbox -1 -1 text 40 | ||
| 117 | #:flags FLAG-BORDER)) | ||
| 118 | (grid (make-grid 1 2)) | ||
| 119 | (ok-button (make-button -1 -1 "Ok")) | ||
| 120 | (form (make-form))) | ||
| 121 | |||
| 122 | (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box) | ||
| 123 | (set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT ok-button | ||
| 124 | #:pad-top 1) | ||
| 125 | |||
| 126 | ;; Set the background color to red to indicate something went wrong. | ||
| 127 | (newt-set-color COLORSET-ROOT "white" "red") | ||
| 128 | (add-components-to-form form text-box ok-button) | ||
| 129 | (make-wrapped-grid-window grid title) | ||
| 130 | (run-form form) | ||
| 131 | ;; Restore the background to its original color. | ||
| 132 | (newt-set-color COLORSET-ROOT "white" "blue") | ||
| 133 | (destroy-form-and-pop form))) | ||
| 134 | |||
| 135 | (define* (run-listbox-selection-page #:key | ||
| 136 | info-text | ||
| 137 | title | ||
| 138 | (info-textbox-width 50) | ||
| 139 | listbox-items | ||
| 140 | listbox-item->text | ||
| 141 | (listbox-height 20) | ||
| 142 | (listbox-default-item #f) | ||
| 143 | (listbox-allow-multiple? #f) | ||
| 144 | (sort-listbox-items? #t) | ||
| 145 | button-text | ||
| 146 | (button-callback-procedure | ||
| 147 | (const #t)) | ||
| 148 | (listbox-callback-procedure | ||
| 149 | (const #t))) | ||
| 150 | "Run a page asking the user to select an item in a listbox. The page | ||
| 151 | contains, stacked vertically from the top to the bottom, an informative text | ||
| 152 | set to INFO-TEXT, a listbox and a button. The listbox will be filled with | ||
| 153 | LISTBOX-ITEMS converted to text by applying the procedure LISTBOX-ITEM->TEXT | ||
| 154 | on every item. The selected item from LISTBOX-ITEMS is returned. The button | ||
| 155 | text is set to BUTTON-TEXT and the procedure BUTTON-CALLBACK-PROCEDURE called | ||
| 156 | when it is pressed. The procedure LISTBOX-CALLBACK-PROCEDURE is called when an | ||
| 157 | item from the listbox is selected (by pressing the <ENTER> key). | ||
| 158 | |||
| 159 | INFO-TEXTBOX-WIDTH is the width of the textbox where INFO-TEXT will be | ||
| 160 | displayed. LISTBOX-HEIGHT is the height of the listbox. | ||
| 161 | |||
| 162 | If LISTBOX-DEFAULT-ITEM is set to the value of one of the items in | ||
| 163 | LISTBOX-ITEMS, it will be selected by default. Otherwise, the first element of | ||
| 164 | the listbox is selected. | ||
| 165 | |||
| 166 | If LISTBOX-ALLOW-MULTIPLE? is set to #t, multiple items from the listbox can | ||
| 167 | be selected (using the <SPACE> key). It that case, a list containing the | ||
| 168 | selected items will be returned. | ||
| 169 | |||
| 170 | If SORT-LISTBOX-ITEMS? is set to #t, the listbox items are sorted using | ||
| 171 | 'string<=' procedure (after being converted to text)." | ||
| 172 | |||
| 173 | (define (fill-listbox listbox items) | ||
| 174 | "Append the given ITEMS to LISTBOX, once they have been converted to text | ||
| 175 | with LISTBOX-ITEM->TEXT. Each item appended to the LISTBOX is given a key by | ||
| 176 | newt. Save this key by returning an association list under the form: | ||
| 177 | |||
| 178 | ((NEWT-LISTBOX-KEY . ITEM) ...) | ||
| 179 | |||
| 180 | where NEWT-LISTBOX-KEY is the key returned by APPEND-ENTRY-TO-LISTBOX, when | ||
| 181 | ITEM was inserted into LISTBOX." | ||
| 182 | (map (lambda (item) | ||
| 183 | (let* ((text (listbox-item->text item)) | ||
| 184 | (key (append-entry-to-listbox listbox text))) | ||
| 185 | (cons key item))) | ||
| 186 | items)) | ||
| 187 | |||
| 188 | (define (sort-listbox-items listbox-items) | ||
| 189 | "Return LISTBOX-ITEMS sorted using the 'string<=' procedure on the text | ||
| 190 | corresponding to each item in the list." | ||
| 191 | (let* ((items (map (lambda (item) | ||
| 192 | (cons item (listbox-item->text item))) | ||
| 193 | listbox-items)) | ||
| 194 | (sorted-items | ||
| 195 | (sort items (lambda (a b) | ||
| 196 | (let ((text-a (cdr a)) | ||
| 197 | (text-b (cdr b))) | ||
| 198 | (string<= text-a text-b)))))) | ||
| 199 | (map car sorted-items))) | ||
| 200 | |||
| 201 | (define (set-default-item listbox listbox-keys default-item) | ||
| 202 | "Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the | ||
| 203 | association list returned by the FILL-LISTBOX procedure. It is used because | ||
| 204 | the current listbox item has to be selected by key." | ||
| 205 | (for-each (match-lambda | ||
| 206 | ((key . item) | ||
| 207 | (when (equal? item default-item) | ||
| 208 | (set-current-listbox-entry-by-key listbox key)))) | ||
| 209 | listbox-keys)) | ||
| 210 | |||
| 211 | (let* ((listbox (make-listbox | ||
| 212 | -1 -1 | ||
| 213 | listbox-height | ||
| 214 | (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT | ||
| 215 | (if listbox-allow-multiple? | ||
| 216 | FLAG-MULTIPLE | ||
| 217 | 0)))) | ||
| 218 | (form (make-form)) | ||
| 219 | (info-textbox | ||
| 220 | (make-reflowed-textbox -1 -1 info-text | ||
| 221 | info-textbox-width | ||
| 222 | #:flags FLAG-BORDER)) | ||
| 223 | (button (make-button -1 -1 button-text)) | ||
| 224 | (grid (vertically-stacked-grid | ||
| 225 | GRID-ELEMENT-COMPONENT info-textbox | ||
| 226 | GRID-ELEMENT-COMPONENT listbox | ||
| 227 | GRID-ELEMENT-COMPONENT button)) | ||
| 228 | (sorted-items (if sort-listbox-items? | ||
| 229 | (sort-listbox-items listbox-items) | ||
| 230 | listbox-items)) | ||
| 231 | (keys (fill-listbox listbox sorted-items))) | ||
| 232 | |||
| 233 | (when listbox-default-item | ||
| 234 | (set-default-item listbox keys listbox-default-item)) | ||
| 235 | |||
| 236 | (add-form-to-grid grid form #t) | ||
| 237 | (make-wrapped-grid-window grid title) | ||
| 238 | |||
| 239 | (receive (exit-reason argument) | ||
| 240 | (run-form form) | ||
| 241 | (dynamic-wind | ||
| 242 | (const #t) | ||
| 243 | (lambda () | ||
| 244 | (when (eq? exit-reason 'exit-component) | ||
| 245 | (cond | ||
| 246 | ((components=? argument button) | ||
| 247 | (button-callback-procedure)) | ||
| 248 | ((components=? argument listbox) | ||
| 249 | (if listbox-allow-multiple? | ||
| 250 | (let* ((entries (listbox-selection listbox)) | ||
| 251 | (items (map (lambda (entry) | ||
| 252 | (assoc-ref keys entry)) | ||
| 253 | entries))) | ||
| 254 | (listbox-callback-procedure items) | ||
| 255 | items) | ||
| 256 | (let* ((entry (current-listbox-entry listbox)) | ||
| 257 | (item (assoc-ref keys entry))) | ||
| 258 | (listbox-callback-procedure item) | ||
| 259 | item)))))) | ||
| 260 | (lambda () | ||
| 261 | (destroy-form-and-pop form)))))) | ||
| 262 | |||
| 263 | (define* (run-scale-page #:key | ||
| 264 | title | ||
| 265 | info-text | ||
| 266 | (info-textbox-width 50) | ||
| 267 | (scale-width 40) | ||
| 268 | (scale-full-value 100) | ||
| 269 | scale-update-proc | ||
| 270 | (max-scale-update 5)) | ||
| 271 | "Run a page with a progress bar (called 'scale' in newt). The given | ||
| 272 | INFO-TEXT is displayed in a textbox above the scale. The width of the textbox | ||
| 273 | is set to INFO-TEXTBOX-WIDTH. The width of the scale is set to | ||
| 274 | SCALE-WIDTH. SCALE-FULL-VALUE indicates the value that correspond to 100% of | ||
| 275 | the scale. | ||
| 276 | |||
| 277 | The procedure SCALE-UPDATE-PROC shall return a new scale | ||
| 278 | value. SCALE-UPDATE-PROC will be called until the returned value is superior | ||
| 279 | or equal to SCALE-FULL-VALUE, but no more than MAX-SCALE-UPDATE times. An | ||
| 280 | error is raised if the MAX-SCALE-UPDATE limit is reached." | ||
| 281 | (let* ((info-textbox | ||
| 282 | (make-reflowed-textbox -1 -1 info-text | ||
| 283 | info-textbox-width | ||
| 284 | #:flags FLAG-BORDER)) | ||
| 285 | (scale (make-scale -1 -1 scale-width scale-full-value)) | ||
| 286 | (grid (vertically-stacked-grid | ||
| 287 | GRID-ELEMENT-COMPONENT info-textbox | ||
| 288 | GRID-ELEMENT-COMPONENT scale)) | ||
| 289 | (form (make-form))) | ||
| 290 | |||
| 291 | (add-form-to-grid grid form #t) | ||
| 292 | (make-wrapped-grid-window grid title) | ||
| 293 | |||
| 294 | (draw-form form) | ||
| 295 | ;; This call is imperative, otherwise the form won't be displayed. See the | ||
| 296 | ;; explanation in the above commentary. | ||
| 297 | (newt-refresh) | ||
| 298 | |||
| 299 | (dynamic-wind | ||
| 300 | (const #t) | ||
| 301 | (lambda () | ||
| 302 | (let loop ((i max-scale-update) | ||
| 303 | (last-value 0)) | ||
| 304 | (let ((value (scale-update-proc last-value))) | ||
| 305 | (set-scale-value scale value) | ||
| 306 | ;; Same as above. | ||
| 307 | (newt-refresh) | ||
| 308 | (unless (>= value scale-full-value) | ||
| 309 | (if (> i 0) | ||
| 310 | (loop (- i 1) value) | ||
| 311 | (error "Max scale updates reached.")))))) | ||
| 312 | (lambda () | ||
| 313 | (destroy-form-and-pop form))))) | ||
diff --git a/gnu/installer/newt/timezone.scm b/gnu/installer/newt/timezone.scm new file mode 100644 index 00000000000..a2c9b458f51 --- /dev/null +++ b/gnu/installer/newt/timezone.scm | |||
| @@ -0,0 +1,83 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer newt timezone) | ||
| 20 | #:use-module (gnu installer steps) | ||
| 21 | #:use-module (gnu installer timezone) | ||
| 22 | #:use-module (gnu installer newt page) | ||
| 23 | #:use-module (guix i18n) | ||
| 24 | #:use-module (srfi srfi-1) | ||
| 25 | #:use-module (srfi srfi-26) | ||
| 26 | #:use-module (srfi srfi-34) | ||
| 27 | #:use-module (srfi srfi-35) | ||
| 28 | #:use-module (ice-9 match) | ||
| 29 | #:use-module (ice-9 receive) | ||
| 30 | #:use-module (newt) | ||
| 31 | #:export (run-timezone-page)) | ||
| 32 | |||
| 33 | ;; Heigth of the listbox displaying timezones. | ||
| 34 | (define timezone-listbox-heigth (make-parameter 20)) | ||
| 35 | |||
| 36 | ;; Information textbox width. | ||
| 37 | (define info-textbox-width (make-parameter 40)) | ||
| 38 | |||
| 39 | (define (fill-timezones listbox timezones) | ||
| 40 | "Fill the given LISTBOX with TIMEZONES. Return an association list | ||
| 41 | correlating listbox keys with timezones." | ||
| 42 | (map (lambda (timezone) | ||
| 43 | (let ((key (append-entry-to-listbox listbox timezone))) | ||
| 44 | (cons key timezone))) | ||
| 45 | timezones)) | ||
| 46 | |||
| 47 | (define (run-timezone-page zonetab) | ||
| 48 | "Run a page displaying available timezones, grouped by regions. The user is | ||
| 49 | invited to select a timezone. The selected timezone, under Posix format is | ||
| 50 | returned." | ||
| 51 | (define (all-but-last list) | ||
| 52 | (reverse (cdr (reverse list)))) | ||
| 53 | |||
| 54 | (define (run-page timezone-tree) | ||
| 55 | (define (loop path) | ||
| 56 | (let ((timezones (locate-childrens timezone-tree path))) | ||
| 57 | (run-listbox-selection-page | ||
| 58 | #:title (G_ "Timezone selection") | ||
| 59 | #:info-text (G_ "Please select a timezone.") | ||
| 60 | #:listbox-items timezones | ||
| 61 | #:listbox-item->text identity | ||
| 62 | #:button-text (if (null? path) | ||
| 63 | (G_ "Cancel") | ||
| 64 | (G_ "Back")) | ||
| 65 | #:button-callback-procedure | ||
| 66 | (if (null? path) | ||
| 67 | (lambda _ | ||
| 68 | (raise | ||
| 69 | (condition | ||
| 70 | (&installer-step-abort)))) | ||
| 71 | (lambda _ | ||
| 72 | (loop (all-but-last path)))) | ||
| 73 | #:listbox-callback-procedure | ||
| 74 | (lambda (timezone) | ||
| 75 | (let* ((timezone* (append path (list timezone))) | ||
| 76 | (tz (timezone->posix-tz timezone*))) | ||
| 77 | (if (timezone-has-child? timezone-tree timezone*) | ||
| 78 | (loop timezone*) | ||
| 79 | tz)))))) | ||
| 80 | (loop '())) | ||
| 81 | |||
| 82 | (let ((timezone-tree (zonetab->timezone-tree zonetab))) | ||
| 83 | (run-page timezone-tree))) | ||
diff --git a/gnu/installer/newt/user.scm b/gnu/installer/newt/user.scm new file mode 100644 index 00000000000..f342caae043 --- /dev/null +++ b/gnu/installer/newt/user.scm | |||
| @@ -0,0 +1,181 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer newt user) | ||
| 20 | #:use-module (gnu installer newt page) | ||
| 21 | #:use-module (gnu installer newt utils) | ||
| 22 | #:use-module (guix i18n) | ||
| 23 | #:use-module (newt) | ||
| 24 | #:use-module (ice-9 match) | ||
| 25 | #:use-module (ice-9 receive) | ||
| 26 | #:use-module (srfi srfi-1) | ||
| 27 | #:use-module (srfi srfi-26) | ||
| 28 | #:export (run-user-page)) | ||
| 29 | |||
| 30 | (define (run-user-add-page) | ||
| 31 | (define (pad-label label) | ||
| 32 | (string-pad-right label 20)) | ||
| 33 | |||
| 34 | (let* ((label-name | ||
| 35 | (make-label -1 -1 (pad-label (G_ "Name")))) | ||
| 36 | (label-group | ||
| 37 | (make-label -1 -1 (pad-label (G_ "Group")))) | ||
| 38 | (label-home-directory | ||
| 39 | (make-label -1 -1 (pad-label (G_ "Home directory")))) | ||
| 40 | (entry-width 30) | ||
| 41 | (entry-name (make-entry -1 -1 entry-width)) | ||
| 42 | (entry-group (make-entry -1 -1 entry-width | ||
| 43 | #:initial-value "users")) | ||
| 44 | (entry-home-directory (make-entry -1 -1 entry-width)) | ||
| 45 | (entry-grid (make-grid 2 3)) | ||
| 46 | (button-grid (make-grid 1 1)) | ||
| 47 | (ok-button (make-button -1 -1 (G_ "Ok"))) | ||
| 48 | (grid (make-grid 1 2)) | ||
| 49 | (title (G_ "User creation")) | ||
| 50 | (set-entry-grid-field | ||
| 51 | (cut set-grid-field entry-grid <> <> GRID-ELEMENT-COMPONENT <>)) | ||
| 52 | (form (make-form))) | ||
| 53 | |||
| 54 | (set-entry-grid-field 0 0 label-name) | ||
| 55 | (set-entry-grid-field 1 0 entry-name) | ||
| 56 | (set-entry-grid-field 0 1 label-group) | ||
| 57 | (set-entry-grid-field 1 1 entry-group) | ||
| 58 | (set-entry-grid-field 0 2 label-home-directory) | ||
| 59 | (set-entry-grid-field 1 2 entry-home-directory) | ||
| 60 | |||
| 61 | (set-grid-field button-grid 0 0 GRID-ELEMENT-COMPONENT ok-button) | ||
| 62 | |||
| 63 | (add-component-callback | ||
| 64 | entry-name | ||
| 65 | (lambda (component) | ||
| 66 | (set-entry-text entry-home-directory | ||
| 67 | (string-append "/home/" (entry-value entry-name))))) | ||
| 68 | |||
| 69 | (add-components-to-form form | ||
| 70 | label-name label-group label-home-directory | ||
| 71 | entry-name entry-group entry-home-directory | ||
| 72 | ok-button) | ||
| 73 | |||
| 74 | (make-wrapped-grid-window (vertically-stacked-grid | ||
| 75 | GRID-ELEMENT-SUBGRID entry-grid | ||
| 76 | GRID-ELEMENT-SUBGRID button-grid) | ||
| 77 | title) | ||
| 78 | (let ((error-page | ||
| 79 | (lambda () | ||
| 80 | (run-error-page (G_ "Empty inputs are not allowed") | ||
| 81 | (G_ "Empty input"))))) | ||
| 82 | (receive (exit-reason argument) | ||
| 83 | (run-form form) | ||
| 84 | (dynamic-wind | ||
| 85 | (const #t) | ||
| 86 | (lambda () | ||
| 87 | (when (eq? exit-reason 'exit-component) | ||
| 88 | (cond | ||
| 89 | ((components=? argument ok-button) | ||
| 90 | (let ((name (entry-value entry-name)) | ||
| 91 | (group (entry-value entry-group)) | ||
| 92 | (home-directory (entry-value entry-home-directory))) | ||
| 93 | (if (or (string=? name "") | ||
| 94 | (string=? group "") | ||
| 95 | (string=? home-directory "")) | ||
| 96 | (begin | ||
| 97 | (error-page) | ||
| 98 | (run-user-add-page)) | ||
| 99 | `((name . ,name) | ||
| 100 | (group . ,group) | ||
| 101 | (home-directory . ,home-directory)))))))) | ||
| 102 | (lambda () | ||
| 103 | (destroy-form-and-pop form))))))) | ||
| 104 | |||
| 105 | (define (run-user-page) | ||
| 106 | (define (run users) | ||
| 107 | (let* ((listbox (make-listbox | ||
| 108 | -1 -1 10 | ||
| 109 | (logior FLAG-SCROLL FLAG-BORDER))) | ||
| 110 | (info-textbox | ||
| 111 | (make-reflowed-textbox | ||
| 112 | -1 -1 | ||
| 113 | (G_ "Please add at least one user to system\ | ||
| 114 | using the 'Add' button.") | ||
| 115 | 40 #:flags FLAG-BORDER)) | ||
| 116 | (add-button (make-compact-button -1 -1 (G_ "Add"))) | ||
| 117 | (del-button (make-compact-button -1 -1 (G_ "Delete"))) | ||
| 118 | (listbox-button-grid | ||
| 119 | (apply | ||
| 120 | vertically-stacked-grid | ||
| 121 | GRID-ELEMENT-COMPONENT add-button | ||
| 122 | `(,@(if (null? users) | ||
| 123 | '() | ||
| 124 | (list GRID-ELEMENT-COMPONENT del-button))))) | ||
| 125 | (ok-button (make-button -1 -1 (G_ "Ok"))) | ||
| 126 | (cancel-button (make-button -1 -1 (G_ "Cancel"))) | ||
| 127 | (title "User selection") | ||
| 128 | (grid | ||
| 129 | (vertically-stacked-grid | ||
| 130 | GRID-ELEMENT-COMPONENT info-textbox | ||
| 131 | GRID-ELEMENT-SUBGRID (horizontal-stacked-grid | ||
| 132 | GRID-ELEMENT-COMPONENT listbox | ||
| 133 | GRID-ELEMENT-SUBGRID listbox-button-grid) | ||
| 134 | GRID-ELEMENT-SUBGRID (horizontal-stacked-grid | ||
| 135 | GRID-ELEMENT-COMPONENT ok-button | ||
| 136 | GRID-ELEMENT-COMPONENT cancel-button))) | ||
| 137 | (sorted-users (sort users (lambda (a b) | ||
| 138 | (string<= (assoc-ref a 'name) | ||
| 139 | (assoc-ref b 'name))))) | ||
| 140 | (listbox-elements | ||
| 141 | (map | ||
| 142 | (lambda (user) | ||
| 143 | `((key . ,(append-entry-to-listbox listbox | ||
| 144 | (assoc-ref user 'name))) | ||
| 145 | (user . ,user))) | ||
| 146 | sorted-users)) | ||
| 147 | (form (make-form))) | ||
| 148 | |||
| 149 | |||
| 150 | (add-form-to-grid grid form #t) | ||
| 151 | (make-wrapped-grid-window grid title) | ||
| 152 | (if (null? users) | ||
| 153 | (set-current-component form add-button) | ||
| 154 | (set-current-component form ok-button)) | ||
| 155 | |||
| 156 | (receive (exit-reason argument) | ||
| 157 | (run-form form) | ||
| 158 | (dynamic-wind | ||
| 159 | (const #t) | ||
| 160 | (lambda () | ||
| 161 | (when (eq? exit-reason 'exit-component) | ||
| 162 | (cond | ||
| 163 | ((components=? argument add-button) | ||
| 164 | (run (cons (run-user-add-page) users))) | ||
| 165 | ((components=? argument del-button) | ||
| 166 | (let* ((current-user-key (current-listbox-entry listbox)) | ||
| 167 | (users | ||
| 168 | (map (cut assoc-ref <> 'user) | ||
| 169 | (remove (lambda (element) | ||
| 170 | (equal? (assoc-ref element 'key) | ||
| 171 | current-user-key)) | ||
| 172 | listbox-elements)))) | ||
| 173 | (run users))) | ||
| 174 | ((components=? argument ok-button) | ||
| 175 | (when (null? users) | ||
| 176 | (run-error-page (G_ "Please create at least one user.") | ||
| 177 | (G_ "No user")) | ||
| 178 | (run users)))))) | ||
| 179 | (lambda () | ||
| 180 | (destroy-form-and-pop form)))))) | ||
| 181 | (run '())) | ||
diff --git a/gnu/installer/newt/utils.scm b/gnu/installer/newt/utils.scm new file mode 100644 index 00000000000..1c2ce4e6283 --- /dev/null +++ b/gnu/installer/newt/utils.scm | |||
| @@ -0,0 +1,43 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer newt utils) | ||
| 20 | #:use-module (ice-9 receive) | ||
| 21 | #:use-module (newt) | ||
| 22 | #:export (screen-columns | ||
| 23 | screen-rows | ||
| 24 | |||
| 25 | destroy-form-and-pop | ||
| 26 | set-screen-size!)) | ||
| 27 | |||
| 28 | ;; Number of columns and rows of the terminal. | ||
| 29 | (define screen-columns (make-parameter 0)) | ||
| 30 | (define screen-rows (make-parameter 0)) | ||
| 31 | |||
| 32 | (define (destroy-form-and-pop form) | ||
| 33 | "Destory the given FORM and pop the current window." | ||
| 34 | (destroy-form form) | ||
| 35 | (pop-window)) | ||
| 36 | |||
| 37 | (define (set-screen-size!) | ||
| 38 | "Set the parameters 'screen-columns' and 'screen-rows' to the number of | ||
| 39 | columns and rows respectively of the current terminal." | ||
| 40 | (receive (columns rows) | ||
| 41 | (screen-size) | ||
| 42 | (screen-columns columns) | ||
| 43 | (screen-rows rows))) | ||
diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm new file mode 100644 index 00000000000..8ed9f68918b --- /dev/null +++ b/gnu/installer/newt/welcome.scm | |||
| @@ -0,0 +1,122 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | |||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer newt welcome) | ||
| 20 | #:use-module (gnu installer utils) | ||
| 21 | #:use-module (gnu installer newt utils) | ||
| 22 | #:use-module (guix build syscalls) | ||
| 23 | #:use-module (guix i18n) | ||
| 24 | #:use-module (ice-9 match) | ||
| 25 | #:use-module (ice-9 receive) | ||
| 26 | #:use-module (newt) | ||
| 27 | #:export (run-welcome-page)) | ||
| 28 | |||
| 29 | ;; Margin between screen border and newt root window. | ||
| 30 | (define margin-left (make-parameter 3)) | ||
| 31 | (define margin-top (make-parameter 3)) | ||
| 32 | |||
| 33 | ;; Expected width and height for the logo. | ||
| 34 | (define logo-width (make-parameter 50)) | ||
| 35 | (define logo-height (make-parameter 23)) | ||
| 36 | |||
| 37 | (define (nearest-exact-integer x) | ||
| 38 | "Given a real number X, return the nearest exact integer, with ties going to | ||
| 39 | the nearest exact even integer." | ||
| 40 | (inexact->exact (round x))) | ||
| 41 | |||
| 42 | (define* (run-menu-page title logo | ||
| 43 | #:key | ||
| 44 | listbox-items | ||
| 45 | listbox-item->text) | ||
| 46 | "Run a page with the given TITLE, to ask the user to choose between | ||
| 47 | LISTBOX-ITEMS displayed in a listbox. The listbox items are converted to text | ||
| 48 | using LISTBOX-ITEM->TEXT procedure. Display the textual LOGO in the center of | ||
| 49 | the page. Contrary to other pages, we cannot resort to grid layouts, because | ||
| 50 | we want this page to occupy all the screen space available." | ||
| 51 | (define (fill-listbox listbox items) | ||
| 52 | (map (lambda (item) | ||
| 53 | (let* ((text (listbox-item->text item)) | ||
| 54 | (key (append-entry-to-listbox listbox text))) | ||
| 55 | (cons key item))) | ||
| 56 | items)) | ||
| 57 | |||
| 58 | (let* ((windows | ||
| 59 | (make-window (margin-left) | ||
| 60 | (margin-top) | ||
| 61 | (- (screen-columns) (* 2 (margin-left))) | ||
| 62 | (- (screen-rows) (* 2 (margin-top))) | ||
| 63 | title)) | ||
| 64 | (logo-textbox | ||
| 65 | (make-textbox (nearest-exact-integer | ||
| 66 | (- (/ (screen-columns) 2) | ||
| 67 | (+ (/ (logo-width) 2) (margin-left)))) | ||
| 68 | (margin-top) (logo-width) (logo-height) 0)) | ||
| 69 | (text (set-textbox-text logo-textbox | ||
| 70 | (read-all logo))) | ||
| 71 | (options-listbox | ||
| 72 | (make-listbox (margin-left) | ||
| 73 | (+ (logo-height) (margin-top)) | ||
| 74 | (- (screen-rows) (+ (logo-height) | ||
| 75 | (* (margin-top) 4))) | ||
| 76 | (logior FLAG-BORDER FLAG-RETURNEXIT))) | ||
| 77 | (keys (fill-listbox options-listbox listbox-items)) | ||
| 78 | (form (make-form))) | ||
| 79 | (set-listbox-width options-listbox (- (screen-columns) | ||
| 80 | (* (margin-left) 4))) | ||
| 81 | (add-components-to-form form logo-textbox options-listbox) | ||
| 82 | |||
| 83 | (receive (exit-reason argument) | ||
| 84 | (run-form form) | ||
| 85 | (dynamic-wind | ||
| 86 | (const #t) | ||
| 87 | (lambda () | ||
| 88 | (when (eq? exit-reason 'exit-component) | ||
| 89 | (cond | ||
| 90 | ((components=? argument options-listbox) | ||
| 91 | (let* ((entry (current-listbox-entry options-listbox)) | ||
| 92 | (item (assoc-ref keys entry))) | ||
| 93 | (match item | ||
| 94 | ((text . proc) | ||
| 95 | (proc)))))))) | ||
| 96 | (lambda () | ||
| 97 | (destroy-form-and-pop form)))))) | ||
| 98 | |||
| 99 | (define (run-welcome-page logo) | ||
| 100 | "Run a welcome page with the given textual LOGO displayed at the center of | ||
| 101 | the page. Ask the user to choose between manual installation, graphical | ||
| 102 | installation and reboot." | ||
| 103 | (run-menu-page | ||
| 104 | (G_ "GNU GuixSD install") | ||
| 105 | logo | ||
| 106 | #:listbox-items | ||
| 107 | `((,(G_ "Install using the unguided shell based process") | ||
| 108 | . | ||
| 109 | ,(lambda () | ||
| 110 | (clear-screen) | ||
| 111 | (newt-suspend) | ||
| 112 | (system* "bash" "-l") | ||
| 113 | (newt-resume))) | ||
| 114 | (,(G_ "Graphical install using a guided terminal based interface") | ||
| 115 | . | ||
| 116 | ,(const #t)) | ||
| 117 | (,(G_ "Reboot") | ||
| 118 | . | ||
| 119 | ,(lambda () | ||
| 120 | (newt-finish) | ||
| 121 | (reboot)))) | ||
| 122 | #:listbox-item->text car)) | ||
diff --git a/gnu/installer/newt/wifi.scm b/gnu/installer/newt/wifi.scm new file mode 100644 index 00000000000..6cac54399a3 --- /dev/null +++ b/gnu/installer/newt/wifi.scm | |||
| @@ -0,0 +1,243 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer newt wifi) | ||
| 20 | #:use-module (gnu installer connman) | ||
| 21 | #:use-module (gnu installer steps) | ||
| 22 | #:use-module (gnu installer newt utils) | ||
| 23 | #:use-module (gnu installer newt page) | ||
| 24 | #:use-module (guix i18n) | ||
| 25 | #:use-module (guix records) | ||
| 26 | #:use-module (ice-9 format) | ||
| 27 | #:use-module (ice-9 popen) | ||
| 28 | #:use-module (ice-9 receive) | ||
| 29 | #:use-module (ice-9 regex) | ||
| 30 | #:use-module (ice-9 rdelim) | ||
| 31 | #:use-module (srfi srfi-1) | ||
| 32 | #:use-module (srfi srfi-34) | ||
| 33 | #:use-module (srfi srfi-35) | ||
| 34 | #:use-module (newt) | ||
| 35 | #:export (run-wifi-page)) | ||
| 36 | |||
| 37 | ;; This record associates a connman service to its key the listbox. | ||
| 38 | (define-record-type* <service-item> | ||
| 39 | service-item make-service-item | ||
| 40 | service-item? | ||
| 41 | (service service-item-service) ; connman <service> | ||
| 42 | (key service-item-key)) ; newt listbox-key | ||
| 43 | |||
| 44 | (define (strength->string strength) | ||
| 45 | "Convert STRENGTH as an integer percentage into a text printable strength | ||
| 46 | bar using unicode characters. Taken from NetworkManager's | ||
| 47 | nmc_wifi_strength_bars." | ||
| 48 | (let ((quarter #\x2582) | ||
| 49 | (half #\x2584) | ||
| 50 | (three-quarter #\x2586) | ||
| 51 | (full #\x2588)) | ||
| 52 | (cond | ||
| 53 | ((> strength 80) | ||
| 54 | ;; ▂▄▆█ | ||
| 55 | (string quarter half three-quarter full)) | ||
| 56 | ((> strength 55) | ||
| 57 | ;; ▂▄▆_ | ||
| 58 | (string quarter half three-quarter #\_)) | ||
| 59 | ((> strength 30) | ||
| 60 | ;; ▂▄__ | ||
| 61 | (string quarter half #\_ #\_)) | ||
| 62 | ((> strength 5) | ||
| 63 | ;; ▂___ | ||
| 64 | (string quarter #\_ #\_ #\_)) | ||
| 65 | (else | ||
| 66 | ;; ____ | ||
| 67 | (string quarter #\_ #\_ #\_ #\_))))) | ||
| 68 | |||
| 69 | (define (force-wifi-scan) | ||
| 70 | "Force a wifi scan. Raise a condition if no wifi technology is available." | ||
| 71 | (let* ((technologies (connman-technologies)) | ||
| 72 | (wifi-technology | ||
| 73 | (find (lambda (technology) | ||
| 74 | (string=? (technology-type technology) "wifi")) | ||
| 75 | technologies))) | ||
| 76 | (if wifi-technology | ||
| 77 | (connman-scan-technology wifi-technology) | ||
| 78 | (raise (condition | ||
| 79 | (&message | ||
| 80 | (message (G_ "Unable to find a wifi technology")))))))) | ||
| 81 | |||
| 82 | (define (draw-scanning-page) | ||
| 83 | "Draw a page to indicate a wifi scan in in progress." | ||
| 84 | (draw-info-page (G_ "Scanning wifi for available networks, please wait.") | ||
| 85 | (G_ "Scan in progress"))) | ||
| 86 | |||
| 87 | (define (run-wifi-password-page) | ||
| 88 | "Run a page prompting user for a password and return it." | ||
| 89 | (run-input-page (G_ "Please enter the wifi password") | ||
| 90 | (G_ "Password required"))) | ||
| 91 | |||
| 92 | (define (run-wrong-password-page service-name) | ||
| 93 | "Run a page to inform user of a wrong password input." | ||
| 94 | (run-error-page | ||
| 95 | (format #f (G_ "The password you entered for ~a is incorrect.") | ||
| 96 | service-name) | ||
| 97 | (G_ "Wrong password"))) | ||
| 98 | |||
| 99 | (define (run-unknown-error-page service-name) | ||
| 100 | "Run a page to inform user that a connection error happened." | ||
| 101 | (run-error-page | ||
| 102 | (format #f | ||
| 103 | (G_ "An error occured while trying to connect to ~a, please retry.") | ||
| 104 | service-name) | ||
| 105 | (G_ "Connection error"))) | ||
| 106 | |||
| 107 | (define (password-callback) | ||
| 108 | (run-wifi-password-page)) | ||
| 109 | |||
| 110 | (define (connect-wifi-service listbox service-items) | ||
| 111 | "Connect to the wifi service selected in LISTBOX. SERVICE-ITEMS is the list | ||
| 112 | of <service-item> records present in LISTBOX." | ||
| 113 | (let* ((listbox-key (current-listbox-entry listbox)) | ||
| 114 | (item (find (lambda (item) | ||
| 115 | (eq? (service-item-key item) listbox-key)) | ||
| 116 | service-items)) | ||
| 117 | (service (service-item-service item)) | ||
| 118 | (service-name (service-name service)) | ||
| 119 | (form (draw-connecting-page service-name))) | ||
| 120 | (dynamic-wind | ||
| 121 | (const #t) | ||
| 122 | (lambda () | ||
| 123 | (guard (c ((connman-password-error? c) | ||
| 124 | (run-wrong-password-page service-name) | ||
| 125 | #f) | ||
| 126 | ((connman-already-connected-error? c) | ||
| 127 | #t) | ||
| 128 | ((connman-connection-error? c) | ||
| 129 | (run-unknown-error-page service-name) | ||
| 130 | #f)) | ||
| 131 | (connman-connect-with-auth service password-callback))) | ||
| 132 | (lambda () | ||
| 133 | (destroy-form-and-pop form))))) | ||
| 134 | |||
| 135 | (define (run-wifi-scan-page) | ||
| 136 | "Force a wifi scan and draw a page during the operation." | ||
| 137 | (let ((form (draw-scanning-page))) | ||
| 138 | (force-wifi-scan) | ||
| 139 | (destroy-form-and-pop form))) | ||
| 140 | |||
| 141 | (define (wifi-services) | ||
| 142 | "Return all the connman services of wifi type." | ||
| 143 | (let ((services (connman-services))) | ||
| 144 | (filter (lambda (service) | ||
| 145 | (and (string=? (service-type service) "wifi") | ||
| 146 | (not (string-null? (service-name service))))) | ||
| 147 | services))) | ||
| 148 | |||
| 149 | (define* (fill-wifi-services listbox wifi-services) | ||
| 150 | "Append all the services in WIFI-SERVICES to the given LISTBOX." | ||
| 151 | (clear-listbox listbox) | ||
| 152 | (map (lambda (service) | ||
| 153 | (let* ((text (service->text service)) | ||
| 154 | (key (append-entry-to-listbox listbox text))) | ||
| 155 | (service-item | ||
| 156 | (service service) | ||
| 157 | (key key)))) | ||
| 158 | wifi-services)) | ||
| 159 | |||
| 160 | ;; Maximum length of a wifi service name. | ||
| 161 | (define service-name-max-length (make-parameter 20)) | ||
| 162 | |||
| 163 | ;; Heigth of the listbox displaying wifi services. | ||
| 164 | (define wifi-listbox-heigth (make-parameter 20)) | ||
| 165 | |||
| 166 | ;; Information textbox width. | ||
| 167 | (define info-textbox-width (make-parameter 40)) | ||
| 168 | |||
| 169 | (define (service->text service) | ||
| 170 | "Return a string composed of the name and the strength of the given | ||
| 171 | SERVICE. A '*' preceding the service name indicates that it is connected." | ||
| 172 | (let* ((name (service-name service)) | ||
| 173 | (padded-name (string-pad-right name | ||
| 174 | (service-name-max-length))) | ||
| 175 | (strength (service-strength service)) | ||
| 176 | (strength-string (strength->string strength)) | ||
| 177 | (state (service-state service)) | ||
| 178 | (connected? (or (string=? state "online") | ||
| 179 | (string=? state "ready")))) | ||
| 180 | (format #f "~c ~a ~a~%" | ||
| 181 | (if connected? #\* #\ ) | ||
| 182 | padded-name | ||
| 183 | strength-string))) | ||
| 184 | |||
| 185 | (define (run-wifi-page) | ||
| 186 | "Run a page displaying available wifi networks in a listbox. Connect to the | ||
| 187 | network when the corresponding listbox entry is selected. A button allow to | ||
| 188 | force a wifi scan." | ||
| 189 | (let* ((listbox (make-listbox | ||
| 190 | -1 -1 | ||
| 191 | (wifi-listbox-heigth) | ||
| 192 | (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT))) | ||
| 193 | (form (make-form)) | ||
| 194 | (buttons-grid (make-grid 1 1)) | ||
| 195 | (middle-grid (make-grid 2 1)) | ||
| 196 | (info-text (G_ "Please select a wifi network.")) | ||
| 197 | (info-textbox | ||
| 198 | (make-reflowed-textbox -1 -1 info-text | ||
| 199 | (info-textbox-width) | ||
| 200 | #:flags FLAG-BORDER)) | ||
| 201 | (cancel-button (make-button -1 -1 (G_ "Cancel"))) | ||
| 202 | (scan-button (make-button -1 -1 (G_ "Scan"))) | ||
| 203 | (services (wifi-services)) | ||
| 204 | (service-items '())) | ||
| 205 | |||
| 206 | (if (null? services) | ||
| 207 | (append-entry-to-listbox listbox (G_ "No wifi detected")) | ||
| 208 | (set! service-items (fill-wifi-services listbox services))) | ||
| 209 | |||
| 210 | (set-grid-field middle-grid 0 0 GRID-ELEMENT-COMPONENT listbox) | ||
| 211 | (set-grid-field middle-grid 1 0 GRID-ELEMENT-COMPONENT scan-button | ||
| 212 | #:anchor ANCHOR-TOP | ||
| 213 | #:pad-left 2) | ||
| 214 | (set-grid-field buttons-grid 0 0 GRID-ELEMENT-COMPONENT cancel-button) | ||
| 215 | |||
| 216 | (add-components-to-form form | ||
| 217 | info-textbox | ||
| 218 | listbox scan-button | ||
| 219 | cancel-button) | ||
| 220 | (make-wrapped-grid-window | ||
| 221 | (basic-window-grid info-textbox middle-grid buttons-grid) | ||
| 222 | (G_ "Wifi selection")) | ||
| 223 | |||
| 224 | (receive (exit-reason argument) | ||
| 225 | (run-form form) | ||
| 226 | (dynamic-wind | ||
| 227 | (const #t) | ||
| 228 | (lambda () | ||
| 229 | (when (eq? exit-reason 'exit-component) | ||
| 230 | (cond | ||
| 231 | ((components=? argument scan-button) | ||
| 232 | (run-wifi-scan-page) | ||
| 233 | (run-wifi-page)) | ||
| 234 | ((components=? argument cancel-button) | ||
| 235 | (raise | ||
| 236 | (condition | ||
| 237 | (&installer-step-abort)))) | ||
| 238 | ((components=? argument listbox) | ||
| 239 | (let ((result (connect-wifi-service listbox service-items))) | ||
| 240 | (unless result | ||
| 241 | (run-wifi-page))))))) | ||
| 242 | (lambda () | ||
| 243 | (destroy-form-and-pop form)))))) | ||
diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm new file mode 100644 index 00000000000..5fd54356dd7 --- /dev/null +++ b/gnu/installer/steps.scm | |||
| @@ -0,0 +1,187 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer steps) | ||
| 20 | #:use-module (guix records) | ||
| 21 | #:use-module (ice-9 match) | ||
| 22 | #:use-module (srfi srfi-1) | ||
| 23 | #:use-module (srfi srfi-34) | ||
| 24 | #:use-module (srfi srfi-35) | ||
| 25 | #:export (&installer-step-abort | ||
| 26 | installer-step-abort? | ||
| 27 | |||
| 28 | &installer-step-break | ||
| 29 | installer-step-break? | ||
| 30 | |||
| 31 | <installer-step> | ||
| 32 | installer-step | ||
| 33 | make-installer-step | ||
| 34 | installer-step? | ||
| 35 | installer-step-id | ||
| 36 | installer-step-description | ||
| 37 | installer-step-compute | ||
| 38 | installer-step-configuration-proc | ||
| 39 | |||
| 40 | run-installer-steps | ||
| 41 | find-step-by-id | ||
| 42 | result->step-ids | ||
| 43 | result-step | ||
| 44 | result-step-done?)) | ||
| 45 | |||
| 46 | ;; This condition may be raised to abort the current step. | ||
| 47 | (define-condition-type &installer-step-abort &condition | ||
| 48 | installer-step-abort?) | ||
| 49 | |||
| 50 | ;; This condition may be raised to break out from the steps execution. | ||
| 51 | (define-condition-type &installer-step-break &condition | ||
| 52 | installer-step-break?) | ||
| 53 | |||
| 54 | ;; An installer-step record is basically an id associated to a compute | ||
| 55 | ;; procedure. The COMPUTE procedure takes exactly one argument, an association | ||
| 56 | ;; list containing the results of previously executed installer-steps (see | ||
| 57 | ;; RUN-INSTALLER-STEPS description). The value returned by the COMPUTE | ||
| 58 | ;; procedure will be stored in the results list passed to the next | ||
| 59 | ;; installer-step and so on. | ||
| 60 | (define-record-type* <installer-step> | ||
| 61 | installer-step make-installer-step | ||
| 62 | installer-step? | ||
| 63 | (id installer-step-id) ;symbol | ||
| 64 | (description installer-step-description ;string | ||
| 65 | (default #f)) | ||
| 66 | (compute installer-step-compute) ;procedure | ||
| 67 | (configuration-format-proc installer-step-configuration-proc ;procedure | ||
| 68 | (default #f))) | ||
| 69 | |||
| 70 | (define* (run-installer-steps #:key | ||
| 71 | steps | ||
| 72 | (rewind-strategy 'previous) | ||
| 73 | (menu-proc (const #f))) | ||
| 74 | "Run the COMPUTE procedure of all <installer-step> records in STEPS | ||
| 75 | sequencially. If the &installer-step-abort condition is raised, fallback to a | ||
| 76 | previous install-step, accordingly to the specified REWIND-STRATEGY. | ||
| 77 | |||
| 78 | REWIND-STRATEGY possible values are 'previous, 'menu and 'start. If 'previous | ||
| 79 | is selected, the execution will resume at the previous installer-step. If | ||
| 80 | 'menu is selected, the MENU-PROC procedure will be called. Its return value | ||
| 81 | has to be an installer-step ID to jump to. The ID has to be the one of a | ||
| 82 | previously executed step. It is impossible to jump forward. Finally if 'start | ||
| 83 | is selected, the execution will resume at the first installer-step. | ||
| 84 | |||
| 85 | The result of every COMPUTE procedures is stored in an association list, under | ||
| 86 | the form: | ||
| 87 | |||
| 88 | '((STEP-ID . COMPUTE-RESULT) ...) | ||
| 89 | |||
| 90 | where STEP-ID is the ID field of the installer-step and COMPUTE-RESULT the | ||
| 91 | result of the associated COMPUTE procedure. This result association list is | ||
| 92 | passed as argument of every COMPUTE procedure. It is finally returned when the | ||
| 93 | computation is over. | ||
| 94 | |||
| 95 | If the &installer-step-break condition is raised, stop the computation and | ||
| 96 | return the accumalated result so far." | ||
| 97 | (define (pop-result list) | ||
| 98 | (cdr list)) | ||
| 99 | |||
| 100 | (define (first-step? steps step) | ||
| 101 | (match steps | ||
| 102 | ((first-step . rest-steps) | ||
| 103 | (equal? first-step step)))) | ||
| 104 | |||
| 105 | (define* (skip-to-step step result | ||
| 106 | #:key todo-steps done-steps) | ||
| 107 | (match (list todo-steps done-steps) | ||
| 108 | (((todo . rest-todo) (prev-done ... last-done)) | ||
| 109 | (if (eq? (installer-step-id todo) | ||
| 110 | (installer-step-id step)) | ||
| 111 | (run result | ||
| 112 | #:todo-steps todo-steps | ||
| 113 | #:done-steps done-steps) | ||
| 114 | (skip-to-step step (pop-result result) | ||
| 115 | #:todo-steps (cons last-done todo-steps) | ||
| 116 | #:done-steps prev-done))))) | ||
| 117 | |||
| 118 | (define* (run result #:key todo-steps done-steps) | ||
| 119 | (match todo-steps | ||
| 120 | (() (reverse result)) | ||
| 121 | ((step . rest-steps) | ||
| 122 | (guard (c ((installer-step-abort? c) | ||
| 123 | (case rewind-strategy | ||
| 124 | ((previous) | ||
| 125 | (match done-steps | ||
| 126 | (() | ||
| 127 | ;; We cannot go previous the first step. So re-raise | ||
| 128 | ;; the exception. It might be useful in the case of | ||
| 129 | ;; nested run-installer-steps. Abort to 'raise-above | ||
| 130 | ;; prompt to prevent the condition from being catched | ||
| 131 | ;; by one of the previously installed guard. | ||
| 132 | (abort-to-prompt 'raise-above c)) | ||
| 133 | ((prev-done ... last-done) | ||
| 134 | (run (pop-result result) | ||
| 135 | #:todo-steps (cons last-done todo-steps) | ||
| 136 | #:done-steps prev-done)))) | ||
| 137 | ((menu) | ||
| 138 | (let ((goto-step (menu-proc | ||
| 139 | (append done-steps (list step))))) | ||
| 140 | (if (eq? goto-step step) | ||
| 141 | (run result | ||
| 142 | #:todo-steps todo-steps | ||
| 143 | #:done-steps done-steps) | ||
| 144 | (skip-to-step goto-step result | ||
| 145 | #:todo-steps todo-steps | ||
| 146 | #:done-steps done-steps)))) | ||
| 147 | ((start) | ||
| 148 | (if (null? done-steps) | ||
| 149 | ;; Same as above, it makes no sense to jump to start | ||
| 150 | ;; when we are at the first installer-step. Abort to | ||
| 151 | ;; 'raise-above prompt to re-raise the condition. | ||
| 152 | (abort-to-prompt 'raise-above c) | ||
| 153 | (run '() | ||
| 154 | #:todo-steps steps | ||
| 155 | #:done-steps '()))))) | ||
| 156 | ((installer-step-break? c) | ||
| 157 | (reverse result))) | ||
| 158 | (let* ((id (installer-step-id step)) | ||
| 159 | (compute (installer-step-compute step)) | ||
| 160 | (res (compute result))) | ||
| 161 | (run (alist-cons id res result) | ||
| 162 | #:todo-steps rest-steps | ||
| 163 | #:done-steps (append done-steps (list step)))))))) | ||
| 164 | |||
| 165 | (call-with-prompt 'raise-above | ||
| 166 | (lambda () | ||
| 167 | (run '() | ||
| 168 | #:todo-steps steps | ||
| 169 | #:done-steps '())) | ||
| 170 | (lambda (k condition) | ||
| 171 | (raise condition)))) | ||
| 172 | |||
| 173 | (define (find-step-by-id steps id) | ||
| 174 | "Find and return the step in STEPS whose id is equal to ID." | ||
| 175 | (find (lambda (step) | ||
| 176 | (eq? (installer-step-id step) id)) | ||
| 177 | steps)) | ||
| 178 | |||
| 179 | (define (result-step results step-id) | ||
| 180 | "Return the result of the installer-step specified by STEP-ID in | ||
| 181 | RESULTS." | ||
| 182 | (assoc-ref results step-id)) | ||
| 183 | |||
| 184 | (define (result-step-done? results step-id) | ||
| 185 | "Return #t if the installer-step specified by STEP-ID has a COMPUTE value | ||
| 186 | stored in RESULTS. Return #f otherwise." | ||
| 187 | (and (assoc step-id results) #t)) | ||
diff --git a/gnu/installer/timezone.scm b/gnu/installer/timezone.scm new file mode 100644 index 00000000000..061e8c2e48c --- /dev/null +++ b/gnu/installer/timezone.scm | |||
| @@ -0,0 +1,117 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer timezone) | ||
| 20 | #:use-module (gnu installer utils) | ||
| 21 | #:use-module (guix i18n) | ||
| 22 | #:use-module (srfi srfi-1) | ||
| 23 | #:use-module (srfi srfi-26) | ||
| 24 | #:use-module (srfi srfi-34) | ||
| 25 | #:use-module (srfi srfi-35) | ||
| 26 | #:use-module (ice-9 match) | ||
| 27 | #:use-module (ice-9 receive) | ||
| 28 | #:export (locate-childrens | ||
| 29 | timezone->posix-tz | ||
| 30 | timezone-has-child? | ||
| 31 | zonetab->timezone-tree)) | ||
| 32 | |||
| 33 | (define %not-blank | ||
| 34 | (char-set-complement char-set:blank)) | ||
| 35 | |||
| 36 | (define (posix-tz->timezone tz) | ||
| 37 | "Convert given TZ in Posix format like \"Europe/Paris\" into a list like | ||
| 38 | (\"Europe\" \"Paris\")." | ||
| 39 | (string-split tz #\/)) | ||
| 40 | |||
| 41 | (define (timezone->posix-tz timezone) | ||
| 42 | "Convert given TIMEZONE like (\"Europe\" \"Paris\") into a Posix timezone | ||
| 43 | like \"Europe/Paris\"." | ||
| 44 | (string-join timezone "/")) | ||
| 45 | |||
| 46 | (define (zonetab->timezones zonetab) | ||
| 47 | "Parse ZONETAB file and return the corresponding list of timezones." | ||
| 48 | |||
| 49 | (define (zonetab-line->posix-tz line) | ||
| 50 | (let ((tokens (string-tokenize line %not-blank))) | ||
| 51 | (match tokens | ||
| 52 | ((code coordinates tz _ ...) | ||
| 53 | tz)))) | ||
| 54 | |||
| 55 | (call-with-input-file zonetab | ||
| 56 | (lambda (port) | ||
| 57 | (let* ((lines (read-lines port)) | ||
| 58 | ;; Filter comment lines starting with '#' character. | ||
| 59 | (tz-lines (filter (lambda (line) | ||
| 60 | (not (eq? (string-ref line 0) | ||
| 61 | #\#))) | ||
| 62 | lines))) | ||
| 63 | (map (lambda (line) | ||
| 64 | (posix-tz->timezone | ||
| 65 | (zonetab-line->posix-tz line))) | ||
| 66 | tz-lines))))) | ||
| 67 | |||
| 68 | (define (timezones->timezone-tree timezones) | ||
| 69 | "Convert the list of timezones, TIMEZONES into a tree under the form: | ||
| 70 | |||
| 71 | (\"America\" (\"North_Dakota\" \"New_Salem\" \"Center\")) | ||
| 72 | |||
| 73 | representing America/North_Dakota/New_Salem and America/North_Dakota/Center | ||
| 74 | timezones." | ||
| 75 | |||
| 76 | (define (remove-first lists) | ||
| 77 | "Remove the first element of every sublists in the argument LISTS." | ||
| 78 | (map (lambda (list) | ||
| 79 | (if (null? list) list (cdr list))) | ||
| 80 | lists)) | ||
| 81 | |||
| 82 | (let loop ((cur-timezones timezones)) | ||
| 83 | (match cur-timezones | ||
| 84 | (() '()) | ||
| 85 | (((region . rest-region) . rest-timezones) | ||
| 86 | (if (null? rest-region) | ||
| 87 | (cons (list region) (loop rest-timezones)) | ||
| 88 | (receive (same-region other-region) | ||
| 89 | (partition (lambda (timezone) | ||
| 90 | (string=? (car timezone) region)) | ||
| 91 | cur-timezones) | ||
| 92 | (acons region | ||
| 93 | (loop (remove-first same-region)) | ||
| 94 | (loop other-region)))))))) | ||
| 95 | |||
| 96 | (define (locate-childrens tree path) | ||
| 97 | "Return the childrens of the timezone indicated by PATH in the given | ||
| 98 | TREE. Raise a condition if the PATH could not be found." | ||
| 99 | (let ((extract-proc (cut map car <>))) | ||
| 100 | (match path | ||
| 101 | (() (sort (extract-proc tree) string<?)) | ||
| 102 | ((region . rest) | ||
| 103 | (or (and=> (assoc-ref tree region) | ||
| 104 | (cut locate-childrens <> rest)) | ||
| 105 | (raise | ||
| 106 | (condition | ||
| 107 | (&message | ||
| 108 | (message | ||
| 109 | (format #f (G_ "Unable to locate path: ~a.") path)))))))))) | ||
| 110 | |||
| 111 | (define (timezone-has-child? tree timezone) | ||
| 112 | "Return #t if the given TIMEZONE any child in TREE and #f otherwise." | ||
| 113 | (not (null? (locate-childrens tree timezone)))) | ||
| 114 | |||
| 115 | (define* (zonetab->timezone-tree zonetab) | ||
| 116 | "Return the timezone tree corresponding to the given ZONETAB file." | ||
| 117 | (timezones->timezone-tree (zonetab->timezones zonetab))) | ||
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm new file mode 100644 index 00000000000..50876837151 --- /dev/null +++ b/gnu/installer/utils.scm | |||
| @@ -0,0 +1,37 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (gnu installer utils) | ||
| 20 | #:use-module (ice-9 rdelim) | ||
| 21 | #:use-module (ice-9 textual-ports) | ||
| 22 | #:export (read-lines | ||
| 23 | read-all)) | ||
| 24 | |||
| 25 | (define* (read-lines #:optional (port (current-input-port))) | ||
| 26 | "Read lines from PORT and return them as a list." | ||
| 27 | (let loop ((line (read-line port)) | ||
| 28 | (lines '())) | ||
| 29 | (if (eof-object? line) | ||
| 30 | (reverse lines) | ||
| 31 | (loop (read-line port) | ||
| 32 | (cons line lines))))) | ||
| 33 | |||
| 34 | (define (read-all file) | ||
| 35 | "Return the content of the given FILE as a string." | ||
| 36 | (call-with-input-file file | ||
| 37 | get-string-all)) | ||
diff --git a/gnu/local.mk b/gnu/local.mk index 1268e0c600a..3e6d30d8e92 100644 --- a/gnu/local.mk +++ b/gnu/local.mk | |||
| @@ -543,6 +543,28 @@ GNU_SYSTEM_MODULES = \ | |||
| 543 | %D%/build/marionette.scm \ | 543 | %D%/build/marionette.scm \ |
| 544 | %D%/build/vm.scm \ | 544 | %D%/build/vm.scm \ |
| 545 | \ | 545 | \ |
| 546 | %D%/installer.scm \ | ||
| 547 | %D%/installer/build-installer.scm \ | ||
| 548 | %D%/installer/connman.scm \ | ||
| 549 | %D%/installer/keymap.scm \ | ||
| 550 | %D%/installer/locale.scm \ | ||
| 551 | %D%/installer/newt.scm \ | ||
| 552 | %D%/installer/steps.scm \ | ||
| 553 | %D%/installer/timezone.scm \ | ||
| 554 | %D%/installer/utils.scm \ | ||
| 555 | \ | ||
| 556 | %D%/installer/newt/ethernet.scm \ | ||
| 557 | %D%/installer/newt/hostname.scm \ | ||
| 558 | %D%/installer/newt/keymap.scm \ | ||
| 559 | %D%/installer/newt/locale.scm \ | ||
| 560 | %D%/installer/newt/menu.scm \ | ||
| 561 | %D%/installer/newt/network.scm \ | ||
| 562 | %D%/installer/newt/page.scm \ | ||
| 563 | %D%/installer/newt/timezone.scm \ | ||
| 564 | %D%/installer/newt/utils.scm \ | ||
| 565 | %D%/installer/newt/welcome.scm \ | ||
| 566 | %D%/installer/newt/wifi.scm \ | ||
| 567 | \ | ||
| 546 | %D%/tests.scm \ | 568 | %D%/tests.scm \ |
| 547 | %D%/tests/audio.scm \ | 569 | %D%/tests/audio.scm \ |
| 548 | %D%/tests/base.scm \ | 570 | %D%/tests/base.scm \ |
diff --git a/gnu/system.scm b/gnu/system.scm index 09ee88d433c..e6c86cb9ba5 100644 --- a/gnu/system.scm +++ b/gnu/system.scm | |||
| @@ -119,6 +119,7 @@ | |||
| 119 | boot-parameters->menu-entry | 119 | boot-parameters->menu-entry |
| 120 | 120 | ||
| 121 | local-host-aliases | 121 | local-host-aliases |
| 122 | %root-account | ||
| 122 | %setuid-programs | 123 | %setuid-programs |
| 123 | %base-packages | 124 | %base-packages |
| 124 | %base-firmware)) | 125 | %base-firmware)) |
diff --git a/gnu/system/install.scm b/gnu/system/install.scm index 3aded93f385..05f3795b818 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm | |||
| @@ -22,16 +22,23 @@ | |||
| 22 | 22 | ||
| 23 | (define-module (gnu system install) | 23 | (define-module (gnu system install) |
| 24 | #:use-module (gnu) | 24 | #:use-module (gnu) |
| 25 | #:use-module (gnu system) | ||
| 25 | #:use-module (gnu bootloader u-boot) | 26 | #:use-module (gnu bootloader u-boot) |
| 26 | #:use-module (guix gexp) | 27 | #:use-module (guix gexp) |
| 27 | #:use-module (guix store) | 28 | #:use-module (guix store) |
| 28 | #:use-module (guix monads) | 29 | #:use-module (guix monads) |
| 29 | #:use-module ((guix store) #:select (%store-prefix)) | 30 | #:use-module ((guix store) #:select (%store-prefix)) |
| 31 | #:use-module (gnu installer newt) | ||
| 32 | #:use-module (gnu installer build-installer) | ||
| 33 | #:use-module (gnu services dbus) | ||
| 34 | #:use-module (gnu services networking) | ||
| 30 | #:use-module (gnu services shepherd) | 35 | #:use-module (gnu services shepherd) |
| 31 | #:use-module (gnu services ssh) | 36 | #:use-module (gnu services ssh) |
| 32 | #:use-module (gnu packages admin) | 37 | #:use-module (gnu packages admin) |
| 33 | #:use-module (gnu packages bash) | 38 | #:use-module (gnu packages bash) |
| 34 | #:use-module (gnu packages bootloaders) | 39 | #:use-module (gnu packages bootloaders) |
| 40 | #:use-module (gnu packages fonts) | ||
| 41 | #:use-module (gnu packages fontutils) | ||
| 35 | #:use-module (gnu packages guile) | 42 | #:use-module (gnu packages guile) |
| 36 | #:use-module (gnu packages linux) | 43 | #:use-module (gnu packages linux) |
| 37 | #:use-module (gnu packages ssh) | 44 | #:use-module (gnu packages ssh) |
| @@ -202,120 +209,114 @@ the user's target storage device rather than on the RAM disk." | |||
| 202 | (persistent? #f) | 209 | (persistent? #f) |
| 203 | (max-database-size (* 5 (expt 2 20)))))) ;5 MiB | 210 | (max-database-size (* 5 (expt 2 20)))))) ;5 MiB |
| 204 | 211 | ||
| 212 | (define (normal-tty tty) | ||
| 213 | (service kmscon-service-type | ||
| 214 | (kmscon-configuration | ||
| 215 | (virtual-terminal tty) | ||
| 216 | (auto-login "root")))) | ||
| 217 | |||
| 218 | (define bare-bones-os | ||
| 219 | (load "examples/bare-bones.tmpl")) | ||
| 220 | |||
| 205 | (define %installation-services | 221 | (define %installation-services |
| 206 | ;; List of services of the installation system. | 222 | ;; List of services of the installation system. |
| 207 | (let ((motd (plain-file "motd" " | 223 | (list (login-service (login-configuration |
| 208 | \x1b[1;37mWelcome to the installation of the Guix System Distribution!\x1b[0m | 224 | ;; The motd is overlapped by the graphical installer, |
| 209 | 225 | ;; so make sure it is not printed. | |
| 210 | \x1b[2mThere is NO WARRANTY, to the extent permitted by law. In particular, you may | 226 | (motd #f))) |
| 211 | LOSE ALL YOUR DATA as a side effect of the installation process. Furthermore, | 227 | |
| 212 | it is 'beta' software, so it may contain bugs. | 228 | ;; This will be the active virtual terminal at boot. The graphical |
| 213 | 229 | ;; installer is launched as the 'shell' program of the root | |
| 214 | You have been warned. Thanks for being so brave.\x1b[0m | 230 | ;; user-account. Thanks to auto-login, it will be started |
| 215 | "))) | 231 | ;; automatically. Another option would have been to set the graphical |
| 216 | (define (normal-tty tty) | 232 | ;; installer as a login program. However, it is preferable to wait |
| 217 | (mingetty-service (mingetty-configuration (tty tty) | 233 | ;; for the login phase to be over, so that the environnment variables |
| 218 | (auto-login "root") | 234 | ;; of /etc/environment like LANG are loaded by PAM. |
| 219 | (login-pause? #t)))) | 235 | (normal-tty "tty1") |
| 220 | 236 | ||
| 221 | (define bare-bones-os | 237 | ;; Documentation. |
| 222 | (load "examples/bare-bones.tmpl")) | 238 | (service kmscon-service-type |
| 223 | 239 | (kmscon-configuration | |
| 224 | (list (service virtual-terminal-service-type) | 240 | (virtual-terminal "tty2") |
| 225 | 241 | (login-program (log-to-info)) | |
| 226 | (mingetty-service (mingetty-configuration | 242 | (auto-login "guest"))) |
| 227 | (tty "tty1") | 243 | |
| 228 | (auto-login "root"))) | 244 | ;; Documentation add-on. |
| 229 | 245 | %configuration-template-service | |
| 230 | (login-service (login-configuration | 246 | |
| 231 | (motd motd))) | 247 | ;; A bunch of 'root' ttys. |
| 232 | 248 | (normal-tty "tty3") | |
| 233 | ;; Documentation. The manual is in UTF-8, but | 249 | (normal-tty "tty4") |
| 234 | ;; 'console-font-service' sets up Unicode support and loads a font | 250 | (normal-tty "tty5") |
| 235 | ;; with all the useful glyphs like em dash and quotation marks. | 251 | (normal-tty "tty6") |
| 236 | (mingetty-service (mingetty-configuration | 252 | |
| 237 | (tty "tty2") | 253 | ;; The usual services. |
| 238 | (auto-login "guest") | 254 | (syslog-service) |
| 239 | (login-program (log-to-info)))) | 255 | |
| 240 | 256 | ;; The build daemon. Register the hydra.gnu.org key as trusted. | |
| 241 | ;; Documentation add-on. | 257 | ;; This allows the installation process to use substitutes by |
| 242 | %configuration-template-service | 258 | ;; default. |
| 243 | 259 | (service guix-service-type | |
| 244 | ;; A bunch of 'root' ttys. | 260 | (guix-configuration (authorize-key? #t))) |
| 245 | (normal-tty "tty3") | 261 | |
| 246 | (normal-tty "tty4") | 262 | ;; Start udev so that useful device nodes are available. |
| 247 | (normal-tty "tty5") | 263 | ;; Use device-mapper rules for cryptsetup & co; enable the CRDA for |
| 248 | (normal-tty "tty6") | 264 | ;; regulations-compliant WiFi access. |
| 249 | 265 | (udev-service #:rules (list lvm2 crda)) | |
| 250 | ;; The usual services. | 266 | |
| 251 | (syslog-service) | 267 | ;; Add the 'cow-store' service, which users have to start manually |
| 252 | 268 | ;; since it takes the installation directory as an argument. | |
| 253 | ;; The build daemon. Register the official server keys as trusted. | 269 | (cow-store-service) |
| 254 | ;; This allows the installation process to use substitutes by | 270 | |
| 255 | ;; default. | 271 | ;; To facilitate copy/paste. |
| 256 | (service guix-service-type | 272 | (service gpm-service-type) |
| 257 | (guix-configuration (authorize-key? #t))) | 273 | |
| 258 | 274 | ;; Add an SSH server to facilitate remote installs. | |
| 259 | ;; Start udev so that useful device nodes are available. | 275 | (service openssh-service-type |
| 260 | ;; Use device-mapper rules for cryptsetup & co; enable the CRDA for | 276 | (openssh-configuration |
| 261 | ;; regulations-compliant WiFi access. | 277 | (port-number 22) |
| 262 | (udev-service #:rules (list lvm2 crda)) | 278 | (permit-root-login #t) |
| 263 | 279 | ;; The root account is passwordless, so make sure | |
| 264 | ;; Add the 'cow-store' service, which users have to start manually | 280 | ;; a password is set before allowing logins. |
| 265 | ;; since it takes the installation directory as an argument. | 281 | (allow-empty-passwords? #f) |
| 266 | (cow-store-service) | 282 | (password-authentication? #t) |
| 267 | 283 | ||
| 268 | ;; Install Unicode support and a suitable font. Use a font that | 284 | ;; Don't start it upfront. |
| 269 | ;; doesn't have more than 256 glyphs so that we can use colors with | 285 | (%auto-start? #f))) |
| 270 | ;; varying brightness levels (see note in setfont(8)). | 286 | |
| 271 | (service console-font-service-type | 287 | ;; Since this is running on a USB stick with a overlayfs as the root |
| 272 | (map (lambda (tty) | 288 | ;; file system, use an appropriate cache configuration. |
| 273 | (cons tty "lat9u-16")) | 289 | (nscd-service (nscd-configuration |
| 274 | '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6"))) | 290 | (caches %nscd-minimal-caches))) |
| 275 | 291 | ||
| 276 | ;; To facilitate copy/paste. | 292 | ;; Having /bin/sh is a good idea. In particular it allows Tramp |
| 277 | (service gpm-service-type) | 293 | ;; connections to this system to work. |
| 278 | 294 | (service special-files-service-type | |
| 279 | ;; Add an SSH server to facilitate remote installs. | 295 | `(("/bin/sh" ,(file-append (canonical-package bash) |
| 280 | (service openssh-service-type | 296 | "/bin/sh")))) |
| 281 | (openssh-configuration | 297 | |
| 282 | (port-number 22) | 298 | ;; Loopback device, needed by OpenSSH notably. |
| 283 | (permit-root-login #t) | 299 | (service static-networking-service-type |
| 284 | ;; The root account is passwordless, so make sure | 300 | (list (static-networking (interface "lo") |
| 285 | ;; a password is set before allowing logins. | 301 | (ip "127.0.0.1") |
| 286 | (allow-empty-passwords? #f) | 302 | (requirement '()) |
| 287 | (password-authentication? #t) | 303 | (provision '(loopback))))) |
| 288 | 304 | ||
| 289 | ;; Don't start it upfront. | 305 | (service wpa-supplicant-service-type) |
| 290 | (%auto-start? #f))) | 306 | (dbus-service) |
| 291 | 307 | (service connman-service-type | |
| 292 | ;; Since this is running on a USB stick with a overlayfs as the root | 308 | (connman-configuration |
| 293 | ;; file system, use an appropriate cache configuration. | 309 | (disable-vpn? #t))) |
| 294 | (nscd-service (nscd-configuration | 310 | |
| 295 | (caches %nscd-minimal-caches))) | 311 | ;; Keep a reference to BARE-BONES-OS to make sure it can be |
| 296 | 312 | ;; installed without downloading/building anything. Also keep the | |
| 297 | ;; Having /bin/sh is a good idea. In particular it allows Tramp | 313 | ;; things needed by 'profile-derivation' to minimize the amount of |
| 298 | ;; connections to this system to work. | 314 | ;; download. |
| 299 | (service special-files-service-type | 315 | (service gc-root-service-type |
| 300 | `(("/bin/sh" ,(file-append (canonical-package bash) | 316 | (list bare-bones-os |
| 301 | "/bin/sh")))) | 317 | glibc-utf8-locales |
| 302 | 318 | texinfo | |
| 303 | ;; Loopback device, needed by OpenSSH notably. | 319 | (canonical-package guile-2.2))))) |
| 304 | (service static-networking-service-type | ||
| 305 | (list (static-networking (interface "lo") | ||
| 306 | (ip "127.0.0.1") | ||
| 307 | (requirement '()) | ||
| 308 | (provision '(loopback))))) | ||
| 309 | |||
| 310 | ;; Keep a reference to BARE-BONES-OS to make sure it can be | ||
| 311 | ;; installed without downloading/building anything. Also keep the | ||
| 312 | ;; things needed by 'profile-derivation' to minimize the amount of | ||
| 313 | ;; download. | ||
| 314 | (service gc-root-service-type | ||
| 315 | (list bare-bones-os | ||
| 316 | glibc-utf8-locales | ||
| 317 | texinfo | ||
| 318 | (canonical-package guile-2.2)))))) | ||
| 319 | 320 | ||
| 320 | (define %issue | 321 | (define %issue |
| 321 | ;; Greeting. | 322 | ;; Greeting. |
| @@ -360,13 +361,18 @@ You have been warned. Thanks for being so brave.\x1b[0m | |||
| 360 | %shared-memory-file-system | 361 | %shared-memory-file-system |
| 361 | %immutable-store))) | 362 | %immutable-store))) |
| 362 | 363 | ||
| 363 | (users (list (user-account | 364 | (users (list |
| 364 | (name "guest") | 365 | (user-account |
| 365 | (group "users") | 366 | (inherit %root-account) |
| 366 | (supplementary-groups '("wheel")) ; allow use of sudo | 367 | ;; Launch the graphical installer. |
| 367 | (password "") | 368 | (shell (installer-program newt-installer))) |
| 368 | (comment "Guest of GNU") | 369 | (user-account |
| 369 | (home-directory "/home/guest")))) | 370 | (name "guest") |
| 371 | (group "users") | ||
| 372 | (supplementary-groups '("wheel")) ; allow use of sudo | ||
| 373 | (password "") | ||
| 374 | (comment "Guest of GNU") | ||
| 375 | (home-directory "/home/guest")))) | ||
| 370 | 376 | ||
| 371 | (issue %issue) | 377 | (issue %issue) |
| 372 | (services %installation-services) | 378 | (services %installation-services) |
| @@ -381,6 +387,8 @@ You have been warned. Thanks for being so brave.\x1b[0m | |||
| 381 | 387 | ||
| 382 | (packages (cons* (canonical-package glibc) ;for 'tzselect' & co. | 388 | (packages (cons* (canonical-package glibc) ;for 'tzselect' & co. |
| 383 | parted gptfdisk ddrescue | 389 | parted gptfdisk ddrescue |
| 390 | fontconfig | ||
| 391 | font-dejavu font-gnu-unifont | ||
| 384 | grub ;mostly so xrefs to its manual work | 392 | grub ;mostly so xrefs to its manual work |
| 385 | cryptsetup | 393 | cryptsetup |
| 386 | mdadm | 394 | mdadm |
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index f7360489c66..585ceeb5c22 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in | |||
| @@ -8,6 +8,27 @@ gnu/services/shepherd.scm | |||
| 8 | gnu/system/mapped-devices.scm | 8 | gnu/system/mapped-devices.scm |
| 9 | gnu/system/shadow.scm | 9 | gnu/system/shadow.scm |
| 10 | guix/import/opam.scm | 10 | guix/import/opam.scm |
| 11 | gnu/installer.scm | ||
| 12 | gnu/installer/build-installer.scm | ||
| 13 | gnu/installer/connman.scm | ||
| 14 | gnu/installer/keymap.scm | ||
| 15 | gnu/installer/locale.scm | ||
| 16 | gnu/installer/newt.scm | ||
| 17 | gnu/installer/newt/ethernet.scm | ||
| 18 | gnu/installer/newt/hostname.scm | ||
| 19 | gnu/installer/newt/keymap.scm | ||
| 20 | gnu/installer/newt/locale.scm | ||
| 21 | gnu/installer/newt/menu.scm | ||
| 22 | gnu/installer/newt/network.scm | ||
| 23 | gnu/installer/newt/page.scm | ||
| 24 | gnu/installer/newt/timezone.scm | ||
| 25 | gnu/installer/newt/user.scm | ||
| 26 | gnu/installer/newt/utils.scm | ||
| 27 | gnu/installer/newt/welcome.scm | ||
| 28 | gnu/installer/newt/wifi.scm | ||
| 29 | gnu/installer/steps.scm | ||
| 30 | gnu/installer/timezone.scm | ||
| 31 | gnu/installer/utils.scm | ||
| 11 | guix/scripts.scm | 32 | guix/scripts.scm |
| 12 | guix/scripts/build.scm | 33 | guix/scripts/build.scm |
| 13 | guix/discovery.scm | 34 | guix/discovery.scm |
