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.

1 files changed, 162 insertions, 0 deletions

diff --git a/gnu/installer/keymap.scm b/gnu/installer/keymap.scm
new file mode 100644
index 0000000000..78065aa6c6
--- /dev/null
+++ b/gnu/installer/keymap.scm
@@ -0,0 +1,162 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer keymap)
+  #:use-module (guix records)
+  #:use-module (sxml match)
+  #:use-module (sxml simple)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:export (<x11-keymap-model>
+            x11-keymap-model
+            make-x11-keymap-model
+            x11-keymap-model?
+            x11-keymap-model-name
+            x11-keymap-model-description
+
+            <x11-keymap-layout>
+            x11-keymap-layout
+            make-x11-keymap-layout
+            x11-keymap-layout?
+            x11-keymap-layout-name
+            x11-keymap-layout-description
+            x11-keymap-layout-variants
+
+            <x11-keymap-variant>
+            x11-keymap-variant
+            make-x11-keymap-variant
+            x11-keymap-variant?
+            x11-keymap-variant-name
+            x11-keymap-variant-description
+
+            xkb-rules->models+layouts
+            kmscon-update-keymap))
+
+(define-record-type* <x11-keymap-model>
+  x11-keymap-model make-x11-keymap-model
+  x11-keymap-model?
+  (name            x11-keymap-model-name) ;string
+  (description     x11-keymap-model-description)) ;string
+
+(define-record-type* <x11-keymap-layout>
+  x11-keymap-layout make-x11-keymap-layout
+  x11-keymap-layout?
+  (name            x11-keymap-layout-name) ;string
+  (description     x11-keymap-layout-description) ;string
+  (variants        x11-keymap-layout-variants)) ;list of <x11-keymap-variant>
+
+(define-record-type* <x11-keymap-variant>
+  x11-keymap-variant make-x11-keymap-variant
+  x11-keymap-variant?
+  (name            x11-keymap-variant-name) ;string
+  (description     x11-keymap-variant-description)) ;string
+
+(define (xkb-rules->models+layouts file)
+  "Parse FILE and return two values, the list of supported X11-KEYMAP-MODEL
+and X11-KEYMAP-LAYOUT records. FILE is an XML file from the X Keyboard
+Configuration Database, describing possible XKB configurations."
+  (define (model m)
+    (sxml-match m
+                [(model
+                  (configItem
+                   (name ,name)
+                   (description ,description)
+                   . ,rest))
+                 (x11-keymap-model
+                  (name name)
+                  (description description))]))
+
+  (define (variant v)
+    (sxml-match v
+                [(variant
+                  ;; According to xbd-rules DTD, the definition of a
+                  ;; configItem is: <!ELEMENT configItem
+                  ;; (name,shortDescription*,description*,vendor?,
+                  ;; countryList?,languageList?,hwList?)>
+                  ;;
+                  ;; shortDescription and description are optional elements
+                  ;; but sxml-match does not support default values for
+                  ;; elements (only attributes). So to avoid writing as many
+                  ;; patterns as existing possibilities, gather all the
+                  ;; remaining elements but name in REST-VARIANT.
+                  (configItem
+                   (name ,name)
+                   . ,rest-variant))
+                 (x11-keymap-variant
+                  (name name)
+                  (description (car
+                                (assoc-ref rest-variant 'description))))]))
+
+  (define (layout l)
+    (sxml-match l
+                [(layout
+                  (configItem
+                   (name ,name)
+                   . ,rest-layout)
+                  (variantList ,[variant -> v] ...))
+                 (x11-keymap-layout
+                  (name name)
+                  (description (car
+                                (assoc-ref rest-layout 'description)))
+                  (variants (list v ...)))]
+                [(layout
+                  (configItem
+                   (name ,name)
+                   . ,rest-layout))
+                 (x11-keymap-layout
+                  (name name)
+                  (description (car
+                                (assoc-ref rest-layout 'description)))
+                  (variants '()))]))
+
+  (let ((sxml (call-with-input-file file
+                (lambda (port)
+                  (xml->sxml port #:trim-whitespace? #t)))))
+    (match
+        (sxml-match sxml
+                    [(*TOP*
+                      ,pi
+                      (xkbConfigRegistry
+                       (@ . ,ignored)
+                       (modelList ,[model -> m] ...)
+                       (layoutList ,[layout -> l] ...)
+                       . ,rest))
+                     (list
+                      (list m ...)
+                      (list l ...))])
+      ((models layouts)
+       (values models layouts)))))
+
+(define (kmscon-update-keymap model layout variant)
+  (let ((keymap-file (getenv "KEYMAP_UPDATE")))
+    (unless (and keymap-file
+                 (file-exists? keymap-file))
+      (error "Unable to locate keymap update file"))
+
+    (call-with-output-file keymap-file
+        (lambda (port)
+          (format port model)
+          (put-u8 port 0)
+
+          (format port layout)
+          (put-u8 port 0)
+
+          (format port variant)
+          (put-u8 port 0)))))