aboutsummaryrefslogtreecommitdiff
path: root/gnu/installer
diff options
context:
space:
mode:
authorMathieu Othacehe <m.othacehe@gmail.com>2018-12-05 14:30:16 +0900
committerLudovic Courtès <ludo@gnu.org>2019-01-17 14:04:22 +0100
commitdc5f3275ecbddc804875899e9e457299a835d7ab (patch)
tree1f6b8225e34595f90f184a2cf16264c35f0d0ba7 /gnu/installer
parent3ad8f7757c840de290a6035747578a18ff7279da (diff)
downloadguix-dc5f3275ecbddc804875899e9e457299a835d7ab.tar
guix-dc5f3275ecbddc804875899e9e457299a835d7ab.tar.gz
installer: Add configuration formatter.
* gnu/installer.scm (installer-steps): Add configuration-formatter procedures. * gnu/installer/final.scm: New file. * gnu/installer/locale.scm (locale->configuration): New exported procedure. * gnu/installer/newt.scm (newt-installer): Add final page. * gnu/installer/newt/final.scm: New file. * gnu/installer/record.scm (installer): Add final-page field. * gnu/installer/timezone.scm (posix-tz->configuration): New exported procedure. * gnu/installer/steps.scm (installer-step): Rename configuration-proc field to configuration-formatter. (%installer-configuration-file): New exported parameter, (%installer-target-dir): ditto, (%configuration-file-width): ditto, (format-configuration): new exported procedure, (configuration->file): new exported procedure.
Diffstat (limited to 'gnu/installer')
-rw-r--r--gnu/installer/final.scm36
-rw-r--r--gnu/installer/locale.scm13
-rw-r--r--gnu/installer/newt.scm5
-rw-r--r--gnu/installer/newt/final.scm84
-rw-r--r--gnu/installer/record.scm3
-rw-r--r--gnu/installer/steps.scm68
-rw-r--r--gnu/installer/timezone.scm12
7 files changed, 210 insertions, 11 deletions
diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm
new file mode 100644
index 0000000000..e1c62f5ce0
--- /dev/null
+++ b/gnu/installer/final.scm
@@ -0,0 +1,36 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer final)
+ #:use-module (gnu installer newt page)
+ #:use-module (gnu installer steps)
+ #:use-module (gnu installer utils)
+ #:use-module (gnu services herd)
+ #:use-module (guix build utils)
+ #:export (install-system))
+
+(define (install-system)
+ "Start COW-STORE service on target directory and launch guix install command
+in a subshell."
+ (let ((install-command
+ (format #f "guix system init ~a ~a"
+ (%installer-configuration-file)
+ (%installer-target-dir))))
+ (mkdir-p (%installer-target-dir))
+ (start-service 'cow-store (list (%installer-target-dir)))
+ (false-if-exception (run-shell-command install-command))))
diff --git a/gnu/installer/locale.scm b/gnu/installer/locale.scm
index 504070d41d..2b45b2200a 100644
--- a/gnu/installer/locale.scm
+++ b/gnu/installer/locale.scm
@@ -35,7 +35,9 @@
language-code->language-name
iso3166->iso3166-territories
- territory-code->territory-name))
+ territory-code->territory-name
+
+ locale->configuration))
;;;
@@ -197,3 +199,12 @@ territory name corresponding to the given TERRITORY-CODE."
territory-code)))
territories)))
(iso3166-territory-name iso3166-territory)))
+
+
+;;;
+;;; Configuration formatter.
+;;;
+
+(define (locale->configuration locale)
+ "Return the configuration field for LOCALE."
+ `((locale ,locale)))
diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm
index db57c732d1..77a7e6dca2 100644
--- a/gnu/installer/newt.scm
+++ b/gnu/installer/newt.scm
@@ -19,6 +19,7 @@
(define-module (gnu installer newt)
#:use-module (gnu installer record)
#:use-module (gnu installer newt ethernet)
+ #:use-module (gnu installer newt final)
#:use-module (gnu installer newt hostname)
#:use-module (gnu installer newt keymap)
#:use-module (gnu installer newt locale)
@@ -46,6 +47,9 @@
(define (exit-error key . args)
(newt-finish))
+(define (final-page result prev-steps)
+ (run-final-page result prev-steps))
+
(define* (locale-page #:key
supported-locales
iso639-languages
@@ -83,6 +87,7 @@
(init init)
(exit exit)
(exit-error exit-error)
+ (final-page final-page)
(keymap-page keymap-page)
(locale-page locale-page)
(menu-page menu-page)
diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm
new file mode 100644
index 0000000000..023777cc0a
--- /dev/null
+++ b/gnu/installer/newt/final.scm
@@ -0,0 +1,84 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt final)
+ #:use-module (gnu installer final)
+ #:use-module (gnu installer parted)
+ #:use-module (gnu installer steps)
+ #:use-module (gnu installer utils)
+ #:use-module (gnu installer newt page)
+ #:use-module (gnu installer newt utils)
+ #:use-module (guix i18n)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (newt)
+ #:export (run-final-page))
+
+(define (run-config-display-page)
+ (let ((width (%configuration-file-width))
+ (height (nearest-exact-integer
+ (/ (screen-rows) 2))))
+ (run-file-textbox-page
+ #:info-text (G_ "Congratulations, the installation is almost over! A \
+system configuration file has been generated, it is displayed just below. The \
+new system will be created from this file when pression the Ok button.")
+ #:title (G_ "Configuration file")
+ #:file (%installer-configuration-file)
+ #:info-textbox-width width
+ #:file-textbox-width width
+ #:file-textbox-height height
+ #:cancel-button-callback-procedure
+ (lambda ()
+ (raise
+ (condition
+ (&installer-step-abort)))))))
+
+(define (run-install-success-page)
+ (message-window
+ (G_ "Installation complete")
+ (G_ "Reboot")
+ (G_ "The installation finished with success. You may now remove the device \
+with the installation image and press the button to reboot.")))
+
+(define (run-install-failed-page)
+ (choice-window
+ (G_ "Installation failed")
+ (G_ "Restart installer")
+ (G_ "Retry system install")
+ (G_ "The final system installation step failed. You can retry the \
+last step, or restart the installer.")))
+
+(define (run-install-shell)
+ (clear-screen)
+ (newt-suspend)
+ (let ((install-ok? (install-system)))
+ (newt-resume)
+ install-ok?))
+
+(define (run-final-page result prev-steps)
+ (let* ((configuration (format-configuration prev-steps result))
+ (user-partitions (result-step result 'partition))
+ (install-ok?
+ (with-mounted-partitions
+ user-partitions
+ (configuration->file configuration)
+ (run-config-display-page)
+ (run-install-shell))))
+ (if install-ok?
+ (run-install-success-page)
+ (run-install-failed-page))))
diff --git a/gnu/installer/record.scm b/gnu/installer/record.scm
index 9c10c65758..bf74040699 100644
--- a/gnu/installer/record.scm
+++ b/gnu/installer/record.scm
@@ -27,6 +27,7 @@
installer-init
installer-exit
installer-exit-error
+ installer-final-page
installer-keymap-page
installer-locale-page
installer-menu-page
@@ -57,6 +58,8 @@
;; procedure (key arguments) -> void
(exit-error installer-exit-error)
;; procedure (#:key models layouts) -> (list model layout variant)
+ ;; procedure void -> void
+ (final-page installer-final-page)
(keymap-page installer-keymap-page)
;; procedure: (#:key supported-locales iso639-languages iso3166-territories)
;; -> glibc-locale
diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm
index 5fd54356dd..3f0bdad4f7 100644
--- a/gnu/installer/steps.scm
+++ b/gnu/installer/steps.scm
@@ -18,10 +18,13 @@
(define-module (gnu installer steps)
#:use-module (guix records)
+ #:use-module (guix build utils)
#:use-module (ice-9 match)
+ #:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module (rnrs io ports)
#:export (&installer-step-abort
installer-step-abort?
@@ -35,13 +38,19 @@
installer-step-id
installer-step-description
installer-step-compute
- installer-step-configuration-proc
+ installer-step-configuration-formatter
run-installer-steps
find-step-by-id
result->step-ids
result-step
- result-step-done?))
+ result-step-done?
+
+ %installer-configuration-file
+ %installer-target-dir
+ %configuration-file-width
+ format-configuration
+ configuration->file))
;; This condition may be raised to abort the current step.
(define-condition-type &installer-step-abort &condition
@@ -60,12 +69,12 @@
(define-record-type* <installer-step>
installer-step make-installer-step
installer-step?
- (id installer-step-id) ;symbol
- (description installer-step-description ;string
- (default #f))
- (compute installer-step-compute) ;procedure
- (configuration-format-proc installer-step-configuration-proc ;procedure
- (default #f)))
+ (id installer-step-id) ;symbol
+ (description installer-step-description ;string
+ (default #f))
+ (compute installer-step-compute) ;procedure
+ (configuration-formatter installer-step-configuration-formatter ;procedure
+ (default #f)))
(define* (run-installer-steps #:key
steps
@@ -157,7 +166,7 @@ return the accumalated result so far."
(reverse result)))
(let* ((id (installer-step-id step))
(compute (installer-step-compute step))
- (res (compute result)))
+ (res (compute result done-steps)))
(run (alist-cons id res result)
#:todo-steps rest-steps
#:done-steps (append done-steps (list step))))))))
@@ -185,3 +194,44 @@ RESULTS."
"Return #t if the installer-step specified by STEP-ID has a COMPUTE value
stored in RESULTS. Return #f otherwise."
(and (assoc step-id results) #t))
+
+(define %installer-configuration-file (make-parameter "/mnt/etc/config.scm"))
+(define %installer-target-dir (make-parameter "/mnt"))
+(define %configuration-file-width (make-parameter 79))
+
+(define (format-configuration steps results)
+ "Return the list resulting from the application of the procedure defined in
+CONFIGURATION-FORMATTER field of <installer-step> on the associated result
+found in RESULTS."
+ (let ((configuration
+ (append-map
+ (lambda (step)
+ (let* ((step-id (installer-step-id step))
+ (conf-formatter
+ (installer-step-configuration-formatter step))
+ (result-step (result-step results step-id)))
+ (if (and result-step conf-formatter)
+ (conf-formatter result-step)
+ '())))
+ steps))
+ (modules '((use-modules (gnu))
+ (use-service-modules desktop))))
+ `(,@modules
+ ()
+ (operating-system ,@configuration))))
+
+(define* (configuration->file configuration
+ #:key (filename (%installer-configuration-file)))
+ "Write the given CONFIGURATION to FILENAME."
+ (mkdir-p (dirname filename))
+ (call-with-output-file filename
+ (lambda (port)
+ (format port ";; This is an operating system configuration generated~%")
+ (format port ";; by the graphical installer.~%")
+ (newline port)
+ (for-each (lambda (part)
+ (if (null? part)
+ (newline port)
+ (pretty-print part port)))
+ configuration)
+ (flush-output-port port))))
diff --git a/gnu/installer/timezone.scm b/gnu/installer/timezone.scm
index 061e8c2e48..32bc2ed6bb 100644
--- a/gnu/installer/timezone.scm
+++ b/gnu/installer/timezone.scm
@@ -28,7 +28,8 @@
#:export (locate-childrens
timezone->posix-tz
timezone-has-child?
- zonetab->timezone-tree))
+ zonetab->timezone-tree
+ posix-tz->configuration))
(define %not-blank
(char-set-complement char-set:blank))
@@ -115,3 +116,12 @@ TREE. Raise a condition if the PATH could not be found."
(define* (zonetab->timezone-tree zonetab)
"Return the timezone tree corresponding to the given ZONETAB file."
(timezones->timezone-tree (zonetab->timezones zonetab)))
+
+
+;;;
+;;; Configuration formatter.
+;;;
+
+(define (posix-tz->configuration timezone)
+ "Return the configuration field for TIMEZONE."
+ `((timezone ,timezone)))