From d0f3a672dcbdfefd3556b6a21985ff0e35eed3be Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 16 Nov 2018 20:43:55 +0900 Subject: 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. --- gnu/installer/newt.scm | 102 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 102 insertions(+) create mode 100644 gnu/installer/newt.scm (limited to 'gnu/installer/newt.scm') diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm new file mode 100644 index 0000000000..abf752959b --- /dev/null +++ b/gnu/installer/newt.scm @@ -0,0 +1,102 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Mathieu Othacehe +;;; +;;; 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 . + +(define-module (gnu installer newt) + #:use-module (gnu installer) + #:use-module (guix discovery) + #:use-module (guix gexp) + #:use-module (guix ui) + #:export (newt-installer)) + +(define (modules) + (cons '(newt) + (map module-name + (scheme-modules + (dirname (search-path %load-path "guix.scm")) + "gnu/installer/newt" + #:warn warn-about-load-error)))) + +(define init + #~(begin + (newt-init) + (clear-screen) + (set-screen-size!))) + +(define exit + #~(begin + (newt-finish))) + +(define exit-error + #~(lambda (key args) + (newt-finish))) + +(define locale-page + #~(lambda* (#:key + supported-locales + iso639-languages + iso3166-territories) + (run-locale-page + #:supported-locales supported-locales + #:iso639-languages iso639-languages + #:iso3166-territories iso3166-territories))) + +(define timezone-page + #~(lambda* (zonetab) + (run-timezone-page zonetab))) + +(define logo + (string-append + (dirname (search-path %load-path "guix.scm")) + "/gnu/installer/aux-files/logo.txt")) + +(define welcome-page + #~(run-welcome-page #$(local-file logo))) + +(define menu-page + #~(lambda (steps) + (run-menu-page steps))) + +(define keymap-page + #~(lambda* (#:key models layouts) + (run-keymap-page #:models models + #:layouts layouts))) + +(define network-page + #~(run-network-page)) + +(define hostname-page + #~(run-hostname-page)) + +(define user-page + #~(run-user-page)) + +(define newt-installer + (installer + (name 'newt) + (modules (modules)) + (init init) + (exit exit) + (exit-error exit-error) + (keymap-page keymap-page) + (locale-page locale-page) + (menu-page menu-page) + (network-page network-page) + (timezone-page timezone-page) + (hostname-page hostname-page) + (user-page user-page) + (welcome-page welcome-page))) -- cgit v1.2.3 From ba32109a28e7c67c748838b8f5d406ccc3983e7f Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sun, 18 Nov 2018 12:14:23 +0900 Subject: installer: newt: Use scheme-modules* instead of scheme-modules. * gnu/installer/newt.scm (modules): Use scheme-modules*. --- gnu/installer/newt.scm | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) (limited to 'gnu/installer/newt.scm') diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index abf752959b..3d9fd69bee 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -25,11 +25,9 @@ (define (modules) (cons '(newt) - (map module-name - (scheme-modules - (dirname (search-path %load-path "guix.scm")) - "gnu/installer/newt" - #:warn warn-about-load-error)))) + (scheme-modules* + (dirname (search-path %load-path "guix.scm")) + "gnu/installer/newt"))) (define init #~(begin -- cgit v1.2.3 From 9b9a5e3283168463545588f83748bb36411e68fe Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sun, 18 Nov 2018 12:22:50 +0900 Subject: installer: newt: Locate the logo within local-file. * gnu/installer/newt.scm (logo): Remove it, (welcome-page): Use a relative path to locate the logo. --- gnu/installer/newt.scm | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) (limited to 'gnu/installer/newt.scm') diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index 3d9fd69bee..23b737ddf0 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -57,13 +57,8 @@ #~(lambda* (zonetab) (run-timezone-page zonetab))) -(define logo - (string-append - (dirname (search-path %load-path "guix.scm")) - "/gnu/installer/aux-files/logo.txt")) - (define welcome-page - #~(run-welcome-page #$(local-file logo))) + #~(run-welcome-page #$(local-file "aux-files/logo.txt"))) (define menu-page #~(lambda (steps) -- cgit v1.2.3 From a49d633c0c65975263270f5ac0050482ca6a5513 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sat, 24 Nov 2018 12:25:03 +0900 Subject: installer: Move everything to the build side. * gnu/installer.scm: Rename to ... * gnu/installer/record.scm: ... this. * gnu/installer/build-installer.scm: Move everything to the build side and rename to gnu/installer.scm. * gnu/installer/newt.scm: Remove all the gexps and add depencies to newt modules as this code will only be used on the build side by now. * gnu/local.mk (GNU_SYSTEM_MODULES): Adapt it, (dist_installer_DATA): New rule to install installer's aux-files. * gnu/system/install.scm (%installation-services): Use only 'installer-program' from (gnu installer). The installer is now choosen on the build side. * guix/self.scm (*system-modules*): Restore previous behaviour and add all installer files to #:extra-files field of the scheme-node. * po/guix/POTFILES.in: Adapt it. --- gnu/installer.scm | 363 +++++++++++++++++++++++++++++--------- gnu/installer/build-installer.scm | 322 --------------------------------- gnu/installer/newt.scm | 94 +++++----- gnu/installer/record.scm | 75 ++++++++ gnu/local.mk | 7 +- gnu/system/install.scm | 6 +- guix/self.scm | 10 +- po/guix/POTFILES.in | 2 +- 8 files changed, 409 insertions(+), 470 deletions(-) delete mode 100644 gnu/installer/build-installer.scm create mode 100644 gnu/installer/record.scm (limited to 'gnu/installer/newt.scm') diff --git a/gnu/installer.scm b/gnu/installer.scm index f3323ea3bc..9e773ee8f0 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -17,95 +17,282 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu installer) - #:use-module (guix discovery) - #:use-module (guix records) + #:use-module (guix packages) + #:use-module (guix gexp) + #:use-module (guix modules) + #:use-module (guix utils) #:use-module (guix ui) + #:use-module ((guix self) #:select (make-config.scm)) + #:use-module (gnu packages admin) + #:use-module (gnu packages base) + #:use-module (gnu packages bash) + #:use-module (gnu packages connman) + #:use-module (gnu packages guile) + #:autoload (gnu packages gnupg) (guile-gcrypt) + #:use-module (gnu packages iso-codes) + #:use-module (gnu packages linux) + #:use-module (gnu packages ncurses) + #:use-module (gnu packages package-management) + #:use-module (gnu packages xorg) + #:use-module (ice-9 match) #:use-module (srfi srfi-1) - #:export ( - installer - make-installer - installer? - installer-name - installer-modules - installer-init - installer-exit - installer-exit-error - installer-keymap-page - installer-locale-page - installer-menu-page - installer-network-page - installer-timezone-page - installer-hostname-page - installer-user-page - installer-welcome-page - - %installers - lookup-installer-by-name)) - - -;;; -;;; Installer record. -;;; + #:export (installer-program)) -;; The record contains pages that will be run to prompt the user -;; for the system configuration. The goal of the installer is to produce a -;; complete record and install it. - -(define-record-type* - installer make-installer - installer? - ;; symbol - (name installer-name) - ;; list of installer modules - (modules installer-modules) - ;; procedure: void -> void - (init installer-init) - ;; procedure: void -> void - (exit installer-exit) - ;; procedure (key arguments) -> void - (exit-error installer-exit-error) - ;; procedure (#:key models layouts) -> (list model layout variant) - (keymap-page installer-keymap-page) - ;; procedure: (#:key supported-locales iso639-languages iso3166-territories) - ;; -> glibc-locale - (locale-page installer-locale-page) - ;; procedure: (steps) -> step-id - (menu-page installer-menu-page) - ;; procedure void -> void - (network-page installer-network-page) - ;; procedure (zonetab) -> posix-timezone - (timezone-page installer-timezone-page) - ;; procedure void -> void - (hostname-page installer-hostname-page) - ;; procedure void -> void - (user-page installer-user-page) - ;; procedure (logo) -> void - (welcome-page installer-welcome-page)) - - -;;; -;;; Installers. -;;; +(define not-config? + ;; Select (guix …) and (gnu …) modules, except (guix config). + (match-lambda + (('guix 'config) #f) + (('guix rest ...) #t) + (('gnu rest ...) #t) + (rest #f))) + +(define* (build-compiled-file name locale-builder) + "Return a file-like object that evalutes the gexp LOCALE-BUILDER and store +its result in the scheme file NAME. The derivation will also build a compiled +version of this file." + (define set-utf8-locale + #~(begin + (setenv "LOCPATH" + #$(file-append glibc-utf8-locales "/lib/locale/" + (version-major+minor + (package-version glibc-utf8-locales)))) + (setlocale LC_ALL "en_US.utf8"))) + + (define builder + (with-extensions (list guile-json) + (with-imported-modules (source-module-closure + '((gnu installer locale))) + #~(begin + (use-modules (gnu installer locale)) + + ;; The locale files contain non-ASCII characters. + #$set-utf8-locale + + (mkdir #$output) + (let ((locale-file + (string-append #$output "/" #$name ".scm")) + (locale-compiled-file + (string-append #$output "/" #$name ".go"))) + (call-with-output-file locale-file + (lambda (port) + (write #$locale-builder port))) + (compile-file locale-file + #:output-file locale-compiled-file)))))) + (computed-file name builder)) + +(define apply-locale + ;; Install the specified locale. + #~(lambda (locale-name) + (false-if-exception + (setlocale LC_ALL locale-name)))) + +(define* (compute-locale-step #:key + locales-name + iso639-languages-name + iso3166-territories-name) + "Return a gexp that run the locale-page of INSTALLER, and install the +selected locale. The list of locales, languages and territories passed to +locale-page are computed in derivations named respectively LOCALES-NAME, +ISO639-LANGUAGES-NAME and ISO3166-TERRITORIES-NAME. Those lists are compiled, +so that when the installer is run, all the lengthy operations have already +been performed at build time." + (define (compiled-file-loader file name) + #~(load-compiled + (string-append #$file "/" #$name ".go"))) + + (let* ((supported-locales #~(supported-locales->locales + #$(local-file "installer/aux-files/SUPPORTED"))) + (iso-codes #~(string-append #$iso-codes "/share/iso-codes/json/")) + (iso639-3 #~(string-append #$iso-codes "iso_639-3.json")) + (iso639-5 #~(string-append #$iso-codes "iso_639-5.json")) + (iso3166 #~(string-append #$iso-codes "iso_3166-1.json")) + (locales-file (build-compiled-file + locales-name + #~`(quote ,#$supported-locales))) + (iso639-file (build-compiled-file + iso639-languages-name + #~`(quote ,(iso639->iso639-languages + #$supported-locales + #$iso639-3 #$iso639-5)))) + (iso3166-file (build-compiled-file + iso3166-territories-name + #~`(quote ,(iso3166->iso3166-territories #$iso3166)))) + (locales-loader (compiled-file-loader locales-file + locales-name)) + (iso639-loader (compiled-file-loader iso639-file + iso639-languages-name)) + (iso3166-loader (compiled-file-loader iso3166-file + iso3166-territories-name))) + #~(lambda (current-installer) + (let ((result + ((installer-locale-page current-installer) + #:supported-locales #$locales-loader + #:iso639-languages #$iso639-loader + #:iso3166-territories #$iso3166-loader))) + (#$apply-locale result))))) + +(define apply-keymap + ;; Apply the specified keymap. + #~(match-lambda + ((model layout variant) + (kmscon-update-keymap model layout variant)))) + +(define* (compute-keymap-step) + "Return a gexp that runs the keymap-page of INSTALLER and install the +selected keymap." + #~(lambda (current-installer) + (let ((result + (call-with-values + (lambda () + (xkb-rules->models+layouts + (string-append #$xkeyboard-config + "/share/X11/xkb/rules/base.xml"))) + (lambda (models layouts) + ((installer-keymap-page current-installer) + #:models models + #:layouts layouts))))) + (#$apply-keymap result)))) + +(define (installer-steps) + (let ((locale-step (compute-locale-step + #:locales-name "locales" + #:iso639-languages-name "iso639-languages" + #:iso3166-territories-name "iso3166-territories")) + (keymap-step (compute-keymap-step)) + (timezone-data #~(string-append #$tzdata + "/share/zoneinfo/zone.tab"))) + #~(lambda (current-installer) + (list + ;; Welcome the user and ask him to choose between manual installation + ;; and graphical install. + (installer-step + (id 'welcome) + (compute (lambda _ + ((installer-welcome-page current-installer) + #$(local-file "installer/aux-files/logo.txt"))))) + + ;; Ask the user to choose a locale among those supported by the glibc. + ;; Install the selected locale right away, so that the user may + ;; benefit from any available translation for the installer messages. + (installer-step + (id 'locale) + (description (G_ "Locale selection")) + (compute (lambda _ + (#$locale-step current-installer)))) + + ;; Ask the user to select a timezone under glibc format. + (installer-step + (id 'timezone) + (description (G_ "Timezone selection")) + (compute (lambda _ + ((installer-timezone-page current-installer) + #$timezone-data)))) + + ;; The installer runs in a kmscon virtual terminal where loadkeys + ;; won't work. kmscon uses libxkbcommon as a backend for keyboard + ;; input. It is possible to update kmscon current keymap by sending it + ;; a keyboard model, layout and variant, in a somehow similar way as + ;; what is done with setxkbmap utility. + ;; + ;; So ask for a keyboard model, layout and variant to update the + ;; current kmscon keymap. + (installer-step + (id 'keymap) + (description (G_ "Keyboard mapping selection")) + (compute (lambda _ + (#$keymap-step current-installer)))) + + ;; Ask the user to input a hostname for the system. + (installer-step + (id 'hostname) + (description (G_ "Hostname selection")) + (compute (lambda _ + ((installer-hostname-page current-installer))))) + + ;; Provide an interface above connmanctl, so that the user can select + ;; a network susceptible to acces Internet. + (installer-step + (id 'network) + (description (G_ "Network selection")) + (compute (lambda _ + ((installer-network-page current-installer))))) + + ;; Prompt for users (name, group and home directory). + (installer-step + (id 'hostname) + (description (G_ "User selection")) + (compute (lambda _ + ((installer-user-page current-installer))))))))) + +(define (installer-program) + "Return a file-like object that runs the given INSTALLER." + (define init-gettext + ;; Initialize gettext support, so that installer messages can be + ;; translated. + #~(begin + (bindtextdomain "guix" (string-append #$guix "/share/locale")) + (textdomain "guix"))) + + (define set-installer-path + ;; Add the specified binary to PATH for later use by the installer. + #~(let* ((inputs + '#$(append (list bash connman shadow) + (map canonical-package (list coreutils))))) + (with-output-to-port (%make-void-port "w") + (lambda () + (set-path-environment-variable "PATH" '("bin" "sbin") inputs))))) + + (define steps (installer-steps)) + + (define installer-builder + (with-extensions (list guile-gcrypt guile-newt guile-json) + (with-imported-modules `(,@(source-module-closure + '((gnu installer newt) + (guix build utils)) + #:select? not-config?) + ((guix config) => ,(make-config.scm))) + #~(begin + (use-modules (gnu installer record) + (gnu installer keymap) + (gnu installer steps) + (gnu installer locale) + (gnu installer newt) + (guix i18n) + (guix build utils) + (ice-9 match)) + + ;; Set the default locale to install unicode support. + (setlocale LC_ALL "en_US.utf8") + + ;; Initialize gettext support so that installers can use + ;; (guix i18n) module. + #$init-gettext + + ;; Add some binaries used by the installers to PATH. + #$set-installer-path + + (let ((current-installer newt-installer)) + ((installer-init current-installer)) + + (catch #t + (lambda () + (run-installer-steps + #:rewind-strategy 'menu + #:menu-proc (installer-menu-page current-installer) + #:steps (#$steps current-installer))) + (const #f) + (lambda (key . args) + ((installer-exit-error current-installer) key args) + + ;; Be sure to call newt-finish, to restore the terminal into + ;; its original state before printing the error report. + (call-with-output-file "/tmp/error" + (lambda (port) + (display-backtrace (make-stack #t) port) + (print-exception port + (stack-ref (make-stack #t) 1) + key args))) + (primitive-exit 1)))) + ((installer-exit current-installer)))))) -(define (installer-top-modules) - "Return the list of installer modules." - (all-modules (map (lambda (entry) - `(,entry . "gnu/installer")) - %load-path) - #:warn warn-about-load-error)) - -(define %installers - ;; The list of publically-known installers. - (delay (fold-module-public-variables (lambda (obj result) - (if (installer? obj) - (cons obj result) - result)) - '() - (installer-top-modules)))) - -(define (lookup-installer-by-name name) - "Return the installer called NAME." - (or (find (lambda (installer) - (eq? name (installer-name installer))) - (force %installers)) - (leave (G_ "~a: no such installer~%") name))) + (program-file "installer" installer-builder)) diff --git a/gnu/installer/build-installer.scm b/gnu/installer/build-installer.scm deleted file mode 100644 index c7f439b35f..0000000000 --- a/gnu/installer/build-installer.scm +++ /dev/null @@ -1,322 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Mathieu Othacehe -;;; -;;; 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 . - -(define-module (gnu installer build-installer) - #:use-module (guix packages) - #:use-module (guix gexp) - #:use-module (guix modules) - #:use-module (guix utils) - #:use-module (guix ui) - #:use-module ((guix self) #:select (make-config.scm)) - #:use-module (gnu installer) - #:use-module (gnu packages admin) - #:use-module (gnu packages base) - #:use-module (gnu packages bash) - #:use-module (gnu packages connman) - #:use-module (gnu packages guile) - #:autoload (gnu packages gnupg) (guile-gcrypt) - #:use-module (gnu packages iso-codes) - #:use-module (gnu packages linux) - #:use-module (gnu packages ncurses) - #:use-module (gnu packages package-management) - #:use-module (gnu packages xorg) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:export (installer-program - installer-program-launcher)) - -(define not-config? - ;; Select (guix …) and (gnu …) modules, except (guix config). - (match-lambda - (('guix 'config) #f) - (('guix rest ...) #t) - (('gnu rest ...) #t) - (rest #f))) - -(define* (build-compiled-file name locale-builder) - "Return a file-like object that evalutes the gexp LOCALE-BUILDER and store -its result in the scheme file NAME. The derivation will also build a compiled -version of this file." - (define set-utf8-locale - #~(begin - (setenv "LOCPATH" - #$(file-append glibc-utf8-locales "/lib/locale/" - (version-major+minor - (package-version glibc-utf8-locales)))) - (setlocale LC_ALL "en_US.utf8"))) - - (define builder - (with-extensions (list guile-json) - (with-imported-modules (source-module-closure - '((gnu installer locale))) - #~(begin - (use-modules (gnu installer locale)) - - ;; The locale files contain non-ASCII characters. - #$set-utf8-locale - - (mkdir #$output) - (let ((locale-file - (string-append #$output "/" #$name ".scm")) - (locale-compiled-file - (string-append #$output "/" #$name ".go"))) - (call-with-output-file locale-file - (lambda (port) - (write #$locale-builder port))) - (compile-file locale-file - #:output-file locale-compiled-file)))))) - (computed-file name builder)) - -(define apply-locale - ;; Install the specified locale. - #~(lambda (locale-name) - (false-if-exception - (setlocale LC_ALL locale-name)))) - -(define* (compute-locale-step installer - #:key - locales-name - iso639-languages-name - iso3166-territories-name) - "Return a gexp that run the locale-page of INSTALLER, and install the -selected locale. The list of locales, languages and territories passed to -locale-page are computed in derivations named respectively LOCALES-NAME, -ISO639-LANGUAGES-NAME and ISO3166-TERRITORIES-NAME. Those lists are compiled, -so that when the installer is run, all the lengthy operations have already -been performed at build time." - (define (compiled-file-loader file name) - #~(load-compiled - (string-append #$file "/" #$name ".go"))) - - (let* ((supported-locales #~(supported-locales->locales - #$(local-file "aux-files/SUPPORTED"))) - (iso-codes #~(string-append #$iso-codes "/share/iso-codes/json/")) - (iso639-3 #~(string-append #$iso-codes "iso_639-3.json")) - (iso639-5 #~(string-append #$iso-codes "iso_639-5.json")) - (iso3166 #~(string-append #$iso-codes "iso_3166-1.json")) - (locales-file (build-compiled-file - locales-name - #~`(quote ,#$supported-locales))) - (iso639-file (build-compiled-file - iso639-languages-name - #~`(quote ,(iso639->iso639-languages - #$supported-locales - #$iso639-3 #$iso639-5)))) - (iso3166-file (build-compiled-file - iso3166-territories-name - #~`(quote ,(iso3166->iso3166-territories #$iso3166)))) - (locales-loader (compiled-file-loader locales-file - locales-name)) - (iso639-loader (compiled-file-loader iso639-file - iso639-languages-name)) - (iso3166-loader (compiled-file-loader iso3166-file - iso3166-territories-name))) - #~(let ((result - (#$(installer-locale-page installer) - #:supported-locales #$locales-loader - #:iso639-languages #$iso639-loader - #:iso3166-territories #$iso3166-loader))) - (#$apply-locale result)))) - -(define apply-keymap - ;; Apply the specified keymap. - #~(match-lambda - ((model layout variant) - (kmscon-update-keymap model layout variant)))) - -(define* (compute-keymap-step installer) - "Return a gexp that runs the keymap-page of INSTALLER and install the -selected keymap." - #~(let ((result - (call-with-values - (lambda () - (xkb-rules->models+layouts - (string-append #$xkeyboard-config - "/share/X11/xkb/rules/base.xml"))) - (lambda (models layouts) - (#$(installer-keymap-page installer) - #:models models - #:layouts layouts))))) - (#$apply-keymap result))) - -(define (installer-steps installer) - (let ((locale-step (compute-locale-step - installer - #:locales-name "locales" - #:iso639-languages-name "iso639-languages" - #:iso3166-territories-name "iso3166-territories")) - (keymap-step (compute-keymap-step installer)) - (timezone-data #~(string-append #$tzdata - "/share/zoneinfo/zone.tab"))) - #~(list - ;; Welcome the user and ask him to choose between manual installation - ;; and graphical install. - (installer-step - (id 'welcome) - (compute (lambda _ - #$(installer-welcome-page installer)))) - - ;; Ask the user to choose a locale among those supported by the glibc. - ;; Install the selected locale right away, so that the user may - ;; benefit from any available translation for the installer messages. - (installer-step - (id 'locale) - (description (G_ "Locale selection")) - (compute (lambda _ - #$locale-step))) - - ;; Ask the user to select a timezone under glibc format. - (installer-step - (id 'timezone) - (description (G_ "Timezone selection")) - (compute (lambda _ - (#$(installer-timezone-page installer) - #$timezone-data)))) - - ;; The installer runs in a kmscon virtual terminal where loadkeys - ;; won't work. kmscon uses libxkbcommon as a backend for keyboard - ;; input. It is possible to update kmscon current keymap by sending it - ;; a keyboard model, layout and variant, in a somehow similar way as - ;; what is done with setxkbmap utility. - ;; - ;; So ask for a keyboard model, layout and variant to update the - ;; current kmscon keymap. - (installer-step - (id 'keymap) - (description (G_ "Keyboard mapping selection")) - (compute (lambda _ - #$keymap-step))) - - ;; Ask the user to input a hostname for the system. - (installer-step - (id 'hostname) - (description (G_ "Hostname selection")) - (compute (lambda _ - #$(installer-hostname-page installer)))) - - ;; Provide an interface above connmanctl, so that the user can select - ;; a network susceptible to acces Internet. - (installer-step - (id 'network) - (description (G_ "Network selection")) - (compute (lambda _ - #$(installer-network-page installer)))) - - ;; Prompt for users (name, group and home directory). - (installer-step - (id 'hostname) - (description (G_ "User selection")) - (compute (lambda _ - #$(installer-user-page installer))))))) - -(define (installer-program installer) - "Return a file-like object that runs the given INSTALLER." - (define init-gettext - ;; Initialize gettext support, so that installer messages can be - ;; translated. - #~(begin - (bindtextdomain "guix" (string-append #$guix "/share/locale")) - (textdomain "guix"))) - - (define set-installer-path - ;; Add the specified binary to PATH for later use by the installer. - #~(let* ((inputs - '#$(append (list bash connman shadow) - (map canonical-package (list coreutils))))) - (with-output-to-port (%make-void-port "w") - (lambda () - (set-path-environment-variable "PATH" '("bin" "sbin") inputs))))) - - (define installer-builder - (with-extensions (list guile-gcrypt guile-newt guile-json) - (with-imported-modules `(,@(source-module-closure - `(,@(installer-modules installer) - (guix build utils)) - #:select? not-config?) - ((guix config) => ,(make-config.scm))) - #~(begin - (use-modules (gnu installer keymap) - (gnu installer steps) - (gnu installer locale) - #$@(installer-modules installer) - (guix i18n) - (guix build utils) - (ice-9 match)) - - ;; Initialize gettext support so that installers can use - ;; (guix i18n) module. - #$init-gettext - - ;; Add some binaries used by the installers to PATH. - #$set-installer-path - - #$(installer-init installer) - - (catch #t - (lambda () - (run-installer-steps - #:rewind-strategy 'menu - #:menu-proc #$(installer-menu-page installer) - #:steps #$(installer-steps installer))) - (const #f) - (lambda (key . args) - (#$(installer-exit-error installer) key args) - - ;; Be sure to call newt-finish, to restore the terminal into - ;; its original state before printing the error report. - (call-with-output-file "/tmp/error" - (lambda (port) - (display-backtrace (make-stack #t) port) - (print-exception port - (stack-ref (make-stack #t) 1) - key args))) - (primitive-exit 1))) - #$(installer-exit installer))))) - - (program-file "installer" installer-builder)) - -;; We want the installer to honor the LANG environment variable, so that the -;; locale is correctly installed when the installer is launched, and the -;; welcome page is possibly translated. The /etc/environment file (containing -;; LANG) is supposed to be loaded using PAM by the login program. As the -;; installer replaces the login program, read this file and set all the -;; variables it contains before starting the installer. This is a dirty hack, -;; we might want to find a better way to do it in the future. -(define (installer-program-launcher installer) - "Return a file-like object that set the variables in /etc/environment and -run the given INSTALLER." - (define load-environment - #~(call-with-input-file "/etc/environment" - (lambda (port) - (let ((lines (read-lines port))) - (map (lambda (line) - (match (string-split line #\=) - ((name value) - (setenv name value)))) - lines))))) - - (define wrapper - (with-imported-modules '((gnu installer utils)) - #~(begin - (use-modules (gnu installer utils) - (ice-9 match)) - - #$load-environment - (system #$(installer-program installer))))) - - (program-file "installer-launcher" wrapper)) diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index 23b737ddf0..db57c732d1 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -17,71 +17,69 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu installer newt) - #:use-module (gnu installer) + #:use-module (gnu installer record) + #:use-module (gnu installer newt ethernet) + #:use-module (gnu installer newt hostname) + #:use-module (gnu installer newt keymap) + #:use-module (gnu installer newt locale) + #:use-module (gnu installer newt menu) + #:use-module (gnu installer newt network) + #:use-module (gnu installer newt timezone) + #:use-module (gnu installer newt user) + #:use-module (gnu installer newt utils) + #:use-module (gnu installer newt welcome) + #:use-module (gnu installer newt wifi) #:use-module (guix discovery) - #:use-module (guix gexp) - #:use-module (guix ui) + #:use-module (guix i18n) + #:use-module (srfi srfi-26) + #:use-module (newt) #:export (newt-installer)) -(define (modules) - (cons '(newt) - (scheme-modules* - (dirname (search-path %load-path "guix.scm")) - "gnu/installer/newt"))) +(define (init) + (newt-init) + (clear-screen) + (set-screen-size!)) -(define init - #~(begin - (newt-init) - (clear-screen) - (set-screen-size!))) +(define (exit) + (newt-finish)) -(define exit - #~(begin - (newt-finish))) +(define (exit-error key . args) + (newt-finish)) -(define exit-error - #~(lambda (key args) - (newt-finish))) +(define* (locale-page #:key + supported-locales + iso639-languages + iso3166-territories) + (run-locale-page + #:supported-locales supported-locales + #:iso639-languages iso639-languages + #:iso3166-territories iso3166-territories)) -(define locale-page - #~(lambda* (#:key - supported-locales - iso639-languages - iso3166-territories) - (run-locale-page - #:supported-locales supported-locales - #:iso639-languages iso639-languages - #:iso3166-territories iso3166-territories))) +(define (timezone-page zonetab) + (run-timezone-page zonetab)) -(define timezone-page - #~(lambda* (zonetab) - (run-timezone-page zonetab))) +(define (welcome-page logo) + (run-welcome-page logo)) -(define welcome-page - #~(run-welcome-page #$(local-file "aux-files/logo.txt"))) +(define (menu-page steps) + (run-menu-page steps)) -(define menu-page - #~(lambda (steps) - (run-menu-page steps))) +(define* (keymap-page #:key models layouts) + (run-keymap-page #:models models + #:layouts layouts)) -(define keymap-page - #~(lambda* (#:key models layouts) - (run-keymap-page #:models models - #:layouts layouts))) +(define (network-page) + (run-network-page)) -(define network-page - #~(run-network-page)) +(define (hostname-page) + (run-hostname-page)) -(define hostname-page - #~(run-hostname-page)) - -(define user-page - #~(run-user-page)) +(define (user-page) + (run-user-page)) (define newt-installer (installer (name 'newt) - (modules (modules)) (init init) (exit exit) (exit-error exit-error) diff --git a/gnu/installer/record.scm b/gnu/installer/record.scm new file mode 100644 index 0000000000..9c10c65758 --- /dev/null +++ b/gnu/installer/record.scm @@ -0,0 +1,75 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Mathieu Othacehe +;;; +;;; 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 . + +(define-module (gnu installer record) + #:use-module (guix records) + #:use-module (srfi srfi-1) + #:export ( + installer + make-installer + installer? + installer-name + installer-init + installer-exit + installer-exit-error + installer-keymap-page + installer-locale-page + installer-menu-page + installer-network-page + installer-timezone-page + installer-hostname-page + installer-user-page + installer-welcome-page)) + + +;;; +;;; Installer record. +;;; + +;; The record contains pages that will be run to prompt the user +;; for the system configuration. The goal of the installer is to produce a +;; complete record and install it. + +(define-record-type* + installer make-installer + installer? + ;; symbol + (name installer-name) + ;; procedure: void -> void + (init installer-init) + ;; procedure: void -> void + (exit installer-exit) + ;; procedure (key arguments) -> void + (exit-error installer-exit-error) + ;; procedure (#:key models layouts) -> (list model layout variant) + (keymap-page installer-keymap-page) + ;; procedure: (#:key supported-locales iso639-languages iso3166-territories) + ;; -> glibc-locale + (locale-page installer-locale-page) + ;; procedure: (steps) -> step-id + (menu-page installer-menu-page) + ;; procedure void -> void + (network-page installer-network-page) + ;; procedure (zonetab) -> posix-timezone + (timezone-page installer-timezone-page) + ;; procedure void -> void + (hostname-page installer-hostname-page) + ;; procedure void -> void + (user-page installer-user-page) + ;; procedure (logo) -> void + (welcome-page installer-welcome-page)) diff --git a/gnu/local.mk b/gnu/local.mk index 665721bec1..b0ec16de34 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -567,7 +567,7 @@ if ENABLE_INSTALLER GNU_SYSTEM_MODULES += \ %D%/installer.scm \ - %D%/installer/build-installer.scm \ + %D%/installer/record.scm \ %D%/installer/connman.scm \ %D%/installer/keymap.scm \ %D%/installer/locale.scm \ @@ -588,6 +588,11 @@ GNU_SYSTEM_MODULES += \ %D%/installer/newt/welcome.scm \ %D%/installer/newt/wifi.scm +installerdir = $(guilemoduledir)/%D%/installer +dist_installer_DATA = \ + %D%/installer/aux-files/logo.txt \ + %D%/installer/aux-files/SUPPORTED + endif ENABLE_INSTALLER # Modules that do not need to be compiled. diff --git a/gnu/system/install.scm b/gnu/system/install.scm index aef083506c..880a8be32d 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -28,8 +28,7 @@ #:use-module (guix store) #:use-module (guix monads) #:use-module ((guix store) #:select (%store-prefix)) - #:use-module (gnu installer newt) - #:use-module (gnu installer build-installer) + #:use-module (gnu installer) #:use-module (gnu services dbus) #:use-module (gnu services networking) #:use-module (gnu services shepherd) @@ -233,8 +232,7 @@ You have been warned. Thanks for being so brave.\x1b[0m (service kmscon-service-type (kmscon-configuration (virtual-terminal "tty1") - (login-program (installer-program-launcher - newt-installer)))) + (login-program (installer-program)))) (login-service (login-configuration (motd motd))) diff --git a/guix/self.scm b/guix/self.scm index 2698596387..4df4f6506e 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -604,11 +604,7 @@ Info manual." (scheme-node "guix-system" `((gnu system) (gnu services) - ,@(filter-map - (match-lambda - (('gnu 'system 'install) #f) - (name name)) - (scheme-modules* source "gnu/system")) + ,@(scheme-modules* source "gnu/system") ,@(scheme-modules* source "gnu/services")) (list *core-package-modules* *package-modules* *extra-modules* *core-modules*) @@ -616,7 +612,9 @@ Info manual." #:extra-files (append (file-imports source "gnu/system/examples" (const #t)) - + ;; All the installer code is on the build-side. + (file-imports source "gnu/installer/" + (const #t)) ;; Build-side code that we don't build. Some of ;; these depend on guile-rsvg, the Shepherd, etc. (file-imports source "gnu/build" (const #t))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 585ceeb5c2..1378b33e0e 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -9,7 +9,7 @@ gnu/system/mapped-devices.scm gnu/system/shadow.scm guix/import/opam.scm gnu/installer.scm -gnu/installer/build-installer.scm +gnu/installer/record.scm gnu/installer/connman.scm gnu/installer/keymap.scm gnu/installer/locale.scm -- cgit v1.2.3 From dc5f3275ecbddc804875899e9e457299a835d7ab Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 14:30:16 +0900 Subject: 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. --- gnu/installer.scm | 51 +++++++++++++++++++-------- gnu/installer/final.scm | 36 +++++++++++++++++++ gnu/installer/locale.scm | 13 ++++++- gnu/installer/newt.scm | 5 +++ gnu/installer/newt/final.scm | 84 ++++++++++++++++++++++++++++++++++++++++++++ gnu/installer/record.scm | 3 ++ gnu/installer/steps.scm | 68 ++++++++++++++++++++++++++++++----- gnu/installer/timezone.scm | 12 ++++++- gnu/local.mk | 2 ++ 9 files changed, 249 insertions(+), 25 deletions(-) create mode 100644 gnu/installer/final.scm create mode 100644 gnu/installer/newt/final.scm (limited to 'gnu/installer/newt.scm') diff --git a/gnu/installer.scm b/gnu/installer.scm index b3eb2a6b08..e53acb12f4 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -129,7 +129,8 @@ been performed at build time." #:supported-locales #$locales-loader #:iso639-languages #$iso639-loader #:iso3166-territories #$iso3166-loader))) - (#$apply-locale result))))) + (#$apply-locale result) + result)))) (define apply-keymap ;; Apply the specified keymap. @@ -176,17 +177,19 @@ selected keymap." ;; benefit from any available translation for the installer messages. (installer-step (id 'locale) - (description (G_ "Locale selection")) + (description (G_ "Locale")) (compute (lambda _ - (#$locale-step current-installer)))) + (#$locale-step current-installer))) + (configuration-formatter locale->configuration)) ;; Ask the user to select a timezone under glibc format. (installer-step (id 'timezone) - (description (G_ "Timezone selection")) + (description (G_ "Timezone")) (compute (lambda _ ((installer-timezone-page current-installer) - #$timezone-data)))) + #$timezone-data))) + (configuration-formatter posix-tz->configuration)) ;; The installer runs in a kmscon virtual terminal where loadkeys ;; won't work. kmscon uses libxkbcommon as a backend for keyboard @@ -205,9 +208,10 @@ selected keymap." ;; Ask the user to input a hostname for the system. (installer-step (id 'hostname) - (description (G_ "Hostname selection")) + (description (G_ "Hostname")) (compute (lambda _ - ((installer-hostname-page current-installer))))) + ((installer-hostname-page current-installer)))) + (configuration-formatter hostname->configuration)) ;; Provide an interface above connmanctl, so that the user can select ;; a network susceptible to acces Internet. @@ -219,10 +223,22 @@ selected keymap." ;; Prompt for users (name, group and home directory). (installer-step - (id 'hostname) - (description (G_ "User selection")) + (id 'user) + (description (G_ "User creation")) + (compute (lambda _ + ((installer-user-page current-installer)))) + (configuration-formatter users->configuration)) + (compute (lambda _ - ((installer-user-page current-installer))))))))) + ((installer-user-page current-installer))))) + + (installer-step + (id 'final) + (description (G_ "Configuration file")) + (compute + (lambda (result prev-steps) + ((installer-final-page current-installer) + result prev-steps))))))) (define (installer-program) "Return a file-like object that runs the given INSTALLER." @@ -255,7 +271,12 @@ selected keymap." (use-modules (gnu installer record) (gnu installer keymap) (gnu installer steps) + (gnu installer final) (gnu installer locale) + (gnu installer parted) + (gnu installer services) + (gnu installer timezone) + (gnu installer user) (gnu installer newt) (guix i18n) (guix build utils) @@ -268,7 +289,8 @@ selected keymap." ;; Add some binaries used by the installers to PATH. #$set-installer-path - (let ((current-installer newt-installer)) + (let* ((current-installer newt-installer) + (steps (#$steps current-installer))) ((installer-init current-installer)) (catch #t @@ -276,7 +298,7 @@ selected keymap." (run-installer-steps #:rewind-strategy 'menu #:menu-proc (installer-menu-page current-installer) - #:steps (#$steps current-installer))) + #:steps steps)) (const #f) (lambda (key . args) ((installer-exit-error current-installer) key args) @@ -289,8 +311,9 @@ selected keymap." (print-exception port (stack-ref (make-stack #t) 1) key args))) - (primitive-exit 1)))) - ((installer-exit current-installer)))))) + (primitive-exit 1))) + + ((installer-exit current-installer))))))) (program-file "installer" 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 +;;; +;;; 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 . + +(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 +;;; +;;; 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 . + +(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 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 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))) diff --git a/gnu/local.mk b/gnu/local.mk index b0ec16de34..d4acb8d2ec 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -569,6 +569,7 @@ GNU_SYSTEM_MODULES += \ %D%/installer.scm \ %D%/installer/record.scm \ %D%/installer/connman.scm \ + %D%/installer/final.scm \ %D%/installer/keymap.scm \ %D%/installer/locale.scm \ %D%/installer/newt.scm \ @@ -577,6 +578,7 @@ GNU_SYSTEM_MODULES += \ %D%/installer/utils.scm \ \ %D%/installer/newt/ethernet.scm \ + %D%/installer/newt/final.scm \ %D%/installer/newt/hostname.scm \ %D%/installer/newt/keymap.scm \ %D%/installer/newt/locale.scm \ -- cgit v1.2.3 From c088b2e47f6675199f1ef545df7d04d4532e64e3 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 14:36:22 +0900 Subject: installer: Do not ask for keyboard model. Suppose that the keyboard model is "pc105". * gnu/installer.scm (apply-keymap): Remove model ... * gnu/installer/newt/keymap.scm (run-keymap-page): passed here. (run-model-page): remove procedure * gnu/installer/record.scm (installer): Edit keymap-page prototype in comment. * gnu/installer/keymap.scm (default-keyboard-model): New exported parameter. --- gnu/installer.scm | 10 +++++----- gnu/installer/keymap.scm | 4 ++++ gnu/installer/newt.scm | 5 ++--- gnu/installer/newt/keymap.scm | 44 ++++++------------------------------------- gnu/installer/newt/locale.scm | 6 +++--- gnu/installer/record.scm | 2 +- 6 files changed, 21 insertions(+), 50 deletions(-) (limited to 'gnu/installer/newt.scm') diff --git a/gnu/installer.scm b/gnu/installer.scm index e53acb12f4..4a587eb35b 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -133,10 +133,11 @@ been performed at build time." result)))) (define apply-keymap - ;; Apply the specified keymap. + ;; Apply the specified keymap. Use the default keyboard model. #~(match-lambda - ((model layout variant) - (kmscon-update-keymap model layout variant)))) + ((layout variant) + (kmscon-update-keymap (default-keyboard-model) + layout variant)))) (define* (compute-keymap-step) "Return a gexp that runs the keymap-page of INSTALLER and install the @@ -150,8 +151,7 @@ selected keymap." "/share/X11/xkb/rules/base.xml"))) (lambda (models layouts) ((installer-keymap-page current-installer) - #:models models - #:layouts layouts))))) + layouts))))) (#$apply-keymap result)))) (define (installer-steps) diff --git a/gnu/installer/keymap.scm b/gnu/installer/keymap.scm index 78065aa6c6..d9f8656855 100644 --- a/gnu/installer/keymap.scm +++ b/gnu/installer/keymap.scm @@ -46,6 +46,7 @@ x11-keymap-variant-name x11-keymap-variant-description + default-keyboard-model xkb-rules->models+layouts kmscon-update-keymap)) @@ -68,6 +69,9 @@ (name x11-keymap-variant-name) ;string (description x11-keymap-variant-description)) ;string +;; Assume all modern keyboards have this model. +(define default-keyboard-model (make-parameter "pc105")) + (define (xkb-rules->models+layouts file) "Parse FILE and return two values, the list of supported X11-KEYMAP-MODEL and X11-KEYMAP-LAYOUT records. FILE is an XML file from the X Keyboard diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index 77a7e6dca2..1f51b111a8 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -68,9 +68,8 @@ (define (menu-page steps) (run-menu-page steps)) -(define* (keymap-page #:key models layouts) - (run-keymap-page #:models models - #:layouts layouts)) +(define* (keymap-page layouts) + (run-keymap-page layouts)) (define (network-page) (run-network-page)) diff --git a/gnu/installer/newt/keymap.scm b/gnu/installer/newt/keymap.scm index 0c9432bba2..0c38a79e19 100644 --- a/gnu/installer/newt/keymap.scm +++ b/gnu/installer/newt/keymap.scm @@ -56,42 +56,12 @@ (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* (run-keymap-page layouts) + "Run a page asking the user to select a keyboard layout and variant. LAYOUTS +is a list of supported X11-KEYMAP-LAYOUT. Return a list of two elements, the +names of the selected keyboard layout and variant." (define keymap-steps (list - (installer-step - (id '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 @@ -120,13 +90,11 @@ keyboard model, layout and variant." variant))))))))) (define (format-result result) - (let ((model (x11-keymap-model-name - (result-step result 'model))) - (layout (x11-keymap-layout-name + (let ((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 "")))) + (list layout (or variant "")))) (format-result (run-installer-steps #:steps keymap-steps))) diff --git a/gnu/installer/newt/locale.scm b/gnu/installer/newt/locale.scm index 599a6b0ecf..028372c194 100644 --- a/gnu/installer/newt/locale.scm +++ b/gnu/installer/newt/locale.scm @@ -143,7 +143,7 @@ glibc locale string and return it." (installer-step (id 'territory) (compute - (lambda (result) + (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. @@ -161,7 +161,7 @@ glibc locale string and return it." (installer-step (id 'codeset) (compute - (lambda (result) + (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. @@ -173,7 +173,7 @@ glibc locale string and return it." (installer-step (id 'modifier) (compute - (lambda (result) + (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) diff --git a/gnu/installer/record.scm b/gnu/installer/record.scm index bf74040699..ba7625e65a 100644 --- a/gnu/installer/record.scm +++ b/gnu/installer/record.scm @@ -57,9 +57,9 @@ (exit installer-exit) ;; 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) + ;; procedure (layouts) -> (list layout variant) (keymap-page installer-keymap-page) ;; procedure: (#:key supported-locales iso639-languages iso3166-territories) ;; -> glibc-locale -- cgit v1.2.3 From b51bde71a9385f4e81fbea258bfb9e8ff48be119 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 14:41:48 +0900 Subject: installer: Add services page. Add a page to select services, for now only desktop environments choice is available. * gnu/installer.scm (steps): Add services step. * gnu/installer/newt.scm (newt-installer): Add services-page field. * gnu/installer/newt/services.scm: New file. * gnu/installer/record.scm (installer): Add services-page field. * gnu/installer/services.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add new files. * po/guix/POTFILES.in: Add new files. --- gnu/installer.scm | 12 ++++++--- gnu/installer/newt.scm | 5 ++++ gnu/installer/newt/services.scm | 48 +++++++++++++++++++++++++++++++++ gnu/installer/record.scm | 3 +++ gnu/installer/services.scm | 59 +++++++++++++++++++++++++++++++++++++++++ gnu/local.mk | 2 ++ po/guix/POTFILES.in | 2 ++ 7 files changed, 128 insertions(+), 3 deletions(-) create mode 100644 gnu/installer/newt/services.scm create mode 100644 gnu/installer/services.scm (limited to 'gnu/installer/newt.scm') diff --git a/gnu/installer.scm b/gnu/installer.scm index 4a587eb35b..1b9aeaa217 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -229,16 +229,22 @@ selected keymap." ((installer-user-page current-installer)))) (configuration-formatter users->configuration)) + ;; Ask the user to choose one or many desktop environment(s). + (installer-step + (id 'services) + (description (G_ "Services")) (compute (lambda _ - ((installer-user-page current-installer))))) + ((installer-services-page current-installer)))) + (configuration-formatter + desktop-environments->configuration)) - (installer-step + (installer-step (id 'final) (description (G_ "Configuration file")) (compute (lambda (result prev-steps) ((installer-final-page current-installer) - result prev-steps))))))) + result prev-steps)))))))) (define (installer-program) "Return a file-like object that runs the given INSTALLER." diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index 1f51b111a8..3192e55b86 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -25,6 +25,7 @@ #:use-module (gnu installer newt locale) #:use-module (gnu installer newt menu) #:use-module (gnu installer newt network) + #:use-module (gnu installer newt services) #:use-module (gnu installer newt timezone) #:use-module (gnu installer newt user) #:use-module (gnu installer newt utils) @@ -80,6 +81,9 @@ (define (user-page) (run-user-page)) +(define (services-page) + (run-services-page)) + (define newt-installer (installer (name 'newt) @@ -94,4 +98,5 @@ (timezone-page timezone-page) (hostname-page hostname-page) (user-page user-page) + (services-page services-page) (welcome-page welcome-page))) diff --git a/gnu/installer/newt/services.scm b/gnu/installer/newt/services.scm new file mode 100644 index 0000000000..80fac43dc8 --- /dev/null +++ b/gnu/installer/newt/services.scm @@ -0,0 +1,48 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Mathieu Othacehe +;;; +;;; 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 . + +(define-module (gnu installer newt services) + #:use-module (gnu installer services) + #:use-module (gnu installer steps) + #:use-module (gnu installer newt page) + #:use-module (gnu installer newt utils) + #:use-module (guix i18n) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (newt) + #:export (run-services-page)) + +(define (run-desktop-environments-cbt-page) + "Run a page allowing the user to choose between various desktop +environments." + (run-checkbox-tree-page + #:info-text (G_ "Please select the desktop(s) environment(s) you wish to \ +install. If you select multiple desktops environments, we will be able to \ +choose the one to use on the log-in screen with F1.") + #:title (G_ "Desktop environment") + #:items %desktop-environments + #:item->text desktop-environment-name + #:checkbox-tree-height 5 + #:cancel-button-callback-procedure + (lambda () + (raise + (condition + (&installer-step-abort)))))) + +(define (run-services-page) + (run-desktop-environments-cbt-page)) diff --git a/gnu/installer/record.scm b/gnu/installer/record.scm index ba7625e65a..3ef0a101d3 100644 --- a/gnu/installer/record.scm +++ b/gnu/installer/record.scm @@ -35,6 +35,7 @@ installer-timezone-page installer-hostname-page installer-user-page + installer-services-page installer-welcome-page)) @@ -74,5 +75,7 @@ (hostname-page installer-hostname-page) ;; procedure void -> void (user-page installer-user-page) + ;; procedure void -> void + (services-page installer-services-page) ;; procedure (logo) -> void (welcome-page installer-welcome-page)) diff --git a/gnu/installer/services.scm b/gnu/installer/services.scm new file mode 100644 index 0000000000..ed44b87682 --- /dev/null +++ b/gnu/installer/services.scm @@ -0,0 +1,59 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Mathieu Othacehe +;;; +;;; 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 . + +(define-module (gnu installer services) + #:use-module (guix records) + #:export ( + desktop-environment + make-desktop-environment + desktop-environment-name + desktop-environment-snippet + + %desktop-environments + desktop-environments->configuration)) + +(define-record-type* + desktop-environment make-desktop-environment + desktop-environment? + (name desktop-environment-name) ;string + (snippet desktop-environment-snippet)) ;symbol + +;; This is the list of desktop environments supported as services. +(define %desktop-environments + (list + (desktop-environment + (name "GNOME") + (snippet '(gnome-desktop-service))) + (desktop-environment + (name "Xfce") + (snippet '(xfce-desktop-service))) + (desktop-environment + (name "MATE") + (snippet '(mate-desktop-service))) + (desktop-environment + (name "Enlightenment") + (snippet '(service enlightenment-desktop-service-type))))) + +(define (desktop-environments->configuration desktop-environments) + "Return the configuration field for DESKTOP-ENVIRONMENTS." + (let ((snippets + (map desktop-environment-snippet desktop-environments))) + `(,@(if (null? snippets) + '() + `((services (cons* ,@snippets + %desktop-services))))))) diff --git a/gnu/local.mk b/gnu/local.mk index d4acb8d2ec..15a43406a4 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -573,6 +573,7 @@ GNU_SYSTEM_MODULES += \ %D%/installer/keymap.scm \ %D%/installer/locale.scm \ %D%/installer/newt.scm \ + %D%/installer/services.scm \ %D%/installer/steps.scm \ %D%/installer/timezone.scm \ %D%/installer/utils.scm \ @@ -585,6 +586,7 @@ GNU_SYSTEM_MODULES += \ %D%/installer/newt/menu.scm \ %D%/installer/newt/network.scm \ %D%/installer/newt/page.scm \ + %D%/installer/newt/services.scm \ %D%/installer/newt/timezone.scm \ %D%/installer/newt/utils.scm \ %D%/installer/newt/welcome.scm \ diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 1378b33e0e..16d9c9e4ae 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -21,11 +21,13 @@ gnu/installer/newt/locale.scm gnu/installer/newt/menu.scm gnu/installer/newt/network.scm gnu/installer/newt/page.scm +gnu/installer/newt/services.scm gnu/installer/newt/timezone.scm gnu/installer/newt/user.scm gnu/installer/newt/utils.scm gnu/installer/newt/welcome.scm gnu/installer/newt/wifi.scm +gnu/installer/services.scm gnu/installer/steps.scm gnu/installer/timezone.scm gnu/installer/utils.scm -- cgit v1.2.3 From 69a934f23ae1bd7dda9ec269a6ce3012e13c9011 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 14:57:28 +0900 Subject: installer: Add partitioning support. * gnu/installer.scm (installer-steps): Add partitioning step. * gnu/installer/newt.scm (newt-installer): Add partition-page field. * gnu/installer/newt/partition.scm: New file. * gnu/installer/parted.scm: New file. * gnu/installer/record (installer): New partition-page field. * gnu/local.mk (GNU_SYSTEM_MODULES): Add new files. * po/guix/POTFILES.in: Add new files. --- gnu/installer.scm | 32 +- gnu/installer/newt.scm | 5 + gnu/installer/newt/partition.scm | 706 ++++++++++++++++++++++ gnu/installer/parted.scm | 1210 ++++++++++++++++++++++++++++++++++++++ gnu/installer/record.scm | 3 + gnu/local.mk | 2 + po/guix/POTFILES.in | 1 + 7 files changed, 1953 insertions(+), 6 deletions(-) create mode 100644 gnu/installer/newt/partition.scm create mode 100644 gnu/installer/parted.scm (limited to 'gnu/installer/newt.scm') diff --git a/gnu/installer.scm b/gnu/installer.scm index 29178cb536..80b5782202 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu installer) + #:use-module (guix discovery) #:use-module (guix packages) #:use-module (guix gexp) #:use-module (guix modules) @@ -27,6 +28,7 @@ #:use-module (gnu packages base) #:use-module (gnu packages bash) #:use-module (gnu packages connman) + #:use-module (gnu packages disk) #:use-module (gnu packages guile) #:autoload (gnu packages gnupg) (guile-gcrypt) #:use-module (gnu packages iso-codes) @@ -172,9 +174,14 @@ selected keymap." ((installer-welcome-page current-installer) #$(local-file "installer/aux-files/logo.txt"))))) - ;; Ask the user to choose a locale among those supported by the glibc. - ;; Install the selected locale right away, so that the user may - ;; benefit from any available translation for the installer messages. + ;; Run a partitionment tool allowing the user to modify + ;; partition tables, partitions and their mount points. + (installer-step + (id 'partition) + (description (G_ "Partitionment")) + (compute (lambda _ + ((installer-partition-page current-installer)))) + (configuration-formatter user-partitions->configuration)) ;; Ask the user to choose a locale among those supported by ;; the glibc. Install the selected locale right away, so that @@ -263,18 +270,31 @@ selected keymap." (define set-installer-path ;; Add the specified binary to PATH for later use by the installer. #~(let* ((inputs - '#$(append (list bash connman shadow) + '#$(append (list bash ;start subshells + connman ;call connmanctl + dosfstools ;mkfs.fat + e2fsprogs ;mkfs.ext4 + kbd ;chvt + guix ;guix system init call + util-linux ;mkwap + shadow) (map canonical-package (list coreutils))))) (with-output-to-port (%make-void-port "w") (lambda () (set-path-environment-variable "PATH" '("bin" "sbin") inputs))))) (define steps (installer-steps)) + (define modules + (scheme-modules* + (string-append (current-source-directory) "/..") + "gnu/installer")) (define installer-builder - (with-extensions (list guile-gcrypt guile-newt guile-json) + (with-extensions (list guile-gcrypt guile-newt + guile-parted guile-bytestructures + guile-json) (with-imported-modules `(,@(source-module-closure - '((gnu installer newt) + `(,@modules (guix build utils)) #:select? not-config?) ((guix config) => ,(make-config.scm))) diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index 3192e55b86..9d9212173d 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -25,6 +25,7 @@ #:use-module (gnu installer newt locale) #:use-module (gnu installer newt menu) #:use-module (gnu installer newt network) + #:use-module (gnu installer newt partition) #:use-module (gnu installer newt services) #:use-module (gnu installer newt timezone) #:use-module (gnu installer newt user) @@ -81,6 +82,9 @@ (define (user-page) (run-user-page)) +(define (partition-page) + (run-partioning-page)) + (define (services-page) (run-services-page)) @@ -98,5 +102,6 @@ (timezone-page timezone-page) (hostname-page hostname-page) (user-page user-page) + (partition-page partition-page) (services-page services-page) (welcome-page welcome-page))) diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm new file mode 100644 index 0000000000..806337a9cb --- /dev/null +++ b/gnu/installer/newt/partition.scm @@ -0,0 +1,706 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Mathieu Othacehe +;;; +;;; 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 . + +(define-module (gnu installer newt partition) + #:use-module (gnu installer parted) + #:use-module (gnu installer steps) + #:use-module (gnu installer utils) + #:use-module (gnu installer newt page) + #:use-module (gnu installer newt utils) + #:use-module (guix i18n) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (newt) + #:use-module (parted) + #:export (run-partioning-page)) + +(define (button-cancel-action) + "Raise the &installer-step-abort condition." + (raise + (condition + (&installer-step-abort)))) + +(define (run-scheme-page) + "Run a page asking the user for a partitioning scheme." + (let* ((items + '((root . "Everything is one partition") + (root-home . "Separate /home partition"))) + (result (run-listbox-selection-page + #:info-text (G_ "Please select a partitioning scheme.") + #:title (G_ "Partition scheme") + #:listbox-items items + #:listbox-item->text cdr + #:button-text (G_ "Cancel") + #:button-callback-procedure button-cancel-action))) + (car result))) + +(define (draw-formating-page) + "Draw a page to indicate partitions are being formated." + (draw-info-page + (format #f (G_ "Partition formating is in progress, please wait.")) + (G_ "Preparing partitions"))) + +(define (run-device-page devices) + "Run a page asking the user to select a device among those in the given +DEVICES list." + (define (device-items) + (map (lambda (device) + `(,device . ,(device-description device))) + devices)) + + (let* ((result (run-listbox-selection-page + #:info-text (G_ "Please select a disk.") + #:title (G_ "Disk") + #:listbox-items (device-items) + #:listbox-item->text cdr + #:button-text (G_ "Cancel") + #:button-callback-procedure button-cancel-action)) + (device (car result))) + device)) + +(define (run-label-page button-callback) + "Run a page asking the user to select a partition table label." + (run-listbox-selection-page + #:info-text (G_ "Select a new partition table type. \ +Be careful, all data on the disk will be lost.") + #:title (G_ "Partition table") + #:listbox-items '("msdos" "gpt") + #:listbox-item->text identity + #:button-text (G_ "Cancel") + #:button-callback-procedure button-callback)) + +(define (run-type-page partition) + "Run a page asking the user to select a partition type." + (let* ((disk (partition-disk partition)) + (partitions (disk-partitions disk)) + (other-extended-partitions? + (any extended-partition? partitions)) + (items + `(normal ,@(if other-extended-partitions? + '() + '(extended))))) + (run-listbox-selection-page + #:info-text (G_ "Please select a partition type") + #:title (G_ "Partition type") + #:listbox-items items + #:listbox-item->text symbol->string + #:sort-listbox-items? #f + #:button-text (G_ "Cancel") + #:button-callback-procedure button-cancel-action))) + +(define (run-fs-type-page) + "Run a page asking the user to select a file-system type." + (run-listbox-selection-page + #:info-text (G_ "Please select the file-system type for this partition") + #:title (G_ "File-system type") + #:listbox-items '(ext4 btrfs fat32 swap) + #:listbox-item->text user-fs-type-name + #:sort-listbox-items? #f + #:button-text (G_ "Cancel") + #:button-callback-procedure button-cancel-action)) + +(define (inform-can-create-partition? user-partition) + "Return #t if it is possible to create USER-PARTITION. This is determined by +calling CAN-CREATE-PARTITION? procedure. If an exception is raised, catch it +an inform the user with an appropriate error-page and return #f." + (guard (c ((max-primary-exceeded? c) + (run-error-page + (G_ "Primary partitions count exceeded") + (G_ "Creation error")) + #f) + ((extended-creation-error? c) + (run-error-page + (G_ "Extended partition creation error") + (G_ "Creation error")) + #f) + ((logical-creation-error? c) + (run-error-page + (G_ "Logical partition creation error") + (G_ "Creation error")) + #f)) + (can-create-partition? user-partition))) + +(define* (run-partition-page target-user-partition + #:key + (default-item #f)) + "Run a page allowing the user to edit the given TARGET-USER-PARTITION +record. If the argument DEFAULT-ITEM is passed, use it to select the current +listbox item. This is used to avoid the focus to switch back to the first +listbox entry while calling this procedure recursively." + + (define (numeric-size device size) + "Parse the given SIZE on DEVICE and return it." + (call-with-values + (lambda () + (unit-parse size device)) + (lambda (value range) + value))) + + (define (numeric-size-range device size) + "Parse the given SIZE on DEVICE and return the associated RANGE." + (call-with-values + (lambda () + (unit-parse size device)) + (lambda (value range) + range))) + + (define* (fill-user-partition-geom user-part + #:key + device (size #f) start end) + "Return the given USER-PART with the START, END and SIZE fields set to the +eponym arguments. Use UNIT-FORMAT-CUSTOM to format START and END arguments as +sectors on DEVICE." + (user-partition + (inherit user-part) + (size size) + (start (unit-format-custom device start UNIT-SECTOR)) + (end (unit-format-custom device end UNIT-SECTOR)))) + + (define (apply-user-partition-changes user-part) + "Set the name, file-system type and boot flag on the partition specified +by USER-PART, if it is applicable for the partition type." + (let* ((partition (user-partition-parted-object user-part)) + (disk (partition-disk partition)) + (disk-type (disk-disk-type disk)) + (device (disk-device disk)) + (has-name? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-PARTITION-NAME)) + (name (user-partition-name user-part)) + (fs-type (filesystem-type-get + (user-fs-type-name + (user-partition-fs-type user-part)))) + (bootable? (user-partition-bootable? user-part)) + (esp? (user-partition-esp? user-part)) + (flag-bootable? + (partition-is-flag-available? partition PARTITION-FLAG-BOOT)) + (flag-esp? + (partition-is-flag-available? partition PARTITION-FLAG-ESP))) + (when (and has-name? name) + (partition-set-name partition name)) + (partition-set-system partition fs-type) + (when flag-bootable? + (partition-set-flag partition + PARTITION-FLAG-BOOT + (if bootable? 1 0))) + (when flag-esp? + (partition-set-flag partition + PARTITION-FLAG-ESP + (if esp? 1 0))) + #t)) + + (define (listbox-action listbox-item) + (let* ((item (car listbox-item)) + (partition (user-partition-parted-object + target-user-partition)) + (disk (partition-disk partition)) + (device (disk-device disk))) + (list + item + (case item + ((name) + (let* ((old-name (user-partition-name target-user-partition)) + (name + (run-input-page (G_ "Please enter the partition gpt name.") + (G_ "Partition name") + #:default-text old-name))) + (user-partition + (inherit target-user-partition) + (name name)))) + ((type) + (let ((new-type (run-type-page partition))) + (user-partition + (inherit target-user-partition) + (type new-type)))) + ((bootable) + (user-partition + (inherit target-user-partition) + (bootable? (not (user-partition-bootable? + target-user-partition))))) + ((esp?) + (let ((new-esp? (not (user-partition-esp? + target-user-partition)))) + (user-partition + (inherit target-user-partition) + (esp? new-esp?) + (mount-point (if new-esp? + (default-esp-mount-point) + ""))))) + ((need-formating?) + (user-partition + (inherit target-user-partition) + (need-formating? + (not (user-partition-need-formating? + target-user-partition))))) + ((size) + (let* ((old-size (user-partition-size target-user-partition)) + (max-size-value (partition-length partition)) + (max-size (unit-format device max-size-value)) + (start (partition-start partition)) + (size (run-input-page + (format #f (G_ "Please enter the size of the partition.\ + The maximum size is ~a.") max-size) + (G_ "Partition size") + #:default-text (or old-size max-size))) + (size-percentage (read-percentage size)) + (size-value (if size-percentage + (nearest-exact-integer + (/ (* max-size-value size-percentage) + 100)) + (numeric-size device size))) + (end (and size-value + (+ start size-value))) + (size-range (numeric-size-range device size)) + (size-range-ok? (and size-range + (< (+ start + (geometry-start size-range)) + (partition-end partition))))) + (cond + ((and size-percentage (> size-percentage 100)) + (run-error-page + (G_ "The percentage can not be superior to 100.") + (G_ "Size error")) + target-user-partition) + ((not size-value) + (run-error-page + (G_ "The requested size is incorrectly formatted, or too large.") + (G_ "Size error")) + target-user-partition) + ((not (or size-percentage size-range-ok?)) + (run-error-page + (G_ "The request size is superior to the maximum size.") + (G_ "Size error")) + target-user-partition) + (else + (fill-user-partition-geom target-user-partition + #:device device + #:size size + #:start start + #:end end))))) + ((fs-type) + (let ((fs-type (run-fs-type-page))) + (user-partition + (inherit target-user-partition) + (fs-type fs-type)))) + ((mount-point) + (let* ((old-mount (or (user-partition-mount-point + target-user-partition) + "")) + (mount + (run-input-page + (G_ "Please enter the desired mounting point for this \ +partition. Leave this field empty if you don't want to set a mounting point.") + (G_ "Mounting point") + #:default-text old-mount + #:allow-empty-input? #t))) + (user-partition + (inherit target-user-partition) + (mount-point (and (not (string=? mount "")) + mount))))))))) + + (define (button-action) + (let* ((partition (user-partition-parted-object + target-user-partition)) + (prev-part (partition-prev partition)) + (disk (partition-disk partition)) + (device (disk-device disk)) + (creation? (freespace-partition? partition)) + (start (partition-start partition)) + (end (partition-end partition)) + (new-user-partition + (if (user-partition-start target-user-partition) + target-user-partition + (fill-user-partition-geom target-user-partition + #:device device + #:start start + #:end end)))) + ;; It the backend PARTITION has free-space type, it means we are + ;; creating a new partition, otherwise, we are editing an already + ;; existing PARTITION. + (if creation? + (let* ((ok-create-partition? + (inform-can-create-partition? new-user-partition)) + (new-partition + (and ok-create-partition? + (mkpart disk + new-user-partition + #:previous-partition prev-part)))) + (and new-partition + (user-partition + (inherit new-user-partition) + (need-formating? #t) + (path (partition-get-path new-partition)) + (disk-path (device-path device)) + (parted-object new-partition)))) + (and (apply-user-partition-changes new-user-partition) + new-user-partition)))) + + (let* ((items (user-partition-description target-user-partition)) + (partition (user-partition-parted-object + target-user-partition)) + (disk (partition-disk partition)) + (device (disk-device disk)) + (path (device-path device)) + (number-str (partition-print-number partition)) + (type (user-partition-type target-user-partition)) + (type-str (symbol->string type)) + (start (unit-format device (partition-start partition))) + (creation? (freespace-partition? partition)) + (default-item (and default-item + (find (lambda (item) + (eq? (car item) default-item)) + items))) + (result + (run-listbox-selection-page + #:info-text + (if creation? + (G_ (format #f "Creating ~a partition starting at ~a of ~a." + type-str start path)) + (G_ (format #f "You are currently editing partition ~a." + number-str))) + #:title (if creation? + (G_ "Partition creation") + (G_ "Partition edit")) + #:listbox-items items + #:listbox-item->text cdr + #:sort-listbox-items? #f + #:listbox-default-item default-item + #:button-text (G_ "Ok") + #:listbox-callback-procedure listbox-action + #:button-callback-procedure button-action))) + (match result + ((item new-user-partition) + (run-partition-page new-user-partition + #:default-item item)) + (else result)))) + +(define* (run-disk-page disks + #:optional (user-partitions '())) + "Run a page allowing to edit the partition tables of the given DISKS. If +specified, USER-PARTITIONS is a list of records associated to +the partitions on DISKS." + + (define (other-logical-partitions? partitions) + "Return #t if at least one of the partition in PARTITIONS list is a +logical partition, return #f otherwise." + (any logical-partition? partitions)) + + (define (other-non-logical-partitions? partitions) + "Return #t is at least one of the partitions in PARTITIONS list is not a +logical partition, return #f otherwise." + (let ((non-logical-partitions + (remove logical-partition? partitions))) + (or (any normal-partition? non-logical-partitions) + (any freespace-partition? non-logical-partitions)))) + + (define (add-tree-symbols partitions descriptions) + "Concatenate tree symbols to the given DESCRIPTIONS list and return +it. The PARTITIONS list is the list of partitions described in +DESCRIPTIONS. The tree symbols are used to indicate the partition's disk and +for logical partitions, the extended partition which includes them." + (match descriptions + (() '()) + ((description . rest-descriptions) + (match partitions + ((partition . rest-partitions) + (if (null? rest-descriptions) + (list (if (logical-partition? partition) + (string-append " ┗━ " description) + (string-append "┗━ " description))) + (cons (cond + ((extended-partition? partition) + (if (other-non-logical-partitions? rest-partitions) + (string-append "┣┳ " description) + (string-append "┗┳ " description))) + ((logical-partition? partition) + (if (other-logical-partitions? rest-partitions) + (if (other-non-logical-partitions? rest-partitions) + (string-append "┃┣━ " description) + (string-append " ┣━ " description)) + (if (other-non-logical-partitions? rest-partitions) + (string-append "┃┗━ " description) + (string-append " ┗━ " description)))) + (else + (string-append "┣━ " description))) + (add-tree-symbols rest-partitions + rest-descriptions)))))))) + + (define (skip-item? item) + (eq? (car item) 'skip)) + + (define (disk-items) + "Return the list of strings describing DISKS." + (let loop ((disks disks)) + (match disks + (() '()) + ((disk . rest) + (let* ((device (disk-device disk)) + (partitions (disk-partitions disk)) + (partitions* + (filter-map + (lambda (partition) + (and (not (metadata-partition? partition)) + (not (small-freespace-partition? device + partition)) + partition)) + partitions)) + (descriptions (add-tree-symbols + partitions* + (partitions-descriptions partitions* + user-partitions))) + (partition-items (map cons partitions* descriptions))) + (append + `((,disk . ,(device-description device disk)) + ,@partition-items + ,@(if (null? rest) + '() + '((skip . "")))) + (loop rest))))))) + + (define (remove-user-partition-by-partition user-partitions partition) + "Return the USER-PARTITIONS list with the record with the given PARTITION +object removed. If PARTITION is an extended partition, also remove all logical +partitions from USER-PARTITIONS." + (remove (lambda (p) + (let ((cur-partition (user-partition-parted-object p))) + (or (equal? cur-partition partition) + (and (extended-partition? partition) + (logical-partition? cur-partition))))) + user-partitions)) + + (define (remove-user-partition-by-disk user-partitions disk) + "Return the USER-PARTITIONS list with the records located +on given DISK removed." + (remove (lambda (p) + (let* ((partition (user-partition-parted-object p)) + (cur-disk (partition-disk partition))) + (equal? cur-disk disk))) + user-partitions)) + + (define (update-user-partitions user-partitions new-user-partition) + "Update or insert NEW-USER-PARTITION record in USER-PARTITIONS list +depending if one of the record in USER-PARTITIONS has the +same PARTITION object as NEW-USER-PARTITION." + (let* ((partition (user-partition-parted-object new-user-partition)) + (user-partitions* + (remove-user-partition-by-partition user-partitions + partition))) + (cons new-user-partition user-partitions*))) + + (define (button-ok-action) + "Commit the modifications to all DISKS and return #t." + (for-each (lambda (disk) + (disk-commit disk)) + disks) + #t) + + (define (listbox-action listbox-item) + "A disk or a partition has been selected. If it's a disk, ask for a label +to create a new partition table. If it is a partition, propose the user to +edit it." + (let ((item (car listbox-item))) + (cond + ((disk? item) + (let ((label (run-label-page (const #f)))) + (if label + (let* ((device (disk-device item)) + (new-disk (mklabel device label)) + (commit-new-disk (disk-commit new-disk)) + (other-disks (remove (lambda (disk) + (equal? disk item)) + disks)) + (new-user-partitions + (remove-user-partition-by-disk user-partitions item))) + (disk-destroy item) + `((disks . ,(cons new-disk other-disks)) + (user-partitions . ,new-user-partitions))) + `((disks . ,disks) + (user-partitions . ,user-partitions))))) + ((partition? item) + (let* ((partition item) + (disk (partition-disk partition)) + (device (disk-device disk)) + (existing-user-partition + (find-user-partition-by-parted-object user-partitions + partition)) + (edit-user-partition + (or existing-user-partition + (partition->user-partition partition)))) + `((disks . ,disks) + (user-partitions . ,user-partitions) + (edit-user-partition . ,edit-user-partition))))))) + + (define (hotkey-action key listbox-item) + "The DELETE key has been pressed on a disk or a partition item." + (let ((item (car listbox-item)) + (default-result + `((disks . ,disks) + (user-partitions . ,user-partitions)))) + (cond + ((disk? item) + (let* ((device (disk-device item)) + (path (device-path device)) + (info-text + (format #f (G_ "Are you sure you want to delete everything on disk ~a?") + path)) + (result (choice-window (G_ "Delete disk") + (G_ "Ok") + (G_ "Cancel") + info-text))) + (case result + ((1) + (disk-delete-all item) + `((disks . ,disks) + (user-partitions + . ,(remove-user-partition-by-disk user-partitions item)))) + (else + default-result)))) + ((partition? item) + (if (freespace-partition? item) + (run-error-page (G_ "You cannot delete a free space area.") + (G_ "Delete partition")) + (let* ((disk (partition-disk item)) + (number-str (partition-print-number item)) + (info-text + (format #f (G_ "Are you sure you want to delete partition ~a?") + number-str)) + (result (choice-window (G_ "Delete partition") + (G_ "Ok") + (G_ "Cancel") + info-text))) + (case result + ((1) + (let ((new-user-partitions + (remove-user-partition-by-partition user-partitions + item))) + (disk-delete-partition disk item) + `((disks . ,disks) + (user-partitions . ,new-user-partitions)))) + (else + default-result)))))))) + + (let ((result + (run-listbox-selection-page + + #:info-text (G_ "You can change a disk's partition table by \ +selecting it and pressing ENTER. You can also edit a partition by selecting it \ +and pressing ENTER, or remove it by pressing DELETE. To create a new \ +partition, select a free space area and press ENTER. + +At least one partition must have its mounting point set to '/'.") + + #:title (G_ "Manual partitioning") + #:info-textbox-width 70 + #:listbox-items (disk-items) + #:listbox-item->text cdr + #:sort-listbox-items? #f + #:skip-item-procedure? skip-item? + #:allow-delete? #t + #:button-text (G_ "Ok") + #:button-callback-procedure button-ok-action + #:button2-text (G_ "Cancel") + #:button2-callback-procedure button-cancel-action + #:listbox-callback-procedure listbox-action + #:hotkey-callback-procedure hotkey-action))) + (if (eq? result #t) + (let ((user-partitions-ok? + (guard + (c ((no-root-mount-point? c) + (run-error-page + (G_ "No root mount point found") + (G_ "Missing mount point")) + #f)) + (check-user-partitions user-partitions)))) + (if user-partitions-ok? + (begin + (for-each (cut disk-destroy <>) disks) + user-partitions) + (run-disk-page disks user-partitions))) + (let* ((result-disks (assoc-ref result 'disks)) + (result-user-partitions (assoc-ref result + 'user-partitions)) + (edit-user-partition (assoc-ref result + 'edit-user-partition)) + (can-create-partition? + (and edit-user-partition + (inform-can-create-partition? edit-user-partition))) + (new-user-partition (and edit-user-partition + can-create-partition? + (run-partition-page + edit-user-partition))) + (new-user-partitions + (if new-user-partition + (update-user-partitions result-user-partitions + new-user-partition) + result-user-partitions))) + (run-disk-page result-disks new-user-partitions))))) + +(define (run-partioning-page) + "Run a page asking the user for a partitioning method." + (define (run-page devices) + (let* ((items + '((entire . "Guided - using the entire disk") + (manual . "Manual"))) + (result (run-listbox-selection-page + #:info-text (G_ "Please select a partitioning method.") + #:title (G_ "Partitioning method") + #:listbox-items items + #:listbox-item->text cdr + #:button-text (G_ "Cancel") + #:button-callback-procedure button-cancel-action)) + (method (car result))) + (case method + ((entire) + (let* ((device (run-device-page devices)) + (disk-type (disk-probe device)) + (disk (if disk-type + (disk-new device) + (let* ((label (run-label-page + button-cancel-action)) + (disk (mklabel device label))) + (disk-commit disk) + disk))) + (scheme (symbol-append method '- (run-scheme-page))) + (user-partitions (append + (auto-partition disk #:scheme scheme) + (create-special-user-partitions + (disk-partitions disk))))) + (run-disk-page (list disk) user-partitions))) + ((manual) + (let* ((disks (map disk-new devices)) + (user-partitions (append-map + create-special-user-partitions + (map disk-partitions disks))) + (result-user-partitions (run-disk-page disks + user-partitions))) + result-user-partitions))))) + + (init-parted) + (let* ((non-install-devices (non-install-devices)) + (user-partitions (run-page non-install-devices)) + (form (draw-formating-page))) + ;; Make sure the disks are not in use before proceeding to formating. + (free-parted non-install-devices) + (run-error-page (format #f "~a" user-partitions) + "user-partitions") + (format-user-partitions user-partitions) + (destroy-form-and-pop form) + user-partitions)) diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm new file mode 100644 index 0000000000..3fe938124f --- /dev/null +++ b/gnu/installer/parted.scm @@ -0,0 +1,1210 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Mathieu Othacehe +;;; +;;; 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 . + +(define-module (gnu installer parted) + #:use-module (gnu installer steps) + #:use-module (gnu installer utils) + #:use-module (gnu installer newt page) + #:use-module (gnu system uuid) + #:use-module ((gnu build file-systems) + #:select (read-partition-uuid)) + #:use-module (guix build syscalls) + #:use-module (guix build utils) + #:use-module (guix records) + #:use-module (guix i18n) + #:use-module (parted) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:export ( + user-partition + make-user-partition + user-partition? + user-partition-name + user-partition-type + user-partition-path + user-partition-disk-path + user-partition-fs-type + user-partition-bootable? + user-partition-esp? + user-partition-bios-grub? + user-partition-size + user-partition-start + user-partition-end + user-partition-mount-point + user-partition-need-formating? + user-partition-parted-object + + find-esp-partition + data-partition? + metadata-partition? + freespace-partition? + small-freespace-partition? + normal-partition? + extended-partition? + logical-partition? + esp-partition? + boot-partition? + default-esp-mount-point + + with-delay-device-in-use? + force-device-sync + non-install-devices + partition-user-type + user-fs-type-name + partition-filesystem-user-type + partition-get-flags + partition->user-partition + create-special-user-partitions + find-user-partition-by-parted-object + + device-description + partition-end-formatted + partition-print-number + partition-description + partitions-descriptions + user-partition-description + + &max-primary-exceeded + max-primary-exceeded? + &extended-creation-error + extended-creation-error? + &logical-creation-error + logical-creation-error? + + can-create-partition? + mklabel + mkpart + rmpart + + create-adjacent-partitions + auto-partition + + &no-root-mount-point + no-root-mount-point? + + check-user-partitions + set-user-partitions-path + format-user-partitions + mount-user-partitions + umount-user-partitions + with-mounted-partitions + user-partitions->file-systems + user-partitions->configuration + + init-parted + free-parted)) + + +;;; +;;; Partition record. +;;; + +(define-record-type* + user-partition make-user-partition + user-partition? + (name user-partition-name ;string + (default #f)) + (type user-partition-type + (default 'normal)) ; 'normal | 'logical | 'extended + (path user-partition-path + (default #f)) + (disk-path user-partition-disk-path + (default #f)) + (fs-type user-partition-fs-type + (default 'ext4)) + (bootable? user-partition-bootable? + (default #f)) + (esp? user-partition-esp? + (default #f)) + (bios-grub? user-partition-bios-grub? + (default #f)) + (size user-partition-size + (default #f)) + (start user-partition-start ;start as string (e.g. '11MB') + (default #f)) + (end user-partition-end ;same as start + (default #f)) + (mount-point user-partition-mount-point ;string + (default #f)) + (need-formating? user-partition-need-formating? ; boolean + (default #f)) + (parted-object user-partition-parted-object ; from parted + (default #f))) + + +;; +;; Utilities. +;; + +(define (find-esp-partition partitions) + "Find and return the ESP partition among PARTITIONS." + (find esp-partition? partitions)) + +(define (data-partition? partition) + "Return #t if PARTITION is a partition dedicated to data (by opposition to +freespace, metadata and protected partition types), return #f otherwise." + (let ((type (partition-type partition))) + (not (any (lambda (flag) + (member flag type)) + '(free-space metadata protected))))) + +(define (metadata-partition? partition) + "Return #t if PARTITION is a metadata partition, #f otherwise." + (let ((type (partition-type partition))) + (member 'metadata type))) + +(define (freespace-partition? partition) + "Return #t if PARTITION is a free-space partition, #f otherwise." + (let ((type (partition-type partition))) + (member 'free-space type))) + +(define* (small-freespace-partition? device + partition + #:key (max-size MEBIBYTE-SIZE)) + "Return #t is PARTITION is a free-space partition with less a size strictly +inferior to MAX-SIZE, #f otherwise." + (let ((size (partition-length partition)) + (max-sector-size (/ max-size + (device-sector-size device)))) + (< size max-sector-size))) + +(define (normal-partition? partition) + "return #t if partition is a normal partition, #f otherwise." + (let ((type (partition-type partition))) + (member 'normal type))) + +(define (extended-partition? partition) + "return #t if partition is an extended partition, #f otherwise." + (let ((type (partition-type partition))) + (member 'extended type))) + +(define (logical-partition? partition) + "Return #t if PARTITION is a logical partition, #f otherwise." + (let ((type (partition-type partition))) + (member 'logical type))) + +(define (partition-user-type partition) + "Return the type of PARTITION, to be stored in the TYPE field of + record. It can be 'normal, 'extended or 'logical." + (cond ((normal-partition? partition) + 'normal) + ((extended-partition? partition) + 'extended) + ((logical-partition? partition) + 'logical) + (else #f))) + +(define (esp-partition? partition) + "Return #t if partition has the ESP flag, return #f otherwise." + (let* ((disk (partition-disk partition)) + (disk-type (disk-disk-type disk)) + (has-extended? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-EXTENDED))) + (and (data-partition? partition) + (not has-extended?) + (partition-is-flag-available? partition PARTITION-FLAG-ESP) + (partition-get-flag partition PARTITION-FLAG-ESP)))) + +(define (boot-partition? partition) + "Return #t if partition has the boot flag, return #f otherwise." + (and (data-partition? partition) + (partition-is-flag-available? partition PARTITION-FLAG-BOOT) + (partition-get-flag partition PARTITION-FLAG-BOOT))) + + +;; The default mount point for ESP partitions. +(define default-esp-mount-point + (make-parameter "/boot/efi")) + +(define (efi-installation?) + "Return #t if an EFI installation should be performed, #f otherwise." + (file-exists? "/sys/firmware/efi")) + +(define (user-fs-type-name fs-type) + "Return the name of FS-TYPE as specified by libparted." + (case fs-type + ((ext4) "ext4") + ((btrfs) "btrfs") + ((fat32) "fat32") + ((swap) "linux-swap"))) + +(define (user-fs-type->mount-type fs-type) + "Return the mount type of FS-TYPE." + (case fs-type + ((ext4) "ext4") + ((btrfs) "btrfs") + ((fat32) "vfat"))) + +(define (partition-filesystem-user-type partition) + "Return the filesystem type of PARTITION, to be stored in the FS-TYPE field +of record." + (let ((fs-type (partition-fs-type partition))) + (and fs-type + (let ((name (filesystem-type-name fs-type))) + (cond + ((string=? name "ext4") 'ext4) + ((string=? name "btrfs") 'btrfs) + ((string=? name "fat32") 'fat32) + ((or (string=? name "swsusp") + (string=? name "linux-swap(v0)") + (string=? name "linux-swap(v1)")) + 'swap) + (else + (error (format #f "Unhandled ~a fs-type~%" name)))))))) + +(define (partition-get-flags partition) + "Return the list of flags supported by the given PARTITION." + (filter-map (lambda (flag) + (and (partition-get-flag partition flag) + flag)) + (partition-flags partition))) + +(define (partition->user-partition partition) + "Convert PARTITION into a record and return it." + (let* ((disk (partition-disk partition)) + (device (disk-device disk)) + (disk-type (disk-disk-type disk)) + (has-name? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-PARTITION-NAME)) + (name (and has-name? + (data-partition? partition) + (partition-get-name partition)))) + (user-partition + (name (and (and name + (not (string=? name ""))) + name)) + (type (or (partition-user-type partition) + 'normal)) + (path (partition-get-path partition)) + (disk-path (device-path device)) + (fs-type (or (partition-filesystem-user-type partition) + 'ext4)) + (mount-point (and (esp-partition? partition) + (default-esp-mount-point))) + (bootable? (boot-partition? partition)) + (esp? (esp-partition? partition)) + (parted-object partition)))) + +(define (create-special-user-partitions partitions) + "Return a list with a record describing the ESP partition +found in PARTITIONS, if any." + (filter-map (lambda (partition) + (and (esp-partition? partition) + (partition->user-partition partition))) + partitions)) + +(define (find-user-partition-by-parted-object user-partitions + partition) + "Find and return the record in USER-PARTITIONS list which +PARTED-OBJECT field equals PARTITION, return #f if not found." + (find (lambda (user-partition) + (equal? (user-partition-parted-object user-partition) + partition)) + user-partitions)) + + +;; +;; Devices +;; + +(define (with-delay-device-in-use? path) + "Call DEVICE-IN-USE? with a few retries, as the first re-read will often +fail. See rereadpt function in wipefs.c of util-linux for an explanation." + (let loop ((try 4)) + (usleep 250000) + (let ((in-use? (device-in-use? path))) + (if (and in-use? (> try 0)) + (loop (- try 1)) + in-use?)))) + +(define* (force-device-sync device) + "Force a flushing of the given DEVICE." + (device-open device) + (device-sync device) + (device-close device)) + +(define (non-install-devices) + "Return all the available devices, except the busy one, allegedly the +install device. DEVICE-IS-BUSY? is a parted call, checking if the device is +mounted. The install image uses an overlayfs so the install device does not +appear as mounted and won't be considered as busy. So use also DEVICE-IN-USE? +from (guix build syscalls) module, who will try to re-read the device's +partition table to determine whether or not it is already used (like sfdisk +from util-linux)." + (remove (lambda (device) + (let ((path (device-path device))) + (or (device-is-busy? device) + (with-delay-device-in-use? path)))) + (devices))) + + +;; +;; Disk and partition printing. +;; + +(define* (device-description device #:optional disk) + "Return a string describing the given DEVICE." + (let* ((type (device-type device)) + (path (device-path device)) + (model (device-model device)) + (type-str (device-type->string type)) + (disk-type (if disk + (disk-disk-type disk) + (disk-probe device))) + (length (device-length device)) + (sector-size (device-sector-size device)) + (end (unit-format-custom-byte device + (* length sector-size) + UNIT-GIGABYTE))) + (string-join + `(,@(if (string=? model "") + `(,type-str) + `(,model ,(string-append "(" type-str ")"))) + ,path + ,end + ,@(if disk-type + `(,(disk-type-name disk-type)) + '())) + " "))) + +(define (partition-end-formatted device partition) + "Return as a string the end of PARTITION with the relevant unit." + (unit-format-byte + device + (- + (* (+ (partition-end partition) 1) + (device-sector-size device)) + 1))) + +(define (partition-print-number partition) + "Convert the given partition NUMBER to string." + (let ((number (partition-number partition))) + (number->string number))) + +(define (partition-description partition user-partition) + "Return a string describing the given PARTITION, located on the DISK of +DEVICE." + + (define (partition-print-type partition) + "Return the type of PARTITION as a string." + (if (freespace-partition? partition) + (G_ "Free space") + (let ((type (partition-type partition))) + (match type + ((type-symbol) + (symbol->string type-symbol)))))) + + (define (partition-print-flags partition) + "Return the flags of PARTITION as a string of comma separated flags." + (string-join + (filter-map + (lambda (flag) + (and (partition-get-flag partition flag) + (partition-flag-get-name flag))) + (partition-flags partition)) + ",")) + + (define (maybe-string-pad string length) + "Returned a string formatted by padding STRING of LENGTH characters to the +right. If STRING is #f use an empty string." + (string-pad-right (or string "") length)) + + (let* ((disk (partition-disk partition)) + (device (disk-device disk)) + (disk-type (disk-disk-type disk)) + (has-name? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-PARTITION-NAME)) + (has-extended? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-EXTENDED)) + (part-type (partition-print-type partition)) + (number (and (not (freespace-partition? partition)) + (partition-print-number partition))) + (name (and has-name? + (if (freespace-partition? partition) + (G_ "Free space") + (partition-get-name partition)))) + (start (unit-format device + (partition-start partition))) + (end (partition-end-formatted device partition)) + (size (unit-format device (partition-length partition))) + (fs-type (partition-fs-type partition)) + (fs-type-name (and fs-type + (filesystem-type-name fs-type))) + (flags (and (not (freespace-partition? partition)) + (partition-print-flags partition))) + (mount-point (and user-partition + (user-partition-mount-point user-partition)))) + `(,(or number "") + ,@(if has-extended? + (list part-type) + '()) + ,size + ,(or fs-type-name "") + ,(or flags "") + ,(or mount-point "") + ,(maybe-string-pad name 30)))) + +(define (partitions-descriptions partitions user-partitions) + "Return a list of strings describing all the partitions found on +DEVICE. METADATA partitions are not described. The strings are padded to the +right so that they can be displayed as a table." + + (define (max-length-column lists column-index) + "Return the maximum length of the string at position COLUMN-INDEX in the +list of string lists LISTS." + (apply max + (map (lambda (list) + (string-length + (list-ref list column-index))) + lists))) + + (define (pad-descriptions descriptions) + "Return a padded version of the list of string lists DESCRIPTIONS. The +strings are padded to the length of the longer string in a same column, as +determined by MAX-LENGTH-COLUMN procedure." + (let* ((description-length (length (car descriptions))) + (paddings (map (lambda (index) + (max-length-column descriptions index)) + (iota description-length)))) + (map (lambda (description) + (map string-pad-right description paddings)) + descriptions))) + + (let* ((descriptions + (map + (lambda (partition) + (let ((user-partition + (find-user-partition-by-parted-object user-partitions + partition))) + (partition-description partition user-partition))) + partitions)) + (padded-descriptions (if (null? partitions) + '() + (pad-descriptions descriptions)))) + (map (cut string-join <> " ") padded-descriptions))) + +(define (user-partition-description user-partition) + "Return a string describing the given USER-PARTITION record." + (let* ((partition (user-partition-parted-object user-partition)) + (disk (partition-disk partition)) + (disk-type (disk-disk-type disk)) + (device (disk-device disk)) + (has-name? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-PARTITION-NAME)) + (has-extended? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-EXTENDED)) + (name (user-partition-name user-partition)) + (type (user-partition-type user-partition)) + (type-name (symbol->string type)) + (fs-type (user-partition-fs-type user-partition)) + (fs-type-name (user-fs-type-name fs-type)) + (bootable? (user-partition-bootable? user-partition)) + (esp? (user-partition-esp? user-partition)) + (need-formating? (user-partition-need-formating? user-partition)) + (size (user-partition-size user-partition)) + (mount-point (user-partition-mount-point user-partition))) + `(,@(if has-name? + `((name . ,(string-append "Name: " (or name "None")))) + '()) + ,@(if (and has-extended? + (freespace-partition? partition) + (not (eq? type 'logical))) + `((type . ,(string-append "Type: " type-name))) + '()) + ,@(if (eq? type 'extended) + '() + `((fs-type . ,(string-append "Filesystem type: " fs-type-name)))) + ,@(if (or (eq? type 'extended) + (eq? fs-type 'swap) + (not has-extended?)) + '() + `((bootable . ,(string-append "Bootable flag: " + (if bootable? "On" "Off"))))) + ,@(if (and (not has-extended?) + (not (eq? fs-type 'swap))) + `((esp? . ,(string-append "ESP flag: " + (if esp? "On" "Off")))) + '()) + ,@(if (freespace-partition? partition) + (let ((size-formatted + (or size (unit-format device + (partition-length partition))))) + `((size . ,(string-append "Size : " size-formatted)))) + '()) + ,@(if (or (freespace-partition? partition) + (eq? fs-type 'swap)) + '() + `((need-formating? + . ,(string-append "Format the partition? : " + (if need-formating? "Yes" "No"))))) + ,@(if (or (eq? type 'extended) + (eq? fs-type 'swap)) + '() + `((mount-point + . ,(string-append "Mount point : " + (or mount-point + (and esp? (default-esp-mount-point)) + "None")))))))) + + +;; +;; Partition table creation. +;; + +(define (mklabel device type-name) + "Create a partition table on DEVICE. TYPE-NAME is the type of the partition +table, \"msdos\" or \"gpt\"." + (let ((type (disk-type-get type-name))) + (disk-new-fresh device type))) + + +;; +;; Partition creation. +;; + +;; The maximum count of primary partitions is exceeded. +(define-condition-type &max-primary-exceeded &condition + max-primary-exceeded?) + +;; It is not possible to create an extended partition. +(define-condition-type &extended-creation-error &condition + extended-creation-error?) + +;; It is not possible to create a logical partition. +(define-condition-type &logical-creation-error &condition + logical-creation-error?) + +(define (can-create-primary? disk) + "Return #t if it is possible to create a primary partition on DISK, return +#f otherwise." + (let ((max-primary (disk-get-max-primary-partition-count disk))) + (find (lambda (number) + (not (disk-get-partition disk number))) + (iota max-primary 1)))) + +(define (can-create-extended? disk) + "Return #t if it is possible to create an extended partition on DISK, return +#f otherwise." + (let* ((disk-type (disk-disk-type disk)) + (has-extended? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-EXTENDED))) + (and (can-create-primary? disk) + has-extended? + (not (disk-extended-partition disk))))) + +(define (can-create-logical? disk) + "Return #t is it is possible to create a logical partition on DISK, return +#f otherwise." + (let* ((disk-type (disk-disk-type disk)) + (has-extended? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-EXTENDED))) + (and has-extended? + (disk-extended-partition disk)))) + +(define (can-create-partition? user-part) + "Return #t if it is possible to create the given USER-PART record, return #f +otherwise." + (let* ((type (user-partition-type user-part)) + (partition (user-partition-parted-object user-part)) + (disk (partition-disk partition))) + (case type + ((normal) + (or (can-create-primary? disk) + (raise + (condition (&max-primary-exceeded))))) + ((extended) + (or (can-create-extended? disk) + (raise + (condition (&extended-creation-error))))) + ((logical) + (or (can-create-logical? disk) + (raise + (condition (&logical-creation-error)))))))) + +(define* (mkpart disk user-partition + #:key (previous-partition #f)) + "Create the given USER-PARTITION on DISK. The PREVIOUS-PARTITION argument as +to be set to the partition preceeding USER-PARTITION if any." + + (define (parse-start-end start end) + "Parse start and end strings as positions on DEVICE expressed with a unit, +like '100GB' or '12.2KiB'. Return a list of 4 elements, the start sector, its +range (1 unit large area centered on start sector), the end sector and its +range." + (let ((device (disk-device disk))) + (call-with-values + (lambda () + (unit-parse start device)) + (lambda (start-sector start-range) + (call-with-values + (lambda () + (unit-parse end device)) + (lambda (end-sector end-range) + (list start-sector start-range + end-sector end-range))))))) + + (define* (extend-ranges! start-range end-range + #:key (offset 0)) + "Try to extend START-RANGE by 1 MEBIBYTE to the right and END-RANGE by 1 +MEBIBYTE to the left. This way, if the disk is aligned on 2048 sectors of +512KB (like frequently), we will have a chance for the +'optimal-align-constraint' to succeed. Do not extend ranges if that would +cause them to cross." + (let* ((device (disk-device disk)) + (start-range-end (geometry-end start-range)) + (end-range-start (geometry-start end-range)) + (mebibyte-sector-size (/ MEBIBYTE-SIZE + (device-sector-size device))) + (new-start-range-end + (+ start-range-end mebibyte-sector-size offset)) + (new-end-range-start + (- end-range-start mebibyte-sector-size offset))) + (when (< new-start-range-end new-end-range-start) + (geometry-set-end start-range new-start-range-end) + (geometry-set-start end-range new-end-range-start)))) + + (match (parse-start-end (user-partition-start user-partition) + (user-partition-end user-partition)) + ((start-sector start-range end-sector end-range) + (let* ((prev-end (if previous-partition + (partition-end previous-partition) + 0)) + (start-distance (- start-sector prev-end)) + (type (user-partition-type user-partition)) + ;; There should be at least 2 unallocated sectors in front of each + ;; logical partition, otherwise parted will fail badly: + ;; https://gparted.org/h2-fix-msdos-pt.php#apply-action-fail. + (start-offset (if previous-partition + (- 3 start-distance) + 0)) + (start-sector* (if (and (eq? type 'logical) + (< start-distance 3)) + (+ start-sector start-offset) + start-sector))) + ;; This is a hackery but parted almost always fails to create optimally + ;; aligned partitions (unless specifiying percentages) because, the + ;; default range of 1MB centered on the start sector is not enough when + ;; the optimal alignment is 2048 sectors of 512KB. + (extend-ranges! start-range end-range #:offset start-offset) + + (let* ((device (disk-device disk)) + (disk-type (disk-disk-type disk)) + (length (device-length device)) + (name (user-partition-name user-partition)) + (filesystem-type + (filesystem-type-get + (user-fs-type-name + (user-partition-fs-type user-partition)))) + (flags `(,@(if (user-partition-bootable? user-partition) + `(,PARTITION-FLAG-BOOT) + '()) + ,@(if (user-partition-esp? user-partition) + `(,PARTITION-FLAG-ESP) + '()) + ,@(if (user-partition-bios-grub? user-partition) + `(,PARTITION-FLAG-BIOS-GRUB) + '()))) + (has-name? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-PARTITION-NAME)) + (partition-type (partition-type->int type)) + (partition (partition-new disk + #:type partition-type + #:filesystem-type filesystem-type + #:start start-sector* + #:end end-sector)) + (user-constraint (constraint-new + #:start-align 'any + #:end-align 'any + #:start-range start-range + #:end-range end-range + #:min-size 1 + #:max-size length)) + (dev-constraint + (device-get-optimal-aligned-constraint device)) + (final-constraint (constraint-intersect user-constraint + dev-constraint)) + (no-constraint (constraint-any device)) + ;; Try to create a partition with an optimal alignment + ;; constraint. If it fails, fallback to creating a partition with + ;; no specific constraint. + (partition-ok? + (or (disk-add-partition disk partition final-constraint) + (disk-add-partition disk partition no-constraint)))) + ;; Set the partition name if supported. + (when (and partition-ok? has-name? name) + (partition-set-name partition name)) + + ;; Set flags is required. + (for-each (lambda (flag) + (and (partition-is-flag-available? partition flag) + (partition-set-flag partition flag 1))) + flags) + + (and partition-ok? + (partition-set-system partition filesystem-type) + partition)))))) + + +;; +;; Partition destruction. +;; + +(define (rmpart disk number) + "Remove the partition with the given NUMBER on DISK." + (let ((partition (disk-get-partition disk number))) + (disk-remove-partition disk partition))) + + +;; +;; Auto partitionning. +;; + +(define* (create-adjacent-partitions disk partitions + #:key (last-partition-end 0)) + "Create the given PARTITIONS on DISK. LAST-PARTITION-END is the sector from +which we want to start creating partitions. The START and END of each created +partition are computed from its SIZE value and the position of the last +partition." + (let ((device (disk-device disk))) + (let loop ((partitions partitions) + (remaining-space (- (device-length device) + last-partition-end)) + (start last-partition-end)) + (match partitions + (() '()) + ((partition . rest) + (let* ((size (user-partition-size partition)) + (percentage-size (and (string? size) + (read-percentage size))) + (sector-size (device-sector-size device)) + (partition-size (if percentage-size + (exact->inexact + (* (/ percentage-size 100) + remaining-space)) + size)) + (end-partition (min (- (device-length device) 1) + (nearest-exact-integer + (+ start partition-size 1)))) + (name (user-partition-name partition)) + (type (user-partition-type partition)) + (fs-type (user-partition-fs-type partition)) + (start-formatted (unit-format-custom device + start + UNIT-SECTOR)) + (end-formatted (unit-format-custom device + end-partition + UNIT-SECTOR)) + (new-user-partition (user-partition + (inherit partition) + (start start-formatted) + (end end-formatted))) + (new-partition + (mkpart disk new-user-partition))) + (if new-partition + (cons (user-partition + (inherit new-user-partition) + (path (partition-get-path new-partition)) + (disk-path (device-path device)) + (parted-object new-partition)) + (loop rest + (if (eq? type 'extended) + remaining-space + (- remaining-space + (partition-length new-partition))) + (if (eq? type 'extended) + (+ start 1) + (+ (partition-end new-partition) 1)))) + (error + (format #f "Unable to create partition ~a~%" name))))))))) + +(define (force-user-partitions-formating user-partitions) + "Set the NEED-FORMATING? fields to #t on all records of +USER-PARTITIONS list and return the updated list." + (map (lambda (p) + (user-partition + (inherit p) + (need-formating? #t))) + user-partitions)) + +(define* (auto-partition disk + #:key (scheme 'entire-root)) + "Automatically create partitions on DISK. All the previous +partitions (except the ESP on a GPT disk, if present) are wiped. SCHEME is the +desired partitioning scheme. It can be 'entire-root or +'entire-root-home. 'entire-root will create a swap partition and a root +partition occupying all the remaining space. 'entire-root-home will create a +swap partition, a root partition and a home partition." + (let* ((device (disk-device disk)) + (disk-type (disk-disk-type disk)) + (has-extended? (disk-type-check-feature + disk-type + DISK-TYPE-FEATURE-EXTENDED)) + (partitions (filter data-partition? (disk-partitions disk))) + (esp-partition (find-esp-partition partitions)) + ;; According to + ;; https://wiki.archlinux.org/index.php/EFI_system_partition, the ESP + ;; size should be at least 550MiB. + (new-esp-size (nearest-exact-integer + (/ (* 550 MEBIBYTE-SIZE) + (device-sector-size device)))) + (end-esp-partition (and esp-partition + (partition-end esp-partition))) + (non-boot-partitions (remove esp-partition? partitions)) + (bios-grub-size (/ (* 3 MEBIBYTE-SIZE) + (device-sector-size device))) + (five-percent-disk (nearest-exact-integer + (* 0.05 (device-length device)))) + (default-swap-size (nearest-exact-integer + (/ (* 4 GIGABYTE-SIZE) + (device-sector-size device)))) + ;; Use a 4GB size for the swap if it represents less than 5% of the + ;; disk space. Otherwise, set the swap size to 5% of the disk space. + (swap-size (min default-swap-size five-percent-disk))) + + (if has-extended? + ;; msdos - remove everything. + (disk-delete-all disk) + ;; gpt - remove everything but esp if it exists. + (for-each + (lambda (partition) + (and (data-partition? partition) + (disk-remove-partition disk partition))) + non-boot-partitions)) + + (let* ((start-partition + (and (not has-extended?) + (not esp-partition) + (if (efi-installation?) + (user-partition + (fs-type 'fat32) + (esp? #t) + (size new-esp-size) + (mount-point (default-esp-mount-point))) + (user-partition + (fs-type 'ext4) + (bootable? #t) + (bios-grub? #t) + (size bios-grub-size))))) + (new-partitions + (case scheme + ((entire-root) + `(,@(if start-partition + `(,start-partition) + '()) + ,(user-partition + (fs-type 'swap) + (size swap-size)) + ,(user-partition + (fs-type 'ext4) + (bootable? has-extended?) + (size "100%") + (mount-point "/")))) + ((entire-root-home) + `(,@(if start-partition + `(,start-partition) + '()) + ,(user-partition + (fs-type 'ext4) + (bootable? has-extended?) + (size "33%") + (mount-point "/")) + ,@(if has-extended? + `(,(user-partition + (type 'extended) + (size "100%"))) + '()) + ,(user-partition + (type (if has-extended? + 'logical + 'normal)) + (fs-type 'swap) + (size swap-size)) + ,(user-partition + (type (if has-extended? + 'logical + 'normal)) + (fs-type 'ext4) + (size "100%") + (mount-point "/home")))))) + (new-partitions* (force-user-partitions-formating + new-partitions))) + (create-adjacent-partitions disk + new-partitions* + #:last-partition-end + (or end-esp-partition 0))))) + + +;; +;; Convert user-partitions. +;; + +;; No root mount point found. +(define-condition-type &no-root-mount-point &condition + no-root-mount-point?) + +(define (check-user-partitions user-partitions) + "Return #t if the USER-PARTITIONS lists contains one record +with a mount-point set to '/', raise &no-root-mount-point condition +otherwise." + (let ((mount-points + (map user-partition-mount-point user-partitions))) + (or (member "/" mount-points) + (raise + (condition (&no-root-mount-point)))))) + +(define (set-user-partitions-path user-partitions) + "Set the partition path of records in USER-PARTITIONS list +and return the updated list." + (map (lambda (p) + (let* ((partition (user-partition-parted-object p)) + (path (partition-get-path partition))) + (user-partition + (inherit p) + (path path)))) + user-partitions)) + +(define-syntax-rule (with-null-output-ports exp ...) + "Evaluate EXP with both the output port and the error port pointing to the +bit bucket." + (with-output-to-port (%make-void-port "w") + (lambda () + (with-error-to-port (%make-void-port "w") + (lambda () exp ...))))) + +(define (create-ext4-file-system partition) + "Create an ext4 file-system for PARTITION path." + (with-null-output-ports + (invoke "mkfs.ext4" "-F" partition))) + +(define (create-fat32-file-system partition) + "Create an ext4 file-system for PARTITION path." + (with-null-output-ports + (invoke "mkfs.fat" "-F32" partition))) + +(define (create-swap-partition partition) + "Set up swap area on PARTITION path." + (with-null-output-ports + (invoke "mkswap" "-f" partition))) + +(define (start-swaping partition) + "Start swaping on PARTITION path." + (with-null-output-ports + (invoke "swapon" partition))) + +(define (stop-swaping partition) + "Stop swaping on PARTITION path." + (with-null-output-ports + (invoke "swapoff" partition))) + +(define (format-user-partitions user-partitions) + "Format the records in USER-PARTITIONS list with +NEED-FORMATING? field set to #t." + (for-each + (lambda (user-partition) + (let* ((need-formating? + (user-partition-need-formating? user-partition)) + (type (user-partition-type user-partition)) + (path (user-partition-path user-partition)) + (fs-type (user-partition-fs-type user-partition))) + (case fs-type + ((ext4) + (and need-formating? + (not (eq? type 'extended)) + (create-ext4-file-system path))) + ((fat32) + (and need-formating? + (not (eq? type 'extended)) + (create-fat32-file-system path))) + ((swap) + (create-swap-partition path)) + (else + ;; TODO: Add support for other file-system types. + #t)))) + user-partitions)) + +(define (sort-partitions user-partitions) + "Sort USER-PARTITIONS by mount-points, so that the more nested mount-point +comes last. This is useful to mount/umount partitions in a coherent order." + (sort user-partitions + (lambda (a b) + (let ((mount-point-a (user-partition-mount-point a)) + (mount-point-b (user-partition-mount-point b))) + (string-prefix? mount-point-a mount-point-b))))) + +(define (mount-user-partitions user-partitions) + "Mount the records in USER-PARTITIONS list on their +respective mount-points. Also start swaping on records with +FS-TYPE equal to 'swap." + (let* ((mount-partitions (filter user-partition-mount-point user-partitions)) + (sorted-partitions (sort-partitions mount-partitions))) + (for-each (lambda (user-partition) + (let* ((mount-point + (user-partition-mount-point user-partition)) + (target + (string-append (%installer-target-dir) + mount-point)) + (fs-type + (user-partition-fs-type user-partition)) + (mount-type + (user-fs-type->mount-type fs-type)) + (path (user-partition-path user-partition))) + (case fs-type + ((swap) + (start-swaping path)) + (else + (mkdir-p target) + (mount path target mount-type))))) + sorted-partitions))) + +(define (umount-user-partitions user-partitions) + "Unmount all the records in USER-PARTITIONS list. Also stop +swaping on with FS-TYPE set to 'swap." + (let* ((mount-partitions (filter user-partition-mount-point user-partitions)) + (sorted-partitions (sort-partitions mount-partitions))) + (for-each (lambda (user-partition) + (let* ((mount-point + (user-partition-mount-point user-partition)) + (fs-type + (user-partition-fs-type user-partition)) + (path (user-partition-path user-partition)) + (target + (string-append (%installer-target-dir) + mount-point))) + (case fs-type + ((swap) + (stop-swaping path)) + (else + (umount target))))) + (reverse sorted-partitions)))) + +(define-syntax-rule (with-mounted-partitions user-partitions exp ...) + "Mount USER-PARTITIONS within the dynamic extent of EXP." + (dynamic-wind + (lambda () + (mount-user-partitions user-partitions)) + (lambda () + exp ...) + (lambda () + (umount-user-partitions user-partitions) + #f))) + +(define (user-partition->file-system user-partition) + "Convert the given USER-PARTITION record in a FILE-SYSTEM record from +(gnu system file-systems) module and return it." + (let* ((mount-point (user-partition-mount-point user-partition)) + (fs-type (user-partition-fs-type user-partition)) + (mount-type (user-fs-type->mount-type fs-type)) + (path (user-partition-path user-partition)) + (uuid (uuid->string (read-partition-uuid path) + fs-type))) + `(file-system + (mount-point ,mount-point) + (device (uuid ,uuid (quote ,fs-type))) + (type ,mount-type)))) + +(define (user-partitions->file-systems user-partitions) + "Convert the given USER-PARTITIONS list of records into a +list of records." + (filter-map + (lambda (user-partition) + (let ((mount-point + (user-partition-mount-point user-partition))) + (and mount-point + (user-partition->file-system user-partition)))) + user-partitions)) + +(define (find-swap-user-partitions user-partitions) + "Return the subset of records in USER-PARTITIONS list with +the FS-TYPE field set to 'swap, return the empty list if none found." + (filter (lambda (user-partition) + (let ((fs-type (user-partition-fs-type user-partition))) + (eq? fs-type 'swap))) + user-partitions)) + +(define (bootloader-configuration user-partitions) + "Return the bootloader configuration field for USER-PARTITIONS." + (let* ((root-partition + (find (lambda (user-partition) + (let ((mount-point + (user-partition-mount-point user-partition))) + (and mount-point + (string=? mount-point "/")))) + user-partitions)) + (root-partition-disk (user-partition-disk-path root-partition))) + `((bootloader-configuration + ,@(if (efi-installation?) + `((bootloader grub-efi-bootloader) + (target ,(default-esp-mount-point))) + `((bootloader grub-bootloader) + (target ,root-partition-disk))))))) + +(define (user-partitions->configuration user-partitions) + "Return the configuration field for USER-PARTITIONS." + (let* ((swap-user-partitions (find-swap-user-partitions user-partitions)) + (swap-devices (map user-partition-path swap-user-partitions))) + `(,@(if (null? swap-devices) + '() + `((swap-devices (list ,@swap-devices)))) + (bootloader ,@(bootloader-configuration user-partitions)) + (file-systems (cons* + ,@(user-partitions->file-systems user-partitions) + %base-file-systems))))) + + +;; +;; Initialization. +;; + +(define (init-parted) + "Initialize libparted support." + (probe-all-devices) + (exception-set-handler (lambda (exception) + EXCEPTION-OPTION-UNHANDLED))) + +(define (free-parted devices) + "Deallocate memory used for DEVICES in parted, force sync them and wait for +the devices not to be used before returning." + ;; XXX: Formating and further operations on disk partition table may fail + ;; because the partition table changes are not synced, or because the device + ;; is still in use, even if parted should have finished editing + ;; partitions. This is not well understood, but syncing devices and waiting + ;; them to stop returning EBUSY to BLKRRPART ioctl seems to be enough. The + ;; same kind of issue is described here: + ;; https://mail.gnome.org/archives/commits-list/2013-March/msg18423.html. + (let ((device-paths (map device-path devices))) + (for-each force-device-sync devices) + (free-all-devices) + (for-each (lambda (path) + (let ((in-use? (with-delay-device-in-use? path))) + (and in-use? + (error + (format #f (G_ "Device ~a is still in use.") + path))))) + device-paths))) diff --git a/gnu/installer/record.scm b/gnu/installer/record.scm index 3ef0a101d3..edf73b6215 100644 --- a/gnu/installer/record.scm +++ b/gnu/installer/record.scm @@ -35,6 +35,7 @@ installer-timezone-page installer-hostname-page installer-user-page + installer-partition-page installer-services-page installer-welcome-page)) @@ -76,6 +77,8 @@ ;; procedure void -> void (user-page installer-user-page) ;; procedure void -> void + (partition-page installer-partition-page) + ;; procedure void -> void (services-page installer-services-page) ;; procedure (logo) -> void (welcome-page installer-welcome-page)) diff --git a/gnu/local.mk b/gnu/local.mk index 0b5e96afa4..63859a3b67 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -574,6 +574,7 @@ GNU_SYSTEM_MODULES += \ %D%/installer/keymap.scm \ %D%/installer/locale.scm \ %D%/installer/newt.scm \ + %D%/installer/parted.scm \ %D%/installer/services.scm \ %D%/installer/steps.scm \ %D%/installer/timezone.scm \ @@ -588,6 +589,7 @@ GNU_SYSTEM_MODULES += \ %D%/installer/newt/menu.scm \ %D%/installer/newt/network.scm \ %D%/installer/newt/page.scm \ + %D%/installer/newt/partition.scm \ %D%/installer/newt/services.scm \ %D%/installer/newt/timezone.scm \ %D%/installer/newt/utils.scm \ diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 48c09a1e3a..8327bf6c9e 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -28,6 +28,7 @@ gnu/installer/newt/user.scm gnu/installer/newt/utils.scm gnu/installer/newt/welcome.scm gnu/installer/newt/wifi.scm +gnu/installer/parted.scm gnu/installer/services.scm gnu/installer/steps.scm gnu/installer/timezone.scm -- cgit v1.2.3 From 133c401f774d803f92933e9cadb6791641913beb Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Thu, 6 Dec 2018 11:11:04 +0900 Subject: installer: Display an eventual backtrace in a page. * gnu/installer.scm (installer-program): Write the backtrace in "/tmp/last-installer-error" and pass the filename to installer-exit-error. * gnu/installer/newt.scm (exit-error): Display the file passed above in a textbox. --- gnu/installer.scm | 19 +++++++++---------- gnu/installer/newt.scm | 21 ++++++++++++++++++++- 2 files changed, 29 insertions(+), 11 deletions(-) (limited to 'gnu/installer/newt.scm') diff --git a/gnu/installer.scm b/gnu/installer.scm index 586ed29a59..2f01d39d1a 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -333,16 +333,15 @@ selected keymap." #:steps steps)) (const #f) (lambda (key . args) - ((installer-exit-error current-installer) key args) - - ;; Be sure to call newt-finish, to restore the terminal into - ;; its original state before printing the error report. - (call-with-output-file "/tmp/error" - (lambda (port) - (display-backtrace (make-stack #t) port) - (print-exception port - (stack-ref (make-stack #t) 1) - key args))) + (let ((error-file "/tmp/last-installer-error")) + (call-with-output-file error-file + (lambda (port) + (display-backtrace (make-stack #t) port) + (print-exception port + (stack-ref (make-stack #t) 1) + key args))) + ((installer-exit-error current-installer) + error-file key args)) (primitive-exit 1))) ((installer-exit current-installer))))))) diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index 9d9212173d..31329b5c0f 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -18,6 +18,7 @@ (define-module (gnu installer newt) #:use-module (gnu installer record) + #:use-module (gnu installer utils) #:use-module (gnu installer newt ethernet) #:use-module (gnu installer newt final) #:use-module (gnu installer newt hostname) @@ -25,6 +26,7 @@ #:use-module (gnu installer newt locale) #:use-module (gnu installer newt menu) #:use-module (gnu installer newt network) + #:use-module (gnu installer newt page) #:use-module (gnu installer newt partition) #:use-module (gnu installer newt services) #:use-module (gnu installer newt timezone) @@ -32,6 +34,7 @@ #:use-module (gnu installer newt utils) #:use-module (gnu installer newt welcome) #:use-module (gnu installer newt wifi) + #:use-module (guix config) #:use-module (guix discovery) #:use-module (guix i18n) #:use-module (srfi srfi-26) @@ -46,7 +49,23 @@ (define (exit) (newt-finish)) -(define (exit-error key . args) +(define (exit-error file key args) + (newt-set-color COLORSET-ROOT "white" "red") + (let ((width (nearest-exact-integer + (* (screen-columns) 0.8))) + (height (nearest-exact-integer + (* (screen-rows) 0.7)))) + (run-file-textbox-page + #:info-text (format #f (G_ "The installer has encountered an unexpected \ +problem. The backtrace is displayed below. Please report it by email to \ +<~a>.") %guix-bug-report-address) + #:title (G_ "Unexpected problem") + #:file file + #:exit-button? #f + #:info-textbox-width width + #:file-textbox-width width + #:file-textbox-height height)) + (newt-set-color COLORSET-ROOT "white" "blue") (newt-finish)) (define (final-page result prev-steps) -- cgit v1.2.3 From df3664f1ec9a8b3c59c0e61f197798c2dda986e3 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sat, 8 Dec 2018 10:37:56 +0900 Subject: installer: Clear screen upon exit. * gnu/installer/newt.scm (exit): Call clear-screen after newt-finish, (exit-error): ditto. --- gnu/installer/newt.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'gnu/installer/newt.scm') diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index 31329b5c0f..6c44b4acf6 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -47,7 +47,8 @@ (set-screen-size!)) (define (exit) - (newt-finish)) + (newt-finish) + (clear-screen)) (define (exit-error file key args) (newt-set-color COLORSET-ROOT "white" "red") @@ -66,7 +67,8 @@ problem. The backtrace is displayed below. Please report it by email to \ #:file-textbox-width width #:file-textbox-height height)) (newt-set-color COLORSET-ROOT "white" "blue") - (newt-finish)) + (newt-finish) + (clear-screen)) (define (final-page result prev-steps) (run-final-page result prev-steps)) -- cgit v1.2.3