aboutsummaryrefslogtreecommitdiff
path: root/gnu/installer/newt
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/installer/newt')
-rw-r--r--gnu/installer/newt/ethernet.scm80
-rw-r--r--gnu/installer/newt/hostname.scm26
-rw-r--r--gnu/installer/newt/keymap.scm132
-rw-r--r--gnu/installer/newt/locale.scm193
-rw-r--r--gnu/installer/newt/menu.scm44
-rw-r--r--gnu/installer/newt/network.scm159
-rw-r--r--gnu/installer/newt/page.scm313
-rw-r--r--gnu/installer/newt/timezone.scm83
-rw-r--r--gnu/installer/newt/user.scm181
-rw-r--r--gnu/installer/newt/utils.scm43
-rw-r--r--gnu/installer/newt/welcome.scm122
-rw-r--r--gnu/installer/newt/wifi.scm243
12 files changed, 1619 insertions, 0 deletions
diff --git a/gnu/installer/newt/ethernet.scm b/gnu/installer/newt/ethernet.scm
new file mode 100644
index 0000000000..2cbbfddacd
--- /dev/null
+++ b/gnu/installer/newt/ethernet.scm
@@ -0,0 +1,80 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt ethernet)
+ #:use-module (gnu installer connman)
+ #:use-module (gnu installer steps)
+ #:use-module (gnu installer newt utils)
+ #:use-module (gnu installer newt page)
+ #:use-module (guix i18n)
+ #:use-module (ice-9 format)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (newt)
+ #:export (run-ethernet-page))
+
+(define (ethernet-services)
+ "Return all the connman services of ethernet type."
+ (let ((services (connman-services)))
+ (filter (lambda (service)
+ (and (string=? (service-type service) "ethernet")
+ (not (string-null? (service-name service)))))
+ services)))
+
+(define (ethernet-service->text service)
+ "Return a string describing the given ethernet SERVICE."
+ (let* ((name (service-name service))
+ (path (service-path service))
+ (full-name (string-append name "-" path))
+ (state (service-state service))
+ (connected? (or (string=? state "online")
+ (string=? state "ready"))))
+ (format #f "~c ~a~%"
+ (if connected? #\* #\ )
+ full-name)))
+
+(define (connect-ethernet-service service)
+ "Connect to the given ethernet SERVICE. Display a connecting page while the
+connection is pending."
+ (let* ((service-name (service-name service))
+ (form (draw-connecting-page service-name)))
+ (connman-connect service)
+ (destroy-form-and-pop form)))
+
+(define (run-ethernet-page)
+ (let ((services (ethernet-services)))
+ (if (null? services)
+ (begin
+ (run-error-page
+ (G_ "No ethernet service available, please try again.")
+ (G_ "No service"))
+ (raise
+ (condition
+ (&installer-step-abort))))
+ (run-listbox-selection-page
+ #:info-text (G_ "Please select an ethernet network.")
+ #:title (G_ "Ethernet connection")
+ #:listbox-items services
+ #:listbox-item->text ethernet-service->text
+ #:button-text (G_ "Cancel")
+ #:button-callback-procedure
+ (lambda _
+ (raise
+ (condition
+ (&installer-step-abort))))
+ #:listbox-callback-procedure connect-ethernet-service))))
diff --git a/gnu/installer/newt/hostname.scm b/gnu/installer/newt/hostname.scm
new file mode 100644
index 0000000000..acbee64a6a
--- /dev/null
+++ b/gnu/installer/newt/hostname.scm
@@ -0,0 +1,26 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt hostname)
+ #:use-module (gnu installer newt page)
+ #:use-module (guix i18n)
+ #:export (run-hostname-page))
+
+(define (run-hostname-page)
+ (run-input-page (G_ "Please enter the system hostname")
+ (G_ "Hostname selection")))
diff --git a/gnu/installer/newt/keymap.scm b/gnu/installer/newt/keymap.scm
new file mode 100644
index 0000000000..219ac3f8e2
--- /dev/null
+++ b/gnu/installer/newt/keymap.scm
@@ -0,0 +1,132 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt keymap)
+ #:use-module (gnu installer keymap)
+ #:use-module (gnu installer steps)
+ #:use-module (gnu installer newt page)
+ #:use-module (guix i18n)
+ #:use-module (guix records)
+ #:use-module (newt)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:export (run-keymap-page))
+
+(define (run-layout-page layouts layout->text)
+ (let ((title (G_ "Layout selection")))
+ (run-listbox-selection-page
+ #:title title
+ #:info-text (G_ "Please choose your keyboard layout.")
+ #:listbox-items layouts
+ #:listbox-item->text layout->text
+ #:button-text (G_ "Cancel")
+ #:button-callback-procedure
+ (lambda _
+ (raise
+ (condition
+ (&installer-step-abort)))))))
+
+(define (run-variant-page variants variant->text)
+ (let ((title (G_ "Variant selection")))
+ (run-listbox-selection-page
+ #:title title
+ #:info-text (G_ "Please choose a variant for your keyboard layout.")
+ #:listbox-items variants
+ #:listbox-item->text variant->text
+ #:button-text (G_ "Back")
+ #:button-callback-procedure
+ (lambda _
+ (raise
+ (condition
+ (&installer-step-abort)))))))
+
+(define (run-model-page models model->text)
+ (let ((title (G_ "Keyboard model selection")))
+ (run-listbox-selection-page
+ #:title title
+ #:info-text (G_ "Please choose your keyboard model.")
+ #:listbox-items models
+ #:listbox-item->text model->text
+ #:listbox-default-item (find (lambda (model)
+ (string=? (x11-keymap-model-name model)
+ "pc105"))
+ models)
+ #:sort-listbox-items? #f
+ #:button-text (G_ "Back")
+ #:button-callback-procedure
+ (lambda _
+ (raise
+ (condition
+ (&installer-step-abort)))))))
+
+(define* (run-keymap-page #:key models layouts)
+ "Run a page asking the user to select a keyboard model, layout and
+variant. MODELS and LAYOUTS are lists of supported X11-KEYMAP-MODEL and
+X11-KEYMAP-LAYOUT. Return a list of three elements, the names of the selected
+keyboard model, layout and variant."
+ (define keymap-steps
+ (list
+ (installer-step
+ (id 'model)
+ (compute
+ (lambda _
+ ;; TODO: Understand why (run-model-page models x11-keymap-model-name)
+ ;; fails with: warning: possibly unbound variable
+ ;; `%x11-keymap-model-description-procedure.
+ (run-model-page models (lambda (model)
+ (x11-keymap-model-description
+ model))))))
+ (installer-step
+ (id 'layout)
+ (compute
+ (lambda _
+ (let* ((layout (run-layout-page
+ layouts
+ (lambda (layout)
+ (x11-keymap-layout-description layout)))))
+ (if (null? (x11-keymap-layout-variants layout))
+ ;; Break if this layout does not have any variant.
+ (raise
+ (condition
+ (&installer-step-break)))
+ layout)))))
+ ;; Propose the user to select a variant among those supported by the
+ ;; previously selected layout.
+ (installer-step
+ (id 'variant)
+ (compute
+ (lambda (result)
+ (let ((variants (x11-keymap-layout-variants
+ (result-step result 'layout))))
+ (run-variant-page variants
+ (lambda (variant)
+ (x11-keymap-variant-description
+ variant)))))))))
+
+ (define (format-result result)
+ (let ((model (x11-keymap-model-name
+ (result-step result 'model)))
+ (layout (x11-keymap-layout-name
+ (result-step result 'layout)))
+ (variant (and=> (result-step result 'variant)
+ (lambda (variant)
+ (x11-keymap-variant-name variant)))))
+ (list model layout (or variant ""))))
+ (format-result
+ (run-installer-steps #:steps keymap-steps)))
diff --git a/gnu/installer/newt/locale.scm b/gnu/installer/newt/locale.scm
new file mode 100644
index 0000000000..5444a07598
--- /dev/null
+++ b/gnu/installer/newt/locale.scm
@@ -0,0 +1,193 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt locale)
+ #:use-module (gnu installer locale)
+ #:use-module (gnu installer steps)
+ #:use-module (gnu installer newt page)
+ #:use-module (guix i18n)
+ #:use-module (newt)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (ice-9 match)
+ #:export (run-locale-page))
+
+(define (run-language-page languages language->text)
+ (let ((title (G_ "Language selection")))
+ (run-listbox-selection-page
+ #:title title
+ #:info-text (G_ "Choose the language to be used for the installation \
+process. The selected language will also be the default \
+language for the installed system.")
+ #:listbox-items languages
+ #:listbox-item->text language->text
+ #:button-text (G_ "Cancel")
+ #:button-callback-procedure
+ (lambda _
+ (raise
+ (condition
+ (&installer-step-abort)))))))
+
+(define (run-territory-page territories territory->text)
+ (let ((title (G_ "Location selection")))
+ (run-listbox-selection-page
+ #:title title
+ #:info-text (G_ "Choose your location. This is a shortlist of locations \
+based on the language you selected.")
+ #:listbox-items territories
+ #:listbox-item->text territory->text
+ #:button-text (G_ "Back")
+ #:button-callback-procedure
+ (lambda _
+ (raise
+ (condition
+ (&installer-step-abort)))))))
+
+(define (run-codeset-page codesets)
+ (let ((title (G_ "Codeset selection")))
+ (run-listbox-selection-page
+ #:title title
+ #:info-text (G_ "Choose your codeset. If UTF-8 is available, it should be \
+preferred.")
+ #:listbox-items codesets
+ #:listbox-item->text identity
+ #:listbox-default-item "UTF-8"
+ #:button-text (G_ "Back")
+ #:button-callback-procedure
+ (lambda _
+ (raise
+ (condition
+ (&installer-step-abort)))))))
+
+(define (run-modifier-page modifiers modifier->text)
+ (let ((title (G_ "Modifier selection")))
+ (run-listbox-selection-page
+ #:title title
+ #:info-text (G_ "Choose your modifier.")
+ #:listbox-items modifiers
+ #:listbox-item->text modifier->text
+ #:button-text (G_ "Back")
+ #:button-callback-procedure
+ (lambda _
+ (raise
+ (condition
+ (&installer-step-abort)))))))
+
+(define* (run-locale-page #:key
+ supported-locales
+ iso639-languages
+ iso3166-territories)
+
+ (define (break-on-locale-found locales)
+ "Raise the &installer-step-break condition if LOCALES contains exactly one
+element."
+ (and (= (length locales) 1)
+ (raise
+ (condition (&installer-step-break)))))
+
+ (define (filter-locales locales result)
+ "Filter the list of locale records LOCALES using the RESULT returned by
+the installer-steps defined below."
+ (filter
+ (lambda (locale)
+ (and-map identity
+ `(,(string=? (locale-language locale)
+ (result-step result 'language))
+ ,@(if (result-step-done? result 'territory)
+ (list (equal? (locale-territory locale)
+ (result-step result 'territory)))
+ '())
+ ,@(if (result-step-done? result 'codeset)
+ (list (equal? (locale-codeset locale)
+ (result-step result 'codeset)))
+ '())
+ ,@(if (result-step-done? result 'modifier)
+ (list (equal? (locale-modifier locale)
+ (result-step result 'modifier)))
+ '()))))
+ locales))
+
+ (define (result->locale-string locales result)
+ "Supposing that LOCALES contains exactly one locale record, turn it into a
+glibc locale string and return it."
+ (match (filter-locales locales result)
+ ((locale)
+ (locale->locale-string locale))))
+
+ (define locale-steps
+ (list
+ (installer-step
+ (id 'language)
+ (compute
+ (lambda _
+ (run-language-page
+ (delete-duplicates (map locale-language supported-locales))
+ (cut language-code->language-name iso639-languages <>)))))
+ (installer-step
+ (id 'territory)
+ (compute
+ (lambda (result)
+ (let ((locales (filter-locales supported-locales result)))
+ ;; Stop the process if the language returned by the previous step
+ ;; is matching one and only one supported locale.
+ (break-on-locale-found locales)
+
+ ;; Otherwise, ask the user to select a territory among those
+ ;; supported by the previously selected language.
+ (run-territory-page
+ (delete-duplicates (map locale-territory locales))
+ (lambda (territory-code)
+ (if territory-code
+ (territory-code->territory-name iso3166-territories
+ territory-code)
+ (G_ "No location"))))))))
+ (installer-step
+ (id 'codeset)
+ (compute
+ (lambda (result)
+ (let ((locales (filter-locales supported-locales result)))
+ ;; Same as above but we now have a language and a territory to
+ ;; narrow down the search of a locale.
+ (break-on-locale-found locales)
+
+ ;; Otherwise, ask for a codeset.
+ (run-codeset-page
+ (delete-duplicates (map locale-codeset locales)))))))
+ (installer-step
+ (id 'modifier)
+ (compute
+ (lambda (result)
+ (let ((locales (filter-locales supported-locales result)))
+ ;; Same thing with a language, a territory and a codeset this time.
+ (break-on-locale-found locales)
+
+ ;; Otherwise, ask for a modifier.
+ (run-modifier-page
+ (delete-duplicates (map locale-modifier locales))
+ (lambda (modifier)
+ (or modifier (G_ "No modifier"))))))))))
+
+ ;; If run-installer-steps returns locally, it means that the user had to go
+ ;; through all steps (language, territory, codeset and modifier) to select a
+ ;; locale. In that case, like if we exited by raising &installer-step-break
+ ;; condition, turn the result into a glibc locale string and return it.
+ (result->locale-string
+ supported-locales
+ (run-installer-steps #:steps locale-steps)))
diff --git a/gnu/installer/newt/menu.scm b/gnu/installer/newt/menu.scm
new file mode 100644
index 0000000000..756b582a50
--- /dev/null
+++ b/gnu/installer/newt/menu.scm
@@ -0,0 +1,44 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt menu)
+ #:use-module (gnu installer steps)
+ #:use-module (gnu installer newt page)
+ #:use-module (guix i18n)
+ #:use-module (newt)
+ #:export (run-menu-page))
+
+(define (run-menu-page steps)
+ "Run a menu page, asking the user to select where to resume the install
+process from."
+ (define (steps->items steps)
+ (filter (lambda (step)
+ (installer-step-description step))
+ steps))
+
+ (run-listbox-selection-page
+ #:info-text (G_ "Choose where you want to resume the install.\
+You can also abort the installion by pressing the button.")
+ #:title (G_ "Installation menu")
+ #:listbox-items (steps->items steps)
+ #:listbox-item->text installer-step-description
+ #:sort-listbox-items? #f
+ #:button-text (G_ "Abort")
+ #:button-callback-procedure (lambda ()
+ (newt-finish)
+ (primitive-exit 1))))
diff --git a/gnu/installer/newt/network.scm b/gnu/installer/newt/network.scm
new file mode 100644
index 0000000000..c6ba69d4e8
--- /dev/null
+++ b/gnu/installer/newt/network.scm
@@ -0,0 +1,159 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt network)
+ #:use-module (gnu installer connman)
+ #:use-module (gnu installer steps)
+ #:use-module (gnu installer utils)
+ #:use-module (gnu installer newt ethernet)
+ #:use-module (gnu installer newt page)
+ #:use-module (gnu installer newt wifi)
+ #:use-module (guix i18n)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (newt)
+ #:export (run-network-page))
+
+;; Maximum length of a technology name.
+(define technology-name-max-length (make-parameter 20))
+
+(define (technology->text technology)
+ "Return a string describing the given TECHNOLOGY."
+ (let* ((name (technology-name technology))
+ (padded-name (string-pad-right name
+ (technology-name-max-length))))
+ (format #f "~a~%" padded-name)))
+
+(define (run-technology-page)
+ "Run a page to ask the user which technology shall be used to access
+Internet and return the selected technology. For now, only technologies with
+\"ethernet\" or \"wifi\" types are supported."
+ (define (technology-items)
+ (filter (lambda (technology)
+ (let ((type (technology-type technology)))
+ (or
+ (string=? type "ethernet")
+ (string=? type "wifi"))))
+ (connman-technologies)))
+
+ (run-listbox-selection-page
+ #:info-text (G_ "The install process requires an internet access.\
+ Please select a network technology.")
+ #:title (G_ "Technology selection")
+ #:listbox-items (technology-items)
+ #:listbox-item->text technology->text
+ #:button-text (G_ "Cancel")
+ #:button-callback-procedure
+ (lambda _
+ (raise
+ (condition
+ (&installer-step-abort))))))
+
+(define (find-technology-by-type technologies type)
+ "Find and return a technology with the given TYPE in TECHNOLOGIES list."
+ (find (lambda (technology)
+ (string=? (technology-type technology)
+ type))
+ technologies))
+
+(define (wait-technology-powered technology)
+ "Wait and display a progress bar until the given TECHNOLOGY is powered."
+ (let ((name (technology-name technology))
+ (full-value 5))
+ (run-scale-page
+ #:title (G_ "Powering technology")
+ #:info-text (format #f "Waiting for technology ~a to be powered." name)
+ #:scale-full-value full-value
+ #:scale-update-proc
+ (lambda (value)
+ (let* ((technologies (connman-technologies))
+ (type (technology-type technology))
+ (updated-technology
+ (find-technology-by-type technologies type))
+ (technology-powered? updated-technology))
+ (sleep 1)
+ (if technology-powered?
+ full-value
+ (+ value 1)))))))
+
+(define (wait-service-online)
+ "Display a newt scale until connman detects an Internet access. Do
+FULL-VALUE tentatives, spaced by 1 second."
+ (let* ((full-value 5))
+ (run-scale-page
+ #:title (G_ "Checking connectivity")
+ #:info-text (G_ "Waiting internet access is established")
+ #:scale-full-value full-value
+ #:scale-update-proc
+ (lambda (value)
+ (sleep 1)
+ (if (connman-online?)
+ full-value
+ (+ value 1))))
+ (unless (connman-online?)
+ (run-error-page
+ (G_ "The selected network does not provide an Internet \
+access, please try again.")
+ (G_ "Connection error"))
+ (raise
+ (condition
+ (&installer-step-abort))))))
+
+(define (run-network-page)
+ "Run a page to allow the user to configure connman so that it can access the
+Internet."
+ (define network-steps
+ (list
+ ;; Ask the user to choose between ethernet and wifi technologies.
+ (installer-step
+ (id 'select-technology)
+ (compute
+ (lambda _
+ (run-technology-page))))
+ ;; Enable the previously selected technology.
+ (installer-step
+ (id 'power-technology)
+ (compute
+ (lambda (result)
+ (let ((technology (result-step result 'select-technology)))
+ (connman-enable-technology technology)
+ (wait-technology-powered technology)))))
+ ;; Propose the user to connect to one of the service available for the
+ ;; previously selected technology.
+ (installer-step
+ (id 'connect-service)
+ (compute
+ (lambda (result)
+ (let* ((technology (result-step result 'select-technology))
+ (type (technology-type technology)))
+ (cond
+ ((string=? "wifi" type)
+ (run-wifi-page))
+ ((string=? "ethernet" type)
+ (run-ethernet-page)))))))
+ ;; Wait for connman status to switch to 'online, which means it can
+ ;; access Internet.
+ (installer-step
+ (id 'wait-online)
+ (compute (lambda _
+ (wait-service-online))))))
+ (run-installer-steps
+ #:steps network-steps
+ #:rewind-strategy 'start))
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
new file mode 100644
index 0000000000..bcede3e333
--- /dev/null
+++ b/gnu/installer/newt/page.scm
@@ -0,0 +1,313 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt page)
+ #:use-module (gnu installer newt utils)
+ #:use-module (guix i18n)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 receive)
+ #:use-module (newt)
+ #:export (draw-info-page
+ draw-connecting-page
+ run-input-page
+ run-error-page
+ run-listbox-selection-page
+ run-scale-page))
+
+;;; Commentary:
+;;;
+;;; Some helpers around guile-newt to draw or run generic pages. The
+;;; difference between 'draw' and 'run' terms comes from newt library. A page
+;;; is drawn when the form it contains does not expect any user
+;;; interaction. In that case, it is necessary to call (newt-refresh) to force
+;;; the page to be displayed. When a form is 'run', it is blocked waiting for
+;;; any action from the user (press a button, input some text, ...).
+;;;
+;;; Code:
+
+(define (draw-info-page text title)
+ "Draw an informative page with the given TEXT as content. Set the title of
+this page to TITLE."
+ (let* ((text-box
+ (make-reflowed-textbox -1 -1 text 40
+ #:flags FLAG-BORDER))
+ (grid (make-grid 1 1))
+ (form (make-form)))
+ (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box)
+ (add-component-to-form form text-box)
+ (make-wrapped-grid-window grid title)
+ (draw-form form)
+ ;; This call is imperative, otherwise the form won't be displayed. See the
+ ;; explanation in the above commentary.
+ (newt-refresh)
+ form))
+
+(define (draw-connecting-page service-name)
+ "Draw a page to indicate a connection in in progress."
+ (draw-info-page
+ (format #f (G_ "Connecting to ~a, please wait.") service-name)
+ (G_ "Connection in progress")))
+
+(define* (run-input-page text title
+ #:key
+ (allow-empty-input? #f)
+ (input-field-width 40))
+ "Run a page to prompt user for an input. The given TEXT will be displayed
+above the input field. The page title is set to TITLE. Unless
+allow-empty-input? is set to #t, an error page will be displayed if the user
+enters an empty input."
+ (let* ((text-box
+ (make-reflowed-textbox -1 -1 text
+ input-field-width
+ #:flags FLAG-BORDER))
+ (grid (make-grid 1 3))
+ (input-entry (make-entry -1 -1 20))
+ (ok-button (make-button -1 -1 (G_ "Ok")))
+ (form (make-form)))
+
+ (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box)
+ (set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT input-entry
+ #:pad-top 1)
+ (set-grid-field grid 0 2 GRID-ELEMENT-COMPONENT ok-button
+ #:pad-top 1)
+
+ (add-components-to-form form text-box input-entry ok-button)
+ (make-wrapped-grid-window grid title)
+ (let ((error-page (lambda ()
+ (run-error-page (G_ "Please enter a non empty input")
+ (G_ "Empty input")))))
+ (let loop ()
+ (receive (exit-reason argument)
+ (run-form form)
+ (let ((input (entry-value input-entry)))
+ (if (and (not allow-empty-input?)
+ (eq? exit-reason 'exit-component)
+ (string=? input ""))
+ (begin
+ ;; Display the error page.
+ (error-page)
+ ;; Set the focus back to the input input field.
+ (set-current-component form input-entry)
+ (loop))
+ (begin
+ (destroy-form-and-pop form)
+ input))))))))
+
+(define (run-error-page text title)
+ "Run a page to inform the user of an error. The page contains the given TEXT
+to explain the error and an \"OK\" button to acknowledge the error. The title
+of the page is set to TITLE."
+ (let* ((text-box
+ (make-reflowed-textbox -1 -1 text 40
+ #:flags FLAG-BORDER))
+ (grid (make-grid 1 2))
+ (ok-button (make-button -1 -1 "Ok"))
+ (form (make-form)))
+
+ (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box)
+ (set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT ok-button
+ #:pad-top 1)
+
+ ;; Set the background color to red to indicate something went wrong.
+ (newt-set-color COLORSET-ROOT "white" "red")
+ (add-components-to-form form text-box ok-button)
+ (make-wrapped-grid-window grid title)
+ (run-form form)
+ ;; Restore the background to its original color.
+ (newt-set-color COLORSET-ROOT "white" "blue")
+ (destroy-form-and-pop form)))
+
+(define* (run-listbox-selection-page #:key
+ info-text
+ title
+ (info-textbox-width 50)
+ listbox-items
+ listbox-item->text
+ (listbox-height 20)
+ (listbox-default-item #f)
+ (listbox-allow-multiple? #f)
+ (sort-listbox-items? #t)
+ button-text
+ (button-callback-procedure
+ (const #t))
+ (listbox-callback-procedure
+ (const #t)))
+ "Run a page asking the user to select an item in a listbox. The page
+contains, stacked vertically from the top to the bottom, an informative text
+set to INFO-TEXT, a listbox and a button. The listbox will be filled with
+LISTBOX-ITEMS converted to text by applying the procedure LISTBOX-ITEM->TEXT
+on every item. The selected item from LISTBOX-ITEMS is returned. The button
+text is set to BUTTON-TEXT and the procedure BUTTON-CALLBACK-PROCEDURE called
+when it is pressed. The procedure LISTBOX-CALLBACK-PROCEDURE is called when an
+item from the listbox is selected (by pressing the <ENTER> key).
+
+INFO-TEXTBOX-WIDTH is the width of the textbox where INFO-TEXT will be
+displayed. LISTBOX-HEIGHT is the height of the listbox.
+
+If LISTBOX-DEFAULT-ITEM is set to the value of one of the items in
+LISTBOX-ITEMS, it will be selected by default. Otherwise, the first element of
+the listbox is selected.
+
+If LISTBOX-ALLOW-MULTIPLE? is set to #t, multiple items from the listbox can
+be selected (using the <SPACE> key). It that case, a list containing the
+selected items will be returned.
+
+If SORT-LISTBOX-ITEMS? is set to #t, the listbox items are sorted using
+'string<=' procedure (after being converted to text)."
+
+ (define (fill-listbox listbox items)
+ "Append the given ITEMS to LISTBOX, once they have been converted to text
+with LISTBOX-ITEM->TEXT. Each item appended to the LISTBOX is given a key by
+newt. Save this key by returning an association list under the form:
+
+ ((NEWT-LISTBOX-KEY . ITEM) ...)
+
+where NEWT-LISTBOX-KEY is the key returned by APPEND-ENTRY-TO-LISTBOX, when
+ITEM was inserted into LISTBOX."
+ (map (lambda (item)
+ (let* ((text (listbox-item->text item))
+ (key (append-entry-to-listbox listbox text)))
+ (cons key item)))
+ items))
+
+ (define (sort-listbox-items listbox-items)
+ "Return LISTBOX-ITEMS sorted using the 'string<=' procedure on the text
+corresponding to each item in the list."
+ (let* ((items (map (lambda (item)
+ (cons item (listbox-item->text item)))
+ listbox-items))
+ (sorted-items
+ (sort items (lambda (a b)
+ (let ((text-a (cdr a))
+ (text-b (cdr b)))
+ (string<= text-a text-b))))))
+ (map car sorted-items)))
+
+ (define (set-default-item listbox listbox-keys default-item)
+ "Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the
+association list returned by the FILL-LISTBOX procedure. It is used because
+the current listbox item has to be selected by key."
+ (for-each (match-lambda
+ ((key . item)
+ (when (equal? item default-item)
+ (set-current-listbox-entry-by-key listbox key))))
+ listbox-keys))
+
+ (let* ((listbox (make-listbox
+ -1 -1
+ listbox-height
+ (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT
+ (if listbox-allow-multiple?
+ FLAG-MULTIPLE
+ 0))))
+ (form (make-form))
+ (info-textbox
+ (make-reflowed-textbox -1 -1 info-text
+ info-textbox-width
+ #:flags FLAG-BORDER))
+ (button (make-button -1 -1 button-text))
+ (grid (vertically-stacked-grid
+ GRID-ELEMENT-COMPONENT info-textbox
+ GRID-ELEMENT-COMPONENT listbox
+ GRID-ELEMENT-COMPONENT button))
+ (sorted-items (if sort-listbox-items?
+ (sort-listbox-items listbox-items)
+ listbox-items))
+ (keys (fill-listbox listbox sorted-items)))
+
+ (when listbox-default-item
+ (set-default-item listbox keys listbox-default-item))
+
+ (add-form-to-grid grid form #t)
+ (make-wrapped-grid-window grid title)
+
+ (receive (exit-reason argument)
+ (run-form form)
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (when (eq? exit-reason 'exit-component)
+ (cond
+ ((components=? argument button)
+ (button-callback-procedure))
+ ((components=? argument listbox)
+ (if listbox-allow-multiple?
+ (let* ((entries (listbox-selection listbox))
+ (items (map (lambda (entry)
+ (assoc-ref keys entry))
+ entries)))
+ (listbox-callback-procedure items)
+ items)
+ (let* ((entry (current-listbox-entry listbox))
+ (item (assoc-ref keys entry)))
+ (listbox-callback-procedure item)
+ item))))))
+ (lambda ()
+ (destroy-form-and-pop form))))))
+
+(define* (run-scale-page #:key
+ title
+ info-text
+ (info-textbox-width 50)
+ (scale-width 40)
+ (scale-full-value 100)
+ scale-update-proc
+ (max-scale-update 5))
+ "Run a page with a progress bar (called 'scale' in newt). The given
+INFO-TEXT is displayed in a textbox above the scale. The width of the textbox
+is set to INFO-TEXTBOX-WIDTH. The width of the scale is set to
+SCALE-WIDTH. SCALE-FULL-VALUE indicates the value that correspond to 100% of
+the scale.
+
+The procedure SCALE-UPDATE-PROC shall return a new scale
+value. SCALE-UPDATE-PROC will be called until the returned value is superior
+or equal to SCALE-FULL-VALUE, but no more than MAX-SCALE-UPDATE times. An
+error is raised if the MAX-SCALE-UPDATE limit is reached."
+ (let* ((info-textbox
+ (make-reflowed-textbox -1 -1 info-text
+ info-textbox-width
+ #:flags FLAG-BORDER))
+ (scale (make-scale -1 -1 scale-width scale-full-value))
+ (grid (vertically-stacked-grid
+ GRID-ELEMENT-COMPONENT info-textbox
+ GRID-ELEMENT-COMPONENT scale))
+ (form (make-form)))
+
+ (add-form-to-grid grid form #t)
+ (make-wrapped-grid-window grid title)
+
+ (draw-form form)
+ ;; This call is imperative, otherwise the form won't be displayed. See the
+ ;; explanation in the above commentary.
+ (newt-refresh)
+
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (let loop ((i max-scale-update)
+ (last-value 0))
+ (let ((value (scale-update-proc last-value)))
+ (set-scale-value scale value)
+ ;; Same as above.
+ (newt-refresh)
+ (unless (>= value scale-full-value)
+ (if (> i 0)
+ (loop (- i 1) value)
+ (error "Max scale updates reached."))))))
+ (lambda ()
+ (destroy-form-and-pop form)))))
diff --git a/gnu/installer/newt/timezone.scm b/gnu/installer/newt/timezone.scm
new file mode 100644
index 0000000000..a2c9b458f5
--- /dev/null
+++ b/gnu/installer/newt/timezone.scm
@@ -0,0 +1,83 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt timezone)
+ #:use-module (gnu installer steps)
+ #:use-module (gnu installer timezone)
+ #:use-module (gnu installer newt page)
+ #:use-module (guix i18n)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 receive)
+ #:use-module (newt)
+ #:export (run-timezone-page))
+
+;; Heigth of the listbox displaying timezones.
+(define timezone-listbox-heigth (make-parameter 20))
+
+;; Information textbox width.
+(define info-textbox-width (make-parameter 40))
+
+(define (fill-timezones listbox timezones)
+ "Fill the given LISTBOX with TIMEZONES. Return an association list
+correlating listbox keys with timezones."
+ (map (lambda (timezone)
+ (let ((key (append-entry-to-listbox listbox timezone)))
+ (cons key timezone)))
+ timezones))
+
+(define (run-timezone-page zonetab)
+ "Run a page displaying available timezones, grouped by regions. The user is
+invited to select a timezone. The selected timezone, under Posix format is
+returned."
+ (define (all-but-last list)
+ (reverse (cdr (reverse list))))
+
+ (define (run-page timezone-tree)
+ (define (loop path)
+ (let ((timezones (locate-childrens timezone-tree path)))
+ (run-listbox-selection-page
+ #:title (G_ "Timezone selection")
+ #:info-text (G_ "Please select a timezone.")
+ #:listbox-items timezones
+ #:listbox-item->text identity
+ #:button-text (if (null? path)
+ (G_ "Cancel")
+ (G_ "Back"))
+ #:button-callback-procedure
+ (if (null? path)
+ (lambda _
+ (raise
+ (condition
+ (&installer-step-abort))))
+ (lambda _
+ (loop (all-but-last path))))
+ #:listbox-callback-procedure
+ (lambda (timezone)
+ (let* ((timezone* (append path (list timezone)))
+ (tz (timezone->posix-tz timezone*)))
+ (if (timezone-has-child? timezone-tree timezone*)
+ (loop timezone*)
+ tz))))))
+ (loop '()))
+
+ (let ((timezone-tree (zonetab->timezone-tree zonetab)))
+ (run-page timezone-tree)))
diff --git a/gnu/installer/newt/user.scm b/gnu/installer/newt/user.scm
new file mode 100644
index 0000000000..f342caae04
--- /dev/null
+++ b/gnu/installer/newt/user.scm
@@ -0,0 +1,181 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt user)
+ #:use-module (gnu installer newt page)
+ #:use-module (gnu installer newt utils)
+ #:use-module (guix i18n)
+ #:use-module (newt)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 receive)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:export (run-user-page))
+
+(define (run-user-add-page)
+ (define (pad-label label)
+ (string-pad-right label 20))
+
+ (let* ((label-name
+ (make-label -1 -1 (pad-label (G_ "Name"))))
+ (label-group
+ (make-label -1 -1 (pad-label (G_ "Group"))))
+ (label-home-directory
+ (make-label -1 -1 (pad-label (G_ "Home directory"))))
+ (entry-width 30)
+ (entry-name (make-entry -1 -1 entry-width))
+ (entry-group (make-entry -1 -1 entry-width
+ #:initial-value "users"))
+ (entry-home-directory (make-entry -1 -1 entry-width))
+ (entry-grid (make-grid 2 3))
+ (button-grid (make-grid 1 1))
+ (ok-button (make-button -1 -1 (G_ "Ok")))
+ (grid (make-grid 1 2))
+ (title (G_ "User creation"))
+ (set-entry-grid-field
+ (cut set-grid-field entry-grid <> <> GRID-ELEMENT-COMPONENT <>))
+ (form (make-form)))
+
+ (set-entry-grid-field 0 0 label-name)
+ (set-entry-grid-field 1 0 entry-name)
+ (set-entry-grid-field 0 1 label-group)
+ (set-entry-grid-field 1 1 entry-group)
+ (set-entry-grid-field 0 2 label-home-directory)
+ (set-entry-grid-field 1 2 entry-home-directory)
+
+ (set-grid-field button-grid 0 0 GRID-ELEMENT-COMPONENT ok-button)
+
+ (add-component-callback
+ entry-name
+ (lambda (component)
+ (set-entry-text entry-home-directory
+ (string-append "/home/" (entry-value entry-name)))))
+
+ (add-components-to-form form
+ label-name label-group label-home-directory
+ entry-name entry-group entry-home-directory
+ ok-button)
+
+ (make-wrapped-grid-window (vertically-stacked-grid
+ GRID-ELEMENT-SUBGRID entry-grid
+ GRID-ELEMENT-SUBGRID button-grid)
+ title)
+ (let ((error-page
+ (lambda ()
+ (run-error-page (G_ "Empty inputs are not allowed")
+ (G_ "Empty input")))))
+ (receive (exit-reason argument)
+ (run-form form)
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (when (eq? exit-reason 'exit-component)
+ (cond
+ ((components=? argument ok-button)
+ (let ((name (entry-value entry-name))
+ (group (entry-value entry-group))
+ (home-directory (entry-value entry-home-directory)))
+ (if (or (string=? name "")
+ (string=? group "")
+ (string=? home-directory ""))
+ (begin
+ (error-page)
+ (run-user-add-page))
+ `((name . ,name)
+ (group . ,group)
+ (home-directory . ,home-directory))))))))
+ (lambda ()
+ (destroy-form-and-pop form)))))))
+
+(define (run-user-page)
+ (define (run users)
+ (let* ((listbox (make-listbox
+ -1 -1 10
+ (logior FLAG-SCROLL FLAG-BORDER)))
+ (info-textbox
+ (make-reflowed-textbox
+ -1 -1
+ (G_ "Please add at least one user to system\
+ using the 'Add' button.")
+ 40 #:flags FLAG-BORDER))
+ (add-button (make-compact-button -1 -1 (G_ "Add")))
+ (del-button (make-compact-button -1 -1 (G_ "Delete")))
+ (listbox-button-grid
+ (apply
+ vertically-stacked-grid
+ GRID-ELEMENT-COMPONENT add-button
+ `(,@(if (null? users)
+ '()
+ (list GRID-ELEMENT-COMPONENT del-button)))))
+ (ok-button (make-button -1 -1 (G_ "Ok")))
+ (cancel-button (make-button -1 -1 (G_ "Cancel")))
+ (title "User selection")
+ (grid
+ (vertically-stacked-grid
+ GRID-ELEMENT-COMPONENT info-textbox
+ GRID-ELEMENT-SUBGRID (horizontal-stacked-grid
+ GRID-ELEMENT-COMPONENT listbox
+ GRID-ELEMENT-SUBGRID listbox-button-grid)
+ GRID-ELEMENT-SUBGRID (horizontal-stacked-grid
+ GRID-ELEMENT-COMPONENT ok-button
+ GRID-ELEMENT-COMPONENT cancel-button)))
+ (sorted-users (sort users (lambda (a b)
+ (string<= (assoc-ref a 'name)
+ (assoc-ref b 'name)))))
+ (listbox-elements
+ (map
+ (lambda (user)
+ `((key . ,(append-entry-to-listbox listbox
+ (assoc-ref user 'name)))
+ (user . ,user)))
+ sorted-users))
+ (form (make-form)))
+
+
+ (add-form-to-grid grid form #t)
+ (make-wrapped-grid-window grid title)
+ (if (null? users)
+ (set-current-component form add-button)
+ (set-current-component form ok-button))
+
+ (receive (exit-reason argument)
+ (run-form form)
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (when (eq? exit-reason 'exit-component)
+ (cond
+ ((components=? argument add-button)
+ (run (cons (run-user-add-page) users)))
+ ((components=? argument del-button)
+ (let* ((current-user-key (current-listbox-entry listbox))
+ (users
+ (map (cut assoc-ref <> 'user)
+ (remove (lambda (element)
+ (equal? (assoc-ref element 'key)
+ current-user-key))
+ listbox-elements))))
+ (run users)))
+ ((components=? argument ok-button)
+ (when (null? users)
+ (run-error-page (G_ "Please create at least one user.")
+ (G_ "No user"))
+ (run users))))))
+ (lambda ()
+ (destroy-form-and-pop form))))))
+ (run '()))
diff --git a/gnu/installer/newt/utils.scm b/gnu/installer/newt/utils.scm
new file mode 100644
index 0000000000..1c2ce4e628
--- /dev/null
+++ b/gnu/installer/newt/utils.scm
@@ -0,0 +1,43 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt utils)
+ #:use-module (ice-9 receive)
+ #:use-module (newt)
+ #:export (screen-columns
+ screen-rows
+
+ destroy-form-and-pop
+ set-screen-size!))
+
+;; Number of columns and rows of the terminal.
+(define screen-columns (make-parameter 0))
+(define screen-rows (make-parameter 0))
+
+(define (destroy-form-and-pop form)
+ "Destory the given FORM and pop the current window."
+ (destroy-form form)
+ (pop-window))
+
+(define (set-screen-size!)
+ "Set the parameters 'screen-columns' and 'screen-rows' to the number of
+columns and rows respectively of the current terminal."
+ (receive (columns rows)
+ (screen-size)
+ (screen-columns columns)
+ (screen-rows rows)))
diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm
new file mode 100644
index 0000000000..8ed9f68918
--- /dev/null
+++ b/gnu/installer/newt/welcome.scm
@@ -0,0 +1,122 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt welcome)
+ #:use-module (gnu installer utils)
+ #:use-module (gnu installer newt utils)
+ #:use-module (guix build syscalls)
+ #:use-module (guix i18n)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 receive)
+ #:use-module (newt)
+ #:export (run-welcome-page))
+
+;; Margin between screen border and newt root window.
+(define margin-left (make-parameter 3))
+(define margin-top (make-parameter 3))
+
+;; Expected width and height for the logo.
+(define logo-width (make-parameter 50))
+(define logo-height (make-parameter 23))
+
+(define (nearest-exact-integer x)
+ "Given a real number X, return the nearest exact integer, with ties going to
+the nearest exact even integer."
+ (inexact->exact (round x)))
+
+(define* (run-menu-page title logo
+ #:key
+ listbox-items
+ listbox-item->text)
+ "Run a page with the given TITLE, to ask the user to choose between
+LISTBOX-ITEMS displayed in a listbox. The listbox items are converted to text
+using LISTBOX-ITEM->TEXT procedure. Display the textual LOGO in the center of
+the page. Contrary to other pages, we cannot resort to grid layouts, because
+we want this page to occupy all the screen space available."
+ (define (fill-listbox listbox items)
+ (map (lambda (item)
+ (let* ((text (listbox-item->text item))
+ (key (append-entry-to-listbox listbox text)))
+ (cons key item)))
+ items))
+
+ (let* ((windows
+ (make-window (margin-left)
+ (margin-top)
+ (- (screen-columns) (* 2 (margin-left)))
+ (- (screen-rows) (* 2 (margin-top)))
+ title))
+ (logo-textbox
+ (make-textbox (nearest-exact-integer
+ (- (/ (screen-columns) 2)
+ (+ (/ (logo-width) 2) (margin-left))))
+ (margin-top) (logo-width) (logo-height) 0))
+ (text (set-textbox-text logo-textbox
+ (read-all logo)))
+ (options-listbox
+ (make-listbox (margin-left)
+ (+ (logo-height) (margin-top))
+ (- (screen-rows) (+ (logo-height)
+ (* (margin-top) 4)))
+ (logior FLAG-BORDER FLAG-RETURNEXIT)))
+ (keys (fill-listbox options-listbox listbox-items))
+ (form (make-form)))
+ (set-listbox-width options-listbox (- (screen-columns)
+ (* (margin-left) 4)))
+ (add-components-to-form form logo-textbox options-listbox)
+
+ (receive (exit-reason argument)
+ (run-form form)
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (when (eq? exit-reason 'exit-component)
+ (cond
+ ((components=? argument options-listbox)
+ (let* ((entry (current-listbox-entry options-listbox))
+ (item (assoc-ref keys entry)))
+ (match item
+ ((text . proc)
+ (proc))))))))
+ (lambda ()
+ (destroy-form-and-pop form))))))
+
+(define (run-welcome-page logo)
+ "Run a welcome page with the given textual LOGO displayed at the center of
+the page. Ask the user to choose between manual installation, graphical
+installation and reboot."
+ (run-menu-page
+ (G_ "GNU GuixSD install")
+ logo
+ #:listbox-items
+ `((,(G_ "Install using the unguided shell based process")
+ .
+ ,(lambda ()
+ (clear-screen)
+ (newt-suspend)
+ (system* "bash" "-l")
+ (newt-resume)))
+ (,(G_ "Graphical install using a guided terminal based interface")
+ .
+ ,(const #t))
+ (,(G_ "Reboot")
+ .
+ ,(lambda ()
+ (newt-finish)
+ (reboot))))
+ #:listbox-item->text car))
diff --git a/gnu/installer/newt/wifi.scm b/gnu/installer/newt/wifi.scm
new file mode 100644
index 0000000000..6cac54399a
--- /dev/null
+++ b/gnu/installer/newt/wifi.scm
@@ -0,0 +1,243 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt wifi)
+ #:use-module (gnu installer connman)
+ #:use-module (gnu installer steps)
+ #:use-module (gnu installer newt utils)
+ #:use-module (gnu installer newt page)
+ #:use-module (guix i18n)
+ #:use-module (guix records)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 rdelim)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (newt)
+ #:export (run-wifi-page))
+
+;; This record associates a connman service to its key the listbox.
+(define-record-type* <service-item>
+ service-item make-service-item
+ service-item?
+ (service service-item-service) ; connman <service>
+ (key service-item-key)) ; newt listbox-key
+
+(define (strength->string strength)
+ "Convert STRENGTH as an integer percentage into a text printable strength
+bar using unicode characters. Taken from NetworkManager's
+nmc_wifi_strength_bars."
+ (let ((quarter #\x2582)
+ (half #\x2584)
+ (three-quarter #\x2586)
+ (full #\x2588))
+ (cond
+ ((> strength 80)
+ ;; ▂▄▆█
+ (string quarter half three-quarter full))
+ ((> strength 55)
+ ;; ▂▄▆_
+ (string quarter half three-quarter #\_))
+ ((> strength 30)
+ ;; ▂▄__
+ (string quarter half #\_ #\_))
+ ((> strength 5)
+ ;; ▂___
+ (string quarter #\_ #\_ #\_))
+ (else
+ ;; ____
+ (string quarter #\_ #\_ #\_ #\_)))))
+
+(define (force-wifi-scan)
+ "Force a wifi scan. Raise a condition if no wifi technology is available."
+ (let* ((technologies (connman-technologies))
+ (wifi-technology
+ (find (lambda (technology)
+ (string=? (technology-type technology) "wifi"))
+ technologies)))
+ (if wifi-technology
+ (connman-scan-technology wifi-technology)
+ (raise (condition
+ (&message
+ (message (G_ "Unable to find a wifi technology"))))))))
+
+(define (draw-scanning-page)
+ "Draw a page to indicate a wifi scan in in progress."
+ (draw-info-page (G_ "Scanning wifi for available networks, please wait.")
+ (G_ "Scan in progress")))
+
+(define (run-wifi-password-page)
+ "Run a page prompting user for a password and return it."
+ (run-input-page (G_ "Please enter the wifi password")
+ (G_ "Password required")))
+
+(define (run-wrong-password-page service-name)
+ "Run a page to inform user of a wrong password input."
+ (run-error-page
+ (format #f (G_ "The password you entered for ~a is incorrect.")
+ service-name)
+ (G_ "Wrong password")))
+
+(define (run-unknown-error-page service-name)
+ "Run a page to inform user that a connection error happened."
+ (run-error-page
+ (format #f
+ (G_ "An error occured while trying to connect to ~a, please retry.")
+ service-name)
+ (G_ "Connection error")))
+
+(define (password-callback)
+ (run-wifi-password-page))
+
+(define (connect-wifi-service listbox service-items)
+ "Connect to the wifi service selected in LISTBOX. SERVICE-ITEMS is the list
+of <service-item> records present in LISTBOX."
+ (let* ((listbox-key (current-listbox-entry listbox))
+ (item (find (lambda (item)
+ (eq? (service-item-key item) listbox-key))
+ service-items))
+ (service (service-item-service item))
+ (service-name (service-name service))
+ (form (draw-connecting-page service-name)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (guard (c ((connman-password-error? c)
+ (run-wrong-password-page service-name)
+ #f)
+ ((connman-already-connected-error? c)
+ #t)
+ ((connman-connection-error? c)
+ (run-unknown-error-page service-name)
+ #f))
+ (connman-connect-with-auth service password-callback)))
+ (lambda ()
+ (destroy-form-and-pop form)))))
+
+(define (run-wifi-scan-page)
+ "Force a wifi scan and draw a page during the operation."
+ (let ((form (draw-scanning-page)))
+ (force-wifi-scan)
+ (destroy-form-and-pop form)))
+
+(define (wifi-services)
+ "Return all the connman services of wifi type."
+ (let ((services (connman-services)))
+ (filter (lambda (service)
+ (and (string=? (service-type service) "wifi")
+ (not (string-null? (service-name service)))))
+ services)))
+
+(define* (fill-wifi-services listbox wifi-services)
+ "Append all the services in WIFI-SERVICES to the given LISTBOX."
+ (clear-listbox listbox)
+ (map (lambda (service)
+ (let* ((text (service->text service))
+ (key (append-entry-to-listbox listbox text)))
+ (service-item
+ (service service)
+ (key key))))
+ wifi-services))
+
+;; Maximum length of a wifi service name.
+(define service-name-max-length (make-parameter 20))
+
+;; Heigth of the listbox displaying wifi services.
+(define wifi-listbox-heigth (make-parameter 20))
+
+;; Information textbox width.
+(define info-textbox-width (make-parameter 40))
+
+(define (service->text service)
+ "Return a string composed of the name and the strength of the given
+SERVICE. A '*' preceding the service name indicates that it is connected."
+ (let* ((name (service-name service))
+ (padded-name (string-pad-right name
+ (service-name-max-length)))
+ (strength (service-strength service))
+ (strength-string (strength->string strength))
+ (state (service-state service))
+ (connected? (or (string=? state "online")
+ (string=? state "ready"))))
+ (format #f "~c ~a ~a~%"
+ (if connected? #\* #\ )
+ padded-name
+ strength-string)))
+
+(define (run-wifi-page)
+ "Run a page displaying available wifi networks in a listbox. Connect to the
+network when the corresponding listbox entry is selected. A button allow to
+force a wifi scan."
+ (let* ((listbox (make-listbox
+ -1 -1
+ (wifi-listbox-heigth)
+ (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT)))
+ (form (make-form))
+ (buttons-grid (make-grid 1 1))
+ (middle-grid (make-grid 2 1))
+ (info-text (G_ "Please select a wifi network."))
+ (info-textbox
+ (make-reflowed-textbox -1 -1 info-text
+ (info-textbox-width)
+ #:flags FLAG-BORDER))
+ (cancel-button (make-button -1 -1 (G_ "Cancel")))
+ (scan-button (make-button -1 -1 (G_ "Scan")))
+ (services (wifi-services))
+ (service-items '()))
+
+ (if (null? services)
+ (append-entry-to-listbox listbox (G_ "No wifi detected"))
+ (set! service-items (fill-wifi-services listbox services)))
+
+ (set-grid-field middle-grid 0 0 GRID-ELEMENT-COMPONENT listbox)
+ (set-grid-field middle-grid 1 0 GRID-ELEMENT-COMPONENT scan-button
+ #:anchor ANCHOR-TOP
+ #:pad-left 2)
+ (set-grid-field buttons-grid 0 0 GRID-ELEMENT-COMPONENT cancel-button)
+
+ (add-components-to-form form
+ info-textbox
+ listbox scan-button
+ cancel-button)
+ (make-wrapped-grid-window
+ (basic-window-grid info-textbox middle-grid buttons-grid)
+ (G_ "Wifi selection"))
+
+ (receive (exit-reason argument)
+ (run-form form)
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (when (eq? exit-reason 'exit-component)
+ (cond
+ ((components=? argument scan-button)
+ (run-wifi-scan-page)
+ (run-wifi-page))
+ ((components=? argument cancel-button)
+ (raise
+ (condition
+ (&installer-step-abort))))
+ ((components=? argument listbox)
+ (let ((result (connect-wifi-service listbox service-items)))
+ (unless result
+ (run-wifi-page)))))))
+ (lambda ()
+ (destroy-form-and-pop form))))))
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-02 00:33:19 +0000