Merge branch 'master' into staging

TODO

@@ -4,6 +4,7 @@
 #+STARTUP: content hidestars
 
 Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
 
   Copying and distribution of this file, with or without modification,
   are permitted in any medium without royalty provided the copyright
@@ -83,3 +84,38 @@ Problems include that current glibc releases do not build on GNU/Hurd.
 In addition, there haven’t been stable releases of GNU Mach, MiG, and
 Hurd, which would be a pre-condition.
 
+* Installer
+** Fix impossibility to restart on error after cow-store has been started
+See https://lists.gnu.org/archive/html/guix-devel/2018-12/msg00161.html.
+- Force reboot upon installer failure
+- Unshare the installer process
+- Run the installer process in a separate namespace
+** Partitioning
+*** Add RAID support
+*** Add more partitioning schemes
+The actual schemes are taken from Debian Installer but some are not
+implemented yet: like "Separate partitions for /home /var and /tmp".
+*** Replace wait page "Partition formating is in progress, please wait"
+Create a new waiting page describing what's being done:
+
+[              20%              ]
+Running mkfs.ext4 on /dev/sda2 ...
+
+[              40%              ]
+Running mkfs.ext4 on /dev/sda3 ...
+
+** Desktop environments
+*** Allow for no desktop environments
+Propose to choose between "headless server" and "lightweight X11" in a new
+page.
+*** Add services selection feature
+Add a services page to the configuration. Ask for services to be installed
+like SSH, bluetooth, TLP in a checkbox list?
+** Locale and keymap
+*** Try to guess user locale and keymap by probing BIOS or HW (dmidecode)
+** Timezone
+*** Regroup everything in one single page
+Under the form:
+(UTC + 1) Europe/Paris
+(UTC + 2) Africa/Cairo
+...

configure.ac

@@ -135,6 +135,21 @@ if test "x$have_guile_gcrypt" != "xyes"; then
   AC_MSG_ERROR([Guile-Gcrypt could not be found; please install it.])
 fi
 
+dnl Guile-newt is used by the graphical installer.
+GUILE_MODULE_AVAILABLE([have_guile_newt], [(newt)])
+
+AC_ARG_ENABLE([installer],
+    AS_HELP_STRING([--enable-installer], [Build the graphical installer sources.]))
+
+AS_IF([test "x$enable_installer" = "xyes"], [
+if test "x$have_guile_newt" != "xyes"; then
+  AC_MSG_ERROR([Guile-newt could not be found; please install it.])
+fi
+])
+
+AM_CONDITIONAL([ENABLE_INSTALLER],
+  [test "x$enable_installer" = "xyes"])
+
 dnl Make sure we have a full-fledged Guile.
 GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads])
 

doc/guix.texi

@@ -9328,12 +9328,20 @@ GuixSD in a virtual machine (VM).
 @subsection Preparing for Installation
 
 Once you have successfully booted your computer using the installation medium,
-you should end up with a root prompt.  Several console TTYs are configured
+you should end up with the welcome page of the graphical installer.  The
-and can be used to run commands as root.  TTY2 shows this documentation,
+graphical installer is a text-based user interface built upon the newt
-browsable using the Info reader commands (@pxref{Top,,, info-stnd,
+library.  It shall guide you through all the different steps needed to install
-Stand-alone GNU Info}).  The installation system runs the GPM mouse
+GNU GuixSD.  However, as the graphical installer is still under heavy
-daemon, which allows you to select text with the left mouse button and
+development, you might want to fallback to the original, shell based install
-to paste it with the middle button.
+process, by switching to TTYs 3 to 6 with the shortcuts CTRL-ALT-F[3-6]. The
+following sections describe the installation procedure assuming you're using
+one of those TTYs. They are configured and can be used to run commands as
+root.
+
+TTY2 shows this documentation, browsable using the Info reader commands
+(@pxref{Top,,, info-stnd, Stand-alone GNU Info}).  The installation system
+runs the GPM mouse daemon, which allows you to select text with the left mouse
+button and to paste it with the middle button.
 
 @quotation Note
 Installation requires access to the Internet so that any missing
@@ -9660,12 +9668,12 @@ unless your configuration specifies otherwise
 (@pxref{user-account-password, user account passwords}).
 
 @cindex upgrading GuixSD
-From then on, you can update GuixSD whenever you want by running
+From then on, you can update GuixSD whenever you want by running @command{guix
-@command{guix pull} as @code{root} (@pxref{Invoking guix pull}), and
+pull} as @code{root} (@pxref{Invoking guix pull}), and then running
-then running @command{guix system reconfigure} to build a new system
+@command{guix system reconfigure /etc/config.scm}, as @code{root} too, to
-generation with the latest packages and services (@pxref{Invoking guix
+build a new system generation with the latest packages and services
-system}).  We recommend doing that regularly so that your system
+(@pxref{Invoking guix system}).  We recommend doing that regularly so that
-includes the latest security updates (@pxref{Security Updates}).
+your system includes the latest security updates (@pxref{Security Updates}).
 
 Join us on @code{#guix} on the Freenode IRC network or on
 @email{guix-devel@@gnu.org} to share your experience---good or not so
@@ -10848,7 +10856,9 @@ system, you will want to append services to @var{%base-services}, like
 this:
 
 @example
-(cons* (avahi-service) (lsh-service) %base-services)
+(cons* (service avahi-service-type)
+       (service openssh-service-type)
+       %base-services)
 @end example
 @end defvr
 
@@ -12634,6 +12644,19 @@ This is a symbol specifying the logging level: @code{quiet}, @code{fatal},
 @code{error}, @code{info}, @code{verbose}, @code{debug}, etc.  See the man
 page for @file{sshd_config} for the full list of level names.
 
+@item @code{extra-content} (default: @code{""})
+This field can be used to append arbitrary text to the configuration file.  It
+is especially useful for elaborate configurations that cannot be expressed
+otherwise.  This configuration, for example, would generally disable root
+logins, but permit them from one specific IP address:
+
+@example
+(openssh-configuration
+  (extra-content "\
+Match Address 192.168.0.1
+  PermitRootLogin yes"))
+@end example
+
 @end table
 @end deftp
 
@@ -12709,31 +12732,54 @@ browsers, from accessing Facebook.
 
 The @code{(gnu services avahi)} provides the following definition.
 
-@deffn {Scheme Procedure} avahi-service [#:avahi @var{avahi}] @
+@defvr {Scheme Variable} avahi-service-type
-          [#:host-name #f] [#:publish? #t] [#:ipv4? #t] @
+This is the service that runs @command{avahi-daemon}, a system-wide
-          [#:ipv6? #t] [#:wide-area? #f] @
-          [#:domains-to-browse '()] [#:debug? #f]
-Return a service that runs @command{avahi-daemon}, a system-wide
 mDNS/DNS-SD responder that allows for service discovery and
-"zero-configuration" host name lookups (see @uref{http://avahi.org/}), and
+``zero-configuration'' host name lookups (see @uref{http://avahi.org/}).
-extends the name service cache daemon (nscd) so that it can resolve
+Its value must be a @code{zero-configuration} record---see below.
-@code{.local} host names using
-@uref{http://0pointer.de/lennart/projects/nss-mdns/, nss-mdns}.  Additionally,
-add the @var{avahi} package to the system profile so that commands such as
-@command{avahi-browse} are directly usable.
 
-If @var{host-name} is different from @code{#f}, use that as the host name to
+This service extends the name service cache daemon (nscd) so that it can
+resolve @code{.local} host names using
+@uref{http://0pointer.de/lennart/projects/nss-mdns/, nss-mdns}.  @xref{Name
+Service Switch}, for information on host name resolution.
+
+Additionally, add the @var{avahi} package to the system profile so that
+commands such as @command{avahi-browse} are directly usable.
+@end defvr
+
+@deftp {Data Type} avahi-configuration
+Data type representation the configuration for Avahi.
+
+@table @asis
+
+@item @code{host-name} (default: @code{#f})
+If different from @code{#f}, use that as the host name to
 publish for this machine; otherwise, use the machine's actual host name.
 
-When @var{publish?} is true, publishing of host names and services is allowed;
+@item @code{publish?} (default: @code{#t})
-in particular, avahi-daemon will publish the machine's host name and IP
+When true, allow host names and services to be published (broadcast) over the
-address via mDNS on the local network.
+network.
 
-When @var{wide-area?} is true, DNS-SD over unicast DNS is enabled.
+@item @code{publish-workstation?} (default: @code{#t})
+When true, @command{avahi-daemon} publishes the machine's host name and IP
+address via mDNS on the local network.  To view the host names published on
+your local network, you can run:
 
-Boolean values @var{ipv4?} and @var{ipv6?} determine whether to use IPv4/IPv6
+@example
-sockets.
+avahi-browse _workstation._tcp
-@end deffn
+@end example
+
+@item @code{wide-area?} (default: @code{#f})
+When true, DNS-SD over unicast DNS is enabled.
+
+@item @code{ipv4?} (default: @code{#t})
+@itemx @code{ipv6?} (default: @code{#t})
+These fields determine whether to use IPv4/IPv6 sockets.
+
+@item @code{domains-to-browse} (default: @code{'()})
+This is a list of domains to browse.
+@end table
+@end deftp
 
 @deffn {Scheme Variable} openvswitch-service-type
 This is the type of the @uref{http://www.openvswitch.org, Open vSwitch}
@@ -22339,8 +22385,8 @@ want is to have @code{.local} host lookup working.
 
 Note that, in this case, in addition to setting the
 @code{name-service-switch} of the @code{operating-system} declaration,
-you also need to use @code{avahi-service} (@pxref{Networking Services,
+you also need to use @code{avahi-service-type} (@pxref{Networking Services,
-@code{avahi-service}}), or @var{%desktop-services}, which includes it
+@code{avahi-service-type}}), or @var{%desktop-services}, which includes it
 (@pxref{Desktop Services}).  Doing this makes @code{nss-mdns} accessible
 to the name service cache daemon (@pxref{Base Services,
 @code{nscd-service}}).

gnu/bootloader.scm

@@ -105,9 +105,7 @@ (define-record-type* <bootloader-configuration>
   bootloader-configuration make-bootloader-configuration
   bootloader-configuration?
   (bootloader                      bootloader-configuration-bootloader)    ; <bootloader>
-  (device                          bootloader-configuration-device         ; string
+  (target                          bootloader-configuration-target         ; string
-                                   (default #f))
-  (target                          %bootloader-configuration-target         ; string
                                    (default #f))
   (menu-entries                    bootloader-configuration-menu-entries   ; list of <boot-parameters>
                                    (default '()))
@@ -128,15 +126,6 @@ (define-record-type* <bootloader-configuration>
   (additional-configuration        bootloader-configuration-additional-configuration ; record
                                    (default #f)))
 
-(define (bootloader-configuration-target config)
-  (or (%bootloader-configuration-target config)
-      (let ((device (bootloader-configuration-device config)))
-        (when device
-          (warning
-           (G_ "The 'device' field of bootloader configurations is deprecated.~%"))
-          (warning (G_ "Use 'target' instead.~%")))
-        device)))
-
 
 ;;;
 ;;; Bootloaders.

gnu/build/file-systems.scm

@@ -42,6 +42,10 @@ (define-module (gnu build file-systems)
             find-partition-by-luks-uuid
             canonicalize-device-spec
 
+            read-partition-label
+            read-partition-uuid
+            read-luks-partition-uuid
+
             bind-mount
 
             mount-flags->bit-mask
@@ -435,6 +439,12 @@ (define read-partition-label
 (define read-partition-uuid
   (cut read-partition-field <> %partition-uuid-readers))
 
+(define luks-partition-field-reader
+  (partition-field-reader read-luks-header luks-header-uuid))
+
+(define read-luks-partition-uuid
+  (cut read-partition-field <> (list luks-partition-field-reader)))
+
 (define (partition-predicate reader =)
   "Return a predicate that returns true if the FIELD of partition header that
 was READ is = to the given value."
@@ -451,9 +461,7 @@ (define partition-uuid-predicate
   (partition-predicate read-partition-uuid uuid=?))
 
 (define luks-partition-uuid-predicate
-  (partition-predicate
+  (partition-predicate luks-partition-field-reader uuid=?))
-   (partition-field-reader read-luks-header luks-header-uuid)
-   uuid=?))
 
 (define (find-partition predicate)
   "Return the first partition found that matches PREDICATE, or #f if none

gnu/ci.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
 ;;;
@@ -24,7 +24,9 @@ (define-module (gnu ci)
   #:use-module (guix grafts)
   #:use-module (guix profiles)
   #:use-module (guix packages)
+  #:use-module (guix channels)
   #:use-module (guix derivations)
+  #:use-module (guix build-system)
   #:use-module (guix monads)
   #:use-module (guix ui)
   #:use-module ((guix licenses)
@@ -188,8 +190,40 @@ (define MiB
                                               "iso9660"))))))
       '()))
 
-(define (system-test-jobs store system)
+(define channel-build-system
+  ;; Build system used to "convert" a channel instance to a package.
+  (let* ((build (lambda* (store name inputs
+                                #:key instance #:allow-other-keys)
+                  (run-with-store store
+                    (channel-instances->derivation (list instance)))))
+         (lower (lambda* (name #:key system instance #:allow-other-keys)
+                  (bag
+                    (name name)
+                    (system system)
+                    (build build)
+                    (arguments `(#:instance ,instance))))))
+    (build-system (name 'channel)
+                  (description "Turn a channel instance into a package.")
+                  (lower lower))))
+
+(define (channel-instance->package instance)
+  "Return a package for the given channel INSTANCE."
+  (package
+    (inherit guix)
+    (version (or (string-take (channel-instance-commit instance) 7)
+                 (string-append (package-version guix) "+")))
+    (build-system channel-build-system)
+    (arguments `(#:instance ,instance))
+    (inputs '())
+    (native-inputs '())
+    (propagated-inputs '())))
+
+(define* (system-test-jobs store system
+                           #:key source commit)
   "Return a list of jobs for the system tests."
+  (define instance
+    (checkout->channel-instance source #:commit commit))
+
   (define (test->thunk test)
     (lambda ()
       (define drv
@@ -217,7 +251,13 @@ (define (->job test)
       (cons name (test->thunk test))))
 
   (if (member system %guixsd-supported-systems)
-      (map ->job (all-system-tests))
+      ;; Override the value of 'current-guix' used by system tests.  Using a
+      ;; channel instance makes tests that rely on 'current-guix' less
+      ;; expensive.  It also makes sure we get a valid Guix package when this
+      ;; code is not running from a checkout.
+      (parameterize ((current-guix-package
+                      (channel-instance->package instance)))
+        (map ->job (all-system-tests)))
       '()))
 
 (define (tarball-jobs store system)
@@ -343,6 +383,21 @@ (define systems
       ((lst ...)       lst)
       ((? string? str) (call-with-input-string str read))))
 
+  (define checkout
+    ;; Extract metadata about the 'guix' checkout.  Its key in ARGUMENTS may
+    ;; vary, so pick up the first one that's neither 'subset' nor 'systems'.
+    (any (match-lambda
+           ((key . value)
+            (and (not (memq key '(systems subset)))
+                 value)))
+         arguments))
+
+  (define commit
+    (assq-ref checkout 'revision))
+
+  (define source
+    (assq-ref checkout 'file-name))
+
   (define (cross-jobs system)
     (define (from-32-to-64? target)
       ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit.  This hack
@@ -405,7 +460,9 @@ (define (either proc1 proc2 proc3)
                                                 system))))
                        (append (filter-map job all)
                                (qemu-jobs store system)
-                               (system-test-jobs store system)
+                               (system-test-jobs store system
+                                                 #:source source
+                                                 #:commit commit)
                                (tarball-jobs store system)
                                (cross-jobs system))))
                     ((core)

gnu/installer.scm

@@ -0,0 +1,358 @@
+;;; 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)
+  #:use-module (guix discovery)
+  #: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 cryptsetup)
+  #:use-module (gnu packages disk)
+  #: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))
+
+(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)
+          result))))
+
+(define apply-keymap
+  ;; Apply the specified keymap. Use the default keyboard model.
+  #~(match-lambda
+      ((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
+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)
+                  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"))
+          (compute (lambda _
+                     (#$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"))
+          (compute (lambda _
+                     ((installer-timezone-page current-installer)
+                      #$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
+         ;; 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))))
+
+         ;; Run a partitioning tool allowing the user to modify
+         ;; partition tables, partitions and their mount points.
+         (installer-step
+          (id 'partition)
+          (description (G_ "Partitioning"))
+          (compute (lambda _
+                     ((installer-partition-page current-installer))))
+          (configuration-formatter user-partitions->configuration))
+
+         ;; Ask the user to input a hostname for the system.
+         (installer-step
+          (id 'hostname)
+          (description (G_ "Hostname"))
+          (compute (lambda _
+                     ((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.
+         (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 'user)
+          (description (G_ "User creation"))
+          (compute (lambda _
+                     ((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-services-page current-installer))))
+	  (configuration-formatter
+           desktop-environments->configuration))
+
+	 (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."
+  (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 ;start subshells
+                               connman ;call connmanctl
+                               cryptsetup
+                               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-parted guile-bytestructures
+                           guile-json)
+      (with-imported-modules `(,@(source-module-closure
+                                  `(,@modules
+                                    (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 final)
+                         (gnu installer hostname)
+                         (gnu installer locale)
+                         (gnu installer parted)
+                         (gnu installer services)
+                         (gnu installer timezone)
+                         (gnu installer user)
+                         (gnu installer newt)
+                         (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
+
+            (let* ((current-installer newt-installer)
+                   (steps (#$steps current-installer)))
+              ((installer-init current-installer))
+
+              (catch #t
+                (lambda ()
+                  (run-installer-steps
+                   #:rewind-strategy 'menu
+                   #:menu-proc (installer-menu-page current-installer)
+                   #:steps steps))
+                (const #f)
+                (lambda (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)))))))
+
+  (program-file
+   "installer"
+   #~(begin
+       ;; Set the default locale to install unicode support.  For
+       ;; some reason, unicode support is not correctly installed
+       ;; when calling this in 'installer-builder'.
+       (setenv "LANG" "en_US.UTF-8")
+       (system #$(program-file "installer-real" installer-builder)))))

gnu/installer/aux-files/SUPPORTED

@@ -0,0 +1,484 @@
+aa_DJ.UTF-8 UTF-8
+aa_DJ ISO-8859-1
+aa_ER UTF-8
+aa_ER@saaho UTF-8
+aa_ET UTF-8
+af_ZA.UTF-8 UTF-8
+af_ZA ISO-8859-1
+agr_PE UTF-8
+ak_GH UTF-8
+am_ET UTF-8
+an_ES.UTF-8 UTF-8
+an_ES ISO-8859-15
+anp_IN UTF-8
+ar_AE.UTF-8 UTF-8
+ar_AE ISO-8859-6
+ar_BH.UTF-8 UTF-8
+ar_BH ISO-8859-6
+ar_DZ.UTF-8 UTF-8
+ar_DZ ISO-8859-6
+ar_EG.UTF-8 UTF-8
+ar_EG ISO-8859-6
+ar_IN UTF-8
+ar_IQ.UTF-8 UTF-8
+ar_IQ ISO-8859-6
+ar_JO.UTF-8 UTF-8
+ar_JO ISO-8859-6
+ar_KW.UTF-8 UTF-8
+ar_KW ISO-8859-6
+ar_LB.UTF-8 UTF-8
+ar_LB ISO-8859-6
+ar_LY.UTF-8 UTF-8
+ar_LY ISO-8859-6
+ar_MA.UTF-8 UTF-8
+ar_MA ISO-8859-6
+ar_OM.UTF-8 UTF-8
+ar_OM ISO-8859-6
+ar_QA.UTF-8 UTF-8
+ar_QA ISO-8859-6
+ar_SA.UTF-8 UTF-8
+ar_SA ISO-8859-6
+ar_SD.UTF-8 UTF-8
+ar_SD ISO-8859-6
+ar_SS UTF-8
+ar_SY.UTF-8 UTF-8
+ar_SY ISO-8859-6
+ar_TN.UTF-8 UTF-8
+ar_TN ISO-8859-6
+ar_YE.UTF-8 UTF-8
+ar_YE ISO-8859-6
+ayc_PE UTF-8
+az_AZ UTF-8
+az_IR UTF-8
+as_IN UTF-8
+ast_ES.UTF-8 UTF-8
+ast_ES ISO-8859-15
+be_BY.UTF-8 UTF-8
+be_BY CP1251
+be_BY@latin UTF-8
+bem_ZM UTF-8
+ber_DZ UTF-8
+ber_MA UTF-8
+bg_BG.UTF-8 UTF-8
+bg_BG CP1251
+bhb_IN.UTF-8 UTF-8
+bho_IN UTF-8
+bho_NP UTF-8
+bi_VU UTF-8
+bn_BD UTF-8
+bn_IN UTF-8
+bo_CN UTF-8
+bo_IN UTF-8
+br_FR.UTF-8 UTF-8
+br_FR ISO-8859-1
+br_FR@euro ISO-8859-15
+brx_IN UTF-8
+bs_BA.UTF-8 UTF-8
+bs_BA ISO-8859-2
+byn_ER UTF-8
+ca_AD.UTF-8 UTF-8
+ca_AD ISO-8859-15
+ca_ES.UTF-8 UTF-8
+ca_ES ISO-8859-1
+ca_ES@euro ISO-8859-15
+ca_ES@valencia UTF-8
+ca_FR.UTF-8 UTF-8
+ca_FR ISO-8859-15
+ca_IT.UTF-8 UTF-8
+ca_IT ISO-8859-15
+ce_RU UTF-8
+chr_US UTF-8
+cmn_TW UTF-8
+crh_UA UTF-8
+cs_CZ.UTF-8 UTF-8
+cs_CZ ISO-8859-2
+csb_PL UTF-8
+cv_RU UTF-8
+cy_GB.UTF-8 UTF-8
+cy_GB ISO-8859-14
+da_DK.UTF-8 UTF-8
+da_DK ISO-8859-1
+de_AT.UTF-8 UTF-8
+de_AT ISO-8859-1
+de_AT@euro ISO-8859-15
+de_BE.UTF-8 UTF-8
+de_BE ISO-8859-1
+de_BE@euro ISO-8859-15
+de_CH.UTF-8 UTF-8
+de_CH ISO-8859-1
+de_DE.UTF-8 UTF-8
+de_DE ISO-8859-1
+de_DE@euro ISO-8859-15
+de_IT.UTF-8 UTF-8
+de_IT ISO-8859-1
+de_LI.UTF-8 UTF-8
+de_LU.UTF-8 UTF-8
+de_LU ISO-8859-1
+de_LU@euro ISO-8859-15
+doi_IN UTF-8
+dv_MV UTF-8
+dz_BT UTF-8
+el_GR.UTF-8 UTF-8
+el_GR ISO-8859-7
+el_GR@euro ISO-8859-7
+el_CY.UTF-8 UTF-8
+el_CY ISO-8859-7
+en_AG UTF-8
+en_AU.UTF-8 UTF-8
+en_AU ISO-8859-1
+en_BW.UTF-8 UTF-8
+en_BW ISO-8859-1
+en_CA.UTF-8 UTF-8
+en_CA ISO-8859-1
+en_DK.UTF-8 UTF-8
+en_DK ISO-8859-1
+en_GB.UTF-8 UTF-8
+en_GB ISO-8859-1
+en_HK.UTF-8 UTF-8
+en_HK ISO-8859-1
+en_IE.UTF-8 UTF-8
+en_IE ISO-8859-1
+en_IE@euro ISO-8859-15
+en_IL UTF-8
+en_IN UTF-8
+en_NG UTF-8
+en_NZ.UTF-8 UTF-8
+en_NZ ISO-8859-1
+en_PH.UTF-8 UTF-8
+en_PH ISO-8859-1
+en_SC.UTF-8 UTF-8
+en_SG.UTF-8 UTF-8
+en_SG ISO-8859-1
+en_US.UTF-8 UTF-8
+en_US ISO-8859-1
+en_ZA.UTF-8 UTF-8
+en_ZA ISO-8859-1
+en_ZM UTF-8
+en_ZW.UTF-8 UTF-8
+en_ZW ISO-8859-1
+eo UTF-8
+es_AR.UTF-8 UTF-8
+es_AR ISO-8859-1
+es_BO.UTF-8 UTF-8
+es_BO ISO-8859-1
+es_CL.UTF-8 UTF-8
+es_CL ISO-8859-1
+es_CO.UTF-8 UTF-8
+es_CO ISO-8859-1
+es_CR.UTF-8 UTF-8
+es_CR ISO-8859-1
+es_CU UTF-8
+es_DO.UTF-8 UTF-8
+es_DO ISO-8859-1
+es_EC.UTF-8 UTF-8
+es_EC ISO-8859-1
+es_ES.UTF-8 UTF-8
+es_ES ISO-8859-1
+es_ES@euro ISO-8859-15
+es_GT.UTF-8 UTF-8
+es_GT ISO-8859-1
+es_HN.UTF-8 UTF-8
+es_HN ISO-8859-1
+es_MX.UTF-8 UTF-8
+es_MX ISO-8859-1
+es_NI.UTF-8 UTF-8
+es_NI ISO-8859-1
+es_PA.UTF-8 UTF-8
+es_PA ISO-8859-1
+es_PE.UTF-8 UTF-8
+es_PE ISO-8859-1
+es_PR.UTF-8 UTF-8
+es_PR ISO-8859-1
+es_PY.UTF-8 UTF-8
+es_PY ISO-8859-1
+es_SV.UTF-8 UTF-8
+es_SV ISO-8859-1
+es_US.UTF-8 UTF-8
+es_US ISO-8859-1
+es_UY.UTF-8 UTF-8
+es_UY ISO-8859-1
+es_VE.UTF-8 UTF-8
+es_VE ISO-8859-1
+et_EE.UTF-8 UTF-8
+et_EE ISO-8859-1
+et_EE.ISO-8859-15 ISO-8859-15
+eu_ES.UTF-8 UTF-8
+eu_ES ISO-8859-1
+eu_ES@euro ISO-8859-15
+fa_IR UTF-8
+ff_SN UTF-8
+fi_FI.UTF-8 UTF-8
+fi_FI ISO-8859-1
+fi_FI@euro ISO-8859-15
+fil_PH UTF-8
+fo_FO.UTF-8 UTF-8
+fo_FO ISO-8859-1
+fr_BE.UTF-8 UTF-8
+fr_BE ISO-8859-1
+fr_BE@euro ISO-8859-15
+fr_CA.UTF-8 UTF-8
+fr_CA ISO-8859-1
+fr_CH.UTF-8 UTF-8
+fr_CH ISO-8859-1
+fr_FR.UTF-8 UTF-8
+fr_FR ISO-8859-1
+fr_FR@euro ISO-8859-15
+fr_LU.UTF-8 UTF-8
+fr_LU ISO-8859-1
+fr_LU@euro ISO-8859-15
+fur_IT UTF-8
+fy_NL UTF-8
+fy_DE UTF-8
+ga_IE.UTF-8 UTF-8
+ga_IE ISO-8859-1
+ga_IE@euro ISO-8859-15
+gd_GB.UTF-8 UTF-8
+gd_GB ISO-8859-15
+gez_ER UTF-8
+gez_ER@abegede UTF-8
+gez_ET UTF-8
+gez_ET@abegede UTF-8
+gl_ES.UTF-8 UTF-8
+gl_ES ISO-8859-1
+gl_ES@euro ISO-8859-15
+gu_IN UTF-8
+gv_GB.UTF-8 UTF-8
+gv_GB ISO-8859-1
+ha_NG UTF-8
+hak_TW UTF-8
+he_IL.UTF-8 UTF-8
+he_IL ISO-8859-8
+hi_IN UTF-8
+hif_FJ UTF-8
+hne_IN UTF-8
+hr_HR.UTF-8 UTF-8
+hr_HR ISO-8859-2
+hsb_DE ISO-8859-2
+hsb_DE.UTF-8 UTF-8
+ht_HT UTF-8
+hu_HU.UTF-8 UTF-8
+hu_HU ISO-8859-2
+hy_AM UTF-8
+hy_AM.ARMSCII-8 ARMSCII-8
+ia_FR UTF-8
+id_ID.UTF-8 UTF-8
+id_ID ISO-8859-1
+ig_NG UTF-8
+ik_CA UTF-8
+is_IS.UTF-8 UTF-8
+is_IS ISO-8859-1
+it_CH.UTF-8 UTF-8
+it_CH ISO-8859-1
+it_IT.UTF-8 UTF-8
+it_IT ISO-8859-1
+it_IT@euro ISO-8859-15
+iu_CA UTF-8
+ja_JP.EUC-JP EUC-JP
+ja_JP.UTF-8 UTF-8
+ka_GE.UTF-8 UTF-8
+ka_GE GEORGIAN-PS
+kab_DZ UTF-8
+kk_KZ.UTF-8 UTF-8
+kk_KZ PT154
+kl_GL.UTF-8 UTF-8
+kl_GL ISO-8859-1
+km_KH UTF-8
+kn_IN UTF-8
+ko_KR.EUC-KR EUC-KR
+ko_KR.UTF-8 UTF-8
+kok_IN UTF-8
+ks_IN UTF-8
+ks_IN@devanagari UTF-8
+ku_TR.UTF-8 UTF-8
+ku_TR ISO-8859-9
+kw_GB.UTF-8 UTF-8
+kw_GB ISO-8859-1
+ky_KG UTF-8
+lb_LU UTF-8
+lg_UG.UTF-8 UTF-8
+lg_UG ISO-8859-10
+li_BE UTF-8
+li_NL UTF-8
+lij_IT UTF-8
+ln_CD UTF-8
+lo_LA UTF-8
+lt_LT.UTF-8 UTF-8
+lt_LT ISO-8859-13
+lv_LV.UTF-8 UTF-8
+lv_LV ISO-8859-13
+lzh_TW UTF-8
+mag_IN UTF-8
+mai_IN UTF-8
+mai_NP UTF-8
+mfe_MU UTF-8
+mg_MG.UTF-8 UTF-8
+mg_MG ISO-8859-15
+mhr_RU UTF-8
+mi_NZ.UTF-8 UTF-8
+mi_NZ ISO-8859-13
+miq_NI UTF-8
+mjw_IN UTF-8
+mk_MK.UTF-8 UTF-8
+mk_MK ISO-8859-5
+ml_IN UTF-8
+mn_MN UTF-8
+mni_IN UTF-8
+mr_IN UTF-8
+ms_MY.UTF-8 UTF-8
+ms_MY ISO-8859-1
+mt_MT.UTF-8 UTF-8
+mt_MT ISO-8859-3
+my_MM UTF-8
+nan_TW UTF-8
+nan_TW@latin UTF-8
+nb_NO.UTF-8 UTF-8
+nb_NO ISO-8859-1
+nds_DE UTF-8
+nds_NL UTF-8
+ne_NP UTF-8
+nhn_MX UTF-8
+niu_NU UTF-8
+niu_NZ UTF-8
+nl_AW UTF-8
+nl_BE.UTF-8 UTF-8
+nl_BE ISO-8859-1
+nl_BE@euro ISO-8859-15
+nl_NL.UTF-8 UTF-8
+nl_NL ISO-8859-1
+nl_NL@euro ISO-8859-15
+nn_NO.UTF-8 UTF-8
+nn_NO ISO-8859-1
+nr_ZA UTF-8
+nso_ZA UTF-8
+oc_FR.UTF-8 UTF-8
+oc_FR ISO-8859-1
+om_ET UTF-8
+om_KE.UTF-8 UTF-8
+om_KE ISO-8859-1
+or_IN UTF-8
+os_RU UTF-8
+pa_IN UTF-8
+pa_PK UTF-8
+pap_AW UTF-8
+pap_CW UTF-8
+pl_PL.UTF-8 UTF-8
+pl_PL ISO-8859-2
+ps_AF UTF-8
+pt_BR.UTF-8 UTF-8
+pt_BR ISO-8859-1
+pt_PT.UTF-8 UTF-8
+pt_PT ISO-8859-1
+pt_PT@euro ISO-8859-15
+quz_PE UTF-8
+raj_IN UTF-8
+ro_RO.UTF-8 UTF-8
+ro_RO ISO-8859-2
+ru_RU.KOI8-R KOI8-R
+ru_RU.UTF-8 UTF-8
+ru_RU ISO-8859-5
+ru_UA.UTF-8 UTF-8
+ru_UA KOI8-U
+rw_RW UTF-8
+sa_IN UTF-8
+sat_IN UTF-8
+sc_IT UTF-8
+sd_IN UTF-8
+sd_IN@devanagari UTF-8
+se_NO UTF-8
+sgs_LT UTF-8
+shn_MM UTF-8
+shs_CA UTF-8
+si_LK UTF-8
+sid_ET UTF-8
+sk_SK.UTF-8 UTF-8
+sk_SK ISO-8859-2
+sl_SI.UTF-8 UTF-8
+sl_SI ISO-8859-2
+sm_WS UTF-8
+so_DJ.UTF-8 UTF-8
+so_DJ ISO-8859-1
+so_ET UTF-8
+so_KE.UTF-8 UTF-8
+so_KE ISO-8859-1
+so_SO.UTF-8 UTF-8
+so_SO ISO-8859-1
+sq_AL.UTF-8 UTF-8
+sq_AL ISO-8859-1
+sq_MK UTF-8
+sr_ME UTF-8
+sr_RS UTF-8
+sr_RS@latin UTF-8
+ss_ZA UTF-8
+st_ZA.UTF-8 UTF-8
+st_ZA ISO-8859-1
+sv_FI.UTF-8 UTF-8
+sv_FI ISO-8859-1
+sv_FI@euro ISO-8859-15
+sv_SE.UTF-8 UTF-8
+sv_SE ISO-8859-1
+sw_KE UTF-8
+sw_TZ UTF-8
+szl_PL UTF-8
+ta_IN UTF-8
+ta_LK UTF-8
+tcy_IN.UTF-8 UTF-8
+te_IN UTF-8
+tg_TJ.UTF-8 UTF-8
+tg_TJ KOI8-T
+th_TH.UTF-8 UTF-8
+th_TH TIS-620
+the_NP UTF-8
+ti_ER UTF-8
+ti_ET UTF-8
+tig_ER UTF-8
+tk_TM UTF-8
+tl_PH.UTF-8 UTF-8
+tl_PH ISO-8859-1
+tn_ZA UTF-8
+to_TO UTF-8
+tpi_PG UTF-8
+tr_CY.UTF-8 UTF-8
+tr_CY ISO-8859-9
+tr_TR.UTF-8 UTF-8
+tr_TR ISO-8859-9
+ts_ZA UTF-8
+tt_RU UTF-8
+tt_RU@iqtelif UTF-8
+ug_CN UTF-8
+uk_UA.UTF-8 UTF-8
+uk_UA KOI8-U
+unm_US UTF-8
+ur_IN UTF-8
+ur_PK UTF-8
+uz_UZ.UTF-8 UTF-8
+uz_UZ ISO-8859-1
+uz_UZ@cyrillic UTF-8
+ve_ZA UTF-8
+vi_VN UTF-8
+wa_BE ISO-8859-1
+wa_BE@euro ISO-8859-15
+wa_BE.UTF-8 UTF-8
+wae_CH UTF-8
+wal_ET UTF-8
+wo_SN UTF-8
+xh_ZA.UTF-8 UTF-8
+xh_ZA ISO-8859-1
+yi_US.UTF-8 UTF-8
+yi_US CP1255
+yo_NG UTF-8
+yue_HK UTF-8
+yuw_PG UTF-8
+zh_CN.GB18030 GB18030
+zh_CN.GBK GBK
+zh_CN.UTF-8 UTF-8
+zh_CN GB2312
+zh_HK.UTF-8 UTF-8
+zh_HK BIG5-HKSCS
+zh_SG.UTF-8 UTF-8
+zh_SG.GBK GBK
+zh_SG GB2312
+zh_TW.EUC-TW EUC-TW
+zh_TW.UTF-8 UTF-8
+zh_TW BIG5
+zu_ZA.UTF-8 UTF-8
+zu_ZA ISO-8859-1

gnu/installer/aux-files/logo.txt

@@ -0,0 +1,19 @@
+ ░░░                                     ░░░
+ ░░▒▒░░░░░░░░░               ░░░░░░░░░▒▒░░
+  ░░▒▒▒▒▒░░░░░░░           ░░░░░░░▒▒▒▒▒░
+      ░▒▒▒░░▒▒▒▒▒         ░░░░░░░▒▒░
+            ░▒▒▒▒░       ░░░░░░
+             ▒▒▒▒▒      ░░░░░░
+              ▒▒▒▒▒     ░░░░░
+              ░▒▒▒▒▒   ░░░░░
+               ▒▒▒▒▒   ░░░░░
+                ▒▒▒▒▒ ░░░░░
+                ░▒▒▒▒▒░░░░░
+                 ▒▒▒▒▒▒░░░
+                  ▒▒▒▒▒▒░
+  _____ _   _ _    _    _____       _
+ / ____| \ | | |  | |  / ____|     (_)
+| |  __|  \| | |  | | | |  __ _   _ ___  __
+| | |_ | . ' | |  | | | | |_ | | | | \ \/ /
+| |__| | |\  | |__| | | |__| | |_| | |>  <
+ \_____|_| \_|\____/   \_____|\__,_|_/_/\_\

gnu/installer/connman.scm

@@ -0,0 +1,400 @@
+;;; 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 connman)
+  #:use-module (gnu installer utils)
+  #:use-module (guix records)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 regex)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:export (<technology>
+            technology
+            technology?
+            technology-name
+            technology-type
+            technology-powered?
+            technology-connected?
+
+            <service>
+            service
+            service?
+            service-name
+            service-type
+            service-path
+            service-strength
+            service-state
+
+            &connman-error
+            connman-error?
+            connman-error-command
+            connman-error-output
+            connman-error-status
+
+            &connman-connection-error
+            connman-connection-error?
+            connman-connection-error-service
+            connman-connection-error-output
+
+            &connman-password-error
+            connman-password-error?
+
+            &connman-already-connected-error
+            connman-already-connected-error?
+
+            connman-state
+            connman-technologies
+            connman-enable-technology
+            connman-disable-technology
+            connman-scan-technology
+            connman-services
+            connman-connect
+            connman-disconnect
+            connman-online?
+            connman-connect-with-auth))
+
+;;; Commentary:
+;;;
+;;; This module provides procedures for talking with the connman daemon.
+;;; The best approach would have been using connman dbus interface.
+;;; However, as Guile dbus bindings are not available yet, the console client
+;;; "connmanctl" is used to talk with the daemon.
+;;;
+
+
+;;;
+;;; Technology record.
+;;;
+
+;; The <technology> record encapsulates the "Technology" object of connman.
+;; Technology type will be typically "ethernet", "wifi" or "bluetooth".
+
+(define-record-type* <technology>
+  technology make-technology
+  technology?
+  (name            technology-name) ; string
+  (type            technology-type) ; string
+  (powered?        technology-powered?) ; boolean
+  (connected?      technology-connected?)) ; boolean
+
+
+;;;
+;;; Service record.
+;;;
+
+;; The <service> record encapsulates the "Service" object of connman.
+;; Service type is the same as the technology it is associated to, path is a
+;; unique identifier given by connman, strength describes the signal quality
+;; if applicable. Finally, state is "idle", "failure", "association",
+;; "configuration", "ready", "disconnect" or "online".
+
+(define-record-type* <service>
+  service make-service
+  service?
+  (name            service-name) ; string
+  (type            service-type) ; string
+  (path            service-path) ; string
+  (strength        service-strength) ; integer
+  (state           service-state)) ; string
+
+
+;;;
+;;; Condition types.
+;;;
+
+(define-condition-type &connman-error &error
+  connman-error?
+  (command connman-error-command)
+  (output connman-error-output)
+  (status connman-error-status))
+
+(define-condition-type &connman-connection-error &error
+  connman-connection-error?
+  (service connman-connection-error-service)
+  (output  connman-connection-error-output))
+
+(define-condition-type &connman-password-error &connman-connection-error
+  connman-password-error?)
+
+(define-condition-type &connman-already-connected-error
+  &connman-connection-error connman-already-connected-error?)
+
+
+;;;
+;;; Procedures.
+;;;
+
+(define (connman-run command env arguments)
+  "Run the given COMMAND, with the specified ENV and ARGUMENTS.  The error
+output is discarded and &connman-error condition is raised if the command
+returns a non zero exit code."
+  (let* ((command `("env" ,env ,command ,@arguments "2>" "/dev/null"))
+         (command-string (string-join command " "))
+         (pipe (open-input-pipe command-string))
+         (output (read-lines pipe))
+         (ret (close-pipe pipe)))
+    (case (status:exit-val ret)
+      ((0) output)
+      (else (raise (condition (&connman-error
+                               (command command)
+                               (output output)
+                               (status ret))))))))
+
+(define (connman . arguments)
+  "Run connmanctl with the specified ARGUMENTS. Set the LANG environment
+variable to C because the command output will be parsed and we don't want it
+to be translated."
+  (connman-run "connmanctl" "LANG=C" arguments))
+
+(define (parse-keys keys)
+  "Parse the given list of strings KEYS, under the following format:
+
+     '((\"KEY = VALUE\") (\"KEY2 = VALUE2\") ...)
+
+Return the corresponding association list of '((KEY . VALUE) (KEY2 . VALUE2)
+...)  elements."
+  (let ((key-regex (make-regexp "([^ ]+) = ([^$]+)")))
+    (map (lambda (key)
+           (let ((match-key (regexp-exec key-regex key)))
+             (cons (match:substring match-key 1)
+                   (match:substring match-key 2))))
+         keys)))
+
+(define (connman-state)
+  "Return the state of connman. The nominal states are 'offline, 'idle,
+'ready, 'oneline.  If an unexpected state is read, 'unknown is
+returned. Finally, an error is raised if the comman output could not be
+parsed, usually because the connman daemon is not responding."
+  (let* ((output (connman "state"))
+         (state-keys (parse-keys output)))
+    (let ((state (assoc-ref state-keys "State")))
+      (if state
+          (cond ((string=? state "offline") 'offline)
+                ((string=? state "idle") 'idle)
+                ((string=? state "ready") 'ready)
+                ((string=? state "online") 'online)
+                (else 'unknown))
+          (raise (condition
+                  (&message
+                   (message "Could not determine the state of connman."))))))))
+
+(define (split-technology-list technologies)
+  "Parse the given strings list TECHNOLOGIES, under the following format:
+
+	'((\"/net/connman/technology/xxx\")
+          (\"KEY = VALUE\")
+          ...
+          (\"/net/connman/technology/yyy\")
+          (\"KEY2 = VALUE2\")
+          ...)
+ Return the corresponding '(((\"KEY = VALUE\") ...) ((\"KEY2 = VALUE2\") ...))
+list so that each keys of a given technology are gathered in a separate list."
+  (let loop ((result '())
+             (cur-list '())
+             (input (reverse technologies)))
+    (if (null? input)
+        result
+        (let ((item (car input)))
+          (if (string-match "/net/connman/technology" item)
+              (loop (cons cur-list result) '() (cdr input))
+              (loop result (cons item cur-list) (cdr input)))))))
+
+(define (string->boolean string)
+  (equal? string "True"))
+
+(define (connman-technologies)
+  "Return a list of available <technology> records."
+
+  (define (technology-output->technology output)
+    (let ((keys (parse-keys output)))
+      (technology
+       (name (assoc-ref keys "Name"))
+       (type (assoc-ref keys "Type"))
+       (powered? (string->boolean (assoc-ref keys "Powered")))
+       (connected? (string->boolean (assoc-ref keys "Connected"))))))
+
+  (let* ((output (connman "technologies"))
+         (technologies (split-technology-list output)))
+    (map technology-output->technology technologies)))
+
+(define (connman-enable-technology technology)
+  "Enable the given TECHNOLOGY."
+  (let ((type (technology-type technology)))
+    (connman "enable" type)))
+
+(define (connman-disable-technology technology)
+  "Disable the given TECHNOLOGY."
+  (let ((type (technology-type technology)))
+    (connman "disable" type)))
+
+(define (connman-scan-technology technology)
+  "Run a scan for the given TECHNOLOGY."
+  (let ((type (technology-type technology)))
+    (connman "scan" type)))
+
+(define (connman-services)
+  "Return a list of available <services> records."
+
+  (define (service-output->service path output)
+    (let* ((service-keys
+            (match output
+              ((_ . rest) rest)))
+           (keys (parse-keys service-keys)))
+      (service
+       (name (assoc-ref keys "Name"))
+       (type (assoc-ref keys "Type"))
+       (path path)
+       (strength (and=> (assoc-ref keys "Strength") string->number))
+       (state (assoc-ref keys "State")))))
+
+  (let* ((out (connman "services"))
+         (out-filtered (delete "" out))
+         (services-path (map (lambda (service)
+                               (match (string-split service #\ )
+                                 ((_ ... path) path)))
+                             out-filtered))
+         (services-output (map (lambda (service)
+                                 (connman "services" service))
+                               services-path)))
+    (map service-output->service services-path services-output)))
+
+(define (connman-connect service)
+  "Connect to the given SERVICE."
+  (let ((path (service-path service)))
+    (connman "connect" path)))
+
+(define (connman-disconnect service)
+  "Disconnect from the given SERVICE."
+  (let ((path (service-path service)))
+    (connman "disconnect" path)))
+
+(define (connman-online?)
+  (let ((state (connman-state)))
+    (eq? state 'online)))
+
+(define (connman-connect-with-auth service password-proc)
+  "Connect to the given SERVICE with the password returned by calling
+PASSWORD-PROC. This is only possible in the interactive mode of connmanctl
+because authentication is done by communicating with an agent.
+
+As the open-pipe procedure of Guile do not allow to read from stderr, we have
+to merge stdout and stderr using bash redirection. Then error messages are
+extracted from connmanctl output using a regexp. This makes the whole
+procedure even more unreliable.
+
+Raise &connman-connection-error if an error occured during connection. Raise
+&connman-password-error if the given password is incorrect."
+
+  (define connman-error-regexp (make-regexp "Error[ ]*([^\n]+)\n"))
+
+  (define (match-connman-error str)
+    (let ((match-error (regexp-exec connman-error-regexp str)))
+      (and match-error (match:substring match-error 1))))
+
+  (define* (read-regexps-or-error port regexps error-handler)
+    "Read characters from port until an error is detected, or one of the given
+REGEXPS is matched. If an error is detected, call ERROR-HANDLER with the error
+string as argument. Raise an error if the eof is reached before one of the
+regexps is matched."
+    (let loop ((res ""))
+      (let ((char (read-char port)))
+        (cond
+         ((eof-object? char)
+          (raise (condition
+                  (&message
+                   (message "Unable to find expected regexp.")))))
+         ((match-connman-error res)
+          =>
+          (lambda (match)
+            (error-handler match)))
+         ((or-map (lambda (regexp)
+                    (and (regexp-exec regexp res) regexp))
+                  regexps)
+          =>
+          (lambda (match)
+            match))
+         (else
+          (loop (string-append res (string char))))))))
+
+  (define* (read-regexp-or-error port regexp error-handler)
+    "Same as READ-REGEXPS-OR-ERROR above, but with a single REGEXP."
+    (read-regexps-or-error port (list regexp) error-handler))
+
+  (define (connman-error->condition path error)
+    (cond
+     ((string-match "Already connected" error)
+      (condition (&connman-already-connected-error
+                  (service path)
+                  (output error))))
+     (else
+      (condition (&connman-connection-error
+                  (service path)
+                  (output error))))))
+
+  (define (run-connection-sequence pipe)
+    "Run the connection sequence using PIPE as an opened port to an
+interactive connmanctl process."
+    (let* ((path (service-path service))
+           (error-handler (lambda (error)
+                            (raise
+                             (connman-error->condition path error)))))
+      ;; Start the agent.
+      (format pipe "agent on\n")
+      (read-regexp-or-error pipe (make-regexp "Agent registered") error-handler)
+
+      ;; Let's try to connect to the service. If the service does not require
+      ;; a password, the connection might succeed right after this call.
+      ;; Otherwise, connmanctl will prompt us for a password.
+      (format pipe "connect ~a\n" path)
+      (let* ((connected-regexp (make-regexp (format #f "Connected ~a" path)))
+             (passphrase-regexp (make-regexp "\nPassphrase\\?[ ]*"))
+             (regexps (list connected-regexp passphrase-regexp))
+             (result (read-regexps-or-error pipe regexps error-handler)))
+
+        ;; A password is required.
+        (when (eq? result passphrase-regexp)
+          (format pipe "~a~%" (password-proc))
+
+          ;; Now, we have to wait for the connection to succeed. If an error
+          ;; occurs, it is most likely because the password is incorrect.
+          ;; In that case, we escape from an eventual retry loop that would
+          ;; add complexity to this procedure, and raise a
+          ;; &connman-password-error condition.
+          (read-regexp-or-error pipe connected-regexp
+                                (lambda (error)
+                                  ;; Escape from retry loop.
+                                  (format pipe "no\n")
+                                  (raise
+                                   (condition (&connman-password-error
+                                               (service path)
+                                               (output error))))))))))
+
+  ;; XXX: Find a better way to read stderr, like with the "subprocess"
+  ;; procedure of racket that return input ports piped on the process stdin and
+  ;; stderr.
+  (let ((pipe (open-pipe "connmanctl 2>&1" OPEN_BOTH)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (run-connection-sequence pipe)
+        #t)
+      (lambda ()
+        (format pipe "quit\n")
+        (close-pipe pipe)))))

gnu/installer/final.scm

@@ -0,0 +1,36 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer final)
+  #:use-module (gnu installer newt page)
+  #:use-module (gnu installer steps)
+  #:use-module (gnu installer utils)
+  #:use-module (gnu services herd)
+  #:use-module (guix build utils)
+  #:export (install-system))
+
+(define (install-system)
+  "Start COW-STORE service on target directory and launch guix install command
+in a subshell."
+  (let ((install-command
+         (format #f "guix system init ~a ~a"
+                 (%installer-configuration-file)
+                 (%installer-target-dir))))
+    (mkdir-p (%installer-target-dir))
+    (start-service 'cow-store (list (%installer-target-dir)))
+    (false-if-exception (run-shell-command install-command))))

gnu/installer/hostname.scm

@@ -0,0 +1,23 @@
+;;; 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 hostname)
+  #:export (hostname->configuration))
+
+(define (hostname->configuration hostname)
+  `((host-name ,hostname)))

gnu/installer/keymap.scm

@@ -0,0 +1,172 @@
+;;; 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
+
+            default-keyboard-model
+            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
+
+;; 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
+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)
+  "Update kmscon keymap with the provided MODEL, LAYOUT and VARIANT."
+  (and=>
+   (getenv "KEYMAP_UPDATE")
+   (lambda (keymap-file)
+     (unless (file-exists? keymap-file)
+       (error "Unable to locate keymap update file"))
+
+     ;; See file gnu/packages/patches/kmscon-runtime-keymap-switch.patch.
+     ;; This dirty hack makes possible to update kmscon keymap at runtime by
+     ;; writing an X11 keyboard model, layout and variant to a named pipe
+     ;; referred by KEYMAP_UPDATE environment variable.
+     (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))))))

gnu/installer/locale.scm

@@ -0,0 +1,210 @@
+;;; 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 locale)
+  #:use-module (gnu installer utils)
+  #:use-module (guix records)
+  #:use-module (json)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:export (locale-language
+            locale-territory
+            locale-codeset
+            locale-modifier
+
+            locale->locale-string
+            supported-locales->locales
+
+            iso639->iso639-languages
+            language-code->language-name
+
+            iso3166->iso3166-territories
+            territory-code->territory-name
+
+            locale->configuration))
+
+
+;;;
+;;; Locale.
+;;;
+
+;; A glibc locale string has the following format:
+;; language[_territory[.codeset][@modifier]].
+(define locale-regexp "^([^_@]+)(_([^\\.@]+))?(\\.([^@]+))?(@([^$]+))?$")
+
+;; LOCALE will be better expressed in a (guix record) that in an association
+;; list. However, loading large files containing records does not scale
+;; well. The same thing goes for ISO639 and ISO3166 association lists used
+;; later in this module.
+(define (locale-language assoc)
+  (assoc-ref assoc 'language))
+(define (locale-territory assoc)
+  (assoc-ref assoc 'territory))
+(define (locale-codeset assoc)
+  (assoc-ref assoc 'codeset))
+(define (locale-modifier assoc)
+  (assoc-ref assoc 'modifier))
+
+(define (locale-string->locale string)
+  "Return the locale association list built from the parsing of STRING."
+  (let ((matches (string-match locale-regexp string)))
+    `((language  . ,(match:substring matches 1))
+      (territory . ,(match:substring matches 3))
+      (codeset   . ,(match:substring matches 5))
+      (modifier  . ,(match:substring matches 7)))))
+
+(define (locale->locale-string locale)
+  "Reverse operation of locale-string->locale."
+  (let ((language (locale-language locale))
+        (territory (locale-territory locale))
+        (codeset (locale-codeset locale))
+        (modifier (locale-modifier locale)))
+    (apply string-append
+           `(,language
+             ,@(if territory
+                   `("_" ,territory)
+                   '())
+             ,@(if codeset
+                   `("." ,codeset)
+                   '())
+             ,@(if modifier
+                   `("@" ,modifier)
+                   '())))))
+
+(define (supported-locales->locales supported-locales)
+  "Parse the SUPPORTED-LOCALES file from the glibc and return the matching
+list of LOCALE association lists."
+ (call-with-input-file supported-locales
+    (lambda (port)
+      (let ((lines (read-lines port)))
+        (map (lambda (line)
+               (match (string-split line #\ )
+                 ((locale-string codeset)
+                  (let ((line-locale (locale-string->locale locale-string)))
+                    (assoc-set! line-locale 'codeset codeset)))))
+             lines)))))
+
+
+;;;
+;;; Language.
+;;;
+
+(define (iso639-language-alpha2 assoc)
+  (assoc-ref assoc 'alpha2))
+
+(define (iso639-language-alpha3 assoc)
+  (assoc-ref assoc 'alpha3))
+
+(define (iso639-language-name assoc)
+  (assoc-ref assoc 'name))
+
+(define (supported-locale? locales alpha2 alpha3)
+  "Find a locale in LOCALES whose alpha2 field matches ALPHA-2 or alpha3 field
+matches ALPHA-3. The ISO639 standard specifies that ALPHA-2 is optional. Thus,
+if ALPHA-2 is #f, only consider ALPHA-3. Return #f if not matching locale was
+found."
+  (find (lambda (locale)
+          (let ((language (locale-language locale)))
+            (or (and=> alpha2
+                       (lambda (code)
+                         (string=? language code)))
+                (string=? language alpha3))))
+        locales))
+
+(define (iso639->iso639-languages locales iso639-3 iso639-5)
+  "Return a list of ISO639 association lists created from the parsing of
+ISO639-3 and ISO639-5 files."
+  (call-with-input-file iso639-3
+    (lambda (port-iso639-3)
+      (call-with-input-file iso639-5
+        (lambda (port-iso639-5)
+          (filter-map
+           (lambda (hash)
+             (let ((alpha2 (hash-ref hash "alpha_2"))
+                   (alpha3 (hash-ref hash "alpha_3"))
+                   (name   (hash-ref hash "name")))
+               (and (supported-locale? locales alpha2 alpha3)
+                    `((alpha2 . ,alpha2)
+                      (alpha3 . ,alpha3)
+                      (name   . ,name)))))
+           (append
+            (hash-ref (json->scm port-iso639-3) "639-3")
+            (hash-ref (json->scm port-iso639-5) "639-5"))))))))
+
+(define (language-code->language-name languages language-code)
+  "Using LANGUAGES as a list of ISO639 association lists, return the language
+name corresponding to the given LANGUAGE-CODE."
+  (let ((iso639-language
+         (find (lambda (language)
+                 (or
+                  (and=> (iso639-language-alpha2 language)
+                         (lambda (alpha2)
+                           (string=? alpha2 language-code)))
+                  (string=? (iso639-language-alpha3 language)
+                            language-code)))
+               languages)))
+    (iso639-language-name iso639-language)))
+
+
+;;;
+;;; Territory.
+;;;
+
+(define (iso3166-territory-alpha2 assoc)
+  (assoc-ref assoc 'alpha2))
+
+(define (iso3166-territory-alpha3 assoc)
+  (assoc-ref assoc 'alpha3))
+
+(define (iso3166-territory-name assoc)
+  (assoc-ref assoc 'name))
+
+(define (iso3166->iso3166-territories iso3166)
+  "Return a list of ISO3166 association lists created from the parsing of
+ISO3166 file."
+  (call-with-input-file iso3166
+    (lambda (port)
+      (map (lambda (hash)
+             `((alpha2 . ,(hash-ref hash "alpha_2"))
+               (alpha3 . ,(hash-ref hash "alpha_3"))
+               (name   . ,(hash-ref hash "name"))))
+           (hash-ref (json->scm port) "3166-1")))))
+
+(define (territory-code->territory-name territories territory-code)
+  "Using TERRITORIES as a list of ISO3166 association lists return the
+territory name corresponding to the given TERRITORY-CODE."
+  (let ((iso3166-territory
+         (find (lambda (territory)
+                 (or
+                  (and=> (iso3166-territory-alpha2 territory)
+                         (lambda (alpha2)
+                           (string=? alpha2 territory-code)))
+                  (string=? (iso3166-territory-alpha3 territory)
+                            territory-code)))
+               territories)))
+    (iso3166-territory-name iso3166-territory)))
+
+
+;;;
+;;; Configuration formatter.
+;;;
+
+(define (locale->configuration locale)
+  "Return the configuration field for LOCALE."
+  `((locale ,locale)))

gnu/installer/newt.scm

@@ -0,0 +1,128 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt)
+  #: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)
+  #: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 page)
+  #:use-module (gnu installer newt partition)
+  #:use-module (gnu installer newt services)
+  #: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 config)
+  #:use-module (guix discovery)
+  #:use-module (guix i18n)
+  #:use-module (srfi srfi-26)
+  #:use-module (newt)
+  #:export (newt-installer))
+
+(define (init)
+  (newt-init)
+  (clear-screen)
+  (set-screen-size!))
+
+(define (exit)
+  (newt-finish)
+  (clear-screen))
+
+(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)
+  (clear-screen))
+
+(define (final-page result prev-steps)
+  (run-final-page result prev-steps))
+
+(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 (timezone-page zonetab)
+  (run-timezone-page zonetab))
+
+(define (welcome-page logo)
+  (run-welcome-page logo))
+
+(define (menu-page steps)
+  (run-menu-page steps))
+
+(define* (keymap-page layouts)
+  (run-keymap-page layouts))
+
+(define (network-page)
+  (run-network-page))
+
+(define (hostname-page)
+  (run-hostname-page))
+
+(define (user-page)
+  (run-user-page))
+
+(define (partition-page)
+  (run-partioning-page))
+
+(define (services-page)
+  (run-services-page))
+
+(define newt-installer
+  (installer
+   (name 'newt)
+   (init init)
+   (exit exit)
+   (exit-error exit-error)
+   (final-page final-page)
+   (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)
+   (partition-page partition-page)
+   (services-page services-page)
+   (welcome-page welcome-page)))

gnu/installer/newt/ethernet.scm

@@ -0,0 +1,81 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt ethernet)
+  #:use-module (gnu installer connman)
+  #:use-module (gnu installer steps)
+  #:use-module (gnu installer newt utils)
+  #:use-module (gnu installer newt page)
+  #:use-module (guix i18n)
+  #:use-module (ice-9 format)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (newt)
+  #:export (run-ethernet-page))
+
+(define (ethernet-services)
+  "Return all the connman services of ethernet type."
+  (let ((services (connman-services)))
+    (filter (lambda (service)
+              (and (string=? (service-type service) "ethernet")
+                   (not (string-null? (service-name service)))))
+            services)))
+
+(define (ethernet-service->text service)
+  "Return a string describing the given ethernet SERVICE."
+  (let* ((name (service-name service))
+         (path (service-path service))
+         (full-name (string-append name "-" path))
+         (state (service-state service))
+         (connected? (or (string=? state "online")
+                         (string=? state "ready"))))
+    (format #f "~c ~a~%"
+            (if connected? #\* #\ )
+            full-name)))
+
+(define (connect-ethernet-service service)
+  "Connect to the given ethernet SERVICE. Display a connecting page while the
+connection is pending."
+  (let* ((service-name (service-name service))
+         (form (draw-connecting-page service-name)))
+    (connman-connect service)
+    (destroy-form-and-pop form)
+    service))
+
+(define (run-ethernet-page)
+  (let ((services (ethernet-services)))
+    (if (null? services)
+        (begin
+          (run-error-page
+           (G_ "No ethernet service available, please try again.")
+           (G_ "No service"))
+          (raise
+           (condition
+            (&installer-step-abort))))
+        (run-listbox-selection-page
+         #:info-text (G_ "Please select an ethernet network.")
+         #:title (G_ "Ethernet connection")
+         #:listbox-items services
+         #:listbox-item->text ethernet-service->text
+         #:button-text (G_ "Exit")
+         #:button-callback-procedure
+         (lambda _
+           (raise
+            (condition
+             (&installer-step-abort))))
+         #:listbox-callback-procedure connect-ethernet-service))))

gnu/installer/newt/final.scm

@@ -0,0 +1,86 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt final)
+  #:use-module (gnu installer final)
+  #:use-module (gnu installer parted)
+  #:use-module (gnu installer steps)
+  #:use-module (gnu installer utils)
+  #:use-module (gnu installer newt page)
+  #:use-module (gnu installer newt utils)
+  #:use-module (guix i18n)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (newt)
+  #:export (run-final-page))
+
+(define (run-config-display-page)
+  (let ((width (%configuration-file-width))
+        (height (nearest-exact-integer
+                 (/ (screen-rows) 2))))
+    (run-file-textbox-page
+     #:info-text (G_ "We're now ready to proceed with the installation! \
+A system configuration file has been generated, it is displayed below.  \
+The new system will be created from this file once you've pressed OK.  \
+This will take a few minutes.")
+     #:title (G_ "Configuration file")
+     #:file (%installer-configuration-file)
+     #:info-textbox-width width
+     #:file-textbox-width width
+     #:file-textbox-height height
+     #:exit-button-callback-procedure
+     (lambda ()
+       (raise
+        (condition
+         (&installer-step-abort)))))))
+
+(define (run-install-success-page)
+  (message-window
+   (G_ "Installation complete")
+   (G_ "Reboot")
+   (G_ "Congratulations!  Installation is now complete.  \
+You may remove the device containing 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))))

gnu/installer/newt/hostname.scm

@@ -0,0 +1,26 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt hostname)
+  #:use-module (gnu installer newt page)
+  #:use-module (guix i18n)
+  #:export (run-hostname-page))
+
+(define (run-hostname-page)
+  (run-input-page (G_ "Please enter the system hostname.")
+                  (G_ "Hostname")))

gnu/installer/newt/keymap.scm

@@ -0,0 +1,122 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt keymap)
+  #:use-module (gnu installer keymap)
+  #:use-module (gnu installer steps)
+  #:use-module (gnu installer newt page)
+  #:use-module (guix i18n)
+  #:use-module (guix records)
+  #:use-module (newt)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:export (run-keymap-page))
+
+(define (run-layout-page layouts layout->text)
+  (let ((title (G_ "Layout")))
+    (run-listbox-selection-page
+     #:title title
+     #:info-text (G_ "Please choose your keyboard layout.")
+     #:listbox-items layouts
+     #:listbox-item->text layout->text
+     #:sort-listbox-items? #f
+     #:button-text (G_ "Exit")
+     #:button-callback-procedure
+     (lambda _
+       (raise
+        (condition
+         (&installer-step-abort)))))))
+
+(define (run-variant-page variants variant->text)
+  (let ((title (G_ "Variant")))
+    (run-listbox-selection-page
+     #:title title
+     #:info-text (G_ "Please choose a variant for your keyboard layout.")
+     #:listbox-items variants
+     #:listbox-item->text variant->text
+     #:sort-listbox-items? #f
+     #:button-text (G_ "Back")
+     #:button-callback-procedure
+     (lambda _
+       (raise
+        (condition
+         (&installer-step-abort)))))))
+
+(define (sort-layouts layouts)
+  "Sort LAYOUTS list by putting the US layout ahead and return it."
+  (call-with-values
+      (lambda ()
+        (partition
+         (lambda (layout)
+           (let ((name (x11-keymap-layout-name layout)))
+             (string=? name "us")))
+         layouts))
+    (cut append <> <>)))
+
+(define (sort-variants variants)
+  "Sort VARIANTS list by putting the internation variant ahead and return it."
+  (call-with-values
+      (lambda ()
+        (partition
+         (lambda (variant)
+           (let ((name (x11-keymap-variant-name variant)))
+             (string=? name "altgr-intl")))
+         variants))
+    (cut append <> <>)))
+
+(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 'layout)
+      (compute
+       (lambda _
+         (run-layout-page
+          (sort-layouts layouts)
+          (lambda (layout)
+            (x11-keymap-layout-description layout))))))
+     ;; Propose the user to select a variant among those supported by the
+     ;; previously selected layout.
+     (installer-step
+      (id 'variant)
+      (compute
+       (lambda (result _)
+         (let* ((layout (result-step result 'layout))
+                (variants (x11-keymap-layout-variants layout)))
+           ;; Return #f if the layout does not have any variant.
+           (and (not (null? variants))
+                (run-variant-page
+                 (sort-variants variants)
+                 (lambda (variant)
+                   (x11-keymap-variant-description
+                    variant))))))))))
+
+  (define (format-result result)
+    (let ((layout (x11-keymap-layout-name
+                   (result-step result 'layout)))
+          (variant (and=> (result-step result 'variant)
+                          (lambda (variant)
+                            (x11-keymap-variant-name variant)))))
+      (list layout (or variant ""))))
+  (format-result
+   (run-installer-steps #:steps keymap-steps)))

gnu/installer/newt/locale.scm

@@ -0,0 +1,217 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt locale)
+  #:use-module (gnu installer locale)
+  #:use-module (gnu installer steps)
+  #:use-module (gnu installer newt page)
+  #:use-module (guix i18n)
+  #:use-module (newt)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (ice-9 match)
+  #:export (run-locale-page))
+
+(define (run-language-page languages language->text)
+  (let ((title (G_ "Locale language")))
+    (run-listbox-selection-page
+     #:title title
+     #:info-text (G_ "Choose the locale's language to be used for the \
+installation process. A locale is a regional variant of your language \
+encompassing number, date and currency format, among other details.
+
+Based on the language you choose, you will possibly be asked to \
+select a locale's territory, codeset and modifier in the next \
+steps. The locale will also be used as the default one for the \
+installed system.")
+     #:info-textbox-width 70
+     #:listbox-items languages
+     #:listbox-item->text language->text
+     #:sort-listbox-items? #f
+     #:button-text (G_ "Exit")
+     #:button-callback-procedure
+     (lambda _
+       (raise
+        (condition
+         (&installer-step-abort)))))))
+
+(define (run-territory-page territories territory->text)
+  (let ((title (G_ "Locale location")))
+    (run-listbox-selection-page
+     #:title title
+     #:info-text (G_ "Choose your locale's location. This is a shortlist of \
+locations based on the language you selected.")
+     #:listbox-items territories
+     #:listbox-item->text territory->text
+     #:button-text (G_ "Back")
+     #:button-callback-procedure
+     (lambda _
+       (raise
+        (condition
+         (&installer-step-abort)))))))
+
+(define (run-codeset-page codesets)
+  (let ((title (G_ "Locale codeset")))
+    (run-listbox-selection-page
+     #:title title
+     #:info-text (G_ "Choose your locale's codeset. If UTF-8 is available, \
+ it should be preferred.")
+     #:listbox-items codesets
+     #:listbox-item->text identity
+     #:listbox-default-item "UTF-8"
+     #:button-text (G_ "Back")
+     #:button-callback-procedure
+     (lambda _
+       (raise
+        (condition
+         (&installer-step-abort)))))))
+
+(define (run-modifier-page modifiers modifier->text)
+  (let ((title (G_ "Locale modifier")))
+    (run-listbox-selection-page
+     #:title title
+     #:info-text (G_ "Choose your locale's modifier. The most frequent \
+modifier is euro. It indicates that you want to use Euro as the currency \
+symbol.")
+     #:listbox-items modifiers
+     #:listbox-item->text modifier->text
+     #:button-text (G_ "Back")
+     #:button-callback-procedure
+     (lambda _
+       (raise
+        (condition
+         (&installer-step-abort)))))))
+
+(define* (run-locale-page #:key
+                          supported-locales
+                          iso639-languages
+                          iso3166-territories)
+  "Run a page asking the user to select a locale language and possibly
+territory, codeset and modifier. Use SUPPORTED-LOCALES as the list of glibc
+available locales. ISO639-LANGUAGES is an association list associating a
+locale code to a locale name. ISO3166-TERRITORIES is an association list
+associating a territory code with a territory name. The formated locale, under
+glibc format is returned."
+
+  (define (break-on-locale-found locales)
+    "Raise the &installer-step-break condition if LOCALES contains exactly one
+element."
+    (and (= (length locales) 1)
+         (raise
+          (condition (&installer-step-break)))))
+
+  (define (filter-locales locales result)
+    "Filter the list of locale records LOCALES using the RESULT returned by
+the installer-steps defined below."
+    (filter
+     (lambda (locale)
+       (and-map identity
+                `(,(string=? (locale-language locale)
+                             (result-step result 'language))
+                  ,@(if (result-step-done? result 'territory)
+                        (list (equal? (locale-territory locale)
+                                      (result-step result 'territory)))
+                        '())
+                  ,@(if (result-step-done? result 'codeset)
+                        (list (equal? (locale-codeset locale)
+                                      (result-step result 'codeset)))
+                        '())
+                  ,@(if (result-step-done? result 'modifier)
+                        (list (equal? (locale-modifier locale)
+                                      (result-step result 'modifier)))
+                        '()))))
+     locales))
+
+  (define (result->locale-string locales result)
+    "Supposing that LOCALES contains exactly one locale record, turn it into a
+glibc locale string and return it."
+    (match (filter-locales locales result)
+      ((locale)
+       (locale->locale-string locale))))
+
+  (define (sort-languages languages)
+    "Extract some languages from LANGUAGES list and place them ahead."
+    (let* ((first-languages '("en"))
+           (other-languages (lset-difference equal?
+                                             languages
+                                             first-languages)))
+      `(,@first-languages ,@other-languages)))
+
+  (define locale-steps
+    (list
+     (installer-step
+      (id 'language)
+      (compute
+       (lambda _
+         (run-language-page
+          (sort-languages
+           (delete-duplicates (map locale-language supported-locales)))
+          (cut language-code->language-name iso639-languages <>)))))
+     (installer-step
+      (id 'territory)
+      (compute
+       (lambda (result _)
+         (let ((locales (filter-locales supported-locales result)))
+           ;; Stop the process if the language returned by the previous step
+           ;; is matching one and only one supported locale.
+           (break-on-locale-found locales)
+
+           ;; Otherwise, ask the user to select a territory among those
+           ;; supported by the previously selected language.
+           (run-territory-page
+            (delete-duplicates (map locale-territory locales))
+            (lambda (territory-code)
+              (if territory-code
+                  (territory-code->territory-name iso3166-territories
+                                                  territory-code)
+                  (G_ "No location"))))))))
+     (installer-step
+      (id 'codeset)
+      (compute
+       (lambda (result _)
+         (let ((locales (filter-locales supported-locales result)))
+           ;; Same as above but we now have a language and a territory to
+           ;; narrow down the search of a locale.
+           (break-on-locale-found locales)
+
+           ;; Otherwise, ask for a codeset.
+           (run-codeset-page
+            (delete-duplicates (map locale-codeset locales)))))))
+     (installer-step
+      (id 'modifier)
+      (compute
+       (lambda (result _)
+         (let ((locales (filter-locales supported-locales result)))
+           ;; Same thing with a language, a territory and a codeset this time.
+           (break-on-locale-found locales)
+
+           ;; Otherwise, ask for a modifier.
+           (run-modifier-page
+            (delete-duplicates (map locale-modifier locales))
+            (lambda (modifier)
+              (or modifier (G_ "No modifier"))))))))))
+
+  ;; If run-installer-steps returns locally, it means that the user had to go
+  ;; through all steps (language, territory, codeset and modifier) to select a
+  ;; locale. In that case, like if we exited by raising &installer-step-break
+  ;; condition, turn the result into a glibc locale string and return it.
+  (result->locale-string
+   supported-locales
+   (run-installer-steps #:steps locale-steps)))

gnu/installer/newt/menu.scm

@@ -0,0 +1,44 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt menu)
+  #:use-module (gnu installer steps)
+  #:use-module (gnu installer newt page)
+  #:use-module (guix i18n)
+  #:use-module (newt)
+  #:export (run-menu-page))
+
+(define (run-menu-page steps)
+  "Run a menu page, asking the user to select where to resume the install
+process from."
+  (define (steps->items steps)
+    (filter (lambda (step)
+              (installer-step-description step))
+            steps))
+
+  (run-listbox-selection-page
+   #:info-text (G_ "Choose where you want to resume the install.\
+You can also abort the installation by pressing the Abort button.")
+   #:title (G_ "Installation menu")
+   #:listbox-items (steps->items steps)
+   #:listbox-item->text installer-step-description
+   #:sort-listbox-items? #f
+   #:button-text (G_ "Abort")
+   #:button-callback-procedure (lambda ()
+                                 (newt-finish)
+                                 (primitive-exit 1))))

gnu/installer/newt/network.scm

@@ -0,0 +1,173 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt network)
+  #:use-module (gnu installer connman)
+  #:use-module (gnu installer steps)
+  #:use-module (gnu installer utils)
+  #:use-module (gnu installer newt ethernet)
+  #:use-module (gnu installer newt page)
+  #:use-module (gnu installer newt wifi)
+  #:use-module (guix i18n)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (newt)
+  #:export (run-network-page))
+
+;; Maximum length of a technology name.
+(define technology-name-max-length (make-parameter 20))
+
+(define (technology->text technology)
+  "Return a string describing the given TECHNOLOGY."
+  (let* ((name (technology-name technology))
+         (padded-name (string-pad-right name
+                                        (technology-name-max-length))))
+    (format #f "~a~%" padded-name)))
+
+(define (run-technology-page)
+  "Run a page to ask the user which technology shall be used to access
+Internet and return the selected technology. For now, only technologies with
+\"ethernet\" or \"wifi\" types are supported."
+  (define (technology-items)
+    (filter (lambda (technology)
+              (let ((type (technology-type technology)))
+                (or
+                 (string=? type "ethernet")
+                 (string=? type "wifi"))))
+            (connman-technologies)))
+
+  (let ((items (technology-items)))
+    (if (null? items)
+        (case (choice-window
+               (G_ "Internet access")
+               (G_ "Continue")
+               (G_ "Exit")
+               (G_ "The install process requires an internet access, but no \
+network device were found. Do you want to continue anyway?"))
+          ((1) (raise
+                (condition
+                 (&installer-step-break))))
+          ((2) (raise
+                (condition
+                 (&installer-step-abort)))))
+        (run-listbox-selection-page
+         #:info-text (G_ "The install process requires an internet access.\
+ Please select a network device.")
+         #:title (G_ "Internet access")
+         #:listbox-items items
+         #:listbox-item->text technology->text
+         #:button-text (G_ "Exit")
+         #:button-callback-procedure
+         (lambda _
+           (raise
+            (condition
+             (&installer-step-abort))))))))
+
+(define (find-technology-by-type technologies type)
+  "Find and return a technology with the given TYPE in TECHNOLOGIES list."
+  (find (lambda (technology)
+          (string=? (technology-type technology)
+                    type))
+        technologies))
+
+(define (wait-technology-powered technology)
+  "Wait and display a progress bar until the given TECHNOLOGY is powered."
+  (let ((name (technology-name technology))
+        (full-value 5))
+    (run-scale-page
+     #:title (G_ "Powering technology")
+     #:info-text (format #f "Waiting for technology ~a to be powered." name)
+     #:scale-full-value full-value
+     #:scale-update-proc
+     (lambda (value)
+       (let* ((technologies (connman-technologies))
+              (type (technology-type technology))
+              (updated-technology
+               (find-technology-by-type technologies type))
+              (technology-powered? updated-technology))
+         (sleep 1)
+         (if technology-powered?
+             full-value
+             (+ value 1)))))))
+
+(define (wait-service-online)
+  "Display a newt scale until connman detects an Internet access. Do
+FULL-VALUE tentatives, spaced by 1 second."
+  (let* ((full-value 5))
+    (run-scale-page
+     #:title (G_ "Checking connectivity")
+     #:info-text (G_ "Waiting internet access is established.")
+     #:scale-full-value full-value
+     #:scale-update-proc
+     (lambda (value)
+       (sleep 1)
+       (if (connman-online?)
+           full-value
+           (+ value 1))))
+    (unless (connman-online?)
+      (run-error-page
+       (G_ "The selected network does not provide an Internet \
+access, please try again.")
+       (G_ "Connection error"))
+      (raise
+       (condition
+        (&installer-step-abort))))))
+
+(define (run-network-page)
+  "Run a page to allow the user to configure connman so that it can access the
+Internet."
+  (define network-steps
+    (list
+     ;; Ask the user to choose between ethernet and wifi technologies.
+     (installer-step
+      (id 'select-technology)
+      (compute
+       (lambda _
+         (run-technology-page))))
+     ;; Enable the previously selected technology.
+     (installer-step
+      (id 'power-technology)
+      (compute
+       (lambda (result _)
+         (let ((technology (result-step result 'select-technology)))
+           (connman-enable-technology technology)
+           (wait-technology-powered technology)))))
+     ;; Propose the user to connect to one of the service available for the
+     ;; previously selected technology.
+     (installer-step
+      (id 'connect-service)
+      (compute
+       (lambda (result _)
+         (let* ((technology (result-step result 'select-technology))
+                (type (technology-type technology)))
+           (cond
+            ((string=? "wifi" type)
+             (run-wifi-page))
+            ((string=? "ethernet" type)
+             (run-ethernet-page)))))))
+     ;; Wait for connman status to switch to 'online, which means it can
+     ;; access Internet.
+     (installer-step
+      (id 'wait-online)
+      (compute (lambda _
+                 (wait-service-online))))))
+  (run-installer-steps
+   #:steps network-steps
+   #:rewind-strategy 'start))

gnu/installer/newt/page.scm

@@ -0,0 +1,530 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt page)
+  #:use-module (gnu installer utils)
+  #:use-module (gnu installer newt utils)
+  #:use-module (guix i18n)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 receive)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (newt)
+  #:export (draw-info-page
+            draw-connecting-page
+            run-input-page
+            run-error-page
+            run-listbox-selection-page
+            run-scale-page
+            run-checkbox-tree-page
+            run-file-textbox-page))
+
+;;; Commentary:
+;;;
+;;; Some helpers around guile-newt to draw or run generic pages. The
+;;; difference between 'draw' and 'run' terms comes from newt library. A page
+;;; is drawn when the form it contains does not expect any user
+;;; interaction. In that case, it is necessary to call (newt-refresh) to force
+;;; the page to be displayed. When a form is 'run', it is blocked waiting for
+;;; any action from the user (press a button, input some text, ...).
+;;;
+;;; Code:
+
+(define (draw-info-page text title)
+  "Draw an informative page with the given TEXT as content.  Set the title of
+this page to TITLE."
+  (let* ((text-box
+          (make-reflowed-textbox -1 -1 text 40
+                                 #:flags FLAG-BORDER))
+         (grid (make-grid 1 1))
+         (form (make-form)))
+    (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box)
+    (add-component-to-form form text-box)
+    (make-wrapped-grid-window grid title)
+    (draw-form form)
+    ;; This call is imperative, otherwise the form won't be displayed. See the
+    ;; explanation in the above commentary.
+    (newt-refresh)
+    form))
+
+(define (draw-connecting-page service-name)
+  "Draw a page to indicate a connection in in progress."
+  (draw-info-page
+   (format #f (G_ "Connecting to ~a, please wait.") service-name)
+   (G_ "Connection in progress")))
+
+(define* (run-input-page text title
+                         #:key
+                         (allow-empty-input? #f)
+                         (default-text #f)
+                         (input-field-width 40))
+  "Run a page to prompt user for an input. The given TEXT will be displayed
+above the input field. The page title is set to TITLE. Unless
+allow-empty-input? is set to #t, an error page will be displayed if the user
+enters an empty input."
+  (let* ((text-box
+          (make-reflowed-textbox -1 -1 text
+                                 input-field-width
+                                 #:flags FLAG-BORDER))
+         (grid (make-grid 1 3))
+         (input-entry (make-entry -1 -1 20))
+         (ok-button (make-button -1 -1 (G_ "OK")))
+         (form (make-form)))
+
+    (when default-text
+      (set-entry-text input-entry default-text))
+
+    (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box)
+    (set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT input-entry
+                    #:pad-top 1)
+    (set-grid-field grid 0 2 GRID-ELEMENT-COMPONENT ok-button
+                    #:pad-top 1)
+
+    (add-components-to-form form text-box input-entry ok-button)
+    (make-wrapped-grid-window grid title)
+    (let ((error-page (lambda ()
+                        (run-error-page (G_ "Please enter a non empty input.")
+                                        (G_ "Empty input")))))
+      (let loop ()
+        (receive (exit-reason argument)
+            (run-form form)
+          (let ((input (entry-value input-entry)))
+            (if (and (not allow-empty-input?)
+                     (eq? exit-reason 'exit-component)
+                     (string=? input ""))
+                (begin
+                  ;; Display the error page.
+                  (error-page)
+                  ;; Set the focus back to the input input field.
+                  (set-current-component form input-entry)
+                  (loop))
+                (begin
+                  (destroy-form-and-pop form)
+                  input))))))))
+
+(define (run-error-page text title)
+  "Run a page to inform the user of an error. The page contains the given TEXT
+to explain the error and an \"OK\" button to acknowledge the error. The title
+of the page is set to TITLE."
+  (let* ((text-box
+          (make-reflowed-textbox -1 -1 text 40
+                                 #:flags FLAG-BORDER))
+         (grid (make-grid 1 2))
+         (ok-button (make-button -1 -1 "OK"))
+         (form (make-form)))
+
+    (set-grid-field grid 0 0 GRID-ELEMENT-COMPONENT text-box)
+    (set-grid-field grid 0 1 GRID-ELEMENT-COMPONENT ok-button
+                    #:pad-top 1)
+
+    ;; Set the background color to red to indicate something went wrong.
+    (newt-set-color COLORSET-ROOT "white" "red")
+    (add-components-to-form form text-box ok-button)
+    (make-wrapped-grid-window grid title)
+    (run-form form)
+    ;; Restore the background to its original color.
+    (newt-set-color COLORSET-ROOT "white" "blue")
+    (destroy-form-and-pop form)))
+
+(define* (run-listbox-selection-page #:key
+                                     info-text
+                                     title
+                                     (info-textbox-width 50)
+                                     listbox-items
+                                     listbox-item->text
+                                     (listbox-height 20)
+                                     (listbox-default-item #f)
+                                     (listbox-allow-multiple? #f)
+                                     (sort-listbox-items? #t)
+                                     (allow-delete? #f)
+                                     (skip-item-procedure?
+                                      (const #f))
+                                     button-text
+                                     (button-callback-procedure
+                                      (const #t))
+                                     (button2-text #f)
+                                     (button2-callback-procedure
+                                      (const #t))
+                                     (listbox-callback-procedure
+                                      identity)
+                                     (hotkey-callback-procedure
+                                      (const #t)))
+  "Run a page asking the user to select an item in a listbox. The page
+contains, stacked vertically from the top to the bottom, an informative text
+set to INFO-TEXT, a listbox and a button. The listbox will be filled with
+LISTBOX-ITEMS converted to text by applying the procedure LISTBOX-ITEM->TEXT
+on every item. The selected item from LISTBOX-ITEMS is returned. The button
+text is set to BUTTON-TEXT and the procedure BUTTON-CALLBACK-PROCEDURE called
+when it is pressed. The procedure LISTBOX-CALLBACK-PROCEDURE is called when an
+item from the listbox is selected (by pressing the <ENTER> key).
+
+INFO-TEXTBOX-WIDTH is the width of the textbox where INFO-TEXT will be
+displayed. LISTBOX-HEIGHT is the height of the listbox.
+
+If LISTBOX-DEFAULT-ITEM is set to the value of one of the items in
+LISTBOX-ITEMS, it will be selected by default. Otherwise, the first element of
+the listbox is selected.
+
+If LISTBOX-ALLOW-MULTIPLE? is set to #t, multiple items from the listbox can
+be selected (using the <SPACE> key). It that case, a list containing the
+selected items will be returned.
+
+If SORT-LISTBOX-ITEMS? is set to #t, the listbox items are sorted using
+'string<=' procedure (after being converted to text).
+
+If ALLOW-DELETE? is #t, the form will return if the <DELETE> key is pressed,
+otherwise nothing will happend.
+
+Each time the listbox current item changes, call SKIP-ITEM-PROCEDURE? with the
+current listbox item as argument. If it returns #t, skip the element and jump
+to the next/previous one depending on the previous item, otherwise do
+nothing."
+
+  (define (fill-listbox listbox items)
+    "Append the given ITEMS to LISTBOX, once they have been converted to text
+with LISTBOX-ITEM->TEXT. Each item appended to the LISTBOX is given a key by
+newt. Save this key by returning an association list under the form:
+
+	((NEWT-LISTBOX-KEY . ITEM) ...)
+
+where NEWT-LISTBOX-KEY is the key returned by APPEND-ENTRY-TO-LISTBOX, when
+ITEM was inserted into LISTBOX."
+    (map (lambda (item)
+           (let* ((text (listbox-item->text item))
+                  (key (append-entry-to-listbox listbox text)))
+             (cons key item)))
+         items))
+
+  (define (sort-listbox-items listbox-items)
+    "Return LISTBOX-ITEMS sorted using the 'string<=' procedure on the text
+corresponding to each item in the list."
+    (let* ((items (map (lambda (item)
+                         (cons item (listbox-item->text item)))
+                       listbox-items))
+           (sorted-items
+            (sort items (lambda (a b)
+                          (let ((text-a (cdr a))
+                                (text-b (cdr b)))
+                            (string<= text-a text-b))))))
+      (map car sorted-items)))
+
+  ;; Store the last selected listbox item's key.
+  (define last-listbox-key (make-parameter #f))
+
+  (define (previous-key keys key)
+    (let ((index (list-index (cut eq? key <>) keys)))
+      (and index
+           (> index 0)
+           (list-ref keys (- index 1)))))
+
+  (define (next-key keys key)
+    (let ((index (list-index (cut eq? key <>) keys)))
+      (and index
+           (< index (- (length keys) 1))
+           (list-ref keys (+ index 1)))))
+
+  (define (set-default-item listbox listbox-keys default-item)
+    "Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the
+association list returned by the FILL-LISTBOX procedure. It is used because
+the current listbox item has to be selected by key."
+    (for-each (match-lambda
+                ((key . item)
+                 (when (equal? item default-item)
+                   (set-current-listbox-entry-by-key listbox key))))
+              listbox-keys))
+
+  (let* ((listbox (make-listbox
+                   -1 -1
+                   listbox-height
+                   (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT
+                           (if listbox-allow-multiple?
+                               FLAG-MULTIPLE
+                               0))))
+         (form (make-form))
+         (info-textbox
+          (make-reflowed-textbox -1 -1 info-text
+                                 info-textbox-width
+                                 #:flags FLAG-BORDER))
+         (button (make-button -1 -1 button-text))
+         (button2 (and button2-text
+                       (make-button -1 -1 button2-text)))
+         (grid (vertically-stacked-grid
+                GRID-ELEMENT-COMPONENT info-textbox
+                GRID-ELEMENT-COMPONENT listbox
+                GRID-ELEMENT-SUBGRID
+                (apply
+                 horizontal-stacked-grid
+                 GRID-ELEMENT-COMPONENT button
+                 `(,@(if button2
+                         (list GRID-ELEMENT-COMPONENT button2)
+                         '())))))
+         (sorted-items (if sort-listbox-items?
+                           (sort-listbox-items listbox-items)
+                           listbox-items))
+         (keys (fill-listbox listbox sorted-items)))
+
+    ;; On every listbox element change, check if we need to skip it. If yes,
+    ;; depending on the 'last-listbox-key', jump forward or backward. If no,
+    ;; do nothing.
+    (add-component-callback
+     listbox
+     (lambda (component)
+       (let* ((current-key (current-listbox-entry listbox))
+              (listbox-keys (map car keys))
+              (last-key (last-listbox-key))
+              (item (assoc-ref keys current-key))
+              (prev-key (previous-key listbox-keys current-key))
+              (next-key (next-key listbox-keys current-key)))
+         ;; Update last-listbox-key before a potential call to
+         ;; set-current-listbox-entry-by-key, because it will immediately
+         ;; cause this callback to be called for the new entry.
+         (last-listbox-key current-key)
+         (when (skip-item-procedure? item)
+           (when (eq? prev-key last-key)
+             (if next-key
+                 (set-current-listbox-entry-by-key listbox next-key)
+                 (set-current-listbox-entry-by-key listbox prev-key)))
+           (when (eq? next-key last-key)
+             (if prev-key
+                 (set-current-listbox-entry-by-key listbox prev-key)
+                 (set-current-listbox-entry-by-key listbox next-key)))))))
+
+    (when listbox-default-item
+      (set-default-item listbox keys listbox-default-item))
+
+    (when allow-delete?
+      (form-add-hotkey form KEY-DELETE))
+
+    (add-form-to-grid grid form #t)
+    (make-wrapped-grid-window grid title)
+
+    (receive (exit-reason argument)
+        (run-form form)
+      (dynamic-wind
+        (const #t)
+        (lambda ()
+          (case exit-reason
+            ((exit-component)
+             (cond
+              ((components=? argument button)
+               (button-callback-procedure))
+              ((and button2
+                    (components=? argument button2))
+               (button2-callback-procedure))
+              ((components=? argument listbox)
+               (if listbox-allow-multiple?
+                   (let* ((entries (listbox-selection listbox))
+                          (items (map (lambda (entry)
+                                        (assoc-ref keys entry))
+                                      entries)))
+                     (listbox-callback-procedure items))
+                   (let* ((entry (current-listbox-entry listbox))
+                          (item (assoc-ref keys entry)))
+                     (listbox-callback-procedure item))))))
+            ((exit-hotkey)
+             (let* ((entry (current-listbox-entry listbox))
+                    (item (assoc-ref keys entry)))
+               (hotkey-callback-procedure argument item)))))
+        (lambda ()
+          (destroy-form-and-pop form))))))
+
+(define* (run-scale-page #:key
+                         title
+                         info-text
+                         (info-textbox-width 50)
+                         (scale-width 40)
+                         (scale-full-value 100)
+                         scale-update-proc
+                         (max-scale-update 5))
+  "Run a page with a progress bar (called 'scale' in newt). The given
+INFO-TEXT is displayed in a textbox above the scale. The width of the textbox
+is set to INFO-TEXTBOX-WIDTH. The width of the scale is set to
+SCALE-WIDTH. SCALE-FULL-VALUE indicates the value that correspond to 100% of
+the scale.
+
+The procedure SCALE-UPDATE-PROC shall return a new scale
+value. SCALE-UPDATE-PROC will be called until the returned value is superior
+or equal to SCALE-FULL-VALUE, but no more than MAX-SCALE-UPDATE times. An
+error is raised if the MAX-SCALE-UPDATE limit is reached."
+  (let* ((info-textbox
+          (make-reflowed-textbox -1 -1 info-text
+                                 info-textbox-width
+                                 #:flags FLAG-BORDER))
+         (scale (make-scale -1 -1 scale-width scale-full-value))
+         (grid (vertically-stacked-grid
+                GRID-ELEMENT-COMPONENT info-textbox
+                GRID-ELEMENT-COMPONENT scale))
+         (form (make-form)))
+
+    (add-form-to-grid grid form #t)
+    (make-wrapped-grid-window grid title)
+
+    (draw-form form)
+    ;; This call is imperative, otherwise the form won't be displayed. See the
+    ;; explanation in the above commentary.
+    (newt-refresh)
+
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (let loop ((i max-scale-update)
+                   (last-value 0))
+          (let ((value (scale-update-proc last-value)))
+            (set-scale-value scale value)
+            ;; Same as above.
+            (newt-refresh)
+            (unless (>= value scale-full-value)
+              (if (> i 0)
+                  (loop (- i 1) value)
+                  (error "Max scale updates reached."))))))
+      (lambda ()
+        (destroy-form-and-pop form)))))
+
+(define* (run-checkbox-tree-page #:key
+                                 info-text
+                                 title
+                                 items
+                                 item->text
+                                 (info-textbox-width 50)
+                                 (checkbox-tree-height 10)
+                                 (ok-button-callback-procedure
+                                  (const #t))
+                                 (exit-button-callback-procedure
+                                  (const #t)))
+  "Run a page allowing the user to select one or multiple items among ITEMS in
+a checkbox list. The page contains vertically stacked from the top to the
+bottom, an informative text set to INFO-TEXT, the checkbox list and two
+buttons, 'Ok' and 'Exit'. The page title's is set to TITLE. ITEMS are
+converted to text using ITEM->TEXT before being displayed in the checkbox
+list.
+
+INFO-TEXTBOX-WIDTH is the width of the textbox where INFO-TEXT will be
+displayed. CHECKBOX-TREE-HEIGHT is the height of the checkbox list.
+
+OK-BUTTON-CALLBACK-PROCEDURE is called when the 'Ok' button is pressed.
+EXIT-BUTTON-CALLBACK-PROCEDURE is called when the 'Exit' button is
+pressed.
+
+This procedure returns the list of checked items in the checkbox list among
+ITEMS when 'Ok' is pressed."
+  (define (fill-checkbox-tree checkbox-tree items)
+    (map
+     (lambda (item)
+       (let* ((item-text (item->text item))
+              (key (add-entry-to-checkboxtree checkbox-tree item-text 0)))
+         (cons key item)))
+     items))
+
+  (let* ((checkbox-tree
+          (make-checkboxtree -1 -1
+                             checkbox-tree-height
+                             FLAG-BORDER))
+         (info-textbox
+          (make-reflowed-textbox -1 -1 info-text
+                                 info-textbox-width
+                                 #:flags FLAG-BORDER))
+         (ok-button (make-button -1 -1 (G_ "OK")))
+         (exit-button (make-button -1 -1 (G_ "Exit")))
+         (grid (vertically-stacked-grid
+                GRID-ELEMENT-COMPONENT info-textbox
+                GRID-ELEMENT-COMPONENT checkbox-tree
+                GRID-ELEMENT-SUBGRID
+                (horizontal-stacked-grid
+                 GRID-ELEMENT-COMPONENT ok-button
+                 GRID-ELEMENT-COMPONENT exit-button)))
+         (keys (fill-checkbox-tree checkbox-tree items))
+         (form (make-form)))
+
+    (add-form-to-grid grid form #t)
+    (make-wrapped-grid-window grid title)
+
+    (receive (exit-reason argument)
+        (run-form form)
+      (dynamic-wind
+        (const #t)
+        (lambda ()
+          (case exit-reason
+            ((exit-component)
+             (cond
+              ((components=? argument ok-button)
+               (let* ((entries (current-checkbox-selection checkbox-tree))
+                      (current-items (map (lambda (entry)
+                                            (assoc-ref keys entry))
+                                          entries)))
+                 (ok-button-callback-procedure)
+                 current-items))
+              ((components=? argument exit-button)
+               (exit-button-callback-procedure))))))
+        (lambda ()
+          (destroy-form-and-pop form))))))
+
+(define* (run-file-textbox-page #:key
+                                info-text
+                                title
+                                file
+                                (info-textbox-width 50)
+                                (file-textbox-width 50)
+                                (file-textbox-height 30)
+                                (exit-button? #t)
+                                (ok-button-callback-procedure
+                                 (const #t))
+                                (exit-button-callback-procedure
+                                 (const #t)))
+  (let* ((info-textbox
+          (make-reflowed-textbox -1 -1 info-text
+                                 info-textbox-width
+                                 #:flags FLAG-BORDER))
+         (file-text (read-all file))
+         (file-textbox
+          (make-textbox -1 -1
+                        file-textbox-width
+                        file-textbox-height
+                        (logior FLAG-SCROLL FLAG-BORDER)))
+         (ok-button (make-button -1 -1 (G_ "OK")))
+         (exit-button (make-button -1 -1 (G_ "Exit")))
+         (grid (vertically-stacked-grid
+                GRID-ELEMENT-COMPONENT info-textbox
+                GRID-ELEMENT-COMPONENT file-textbox
+                GRID-ELEMENT-SUBGRID
+                (apply
+                 horizontal-stacked-grid
+                 GRID-ELEMENT-COMPONENT ok-button
+                 `(,@(if exit-button?
+                         (list GRID-ELEMENT-COMPONENT exit-button)
+                         '())))))
+         (form (make-form)))
+
+    (set-textbox-text file-textbox file-text)
+    (add-form-to-grid grid form #t)
+    (make-wrapped-grid-window grid title)
+
+    (receive (exit-reason argument)
+        (run-form form)
+      (dynamic-wind
+        (const #t)
+        (lambda ()
+          (case exit-reason
+            ((exit-component)
+             (cond
+              ((components=? argument ok-button)
+               (ok-button-callback-procedure))
+              ((and exit-button?
+                    (components=? argument exit-button))
+               (exit-button-callback-procedure))))))
+        (lambda ()
+          (destroy-form-and-pop form))))))

gnu/installer/newt/partition.scm

@@ -0,0 +1,766 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt 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-exit-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_ "Exit")
+                  #:button-callback-procedure button-exit-action)))
+    (car result)))
+
+(define (draw-formatting-page)
+  "Draw a page to indicate partitions are being formated."
+  (draw-info-page
+   (format #f (G_ "Partition formatting 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_ "Exit")
+                  #:button-callback-procedure button-exit-action))
+         (device (car result)))
+    device))
+
+(define (run-label-page button-text 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 button-text
+   #: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_ "Exit")
+     #:button-callback-procedure button-exit-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_ "Exit")
+   #:button-callback-procedure button-exit-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 (prompt-luks-passwords user-partitions)
+  "Prompt for the luks passwords of the encrypted partitions in
+USER-PARTITIONS list. Return this list with password fields filled-in."
+  (map (lambda (user-part)
+         (let* ((crypt-label (user-partition-crypt-label user-part))
+                (file-name (user-partition-file-name user-part))
+                (password-page
+                 (lambda ()
+                   (run-input-page
+                    (format #f (G_ "Please enter the password for the \
+encryption of partition ~a (label: ~a).") file-name crypt-label)
+                    (G_ "Password required"))))
+                (password-confirm-page
+                 (lambda ()
+                   (run-input-page
+                    (format #f (G_ "Please confirm the password for the \
+encryption of partition ~a (label: ~a).") file-name crypt-label)
+                    (G_ "Password confirmation required")))))
+           (if crypt-label
+               (let loop ()
+                 (let ((password (password-page))
+                       (confirmation (password-confirm-page)))
+                   (if (string=? password confirmation)
+                       (user-partition
+                        (inherit user-part)
+                        (crypt-password password))
+                       (begin
+                         (run-error-page
+                          (G_ "Password mismatch, please try again.")
+                          (G_ "Password error"))
+                         (loop)))))
+               user-part)))
+       user-partitions))
+
+(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)
+                              "")))))
+         ((crypt-label)
+          (let* ((label (user-partition-crypt-label
+                         target-user-partition))
+                 (new-label
+                  (and (not label)
+                       (run-input-page
+                        (G_ "Please enter the encrypted label")
+                        (G_ "Encryption label")))))
+            (user-partition
+             (inherit target-user-partition)
+             (need-formatting? #t)
+             (crypt-label new-label))))
+         ((need-formatting?)
+          (user-partition
+           (inherit target-user-partition)
+           (need-formatting?
+            (not (user-partition-need-formatting?
+                  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-formatting? #t)
+                  (file-name (partition-get-path new-partition))
+                  (disk-file-name (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))
+         (file-name (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 file-name))
+               (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 '())
+                        #:key (guided? #f))
+  "Run a page allowing to edit the partition tables of the given DISKS. If
+specified, USER-PARTITIONS is a list of <user-partition> 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 <user-partition> 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 <user-partition> 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 (G_ "Back") (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))
+               (file-name (device-path device))
+               (info-text
+                (format #f (G_ "Are you sure you want to delete everything on disk ~a?")
+                        file-name))
+               (result (choice-window (G_ "Delete disk")
+                                      (G_ "OK")
+                                      (G_ "Exit")
+                                      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_ "Exit")
+                                          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* ((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 '/'."))
+         (guided-info-text (format #f (G_ "This is the proposed \
+partitioning. It is still possible to edit it or to go back to install menu \
+by pressing the Exit button.~%~%")))
+         (result
+          (run-listbox-selection-page
+           #:info-text (if guided?
+                           (string-append guided-info-text info-text)
+                           info-text)
+
+          #:title (if guided?
+                      (G_ "Guided partitioning")
+                      (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_ "Exit")
+          #:button2-callback-procedure button-exit-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
+                             #:guided? guided?)))
+        (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
+                         #:guided? guided?)))))
+
+(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")
+              (entire-encrypted . "Guided - using the entire disk with encryption")
+              (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_ "Exit")
+                    #:button-callback-procedure button-exit-action))
+           (method (car result)))
+      (cond
+       ((or (eq? method 'entire)
+            (eq? method 'entire-encrypted))
+         (let* ((device (run-device-page devices))
+                (disk-type (disk-probe device))
+                (disk (if disk-type
+                          (disk-new device)
+                          (let* ((label (run-label-page
+                                         (G_ "Exit")
+                                         button-exit-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
+                          #:guided? #t)))
+       ((eq? method 'manual)
+         (let* ((disks (filter-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))
+         (user-partitions-with-pass (prompt-luks-passwords
+                                     user-partitions))
+         (form (draw-formatting-page)))
+    ;; Make sure the disks are not in use before proceeding to formatting.
+    (free-parted non-install-devices)
+    (format-user-partitions user-partitions-with-pass)
+    (destroy-form-and-pop form)
+    user-partitions))

gnu/installer/newt/services.scm

@@ -0,0 +1,48 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt 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
+   #:exit-button-callback-procedure
+   (lambda ()
+     (raise
+      (condition
+       (&installer-step-abort))))))
+
+(define (run-services-page)
+  (run-desktop-environments-cbt-page))

gnu/installer/newt/timezone.scm

@@ -0,0 +1,83 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt timezone)
+  #:use-module (gnu installer steps)
+  #:use-module (gnu installer timezone)
+  #:use-module (gnu installer newt page)
+  #:use-module (guix i18n)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 receive)
+  #:use-module (newt)
+  #:export (run-timezone-page))
+
+;; Heigth of the listbox displaying timezones.
+(define timezone-listbox-heigth (make-parameter 20))
+
+;; Information textbox width.
+(define info-textbox-width (make-parameter 40))
+
+(define (fill-timezones listbox timezones)
+  "Fill the given LISTBOX with TIMEZONES. Return an association list
+correlating listbox keys with timezones."
+  (map (lambda (timezone)
+         (let ((key (append-entry-to-listbox listbox timezone)))
+           (cons key timezone)))
+       timezones))
+
+(define (run-timezone-page zonetab)
+  "Run a page displaying available timezones, grouped by regions. The user is
+invited to select a timezone. The selected timezone, under Posix format is
+returned."
+  (define (all-but-last list)
+    (reverse (cdr (reverse list))))
+
+  (define (run-page timezone-tree)
+    (define (loop path)
+      (let ((timezones (locate-childrens timezone-tree path)))
+        (run-listbox-selection-page
+         #:title (G_ "Timezone")
+         #:info-text (G_ "Please select a timezone.")
+         #:listbox-items timezones
+         #:listbox-item->text identity
+         #:button-text (if (null? path)
+                           (G_ "Exit")
+                           (G_ "Back"))
+         #:button-callback-procedure
+         (if (null? path)
+             (lambda _
+               (raise
+                (condition
+                 (&installer-step-abort))))
+             (lambda _
+               (loop (all-but-last path))))
+         #:listbox-callback-procedure
+         (lambda (timezone)
+           (let* ((timezone* (append path (list timezone)))
+                  (tz (timezone->posix-tz timezone*)))
+             (if (timezone-has-child? timezone-tree timezone*)
+                 (loop timezone*)
+                 tz))))))
+    (loop '()))
+
+  (let ((timezone-tree (zonetab->timezone-tree zonetab)))
+    (run-page timezone-tree)))

gnu/installer/newt/user.scm

@@ -0,0 +1,175 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt user)
+  #:use-module (gnu installer user)
+  #:use-module (gnu installer newt page)
+  #:use-module (gnu installer newt utils)
+  #:use-module (guix i18n)
+  #:use-module (newt)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 receive)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:export (run-user-page))
+
+(define (run-user-add-page)
+  (define (pad-label label)
+    (string-pad-right label 20))
+
+  (let* ((label-name
+          (make-label -1 -1 (pad-label (G_ "Name"))))
+         (label-home-directory
+          (make-label -1 -1 (pad-label (G_ "Home directory"))))
+         (entry-width 30)
+         (entry-name (make-entry -1 -1 entry-width))
+         (entry-home-directory (make-entry -1 -1 entry-width))
+         (entry-grid (make-grid 2 2))
+         (button-grid (make-grid 1 1))
+         (ok-button (make-button -1 -1 (G_ "OK")))
+         (grid (make-grid 1 2))
+         (title (G_ "User creation"))
+         (set-entry-grid-field
+          (cut set-grid-field entry-grid <> <> GRID-ELEMENT-COMPONENT <>))
+         (form (make-form)))
+
+    (set-entry-grid-field 0 0 label-name)
+    (set-entry-grid-field 1 0 entry-name)
+    (set-entry-grid-field 0 1 label-home-directory)
+    (set-entry-grid-field 1 1 entry-home-directory)
+
+    (set-grid-field button-grid 0 0 GRID-ELEMENT-COMPONENT ok-button)
+
+    (add-component-callback
+     entry-name
+     (lambda (component)
+       (set-entry-text entry-home-directory
+                       (string-append "/home/" (entry-value entry-name)))))
+
+    (add-components-to-form form
+                            label-name label-home-directory
+                            entry-name entry-home-directory
+                            ok-button)
+
+    (make-wrapped-grid-window (vertically-stacked-grid
+                               GRID-ELEMENT-SUBGRID entry-grid
+                               GRID-ELEMENT-SUBGRID button-grid)
+                              title)
+    (let ((error-page
+           (lambda ()
+             (run-error-page (G_ "Empty inputs are not allowed.")
+                             (G_ "Empty input")))))
+      (receive (exit-reason argument)
+          (run-form form)
+        (dynamic-wind
+          (const #t)
+          (lambda ()
+            (when (eq? exit-reason 'exit-component)
+              (cond
+               ((components=? argument ok-button)
+                (let ((name (entry-value entry-name))
+                      (home-directory (entry-value entry-home-directory)))
+                  (if (or (string=? name "")
+                          (string=? home-directory ""))
+                      (begin
+                        (error-page)
+                        (run-user-add-page))
+                      (user
+                       (name name)
+                       (home-directory home-directory))))))))
+          (lambda ()
+            (destroy-form-and-pop form)))))))
+
+(define (run-user-page)
+  (define (run users)
+    (let* ((listbox (make-listbox
+                     -1 -1 10
+                     (logior FLAG-SCROLL FLAG-BORDER)))
+           (info-textbox
+            (make-reflowed-textbox
+             -1 -1
+             (G_ "Please add at least one user to system\
+ using the 'Add' button.")
+             40 #:flags FLAG-BORDER))
+           (add-button (make-compact-button -1 -1 (G_ "Add")))
+           (del-button (make-compact-button -1 -1 (G_ "Delete")))
+           (listbox-button-grid
+            (apply
+             vertically-stacked-grid
+             GRID-ELEMENT-COMPONENT add-button
+             `(,@(if (null? users)
+                     '()
+                     (list GRID-ELEMENT-COMPONENT del-button)))))
+           (ok-button (make-button -1 -1 (G_ "OK")))
+           (exit-button (make-button -1 -1 (G_ "Exit")))
+           (title "User creation")
+           (grid
+            (vertically-stacked-grid
+             GRID-ELEMENT-COMPONENT info-textbox
+             GRID-ELEMENT-SUBGRID (horizontal-stacked-grid
+                                   GRID-ELEMENT-COMPONENT listbox
+                                   GRID-ELEMENT-SUBGRID listbox-button-grid)
+             GRID-ELEMENT-SUBGRID (horizontal-stacked-grid
+                                   GRID-ELEMENT-COMPONENT ok-button
+                                   GRID-ELEMENT-COMPONENT exit-button)))
+           (sorted-users (sort users (lambda (a b)
+                                       (string<= (user-name a)
+                                                 (user-name b)))))
+           (listbox-elements
+            (map
+             (lambda (user)
+               `((key . ,(append-entry-to-listbox listbox
+                                                  (user-name user)))
+                 (user . ,user)))
+             sorted-users))
+           (form (make-form)))
+
+
+      (add-form-to-grid grid form #t)
+      (make-wrapped-grid-window grid title)
+      (if (null? users)
+          (set-current-component form add-button)
+          (set-current-component form ok-button))
+
+      (receive (exit-reason argument)
+          (run-form form)
+        (dynamic-wind
+          (const #t)
+          (lambda ()
+            (when (eq? exit-reason 'exit-component)
+              (cond
+               ((components=? argument add-button)
+                (run (cons (run-user-add-page) users)))
+               ((components=? argument del-button)
+                (let* ((current-user-key (current-listbox-entry listbox))
+                       (users
+                        (map (cut assoc-ref <> 'user)
+                             (remove (lambda (element)
+                                       (equal? (assoc-ref element 'key)
+                                               current-user-key))
+                                     listbox-elements))))
+                  (run users)))
+               ((components=? argument ok-button)
+                (when (null? users)
+                  (run-error-page (G_ "Please create at least one user.")
+                                  (G_ "No user"))
+                  (run users))
+                users))))
+          (lambda ()
+            (destroy-form-and-pop form))))))
+  (run '()))

gnu/installer/newt/utils.scm

@@ -0,0 +1,43 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt utils)
+  #:use-module (ice-9 receive)
+  #:use-module (newt)
+  #:export (screen-columns
+            screen-rows
+
+            destroy-form-and-pop
+            set-screen-size!))
+
+;; Number of columns and rows of the terminal.
+(define screen-columns (make-parameter 0))
+(define screen-rows    (make-parameter 0))
+
+(define (destroy-form-and-pop form)
+  "Destory the given FORM and pop the current window."
+  (destroy-form form)
+  (pop-window))
+
+(define (set-screen-size!)
+  "Set the parameters 'screen-columns' and 'screen-rows' to the number of
+columns and rows respectively of the current terminal."
+  (receive (columns rows)
+      (screen-size)
+    (screen-columns columns)
+    (screen-rows rows)))

gnu/installer/newt/welcome.scm

@@ -0,0 +1,118 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt welcome)
+  #:use-module (gnu installer utils)
+  #:use-module (gnu installer newt utils)
+  #:use-module (guix build syscalls)
+  #:use-module (guix i18n)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 receive)
+  #:use-module (newt)
+  #:export (run-welcome-page))
+
+;; Expected width and height for the logo.
+(define logo-width (make-parameter 43))
+(define logo-height (make-parameter 19))
+
+(define info-textbox-width (make-parameter 70))
+(define options-listbox-height (make-parameter 5))
+
+(define* (run-menu-page title info-text logo
+                        #:key
+                        listbox-items
+                        listbox-item->text)
+  "Run a page with the given TITLE, to ask the user to choose between
+LISTBOX-ITEMS displayed in a listbox. The listbox items are converted to text
+using LISTBOX-ITEM->TEXT procedure. Display the textual LOGO in the center of
+the page. Contrary to other pages, we cannot resort to grid layouts, because
+we want this page to occupy all the screen space available."
+  (define (fill-listbox listbox items)
+    (map (lambda (item)
+           (let* ((text (listbox-item->text item))
+                  (key (append-entry-to-listbox listbox text)))
+             (cons key item)))
+         items))
+
+  (let* ((logo-textbox
+          (make-textbox -1 -1 (logo-width) (logo-height) 0))
+         (info-textbox
+          (make-reflowed-textbox -1 -1
+                                 info-text
+                                 (info-textbox-width)))
+         (options-listbox
+          (make-listbox -1 -1
+                        (options-listbox-height)
+                        (logior FLAG-BORDER FLAG-RETURNEXIT)))
+         (keys (fill-listbox options-listbox listbox-items))
+         (grid (vertically-stacked-grid
+                GRID-ELEMENT-COMPONENT logo-textbox
+                GRID-ELEMENT-COMPONENT info-textbox
+                GRID-ELEMENT-COMPONENT options-listbox))
+         (form (make-form)))
+
+    (set-textbox-text logo-textbox (read-all logo))
+
+    (add-form-to-grid grid form #t)
+    (make-wrapped-grid-window grid title)
+
+    (receive (exit-reason argument)
+        (run-form form)
+      (dynamic-wind
+        (const #t)
+        (lambda ()
+          (when (eq? exit-reason 'exit-component)
+            (cond
+             ((components=? argument options-listbox)
+              (let* ((entry (current-listbox-entry options-listbox))
+                     (item (assoc-ref keys entry)))
+                (match item
+                  ((text . proc)
+                   (proc))))))))
+        (lambda ()
+          (destroy-form-and-pop form))))))
+
+(define (run-welcome-page logo)
+  "Run a welcome page with the given textual LOGO displayed at the center of
+the page. Ask the user to choose between manual installation, graphical
+installation and reboot."
+  (run-menu-page
+   (G_ "GNU GuixSD install")
+   (G_ "Welcome to GNU GuixSD installer!
+
+Please note that the present graphical installer is still under heavy \
+development, so you might want to prefer using the shell based process. \
+The documentation is accessible at any time by pressing CTRL-ALT-F2.")
+   logo
+   #:listbox-items
+   `((,(G_ "Graphical install using a terminal based interface")
+      .
+      ,(const #t))
+     (,(G_ "Install using the shell based process")
+      .
+      ,(lambda ()
+         ;; Switch to TTY3, where a root shell is available for shell based
+         ;; install. The other root TTY's would have been ok too.
+         (system* "chvt" "3")
+         (run-welcome-page logo)))
+     (,(G_ "Reboot")
+      .
+      ,(lambda ()
+         (newt-finish)
+         (reboot))))
+   #:listbox-item->text car))

gnu/installer/newt/wifi.scm

@@ -0,0 +1,243 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer newt wifi)
+  #:use-module (gnu installer connman)
+  #:use-module (gnu installer steps)
+  #:use-module (gnu installer newt utils)
+  #:use-module (gnu installer newt page)
+  #:use-module (guix i18n)
+  #:use-module (guix records)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 rdelim)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (newt)
+  #:export (run-wifi-page))
+
+;; This record associates a connman service to its key the listbox.
+(define-record-type* <service-item>
+  service-item make-service-item
+  service-item?
+  (service   service-item-service) ; connman <service>
+  (key       service-item-key)) ; newt listbox-key
+
+(define (strength->string strength)
+  "Convert STRENGTH as an integer percentage into a text printable strength
+bar using unicode characters. Taken from NetworkManager's
+nmc_wifi_strength_bars."
+  (let ((quarter #\x2582)
+        (half #\x2584)
+        (three-quarter #\x2586)
+        (full #\x2588))
+    (cond
+     ((> strength 80)
+      ;; ▂▄▆█
+      (string quarter half three-quarter full))
+     ((> strength 55)
+      ;; ▂▄▆_
+      (string quarter half three-quarter #\_))
+     ((> strength 30)
+      ;; ▂▄__
+      (string quarter half #\_ #\_))
+     ((> strength 5)
+      ;; ▂___
+      (string quarter #\_ #\_ #\_))
+     (else
+      ;; ____
+      (string quarter #\_ #\_ #\_ #\_)))))
+
+(define (force-wifi-scan)
+  "Force a wifi scan. Raise a condition if no wifi technology is available."
+  (let* ((technologies (connman-technologies))
+         (wifi-technology
+          (find (lambda (technology)
+                  (string=? (technology-type technology) "wifi"))
+                technologies)))
+    (if wifi-technology
+        (connman-scan-technology wifi-technology)
+        (raise (condition
+                (&message
+                 (message (G_ "Unable to find a wifi technology"))))))))
+
+(define (draw-scanning-page)
+  "Draw a page to indicate a wifi scan in in progress."
+  (draw-info-page (G_ "Scanning wifi for available networks, please wait.")
+                  (G_ "Scan in progress")))
+
+(define (run-wifi-password-page)
+  "Run a page prompting user for a password and return it."
+  (run-input-page (G_ "Please enter the wifi password.")
+                  (G_ "Password required")))
+
+(define (run-wrong-password-page service-name)
+  "Run a page to inform user of a wrong password input."
+  (run-error-page
+   (format #f (G_ "The password you entered for ~a is incorrect.")
+           service-name)
+   (G_ "Wrong password")))
+
+(define (run-unknown-error-page service-name)
+  "Run a page to inform user that a connection error happened."
+  (run-error-page
+   (format #f
+           (G_ "An error occured while trying to connect to ~a, please retry.")
+           service-name)
+   (G_ "Connection error")))
+
+(define (password-callback)
+  (run-wifi-password-page))
+
+(define (connect-wifi-service listbox service-items)
+  "Connect to the wifi service selected in LISTBOX. SERVICE-ITEMS is the list
+of <service-item> records present in LISTBOX."
+  (let* ((listbox-key (current-listbox-entry listbox))
+         (item (find (lambda (item)
+                       (eq? (service-item-key item) listbox-key))
+                     service-items))
+         (service (service-item-service item))
+         (service-name (service-name service))
+         (form (draw-connecting-page service-name)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (guard (c ((connman-password-error? c)
+                   (run-wrong-password-page service-name)
+                   #f)
+                  ((connman-already-connected-error? c)
+                   #t)
+                  ((connman-connection-error? c)
+                   (run-unknown-error-page service-name)
+                   #f))
+          (connman-connect-with-auth service password-callback)))
+      (lambda ()
+        (destroy-form-and-pop form)))))
+
+(define (run-wifi-scan-page)
+  "Force a wifi scan and draw a page during the operation."
+  (let ((form (draw-scanning-page)))
+    (force-wifi-scan)
+    (destroy-form-and-pop form)))
+
+(define (wifi-services)
+  "Return all the connman services of wifi type."
+  (let ((services (connman-services)))
+    (filter (lambda (service)
+              (and (string=? (service-type service) "wifi")
+                   (not (string-null? (service-name service)))))
+            services)))
+
+(define* (fill-wifi-services listbox wifi-services)
+  "Append all the services in WIFI-SERVICES to the given LISTBOX."
+  (clear-listbox listbox)
+  (map (lambda (service)
+         (let* ((text (service->text service))
+                (key (append-entry-to-listbox listbox text)))
+           (service-item
+            (service service)
+            (key key))))
+       wifi-services))
+
+;; Maximum length of a wifi service name.
+(define service-name-max-length (make-parameter 20))
+
+;; Heigth of the listbox displaying wifi services.
+(define wifi-listbox-heigth (make-parameter 20))
+
+;; Information textbox width.
+(define info-textbox-width (make-parameter 40))
+
+(define (service->text service)
+  "Return a string composed of the name and the strength of the given
+SERVICE. A '*' preceding the service name indicates that it is connected."
+  (let* ((name (service-name service))
+         (padded-name (string-pad-right name
+                                        (service-name-max-length)))
+         (strength (service-strength service))
+         (strength-string (strength->string strength))
+         (state (service-state service))
+         (connected? (or (string=? state "online")
+                         (string=? state "ready"))))
+    (format #f "~c ~a ~a~%"
+            (if connected? #\* #\ )
+            padded-name
+            strength-string)))
+
+(define (run-wifi-page)
+  "Run a page displaying available wifi networks in a listbox. Connect to the
+network when the corresponding listbox entry is selected. A button allow to
+force a wifi scan."
+  (let* ((listbox (make-listbox
+                   -1 -1
+                   (wifi-listbox-heigth)
+                   (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT)))
+         (form (make-form))
+         (buttons-grid (make-grid 1 1))
+         (middle-grid (make-grid 2 1))
+         (info-text (G_ "Please select a wifi network."))
+         (info-textbox
+          (make-reflowed-textbox -1 -1 info-text
+                                 (info-textbox-width)
+                                 #:flags FLAG-BORDER))
+         (exit-button (make-button -1 -1 (G_ "Exit")))
+         (scan-button (make-button -1 -1 (G_ "Scan")))
+         (services (wifi-services))
+         (service-items '()))
+
+    (if (null? services)
+        (append-entry-to-listbox listbox (G_ "No wifi detected"))
+        (set! service-items (fill-wifi-services listbox services)))
+
+    (set-grid-field middle-grid 0 0 GRID-ELEMENT-COMPONENT listbox)
+    (set-grid-field middle-grid 1 0 GRID-ELEMENT-COMPONENT scan-button
+                    #:anchor ANCHOR-TOP
+                    #:pad-left 2)
+    (set-grid-field buttons-grid 0 0 GRID-ELEMENT-COMPONENT exit-button)
+
+    (add-components-to-form form
+                            info-textbox
+                            listbox scan-button
+                            exit-button)
+    (make-wrapped-grid-window
+     (basic-window-grid info-textbox middle-grid buttons-grid)
+     (G_ "Wifi"))
+
+    (receive (exit-reason argument)
+        (run-form form)
+      (dynamic-wind
+        (const #t)
+        (lambda ()
+          (when (eq? exit-reason 'exit-component)
+            (cond
+             ((components=? argument scan-button)
+              (run-wifi-scan-page)
+              (run-wifi-page))
+             ((components=? argument exit-button)
+              (raise
+               (condition
+                (&installer-step-abort))))
+             ((components=? argument listbox)
+              (let ((result (connect-wifi-service listbox service-items)))
+                (unless result
+                  (run-wifi-page)))))))
+        (lambda ()
+          (destroy-form-and-pop form))))))

gnu/installer/record.scm

@@ -0,0 +1,84 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu installer record)
+  #:use-module (guix records)
+  #:use-module (srfi srfi-1)
+  #:export (<installer>
+            installer
+            make-installer
+            installer?
+            installer-name
+            installer-init
+            installer-exit
+            installer-exit-error
+            installer-final-page
+            installer-keymap-page
+            installer-locale-page
+            installer-menu-page
+            installer-network-page
+            installer-timezone-page
+            installer-hostname-page
+            installer-user-page
+            installer-partition-page
+            installer-services-page
+            installer-welcome-page))
+
+
+;;;
+;;; Installer record.
+;;;
+
+;; The <installer> 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 <operating-system> record and install it.
+
+(define-record-type* <installer>
+  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 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
+  (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 void -> void
+  (partition-page installer-partition-page)
+  ;; procedure void -> void
+  (services-page installer-services-page)
+  ;; procedure (logo) -> void
+  (welcome-page installer-welcome-page))

gnu/installer/services.scm

@@ -0,0 +1,59 @@
+;;; 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 services)
+  #:use-module (guix records)
+  #:export (<desktop-environment>
+            desktop-environment
+            make-desktop-environment
+            desktop-environment-name
+            desktop-environment-snippet
+
+            %desktop-environments
+            desktop-environments->configuration))
+
+(define-record-type* <desktop-environment>
+  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)))))))

gnu/installer/steps.scm

@@ -0,0 +1,237 @@
+;;; 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 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?
+
+            &installer-step-break
+            installer-step-break?
+
+            <installer-step>
+            installer-step
+            make-installer-step
+            installer-step?
+            installer-step-id
+            installer-step-description
+            installer-step-compute
+            installer-step-configuration-formatter
+
+            run-installer-steps
+            find-step-by-id
+            result->step-ids
+            result-step
+            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
+  installer-step-abort?)
+
+;; This condition may be raised to break out from the steps execution.
+(define-condition-type &installer-step-break &condition
+  installer-step-break?)
+
+;; An installer-step record is basically an id associated to a compute
+;; procedure. The COMPUTE procedure takes exactly one argument, an association
+;; list containing the results of previously executed installer-steps (see
+;; RUN-INSTALLER-STEPS description). The value returned by the COMPUTE
+;; procedure will be stored in the results list passed to the next
+;; installer-step and so on.
+(define-record-type* <installer-step>
+  installer-step make-installer-step
+  installer-step?
+  (id                         installer-step-id) ;symbol
+  (description                installer-step-description ;string
+                              (default #f))
+  (compute                    installer-step-compute) ;procedure
+  (configuration-formatter    installer-step-configuration-formatter ;procedure
+                              (default #f)))
+
+(define* (run-installer-steps #:key
+                              steps
+                              (rewind-strategy 'previous)
+                              (menu-proc (const #f)))
+  "Run the COMPUTE procedure of all <installer-step> records in STEPS
+sequencially. If the &installer-step-abort condition is raised, fallback to a
+previous install-step, accordingly to the specified REWIND-STRATEGY.
+
+REWIND-STRATEGY possible values are 'previous, 'menu and 'start.  If 'previous
+is selected, the execution will resume at the previous installer-step. If
+'menu is selected, the MENU-PROC procedure will be called. Its return value
+has to be an installer-step ID to jump to. The ID has to be the one of a
+previously executed step. It is impossible to jump forward. Finally if 'start
+is selected, the execution will resume at the first installer-step.
+
+The result of every COMPUTE procedures is stored in an association list, under
+the form:
+
+		'((STEP-ID . COMPUTE-RESULT) ...)
+
+where STEP-ID is the ID field of the installer-step and COMPUTE-RESULT the
+result of the associated COMPUTE procedure. This result association list is
+passed as argument of every COMPUTE procedure. It is finally returned when the
+computation is over.
+
+If the &installer-step-break condition is raised, stop the computation and
+return the accumalated result so far."
+  (define (pop-result list)
+    (cdr list))
+
+  (define (first-step? steps step)
+    (match steps
+      ((first-step . rest-steps)
+       (equal? first-step step))))
+
+  (define* (skip-to-step step result
+                         #:key todo-steps done-steps)
+    (match (list todo-steps done-steps)
+      (((todo . rest-todo) (prev-done ... last-done))
+       (if (eq? (installer-step-id todo)
+                (installer-step-id step))
+           (run result
+                #:todo-steps todo-steps
+                #:done-steps done-steps)
+           (skip-to-step step (pop-result result)
+                         #:todo-steps (cons last-done todo-steps)
+                         #:done-steps prev-done)))))
+
+  (define* (run result #:key todo-steps done-steps)
+    (match todo-steps
+      (() (reverse result))
+      ((step . rest-steps)
+       (guard (c ((installer-step-abort? c)
+                  (case rewind-strategy
+                    ((previous)
+                     (match done-steps
+                       (()
+                        ;; We cannot go previous the first step. So re-raise
+                        ;; the exception. It might be useful in the case of
+                        ;; nested run-installer-steps. Abort to 'raise-above
+                        ;; prompt to prevent the condition from being catched
+                        ;; by one of the previously installed guard.
+                        (abort-to-prompt 'raise-above c))
+                       ((prev-done ... last-done)
+                        (run (pop-result result)
+                             #:todo-steps (cons last-done todo-steps)
+                             #:done-steps prev-done))))
+                    ((menu)
+                     (let ((goto-step (menu-proc
+                                       (append done-steps (list step)))))
+                       (if (eq? goto-step step)
+                           (run result
+                                #:todo-steps todo-steps
+                                #:done-steps done-steps)
+                           (skip-to-step goto-step result
+                                         #:todo-steps todo-steps
+                                         #:done-steps done-steps))))
+                    ((start)
+                     (if (null? done-steps)
+                         ;; Same as above, it makes no sense to jump to start
+                         ;; when we are at the first installer-step. Abort to
+                         ;; 'raise-above prompt to re-raise the condition.
+                         (abort-to-prompt 'raise-above c)
+                         (run '()
+                              #:todo-steps steps
+                              #:done-steps '())))))
+                 ((installer-step-break? c)
+                  (reverse result)))
+         (let* ((id (installer-step-id step))
+                (compute (installer-step-compute step))
+                (res (compute result done-steps)))
+           (run (alist-cons id res result)
+                #:todo-steps rest-steps
+                #:done-steps (append done-steps (list step))))))))
+
+  (call-with-prompt 'raise-above
+    (lambda ()
+      (run '()
+           #:todo-steps steps
+           #:done-steps '()))
+    (lambda (k condition)
+      (raise condition))))
+
+(define (find-step-by-id steps id)
+  "Find and return the step in STEPS whose id is equal to ID."
+  (find (lambda (step)
+          (eq? (installer-step-id step) id))
+        steps))
+
+(define (result-step results step-id)
+  "Return the result of the installer-step specified by STEP-ID in
+RESULTS."
+  (assoc-ref results step-id))
+
+(define (result-step-done? results step-id)
+  "Return #t if the installer-step specified by STEP-ID has a COMPUTE value
+stored in RESULTS. Return #f otherwise."
+  (and (assoc step-id results) #t))
+
+(define %installer-configuration-file (make-parameter "/mnt/etc/config.scm"))
+(define %installer-target-dir (make-parameter "/mnt"))
+(define %configuration-file-width (make-parameter 79))
+
+(define (format-configuration steps results)
+  "Return the list resulting from the application of the procedure defined in
+CONFIGURATION-FORMATTER field of <installer-step> on the associated result
+found in RESULTS."
+  (let ((configuration
+         (append-map
+          (lambda (step)
+            (let* ((step-id (installer-step-id step))
+                   (conf-formatter
+                    (installer-step-configuration-formatter step))
+                   (result-step (result-step results step-id)))
+              (if (and result-step conf-formatter)
+                  (conf-formatter result-step)
+                  '())))
+          steps))
+        (modules '((use-modules (gnu))
+                   (use-service-modules desktop))))
+    `(,@modules
+      ()
+      (operating-system ,@configuration))))
+
+(define* (configuration->file configuration
+                              #:key (filename (%installer-configuration-file)))
+  "Write the given CONFIGURATION to FILENAME."
+  (mkdir-p (dirname filename))
+  (call-with-output-file filename
+    (lambda (port)
+      (format port ";; This is an operating system configuration generated~%")
+      (format port ";; by the graphical installer.~%")
+      (newline port)
+      (for-each (lambda (part)
+                  (if (null? part)
+                      (newline port)
+                      (pretty-print part port)))
+                configuration)
+      (flush-output-port port))))

gnu/installer/timezone.scm

@@ -0,0 +1,127 @@
+;;; 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 timezone)
+  #:use-module (gnu installer utils)
+  #:use-module (guix i18n)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 receive)
+  #:export (locate-childrens
+            timezone->posix-tz
+            timezone-has-child?
+            zonetab->timezone-tree
+            posix-tz->configuration))
+
+(define %not-blank
+  (char-set-complement char-set:blank))
+
+(define (posix-tz->timezone tz)
+  "Convert given TZ in Posix format like \"Europe/Paris\" into a list like
+(\"Europe\" \"Paris\")."
+  (string-split tz #\/))
+
+(define (timezone->posix-tz timezone)
+  "Convert given TIMEZONE like (\"Europe\" \"Paris\") into a Posix timezone
+like \"Europe/Paris\"."
+  (string-join timezone "/"))
+
+(define (zonetab->timezones zonetab)
+  "Parse ZONETAB file and return the corresponding list of timezones."
+
+  (define (zonetab-line->posix-tz line)
+    (let ((tokens (string-tokenize line %not-blank)))
+      (match tokens
+        ((code coordinates tz _ ...)
+         tz))))
+
+  (call-with-input-file zonetab
+    (lambda (port)
+      (let* ((lines (read-lines port))
+             ;; Filter comment lines starting with '#' character.
+             (tz-lines (filter (lambda (line)
+                                 (not (eq? (string-ref line 0)
+                                           #\#)))
+                               lines)))
+        (map (lambda (line)
+               (posix-tz->timezone
+                (zonetab-line->posix-tz line)))
+             tz-lines)))))
+
+(define (timezones->timezone-tree timezones)
+  "Convert the list of timezones, TIMEZONES into a tree under the form:
+
+	(\"America\" (\"North_Dakota\" \"New_Salem\" \"Center\"))
+
+representing America/North_Dakota/New_Salem and America/North_Dakota/Center
+timezones."
+
+  (define (remove-first lists)
+    "Remove the first element of every sublists in the argument LISTS."
+    (map (lambda (list)
+           (if (null? list) list (cdr list)))
+         lists))
+
+  (let loop ((cur-timezones timezones))
+    (match cur-timezones
+      (() '())
+      (((region . rest-region) . rest-timezones)
+       (if (null? rest-region)
+           (cons (list region) (loop rest-timezones))
+           (receive (same-region other-region)
+               (partition (lambda (timezone)
+                            (string=? (car timezone) region))
+                          cur-timezones)
+             (acons region
+                    (loop (remove-first same-region))
+                    (loop other-region))))))))
+
+(define (locate-childrens tree path)
+  "Return the childrens of the timezone indicated by PATH in the given
+TREE. Raise a condition if the PATH could not be found."
+  (let ((extract-proc (cut map car <>)))
+    (match path
+      (() (sort (extract-proc tree) string<?))
+      ((region . rest)
+       (or (and=> (assoc-ref tree region)
+                  (cut locate-childrens <> rest))
+           (raise
+            (condition
+             (&message
+              (message
+               (format #f (G_ "Unable to locate path: ~a.") path))))))))))
+
+(define (timezone-has-child? tree timezone)
+  "Return #t if the given TIMEZONE any child in TREE and #f otherwise."
+  (not (null? (locate-childrens tree timezone))))
+
+(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)))

gnu/installer/user.scm

@@ -0,0 +1,50 @@
+;;; 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 user)
+  #:use-module (guix records)
+  #:export (<user>
+            user
+            make-user
+            user-name
+            user-group
+            user-home-directory
+
+            users->configuration))
+
+(define-record-type* <user>
+  user make-user
+  user?
+  (name            user-name)
+  (group           user-group
+                   (default "users"))
+  (home-directory  user-home-directory))
+
+(define (users->configuration users)
+  "Return the configuration field for USERS."
+  `((users (cons*
+             ,@(map (lambda (user)
+                      `(user-account
+                        (name ,(user-name user))
+                        (group ,(user-group user))
+                        (home-directory ,(user-home-directory user))
+                        (supplementary-groups
+                         (quote ("wheel" "netdev"
+                                 "audio" "video")))))
+                    users)
+             %base-user-accounts))))

gnu/installer/utils.scm

@@ -0,0 +1,63 @@
+;;; 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 utils)
+  #:use-module (guix utils)
+  #:use-module (guix build utils)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 textual-ports)
+  #:export (read-lines
+            read-all
+            nearest-exact-integer
+            read-percentage
+            run-shell-command))
+
+(define* (read-lines #:optional (port (current-input-port)))
+  "Read lines from PORT and return them as a list."
+  (let loop ((line (read-line port))
+             (lines '()))
+    (if (eof-object? line)
+        (reverse lines)
+        (loop (read-line port)
+              (cons line lines)))))
+
+(define (read-all file)
+  "Return the content of the given FILE as a string."
+  (call-with-input-file file
+    get-string-all))
+
+(define (nearest-exact-integer x)
+  "Given a real number X, return the nearest exact integer, with ties going to
+the nearest exact even integer."
+  (inexact->exact (round x)))
+
+(define (read-percentage percentage)
+  "Read PERCENTAGE string and return the corresponding percentage as a
+number. If no percentage is found, return #f"
+  (let ((result (string-match "^([0-9]+)%$" percentage)))
+    (and result
+         (string->number (match:substring result 1)))))
+
+(define (run-shell-command command)
+  (call-with-temporary-output-file
+   (lambda (file port)
+     (format port "~a~%" command)
+     ;; (format port "exit~%")
+     (close port)
+     (invoke "bash" "--init-file" file))))

gnu/local.mk

@@ -46,6 +46,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/bootloader/grub.scm                       \
   %D%/bootloader/extlinux.scm                   \
   %D%/bootloader/u-boot.scm                     \
+  %D%/ci.scm					\
   %D%/packages.scm				\
   %D%/packages/abduco.scm			\
   %D%/packages/abiword.scm			\
@@ -112,6 +113,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/packages/conky.scm			\
   %D%/packages/connman.scm			\
   %D%/packages/cook.scm				\
+  %D%/packages/coq.scm				\
   %D%/packages/cpio.scm				\
   %D%/packages/cpp.scm 				\
   %D%/packages/cppi.scm				\
@@ -126,6 +128,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/packages/datamash.scm			\
   %D%/packages/datastructures.scm		\
   %D%/packages/dav.scm				\
+  %D%/packages/dbm.scm				\
   %D%/packages/dc.scm				\
   %D%/packages/debian.scm			\
   %D%/packages/debug.scm			\
@@ -154,6 +157,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/packages/elixir.scm			\
   %D%/packages/embedded.scm			\
   %D%/packages/emacs.scm			\
+  %D%/packages/emacs-xyz.scm			\
   %D%/packages/emulators.scm			\
   %D%/packages/enchant.scm			\
   %D%/packages/engineering.scm			\
@@ -348,6 +352,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/packages/pem.scm				\
   %D%/packages/perl.scm				\
   %D%/packages/perl-check.scm			\
+  %D%/packages/perl-compression.scm		\
   %D%/packages/perl-web.scm			\
   %D%/packages/photo.scm			\
   %D%/packages/phabricator.scm 			\
@@ -366,8 +371,10 @@ GNU_SYSTEM_MODULES =				\
   %D%/packages/pure.scm				\
   %D%/packages/pv.scm				\
   %D%/packages/python.scm			\
+  %D%/packages/python-compression.scm		\
   %D%/packages/python-crypto.scm		\
   %D%/packages/python-web.scm			\
+  %D%/packages/python-xyz.scm			\
   %D%/packages/toys.scm				\
   %D%/packages/tryton.scm			\
   %D%/packages/qt.scm				\
@@ -410,6 +417,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/packages/sml.scm				\
   %D%/packages/speech.scm			\
   %D%/packages/spice.scm			\
+  %D%/packages/sqlite.scm			\
   %D%/packages/ssh.scm				\
   %D%/packages/sssd.scm				\
   %D%/packages/stalonetray.scm			\
@@ -555,9 +563,47 @@ GNU_SYSTEM_MODULES =				\
   %D%/tests/ssh.scm				\
   %D%/tests/version-control.scm			\
   %D%/tests/virtualization.scm			\
-  %D%/tests/web.scm				\
+  %D%/tests/web.scm
+
+if ENABLE_INSTALLER
+
+GNU_SYSTEM_MODULES +=                           \
+  %D%/installer.scm      			\
+  %D%/installer/connman.scm			\
+  %D%/installer/final.scm			\
+  %D%/installer/hostname.scm			\
+  %D%/installer/keymap.scm			\
+  %D%/installer/locale.scm			\
+  %D%/installer/newt.scm			\
+  %D%/installer/parted.scm			\
+  %D%/installer/record.scm		        \
+  %D%/installer/services.scm			\
+  %D%/installer/steps.scm			\
+  %D%/installer/timezone.scm			\
+  %D%/installer/user.scm			\
+  %D%/installer/utils.scm			\
 						\
-  %D%/ci.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			\
+  %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			\
+  %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.
 MODULES_NOT_COMPILED +=				\
@@ -866,6 +912,7 @@ dist_patch_DATA =						\
   %D%/packages/patches/kinit-kdeinit-libpath.patch		\
   %D%/packages/patches/kio-search-smbd-on-PATH.patch		\
   %D%/packages/patches/kmod-module-directory.patch		\
+  %D%/packages/patches/kmscon-runtime-keymap-switch.patch	\
   %D%/packages/patches/kpackage-allow-external-paths.patch	\
   %D%/packages/patches/kobodeluxe-paths.patch			\
   %D%/packages/patches/kobodeluxe-enemies-pipe-decl.patch	\
@@ -873,6 +920,7 @@ dist_patch_DATA =						\
   %D%/packages/patches/kobodeluxe-manpage-minus-not-hyphen.patch	\
   %D%/packages/patches/kobodeluxe-midicon-segmentation-fault.patch	\
   %D%/packages/patches/kobodeluxe-graphics-window-signed-char.patch	\
+  %D%/packages/patches/kodi-skip-test-449.patch		\
   %D%/packages/patches/laby-make-install.patch			\
   %D%/packages/patches/ldc-bootstrap-disable-tests.patch	\
   %D%/packages/patches/ldc-disable-phobos-tests.patch		\
@@ -929,7 +977,6 @@ dist_patch_DATA =						\
   %D%/packages/patches/libsndfile-CVE-2017-8361-8363-8365.patch	\
   %D%/packages/patches/libsndfile-CVE-2017-8362.patch		\
   %D%/packages/patches/libsndfile-CVE-2017-12562.patch		\
-  %D%/packages/patches/libssh-hostname-parser-bug.patch		\
   %D%/packages/patches/libssh2-fix-build-failure-with-gcrypt.patch	\
   %D%/packages/patches/libtar-CVE-2013-4420.patch 		\
   %D%/packages/patches/libtheora-config-guess.patch		\
@@ -1029,11 +1076,13 @@ dist_patch_DATA =						\
   %D%/packages/patches/ola-readdir-r.patch			\
   %D%/packages/patches/openbabel-fix-crash-on-nwchem-output.patch	\
   %D%/packages/patches/opencascade-oce-glibc-2.26.patch		\
+  %D%/packages/patches/opencv-rgbd-aarch64-test-fix.patch	\
   %D%/packages/patches/openfoam-4.1-cleanup.patch			\
   %D%/packages/patches/openjdk-10-idlj-reproducibility.patch	\
   %D%/packages/patches/openldap-CVE-2017-9287.patch		\
   %D%/packages/patches/openocd-nrf52.patch			\
   %D%/packages/patches/opensmtpd-fix-crash.patch		\
+  %D%/packages/patches/openssh-CVE-2018-20685.patch		\
   %D%/packages/patches/openssl-runpath.patch			\
   %D%/packages/patches/openssl-1.1-c-rehash-in.patch		\
   %D%/packages/patches/openssl-c-rehash-in.patch		\

gnu/packages.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2016, 2017 Alex Kost <alezost@gmail.com>
@@ -28,11 +28,14 @@ (define-module (gnu packages)
   #:use-module (guix memoization)
   #:use-module ((guix build utils)
                 #:select ((package-name->name+version
-                           . hyphen-separated-name->name+version)))
+                           . hyphen-separated-name->name+version)
+                          mkdir-p))
   #:autoload   (guix profiles) (packages->manifest)
   #:use-module (guix describe)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
+  #:autoload   (ice-9 binary-ports) (put-bytevector)
+  #:autoload   (system base compile) (compile)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
@@ -50,14 +53,18 @@ (define-module (gnu packages)
             %default-package-module-path
 
             fold-packages
+            fold-available-packages
 
             find-packages-by-name
+            find-package-locations
             find-best-packages-by-name
-            find-newest-available-packages
 
             specification->package
             specification->package+output
-            specifications->manifest))
+            specification->location
+            specifications->manifest
+
+            generate-package-cache))
 
 ;;; Commentary:
 ;;;
@@ -136,6 +143,14 @@ (define %default-package-module-path
   ;; Default search path for package modules.
   `((,%distro-root-directory . "gnu/packages")))
 
+(define (cache-is-authoritative?)
+  "Return true if the pre-computed package cache is authoritative.  It is not
+authoritative when entries have been added via GUIX_PACKAGE_PATH or '-L'
+flags."
+  (equal? (%package-module-path)
+          (append %default-package-module-path
+                  (package-path-entries))))
+
 (define %package-module-path
   ;; Search path for package modules.  Each item must be either a directory
   ;; name or a pair whose car is a directory and whose cdr is a sub-directory
@@ -168,6 +183,50 @@ (define %patch-path
               directory))
         %load-path)))
 
+(define (fold-available-packages proc init)
+  "Fold PROC over the list of available packages.  For each available package,
+PROC is called along these lines:
+
+  (PROC NAME VERSION RESULT
+        #:outputs OUTPUTS
+        #:location LOCATION
+        …)
+
+PROC can use #:allow-other-keys to ignore the bits it's not interested in.
+When a package cache is available, this procedure does not actually load any
+package module."
+  (define cache
+    (load-package-cache (current-profile)))
+
+  (if (and cache (cache-is-authoritative?))
+      (vhash-fold (lambda (name vector result)
+                    (match vector
+                      (#(name version module symbol outputs
+                              supported? deprecated?
+                              file line column)
+                       (proc name version result
+                             #:outputs outputs
+                             #:location (and file
+                                             (location file line column))
+                             #:supported? supported?
+                             #:deprecated? deprecated?))))
+                  init
+                  cache)
+      (fold-packages (lambda (package result)
+                       (proc (package-name package)
+                             (package-version package)
+                             result
+                             #:outputs (package-outputs package)
+                             #:location (package-location package)
+                             #:supported?
+                             (->bool
+                              (member (%current-system)
+                                      (package-supported-systems package)))
+                             #:deprecated?
+                             (->bool
+                              (package-superseded package))))
+                     init)))
+
 (define* (fold-packages proc init
                         #:optional
                         (modules (all-modules (%package-module-path)
@@ -184,7 +243,35 @@ (define* (fold-packages proc init
                                 init
                                 modules))
 
-(define find-packages-by-name
+(define %package-cache-file
+  ;; Location of the package cache.
+  "/lib/guix/package.cache")
+
+(define load-package-cache
+  (mlambda (profile)
+    "Attempt to load the package cache.  On success return a vhash keyed by
+package names.  Return #f on failure."
+    (match profile
+      (#f #f)
+      (profile
+       (catch 'system-error
+         (lambda ()
+           (define lst
+             (load-compiled (string-append profile %package-cache-file)))
+           (fold (lambda (item vhash)
+                   (match item
+                     (#(name version module symbol outputs
+                             supported? deprecated?
+                             file line column)
+                      (vhash-cons name item vhash))))
+                 vlist-null
+                 lst))
+         (lambda args
+           (if (= ENOENT (system-error-errno args))
+               #f
+               (apply throw args))))))))
+
+(define find-packages-by-name/direct              ;bypass the cache
   (let ((packages (delay
                     (fold-packages (lambda (p r)
                                      (vhash-cons (package-name p) p r))
@@ -203,28 +290,61 @@ (define find-packages-by-name
                     matching)
             matching)))))
 
-(define find-newest-available-packages
+(define (cache-lookup cache name)
-  (mlambda ()
+  "Lookup package NAME in CACHE.  Return a list sorted in increasing version
-    "Return a vhash keyed by package names, and with
+order."
-associated values of the form
+  (define (package-version<? v1 v2)
+    (version>? (vector-ref v2 1) (vector-ref v1 1)))
 
-  (newest-version newest-package ...)
+  (sort (vhash-fold* cons '() name cache)
+        package-version<?))
 
-where the preferred package is listed first."
+(define* (find-packages-by-name name #:optional version)
+  "Return the list of packages with the given NAME.  If VERSION is not #f,
+then only return packages whose version is prefixed by VERSION, sorted in
+decreasing version order."
+  (define cache
+    (load-package-cache (current-profile)))
 
-    ;; FIXME: Currently, the preferred package is whichever one
+  (if (and (cache-is-authoritative?) cache)
-    ;; was found last by 'fold-packages'.  Find a better solution.
+      (match (cache-lookup cache name)
-    (fold-packages (lambda (p r)
+        (#f #f)
-                     (let ((name    (package-name p))
+        ((#(_ versions modules symbols _ _ _ _ _ _) ...)
-                           (version (package-version p)))
+         (fold (lambda (version* module symbol result)
-                       (match (vhash-assoc name r)
+                 (if (or (not version)
-                         ((_ newest-so-far . pkgs)
+                         (version-prefix? version version*))
-                          (case (version-compare version newest-so-far)
+                     (cons (module-ref (resolve-interface module)
-                            ((>) (vhash-cons name `(,version ,p) r))
+                                       symbol)
-                            ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
+                           result)
-                            ((<) r)))
+                     result))
-                         (#f (vhash-cons name `(,version ,p) r)))))
+               '()
-                   vlist-null)))
+               versions modules symbols)))
+      (find-packages-by-name/direct name version)))
+
+(define* (find-package-locations name #:optional version)
+  "Return a list of version/location pairs corresponding to each package
+matching NAME and VERSION."
+  (define cache
+    (load-package-cache (current-profile)))
+
+  (if (and cache (cache-is-authoritative?))
+      (match (cache-lookup cache name)
+        (#f '())
+        ((#(name versions modules symbols outputs
+                 supported? deprecated?
+                 files lines columns) ...)
+         (fold (lambda (version* file line column result)
+                 (if (and file
+                          (or (not version)
+                              (version-prefix? version version*)))
+                     (alist-cons version* (location file line column)
+                                 result)
+                     result))
+               '()
+               versions files lines columns)))
+      (map (lambda (package)
+             (cons (package-version package) (package-location package)))
+           (find-packages-by-name/direct name version))))
 
 (define (find-best-packages-by-name name version)
   "If version is #f, return the list of packages named NAME with the highest
@@ -232,9 +352,64 @@ (define (find-best-packages-by-name name version)
 VERSION."
   (if version
       (find-packages-by-name name version)
-      (match (vhash-assoc name (find-newest-available-packages))
+      (match (find-packages-by-name name)
-        ((_ version pkgs ...) pkgs)
+        (()
-        (#f '()))))
+         '())
+        ((matches ...)
+         ;; Return the subset of MATCHES with the higher version number.
+         (let ((highest (package-version (first matches))))
+           (take-while (lambda (p)
+                         (string=? (package-version p) highest))
+                       matches))))))
+
+(define (generate-package-cache directory)
+  "Generate under DIRECTORY a cache of all the available packages.
+
+The primary purpose of the cache is to speed up package lookup by name such
+that we don't have to traverse and load all the package modules, thereby also
+reducing the memory footprint."
+  (define cache-file
+    (string-append directory %package-cache-file))
+
+  (define (expand-cache module symbol variable result)
+    (match (false-if-exception (variable-ref variable))
+      ((? package? package)
+       (if (hidden-package? package)
+           result
+           (cons `#(,(package-name package)
+                    ,(package-version package)
+                    ,(module-name module)
+                    ,symbol
+                    ,(package-outputs package)
+                    ,(->bool (member (%current-system)
+                                     (package-supported-systems package)))
+                    ,(->bool (package-superseded package))
+                    ,@(let ((loc (package-location package)))
+                        (if loc
+                            `(,(location-file loc)
+                              ,(location-line loc)
+                              ,(location-column loc))
+                            '(#f #f #f))))
+                 result)))
+      (_
+       result)))
+
+  (define exp
+    (fold-module-public-variables* expand-cache '()
+                                   (all-modules (%package-module-path)
+                                                #:warn
+                                                warn-about-load-error)))
+
+  (mkdir-p (dirname cache-file))
+  (call-with-output-file cache-file
+    (lambda (port)
+      ;; Store the cache as a '.go' file.  This makes loading fast and reduces
+      ;; heap usage since some of the static data is directly mmapped.
+      (put-bytevector port
+                      (compile `'(,@exp)
+                               #:to 'bytecode
+                               #:opts '(#:to-file? #t)))))
+  cache-file)
 
 
 (define %sigint-prompt
@@ -290,6 +465,30 @@ (define (specification->package spec)
   (let-values (((name version) (package-name->name+version spec)))
     (%find-package spec name version)))
 
+(define (specification->location spec)
+  "Return the location of the highest-numbered package matching SPEC, a
+specification such as \"guile@2\" or \"emacs\"."
+  (let-values (((name version) (package-name->name+version spec)))
+    (match (find-package-locations name version)
+      (()
+       (if version
+           (leave (G_ "~A: package not found for version ~a~%") name version)
+           (leave (G_ "~A: unknown package~%") name)))
+      (lst
+       (let* ((highest   (match lst (((version . _) _ ...) version)))
+              (locations (take-while (match-lambda
+                                       ((version . location)
+                                        (string=? version highest)))
+                                     lst)))
+         (match locations
+           (((version . location) . rest)
+            (unless (null? rest)
+              (warning (G_ "ambiguous package specification `~a'~%") spec)
+              (warning (G_ "choosing ~a@~a from ~a~%")
+                       name version
+                       (location->string location)))
+            location)))))))
+
 (define* (specification->package+output spec #:optional (output "out"))
   "Return the package and output specified by SPEC, or #f and #f; SPEC may
 optionally contain a version number and an output name, as in these examples:

gnu/packages/ada.scm

@@ -26,7 +26,8 @@ (define-module (gnu packages ada)
   #:use-module (gnu packages)
   #:use-module (gnu packages check)
   #:use-module (gnu packages compression)
-  #:use-module (gnu packages python))
+  #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz))
 
 (define-public python2-langkit
   (let ((commit "fe0bc8bf60dbd2937759810df76ac420d99fc15f")

gnu/packages/admin.scm

@@ -13,7 +13,7 @@
 ;;; Copyright © 2016 Peter Feigl <peter.feigl@nexoid.at>
 ;;; Copyright © 2016 John J. Foerch <jjfoerch@earthlink.net>
 ;;; Copyright © 2016, 2017 Nils Gillmann <ng0@n0.is>
-;;; Copyright © 2016, 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2016, 2017, 2018, 2019 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2016 John Darrington <jmd@gnu.org>
 ;;; Copyright © 2017 Ben Sturmfels <ben@sturm.com.au>
 ;;; Copyright © 2017 Ethan R. Jones <doubleplusgood23@gmail.com>
@@ -86,6 +86,7 @@ (define-module (gnu packages admin)
   #:use-module (gnu packages python)
   #:use-module (gnu packages python-crypto)
   #:use-module (gnu packages python-web)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages qt)
   #:use-module (gnu packages terminals)
   #:use-module (gnu packages texinfo)
@@ -1510,7 +1511,7 @@ (define-public libcap-ng
 (define-public smartmontools
   (package
     (name "smartmontools")
-    (version "6.6")
+    (version "7.0")
     (source (origin
               (method url-fetch)
               (uri (string-append
@@ -1518,7 +1519,7 @@ (define-public smartmontools
                     version "/smartmontools-" version ".tar.gz"))
               (sha256
                (base32
-                "0m1hllbb78rr6cxkbalmz1gqkl0psgq8rrmv4gwcmz34n07kvx2i"))))
+                "077nx2rn9szrg6isdh0938zbp7vr3dsyxl4jdyyzv1xwhqksrqg5"))))
     (build-system gnu-build-system)
     (inputs `(("libcap-ng" ,libcap-ng)))
     (home-page "https://www.smartmontools.org/")

gnu/packages/adns.scm

@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015, 2016, 2018 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,6 +22,7 @@ (define-module (gnu packages adns)
   #:use-module (guix licenses)
   #:use-module (guix packages)
   #:use-module (guix download)
+  #:use-module (guix build-system cmake)
   #:use-module (guix build-system gnu)
   #:use-module (gnu packages pkg-config))
 
@@ -80,3 +82,33 @@ (define-public c-ares
 The primary examples of such applications are servers which communicate with
 multiple clients and programs with graphical user interfaces.")
     (license (x11-style "https://c-ares.haxx.se/license.html"))))
+
+;; XXX: temporary package for tensorflow / grpc
+(define-public c-ares-next
+  (package
+    (name "c-ares")
+    (version "1.15.0")
+    (source (origin
+              (method url-fetch)
+              (uri (string-append
+                    "https://c-ares.haxx.se/download/" name "-" version
+                    ".tar.gz"))
+              (sha256
+               (base32
+                "0lk8knip4xk6qzksdkn7085mmgm4ixfczdyyjw656c193y3rgnvc"))))
+    (build-system cmake-build-system)
+    (arguments
+     `(#:tests? #f ; some tests seem to require Internet connection
+       #:configure-flags
+       (list "-DCARES_BUILD_TESTS=ON")))
+    (native-inputs
+     `(("pkg-config" ,pkg-config)))
+    (home-page "https://c-ares.haxx.se/")
+    (synopsis "C library for asynchronous DNS requests")
+    (description
+      "C-ares is a C library that performs DNS requests and name resolution
+asynchronously.  It is intended for applications which need to perform DNS
+queries without blocking, or need to perform multiple DNS queries in parallel.
+The primary examples of such applications are servers which communicate with
+multiple clients and programs with graphical user interfaces.")
+    (license (x11-style "https://c-ares.haxx.se/license.html"))))

gnu/packages/android.scm

@@ -41,6 +41,7 @@ (define-module (gnu packages android)
   #:use-module (gnu packages python)
   #:use-module (gnu packages python-crypto)
   #:use-module (gnu packages python-web)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages selinux)
   #:use-module (gnu packages serialization)
   #:use-module (gnu packages ssh)

gnu/packages/animation.scm

@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2019 Pkill -9 <pkill9@runbox.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -258,3 +259,44 @@ (define-public papagayo
 type in the words being spoken, then drag the words on top of the sound’s
 waveform until they line up with the proper sounds.")
       (license license:gpl3+))))
+
+(define-public pencil2d
+  (package
+    (name "pencil2d")
+    (version "0.6.2")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/pencil2d/pencil")
+                    (commit (string-append "v" version))))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "1iv7drwxs32mqs3hybjx2lxyqn8cv2b4rw9ny7gzdacsbhi65knr"))))
+    (build-system gnu-build-system)
+    (inputs
+     `(("qtbase" ,qtbase)
+       ("qtxmlpatterns" ,qtxmlpatterns)
+       ("qtmultimedia" ,qtmultimedia)
+       ("qtsvg" ,qtsvg)))
+    (arguments
+     `(#:phases
+       (modify-phases %standard-phases
+         (replace 'configure
+           (lambda* (#:key inputs outputs #:allow-other-keys)
+             (let ((out (assoc-ref outputs "out")))
+               (invoke "qmake" (string-append "PREFIX=" out)))))
+         (add-after 'install 'wrap-executable
+           (lambda* (#:key inputs outputs #:allow-other-keys)
+             (let ((out (assoc-ref outputs "out"))
+                   (plugin-path (getenv "QT_PLUGIN_PATH")))
+               (wrap-program (string-append out "/bin/pencil2d")
+                 `("QT_PLUGIN_PATH" ":" prefix (,plugin-path)))
+               #t))))))
+    (home-page "https://www.pencil2d.org")
+    (synopsis "Make 2D hand-drawn animations")
+    (description
+     "Pencil2D is an easy-to-use and intuitive animation and drawing tool.  It
+lets you create traditional hand-drawn animations (cartoons) using both bitmap
+and vector graphics.")
+    (license license:gpl2)))

gnu/packages/apl.scm

@@ -25,8 +25,8 @@ (define-module (gnu packages apl)
   #:use-module (guix build-system gnu)
   #:use-module (gnu packages gettext)
   #:use-module (gnu packages maths)
-  #:use-module (gnu packages databases)
+  #:use-module (gnu packages readline)
-  #:use-module (gnu packages readline))
+  #:use-module (gnu packages sqlite))
 
 (define-public apl
   (package

gnu/packages/audio.scm

@@ -8,7 +8,7 @@
 ;;; Copyright © 2016, 2017 Alex Griffin <a@ajgrf.com>
 ;;; Copyright © 2016 Nils Gillmann <ng0@n0.is>
 ;;; Copyright © 2016 Lukas Gradl <lgradl@openmailbox.org>
-;;; Copyright © 2016, 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2016, 2017, 2018, 2019 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
 ;;; Copyright © 2018 okapi <okapi@firemail.cc>
 ;;; Copyright © 2018 Maxim Cournoyer <maxim.cournoyer@gmail.com>
@@ -18,6 +18,7 @@
 ;;; Copyright © 2018 Thorsten Wilms <t_w_@freenet.de>
 ;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2018 Brendan Tildesley <brendan.tildesley@openmailbox.org>
+;;; Copyright © 2019 Pierre Langlois <pierre.langlois@gmx.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -57,7 +58,7 @@ (define-module (gnu packages audio)
   #:use-module (gnu packages check)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages curl)
-  #:use-module (gnu packages databases)
+  #:use-module (gnu packages dbm)
   #:use-module (gnu packages emacs)
   #:use-module (gnu packages file)
   #:use-module (gnu packages flex)
@@ -82,6 +83,7 @@ (define-module (gnu packages audio)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages pulseaudio)  ;libsndfile, libsamplerate
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages rdf)
   #:use-module (gnu packages readline)
   #:use-module (gnu packages serialization)
@@ -761,7 +763,7 @@ (define-public swh-plugins-lv2
 (define-public csound
   (package
     (name "csound")
-    (version "6.11.0")
+    (version "6.12.0")
     (source (origin
               (method git-fetch)
               (uri (git-reference
@@ -770,7 +772,7 @@ (define-public csound
               (file-name (git-file-name name version))
               (sha256
                (base32
-                "1hlkrnv3gghx4v382nl6v6k2k1dzm5ddk35m5g3q6pzc959726s7"))))
+                "0pv4s54cayvavdp6y30n3r1l5x83x9whyyd2v24y0dh224v3hbxi"))))
     (build-system cmake-build-system)
     (inputs
      `(("alsa-lib" ,alsa-lib)
@@ -2154,7 +2156,11 @@ (define-public qjackctl
                 "1rzzqa39a6llr52vjkjr0a86nc776kmr5xs52qqga8ms9697psz5"))))
     (build-system gnu-build-system)
     (arguments
-     '(#:tests? #f))                    ; no check target
+     '(#:tests? #f ;; no check target
+       ;; Disable xunique to prevent X hanging when starting qjackctl in
+       ;; tiling window managers such as StumpWM or i3
+       ;; (see https://github.com/rncbc/qjackctl/issues/13).
+       #:configure-flags '("--disable-xunique")))
     (inputs
      `(("jack" ,jack-1)
        ("alsa-lib" ,alsa-lib)

gnu/packages/avahi.scm

@@ -24,7 +24,7 @@ (define-module (gnu packages avahi)
   #:use-module (guix download)
   #:use-module (guix build-system gnu)
   #:use-module (gnu packages)
-  #:use-module (gnu packages databases)
+  #:use-module (gnu packages dbm)
   #:use-module (gnu packages libdaemon)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages pkg-config)

gnu/packages/backup.scm

@@ -46,6 +46,7 @@ (define-module (gnu packages backup)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages crypto)
   #:use-module (gnu packages databases)
+  #:use-module (gnu packages dbm)
   #:use-module (gnu packages dejagnu)
   #:use-module (gnu packages ftp)
   #:use-module (gnu packages glib)
@@ -62,6 +63,7 @@ (define-module (gnu packages backup)
   #:use-module (gnu packages python)
   #:use-module (gnu packages python-crypto)
   #:use-module (gnu packages python-web)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages rsync)
   #:use-module (gnu packages ssh)
   #:use-module (gnu packages tls)

gnu/packages/benchmark.scm

@@ -29,6 +29,7 @@ (define-module (gnu packages benchmark)
   #:use-module (gnu packages maths)
   #:use-module (gnu packages mpi)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages storage)
   #:use-module (ice-9 match))
 

gnu/packages/bioconductor.scm

@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2018 Roel Janssen <roel@gnu.org>
+;;; Copyright © 2017, 2018 Roel Janssen <roel@gnu.org>
 ;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -228,6 +228,53 @@ (define-public r-txdb-mmusculus-ucsc-mm9-knowngene
     (license license:artistic2.0)))
 
 
+(define-public r-biocgenerics
+  (package
+    (name "r-biocgenerics")
+    (version "0.28.0")
+    (source (origin
+              (method url-fetch)
+              (uri (bioconductor-uri "BiocGenerics" version))
+              (sha256
+               (base32
+                "0cvpsrhg7sn7lpqgxvqrsagv6j7xj5rafq5xdjfd8zc4gxrs5rb8"))))
+    (properties
+     `((upstream-name . "BiocGenerics")))
+    (build-system r-build-system)
+    (home-page "https://bioconductor.org/packages/BiocGenerics")
+    (synopsis "S4 generic functions for Bioconductor")
+    (description
+     "This package provides S4 generic functions needed by many Bioconductor
+packages.")
+    (license license:artistic2.0)))
+
+(define-public r-annotate
+  (package
+    (name "r-annotate")
+    (version "1.60.0")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (bioconductor-uri "annotate" version))
+       (sha256
+        (base32
+         "0p6c96lay23a67dyirgnwzm2yw22m592z780vy6p4nqwla8ha18n"))))
+    (build-system r-build-system)
+    (propagated-inputs
+     `(("r-annotationdbi" ,r-annotationdbi)
+       ("r-biobase" ,r-biobase)
+       ("r-biocgenerics" ,r-biocgenerics)
+       ("r-dbi" ,r-dbi)
+       ("r-rcurl" ,r-rcurl)
+       ("r-xml" ,r-xml)
+       ("r-xtable" ,r-xtable)))
+    (home-page
+     "https://bioconductor.org/packages/annotate")
+    (synopsis "Annotation for microarrays")
+    (description "This package provides R environments for the annotation of
+microarrays.")
+    (license license:artistic2.0)))
+
 (define-public r-hpar
   (package
     (name "r-hpar")

gnu/packages/bioinformatics.scm

@@ -98,7 +98,9 @@ (define-module (gnu packages bioinformatics)
   #:use-module (gnu packages popt)
   #:use-module (gnu packages protobuf)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-compression)
   #:use-module (gnu packages python-web)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages readline)
   #:use-module (gnu packages ruby)
   #:use-module (gnu packages serialization)
@@ -6338,63 +6340,6 @@ (define-public r-centipede
 information as possible.")
     (license (list license:gpl2+ license:gpl3+))))
 
-(define-public r-vegan
-  (package
-    (name "r-vegan")
-    (version "2.5-3")
-    (source
-     (origin
-       (method url-fetch)
-       (uri (cran-uri "vegan" version))
-       (sha256
-        (base32
-         "023xznh0iy0496icpchadmp7a3rk3nj9s48fvwlvp3dssw58yp3c"))))
-    (build-system r-build-system)
-    (native-inputs
-     `(("gfortran" ,gfortran)))
-    (propagated-inputs
-     `(("r-cluster" ,r-cluster)
-       ("r-knitr" ,r-knitr) ; needed for vignettes
-       ("r-lattice" ,r-lattice)
-       ("r-mass" ,r-mass)
-       ("r-mgcv" ,r-mgcv)
-       ("r-permute" ,r-permute)))
-    (home-page "https://cran.r-project.org/web/packages/vegan")
-    (synopsis "Functions for community ecology")
-    (description
-     "The vegan package provides tools for descriptive community ecology.  It
-has most basic functions of diversity analysis, community ordination and
-dissimilarity analysis.  Most of its multivariate tools can be used for other
-data types as well.")
-    (license license:gpl2+)))
-
-(define-public r-annotate
-  (package
-    (name "r-annotate")
-    (version "1.60.0")
-    (source
-     (origin
-       (method url-fetch)
-       (uri (bioconductor-uri "annotate" version))
-       (sha256
-        (base32
-         "0p6c96lay23a67dyirgnwzm2yw22m592z780vy6p4nqwla8ha18n"))))
-    (build-system r-build-system)
-    (propagated-inputs
-     `(("r-annotationdbi" ,r-annotationdbi)
-       ("r-biobase" ,r-biobase)
-       ("r-biocgenerics" ,r-biocgenerics)
-       ("r-dbi" ,r-dbi)
-       ("r-rcurl" ,r-rcurl)
-       ("r-xml" ,r-xml)
-       ("r-xtable" ,r-xtable)))
-    (home-page
-     "https://bioconductor.org/packages/annotate")
-    (synopsis "Annotation for microarrays")
-    (description "This package provides R environments for the annotation of
-microarrays.")
-    (license license:artistic2.0)))
-
 (define-public r-copynumber
   (package
     (name "r-copynumber")
@@ -7092,26 +7037,6 @@ (define-public r-acsnminer
 barplots or heatmaps.")
     (license license:gpl2+)))
 
-(define-public r-biocgenerics
-  (package
-    (name "r-biocgenerics")
-    (version "0.28.0")
-    (source (origin
-              (method url-fetch)
-              (uri (bioconductor-uri "BiocGenerics" version))
-              (sha256
-               (base32
-                "0cvpsrhg7sn7lpqgxvqrsagv6j7xj5rafq5xdjfd8zc4gxrs5rb8"))))
-    (properties
-     `((upstream-name . "BiocGenerics")))
-    (build-system r-build-system)
-    (home-page "https://bioconductor.org/packages/BiocGenerics")
-    (synopsis "S4 generic functions for Bioconductor")
-    (description
-     "This package provides S4 generic functions needed by many Bioconductor
-packages.")
-    (license license:artistic2.0)))
-
 (define-public r-biocinstaller
   (package
     (name "r-biocinstaller")

gnu/packages/bittorrent.scm

@@ -41,7 +41,6 @@ (define-module (gnu packages bittorrent)
   #:use-module (gnu packages crypto)
   #:use-module (gnu packages curl)
   #:use-module (gnu packages cyrus-sasl)
-  #:use-module (gnu packages databases)
   #:use-module (gnu packages file)
   #:use-module (gnu packages freedesktop)
   #:use-module (gnu packages glib)
@@ -57,7 +56,9 @@ (define-module (gnu packages bittorrent)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
   #:use-module (gnu packages python-crypto)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages qt)
+  #:use-module (gnu packages sqlite)
   #:use-module (gnu packages ssh)
   #:use-module (gnu packages tls)
   #:use-module (gnu packages xml))

gnu/packages/bootloaders.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2015 Leo Famulari <leo@famulari.name>
 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
@@ -8,6 +8,7 @@
 ;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
 ;;; Copyright © 2017, 2018 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2019 nee <nee@cock.li>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -55,6 +56,7 @@ (define-module (gnu packages bootloaders)
   #:use-module (gnu packages swig)
   #:use-module (gnu packages valgrind)
   #:use-module (gnu packages virtualization)
+  #:use-module (gnu packages xorg)
   #:use-module (gnu packages web)
   #:use-module (guix build-system gnu)
   #:use-module (guix download)
@@ -110,6 +112,12 @@ (define-public grub
                      ;; Make the font visible.
                      (copy-file (assoc-ref inputs "unifont") "unifont.bdf.gz")
                      (system* "gunzip" "unifont.bdf.gz")
+
+                     ;; Give the absolute file name of 'ckbcomp'.
+                     (substitute* "util/grub-kbdcomp.in"
+                       (("^ckbcomp ")
+                        (string-append (assoc-ref inputs "console-setup")
+                                       "/bin/ckbcomp ")))
                      #t))
                   (add-before 'check 'disable-flaky-test
                     (lambda _
@@ -134,6 +142,10 @@ (define-public grub
        ;; to determine whether the root file system is RAID.
        ("mdadm" ,mdadm)
 
+       ;; Console-setup's ckbcomp is invoked by grub-kbdcomp.  It is required
+       ;; for generating alternative keyboard layouts.
+       ("console-setup" ,console-setup)
+
        ("freetype" ,freetype)
        ;; ("libusb" ,libusb)
        ;; ("fuse" ,fuse)
@@ -717,7 +729,14 @@ (define-public vboot-utils
                                         ".drv-0/source")))
                       ;; Tests require write permissions to many of these files.
                       (for-each make-file-writable (find-files "tests/futility"))
-                      #t)))
+                      #t))
+                  (add-after 'install 'install-devkeys
+                    (lambda* (#:key outputs #:allow-other-keys)
+                      (let* ((out (assoc-ref outputs "out"))
+                             (share (string-append out "/share/vboot-utils")))
+                        (copy-recursively "tests/devkeys"
+                                          (string-append share "/devkeys"))
+                        #t))))
        #:test-target "runtests"))
     (native-inputs
      `(("pkg-config" ,pkg-config)

gnu/packages/calendar.scm

@@ -32,7 +32,6 @@ (define-module (gnu packages calendar)
   #:use-module (guix build-system python)
   #:use-module (gnu packages base)
   #:use-module (gnu packages check)
-  #:use-module (gnu packages databases)
   #:use-module (gnu packages dav)
   #:use-module (gnu packages freedesktop)
   #:use-module (gnu packages glib)
@@ -40,6 +39,8 @@ (define-module (gnu packages calendar)
   #:use-module (gnu packages perl)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
+  #:use-module (gnu packages sqlite)
   #:use-module (gnu packages time)
   #:use-module (gnu packages xml)
   #:use-module (srfi srfi-26))

gnu/packages/check.scm

@@ -47,13 +47,20 @@
 (define-module (gnu packages check)
   #:use-module (gnu packages)
   #:use-module (gnu packages autotools)
+  #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages compression)
+  #:use-module (gnu packages linux)
   #:use-module (gnu packages llvm)
+  #:use-module (gnu packages glib)
+  #:use-module (gnu packages gnome)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages gtk)
   #:use-module (gnu packages perl)
+  #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
   #:use-module (gnu packages python-web)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages time)
   #:use-module (guix utils)
   #:use-module ((guix licenses) #:prefix license:)
@@ -2153,3 +2160,45 @@ (define-public libfaketime
 @code{LD_PRELOAD} environment variable.  The @command{faketime} command
 provides a simple way to achieve this.")
     (license license:gpl2)))
+
+(define-public umockdev
+  (package
+    (name "umockdev")
+    (version "0.11.3")
+    (source (origin
+              (method url-fetch)
+              (uri (string-append "https://github.com/martinpitt/umockdev/"
+                                  "releases/download/" version  "/"
+                                  "umockdev-" version ".tar.xz"))
+              (sha256
+               (base32
+                "1in2hdan1g62wpvgjlj8mci85551ipr1964j2b9j06gm3blpihcx"))))
+    (build-system gnu-build-system)
+    (arguments
+     `(#:phases
+       (modify-phases %standard-phases
+         (add-after 'unpack 'skip-broken-test
+           (lambda _
+             (substitute* "tests/test-umockdev.c"
+               (("/\\* sys/ in other dir")
+                (string-append "return; // ")))
+             #t)))))
+    (native-inputs
+     `(("vala" ,vala)
+       ("python" ,python) ; for tests
+       ("which" ,which) ; for tests
+       ("gtk-doc" ,gtk-doc)
+       ("pkg-config" ,pkg-config)))
+    (inputs
+     `(("glib" ,glib)
+       ("eudev" ,eudev)
+       ("libgudev" ,libgudev)
+       ("gobject-introspection" ,gobject-introspection)))
+    (home-page "https://github.com/martinpitt/umockdev/")
+    (synopsis "Mock hardware devices for creating unit tests")
+    (description "umockdev mocks hardware devices for creating integration
+tests for hardware related libraries and programs.  It also provides tools to
+record the properties and behaviour of particular devices, and to run a
+program or test suite under a test bed with the previously recorded devices
+loaded.")
+    (license license:lgpl2.1+)))

gnu/packages/chemistry.scm

@@ -33,6 +33,7 @@ (define-module (gnu packages chemistry)
   #:use-module (gnu packages maths)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages qt)
   #:use-module (gnu packages xml)
   #:use-module (guix build-system cmake)

gnu/packages/ci.scm

@@ -36,6 +36,7 @@ (define-module (gnu packages ci)
   #:use-module (gnu packages mail)
   #:use-module (gnu packages package-management)
   #:use-module (gnu packages perl)
+  #:use-module (gnu packages perl-compression)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages tls)
   #:use-module (gnu packages texinfo)

gnu/packages/cluster.scm

@@ -24,7 +24,7 @@ (define-module (gnu packages cluster)
   #:use-module (guix packages)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages pkg-config)
-  #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages texinfo)
   #:use-module (gnu packages tls))
 

gnu/packages/cobol.scm

@@ -22,7 +22,7 @@ (define-module (gnu packages cobol)
   #:use-module (guix licenses)
   #:use-module (guix packages)
   #:use-module (guix download)
-  #:use-module (gnu packages databases)
+  #:use-module (gnu packages dbm)
   #:use-module (gnu packages multiprecision)
   #:use-module (gnu packages ncurses)
   #:use-module (gnu packages perl))

gnu/packages/code.scm

@@ -42,7 +42,6 @@ (define-module (gnu packages code)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages cpp)
-  #:use-module (gnu packages databases)
   #:use-module (gnu packages emacs)
   #:use-module (gnu packages gcc)
   #:use-module (gnu packages graphviz)
@@ -50,6 +49,7 @@ (define-module (gnu packages code)
   #:use-module (gnu packages perl)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages sqlite)
   #:use-module (gnu packages texinfo)
   #:use-module (gnu packages ncurses)
   #:use-module (gnu packages llvm)

gnu/packages/compression.scm

@@ -47,8 +47,6 @@ (define-module (gnu packages compression)
   #:use-module (guix git-download)
   #:use-module (guix build-system cmake)
   #:use-module (guix build-system gnu)
-  #:use-module (guix build-system perl)
-  #:use-module (guix build-system python)
   #:use-module (gnu packages)
   #:use-module (gnu packages assembly)
   #:use-module (gnu packages autotools)
@@ -60,7 +58,6 @@ (define-module (gnu packages compression)
   #:use-module (gnu packages file)
   #:use-module (gnu packages maths)
   #:use-module (gnu packages perl)
-  #:use-module (gnu packages perl-check)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
   #:use-module (gnu packages tls)
@@ -463,44 +460,6 @@ (define-public lzo
 format are designed to be portable across platforms.")
     (license license:gpl2+)))
 
-(define-public python-lzo
-  (package
-    (name "python-lzo")
-    (version "1.12")
-    (source
-     (origin
-       (method url-fetch)
-       (uri (pypi-uri "python-lzo" version))
-       (sha256
-        (base32
-         "0iakqgd51n1cd7r3lpdylm2rgbmd16y74cra9kcapwg84mlf9a4p"))))
-    (build-system python-build-system)
-    (arguments
-     `(#:test-target "check"
-       #:phases
-       (modify-phases %standard-phases
-         (add-after 'unpack 'patch-setuppy
-           (lambda _
-             (substitute* "setup.py"
-               (("include_dirs.append\\(.*\\)")
-                (string-append "include_dirs.append('"
-                               (assoc-ref %build-inputs "lzo")
-                               "/include/lzo"
-                               "')")))
-             #t)))))
-    (inputs
-     `(("lzo" ,lzo)))
-    (home-page "https://github.com/jd-boyd/python-lzo")
-    (synopsis "Python bindings for the LZO data compression library")
-    (description
-     "Python-LZO provides Python bindings for LZO, i.e. you can access
-the LZO library from your Python scripts thereby compressing ordinary
-Python strings.")
-    (license license:gpl2+)))
-
-(define-public python2-lzo
-  (package-with-python2 python-lzo))
-
 (define-public lzop
   (package
     (name "lzop")
@@ -710,84 +669,6 @@ (define-public libmspack
 decompression of some loosely related file formats used by Microsoft.")
     (license license:lgpl2.1+)))
 
-(define-public perl-compress-raw-bzip2
-  (package
-    (name "perl-compress-raw-bzip2")
-    (version "2.081")
-    (source
-     (origin
-       (method url-fetch)
-       (uri (string-append "mirror://cpan/authors/id/P/PM/PMQS/"
-                           "Compress-Raw-Bzip2-" version ".tar.gz"))
-       (sha256
-        (base32
-         "081mpkjy688lg48997fqh3d7ja12vazmz02fw84495civg4vb4l6"))))
-    (build-system perl-build-system)
-    ;; TODO: Use our bzip2 package.
-    (home-page "https://metacpan.org/release/Compress-Raw-Bzip2")
-    (synopsis "Low-level interface to bzip2 compression library")
-    (description "This module provides a Perl interface to the bzip2
-compression library.")
-    (license license:perl-license)))
-
-(define-public perl-compress-raw-zlib
-  (package
-    (name "perl-compress-raw-zlib")
-    (version "2.081")
-    (source
-     (origin
-       (method url-fetch)
-       (uri (string-append "mirror://cpan/authors/id/P/PM/PMQS/"
-                           "Compress-Raw-Zlib-" version ".tar.gz"))
-       (sha256
-        (base32
-         "06rsm9ahp20xfyvd3jc69sd0k8vqysryxc6apzdbn96jbcsdwmp1"))))
-    (build-system perl-build-system)
-    (inputs
-     `(("zlib" ,zlib)))
-    (arguments
-     `(#:phases (modify-phases %standard-phases
-                  (add-before
-                   'configure 'configure-zlib
-                   (lambda* (#:key inputs #:allow-other-keys)
-                     (call-with-output-file "config.in"
-                       (lambda (port)
-                         (format port "
-BUILD_ZLIB = False
-INCLUDE = ~a/include
-LIB = ~:*~a/lib
-OLD_ZLIB = False
-GZIP_OS_CODE = AUTO_DETECT"
-                                 (assoc-ref inputs "zlib"))))
-                     #t)))))
-    (home-page "https://metacpan.org/release/Compress-Raw-Zlib")
-    (synopsis "Low-level interface to zlib compression library")
-    (description "This module provides a Perl interface to the zlib
-compression library.")
-    (license license:perl-license)))
-
-(define-public perl-io-compress
-  (package
-    (name "perl-io-compress")
-    (version "2.081")
-    (source
-     (origin
-       (method url-fetch)
-       (uri (string-append "mirror://cpan/authors/id/P/PM/PMQS/"
-                           "IO-Compress-" version ".tar.gz"))
-       (sha256
-        (base32
-         "1na66ns1g3nni0m9q5494ym4swr21hfgpv88mw8wbj2daiswf4aj"))))
-    (build-system perl-build-system)
-    (propagated-inputs
-     `(("perl-compress-raw-zlib" ,perl-compress-raw-zlib)     ; >=2.081
-       ("perl-compress-raw-bzip2" ,perl-compress-raw-bzip2))) ; >=2.081
-    (home-page "https://metacpan.org/release/IO-Compress")
-    (synopsis "IO Interface to compressed files/buffers")
-    (description "IO-Compress provides a Perl interface to allow reading and
-writing of compressed data created with the zlib and bzip2 libraries.")
-    (license license:perl-license)))
-
 (define-public lz4
   (package
     (name "lz4")
@@ -820,54 +701,6 @@ (define-public lz4
     ;; line interface programs (lz4, fullbench, fuzzer, datagen) are GPL2+.
     (license (list license:bsd-2 license:gpl2+))))
 
-(define-public python-lz4
-  (package
-    (name "python-lz4")
-    (version "0.10.1")
-    (source
-     (origin
-       (method url-fetch)
-       (uri (pypi-uri "lz4" version))
-       (sha256
-        (base32
-         "0ghv1xbaq693kgww1x9c22bplz479ls9szjsaa4ig778ls834hm0"))))
-    (build-system python-build-system)
-    (native-inputs
-     `(("python-nose" ,python-nose)
-       ("python-setuptools-scm" ,python-setuptools-scm)))
-    (home-page "https://github.com/python-lz4/python-lz4")
-    (synopsis "LZ4 bindings for Python")
-    (description
-     "This package provides python bindings for the lz4 compression library
-by Yann Collet.  The project contains bindings for the LZ4 block format and
-the LZ4 frame format.")
-    (license license:bsd-3)))
-
-(define-public python2-lz4
-  (package-with-python2 python-lz4))
-
-(define-public python-lzstring
-  (package
-    (name "python-lzstring")
-    (version "1.0.4")
-    (source
-     (origin
-       (method url-fetch)
-       (uri (pypi-uri "lzstring" version))
-       (sha256
-        (base32
-         "18ly9pppy2yspxzw7k1b23wk77k7m44rz2g0271bqgqrk3jn3yhs"))))
-    (build-system python-build-system)
-    (propagated-inputs
-     `(("python-future" ,python-future)))
-    (home-page "https://github.com/gkovacs/lz-string-python")
-    (synopsis "String compression")
-    (description "Lz-string is a string compressor library for Python.")
-    (license license:expat)))
-
-(define-public python2-lzstring
-  (package-with-python2 python-lzstring))
-
 (define-public squashfs-tools
   (package
     (name "squashfs-tools")
@@ -1197,46 +1030,6 @@ (define-public lrzip
     (license (list license:gpl3+
                    license:public-domain)))) ; most files in lzma/
 
-(define-public bitshuffle
-  (package
-    (name "bitshuffle")
-    (version "0.3.5")
-    (source (origin
-              (method url-fetch)
-              (uri (pypi-uri "bitshuffle" version))
-              (sha256
-               (base32
-                "1823x61kyax4dc2hjmc1xraskxi1193y8lvxd03vqv029jrj8cjy"))
-              (modules '((guix build utils)))
-              (snippet
-               '(begin
-                  ;; Remove generated Cython files.
-                  (delete-file "bitshuffle/h5.c")
-                  (delete-file "bitshuffle/ext.c")
-                  #t))))
-    (build-system python-build-system)
-    (arguments
-     `(#:tests? #f             ; fail: https://github.com/h5py/h5py/issues/769
-       #:phases
-       (modify-phases %standard-phases
-         (add-after 'unpack 'dont-build-native
-           (lambda _
-             (substitute* "setup.py"
-               (("'-march=native', ") ""))
-             #t)))))
-    (inputs
-     `(("numpy" ,python-numpy)
-       ("h5py" ,python-h5py)
-       ("hdf5" ,hdf5)))
-    (native-inputs
-     `(("cython" ,python-cython)))
-    (home-page "https://github.com/kiyo-masui/bitshuffle")
-    (synopsis "Filter for improving compression of typed binary data")
-    (description "Bitshuffle is an algorithm that rearranges typed, binary data
-for improving compression, as well as a python/C package that implements this
-algorithm within the Numpy framework.")
-    (license license:expat)))
-
 (define-public snappy
   (package
     (name "snappy")
@@ -1263,44 +1056,6 @@ (define-public snappy
 100% bigger.")
     (license license:asl2.0)))
 
-(define-public bitshuffle-for-snappy
-  (package
-    (inherit bitshuffle)
-    (name "bitshuffle-for-snappy")
-    (build-system gnu-build-system)
-    (arguments
-     (substitute-keyword-arguments (package-arguments bitshuffle)
-       ((#:tests? _ #f) #f)
-       ((#:phases phases)
-        `(modify-phases %standard-phases
-           (replace 'configure
-             (lambda* (#:key outputs #:allow-other-keys)
-               (with-output-to-file "Makefile"
-                 (lambda _
-                   (format #t "\
-libbitshuffle.so: src/bitshuffle.o src/bitshuffle_core.o src/iochain.o lz4/lz4.o
-\tgcc -O3 -ffast-math -std=c99 -o $@ -shared -fPIC $^
-
-%.o: %.c
-\tgcc -O3 -ffast-math -std=c99 -fPIC -Isrc -Ilz4 -c $< -o $@
-
-PREFIX:=~a
-LIBDIR:=$(PREFIX)/lib
-INCLUDEDIR:=$(PREFIX)/include
-
-install: libbitshuffle.so
-\tinstall -dm755 $(LIBDIR)
-\tinstall -dm755 $(INCLUDEDIR)
-\tinstall -m755 libbitshuffle.so $(LIBDIR)
-\tinstall -m644 src/bitshuffle.h $(INCLUDEDIR)
-\tinstall -m644 src/bitshuffle_core.h $(INCLUDEDIR)
-\tinstall -m644 src/iochain.h $(INCLUDEDIR)
-\tinstall -m644 lz4/lz4.h $(INCLUDEDIR)
-" (assoc-ref outputs "out"))))
-               #t))))))
-    (inputs '())
-    (native-inputs '())))
-
 (define-public p7zip
   (package
     (name "p7zip")
@@ -1755,29 +1510,6 @@ (define-public zziplib
     ;; files carry the Zlib license; see "docs/copying.html" for details.
     (license (list license:lgpl2.0+ license:mpl1.1))))
 
-(define-public perl-archive-zip
-  (package
-    (name "perl-archive-zip")
-    (version "1.64")
-    (source
-     (origin
-       (method url-fetch)
-       (uri (string-append
-             "mirror://cpan/authors/id/P/PH/PHRED/Archive-Zip-"
-             version ".tar.gz"))
-       (sha256
-        (base32
-         "0zfinh8nx3rxzscp57vq3w8hihpdb0zs67vvalykcf402kr88pyy"))))
-    (build-system perl-build-system)
-    (native-inputs
-     ;; For tests.
-     `(("perl-test-mockmodule" ,perl-test-mockmodule)))
-    (synopsis  "Provides an interface to Zip archive files")
-    (description "The @code{Archive::Zip} module allows a Perl program to
-create, manipulate, read, and write Zip archive files.")
-    (home-page "https://metacpan.org/release/Archive-Zip")
-    (license license:perl-license)))
-
 (define-public libzip
   (package
     (name "libzip")
@@ -1838,27 +1570,6 @@ (define-public atool
 of archives.")
     (license license:gpl2+)))
 
-(define-public perl-archive-extract
-  (package
-    (name "perl-archive-extract")
-    (version "0.80")
-    (source
-     (origin
-       (method url-fetch)
-       (uri (string-append "mirror://cpan/authors/id/B/BI/BINGOS/Archive-Extract-"
-                           version ".tar.gz"))
-       (sha256
-        (base32
-         "1x15j1q6w6z8hqyqgap0lz4qbq2174wfhksy1fdd653ccbaw5jr5"))))
-    (build-system perl-build-system)
-    (home-page "https://metacpan.org/release/Archive-Extract")
-    (synopsis "Generic archive extracting mechanism")
-    (description "It allows you to extract any archive file of the type .tar,
-.tar.gz, .gz, .Z, tar.bz2, .tbz, .bz2, .zip, .xz,, .txz, .tar.xz or .lzma
-without having to worry how it does so, or use different interfaces for each
-type by using either Perl modules, or command-line tools on your system.")
-    (license license:perl-license)))
-
 (define-public lunzip
   (package
     (name "lunzip")

gnu/packages/connman.scm

@@ -34,6 +34,7 @@ (define-module (gnu packages connman)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages polkit)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages qt)
   #:use-module (gnu packages readline)
   #:use-module (gnu packages samba)

gnu/packages/cran.scm

@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2016, 2017 Ben Woodcroft <donttrustben@gmail.com>
 ;;; Copyright © 2017, 2018 Roel Janssen <roel@gnu.org>
 ;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2017 Raoul Bonnal <ilpuccio.febo@gmail.com>
@@ -82,6 +83,36 @@ (define-public r-clipr
 the system clipboards.")
     (license license:gpl3)))
 
+(define-public r-vegan
+  (package
+    (name "r-vegan")
+    (version "2.5-3")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (cran-uri "vegan" version))
+       (sha256
+        (base32
+         "023xznh0iy0496icpchadmp7a3rk3nj9s48fvwlvp3dssw58yp3c"))))
+    (build-system r-build-system)
+    (native-inputs
+     `(("gfortran" ,gfortran)))
+    (propagated-inputs
+     `(("r-cluster" ,r-cluster)
+       ("r-knitr" ,r-knitr)             ; needed for vignettes
+       ("r-lattice" ,r-lattice)
+       ("r-mass" ,r-mass)
+       ("r-mgcv" ,r-mgcv)
+       ("r-permute" ,r-permute)))
+    (home-page "https://cran.r-project.org/web/packages/vegan")
+    (synopsis "Functions for community ecology")
+    (description
+     "The vegan package provides tools for descriptive community ecology.  It
+has most basic functions of diversity analysis, community ordination and
+dissimilarity analysis.  Most of its multivariate tools can be used for other
+data types as well.")
+    (license license:gpl2+)))
+
 (define-public r-tidyverse
   (package
     (name "r-tidyverse")
@@ -2503,14 +2534,14 @@ (define-public r-ipred
 (define-public r-psych
   (package
     (name "r-psych")
-    (version "1.8.10")
+    (version "1.8.12")
     (source
      (origin
        (method url-fetch)
        (uri (cran-uri "psych" version))
        (sha256
         (base32
-         "0n3frgzsfmnan6cp3yyq5h6c28v5pd7q5a42pp6byaa7n7d1v478"))))
+         "0hvp0dkkkn0szaf5rkirr3kb8qmr4bxwl775m5wmpvn1kc25w5vf"))))
     (build-system r-build-system)
     (propagated-inputs
      `(("r-foreign" ,r-foreign)
@@ -6459,13 +6490,13 @@ (define-public r-mosaiccore
 (define-public r-ggformula
   (package
     (name "r-ggformula")
-    (version "0.9.0")
+    (version "0.9.1")
     (source
      (origin
        (method url-fetch)
        (uri (cran-uri "ggformula" version))
        (sha256
-        (base32 "1pmpdfjfbrc6kcpq70cr1kbj2qy711hw940g2aiis6l443z706kh"))))
+        (base32 "01ngx8qh9lhmagng6abx2ky54zi3iyj5bpxlnw59slagwv7l6icx"))))
     (build-system r-build-system)
     (propagated-inputs
      `(("r-ggplot2" ,r-ggplot2)
@@ -6504,6 +6535,29 @@ (define-public r-mosaicdata
 used to teach mathematics, statistics, computation and modeling.")
     (license license:gpl2+)))
 
+(define-public r-raster
+  (package
+    (name "r-raster")
+    (version "2.8-4")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (cran-uri "raster" version))
+       (sha256
+        (base32
+         "14pcfznxm5kdwd908axkr9v1l0hzxlrwd8kwrz0liqnfh9cx5rsa"))))
+    (build-system r-build-system)
+    (propagated-inputs
+     `(("r-rcpp" ,r-rcpp)
+       ("r-sp" ,r-sp)))
+    (home-page "http://www.rspatial.org/")
+    (synopsis "Geographic data analysis and modeling")
+    (description
+     "The package implements basic and high-level functions for reading,
+writing, manipulating, analyzing and modeling of gridded spatial data.
+Processing of very large files is supported.")
+    (license license:gpl3+)))
+
 (define-public r-mosaic
   (package
    (name "r-mosaic")

gnu/packages/crypto.scm

@@ -39,7 +39,6 @@ (define-module (gnu packages crypto)
   #:use-module (gnu packages check)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages cryptsetup)
-  #:use-module (gnu packages databases)
   #:use-module (gnu packages gettext)
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages image)
@@ -53,10 +52,12 @@ (define-module (gnu packages crypto)
   #:use-module (gnu packages perl-check)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages readline)
   #:use-module (gnu packages search)
   #:use-module (gnu packages serialization)
   #:use-module (gnu packages shells)
+  #:use-module (gnu packages sqlite)
   #:use-module (gnu packages tcl)
   #:use-module (gnu packages tls)
   #:use-module (gnu packages xml)

gnu/packages/cups.scm

@@ -40,6 +40,7 @@ (define-module (gnu packages cups)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages pretty-print)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages qt)
   #:use-module (gnu packages scanner)
   #:use-module (gnu packages tls)

gnu/packages/cyrus-sasl.scm

@@ -20,7 +20,7 @@
 
 (define-module (gnu packages cyrus-sasl)
   #:use-module (gnu packages)
-  #:use-module (gnu packages databases)
+  #:use-module (gnu packages dbm)
   #:use-module (gnu packages kerberos)
   #:use-module (gnu packages tls)
   #:use-module ((guix licenses) #:prefix license:)

gnu/packages/databases.scm

@@ -64,6 +64,7 @@ (define-module (gnu packages databases)
   #:use-module (gnu packages crypto)
   #:use-module (gnu packages curl)
   #:use-module (gnu packages cyrus-sasl)
+  #:use-module (gnu packages dbm)
   #:use-module (gnu packages emacs)
   #:use-module (gnu packages gettext)
   #:use-module (gnu packages glib)
@@ -85,10 +86,12 @@ (define-module (gnu packages databases)
   #:use-module (gnu packages popt)
   #:use-module (gnu packages python)
   #:use-module (gnu packages python-crypto)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages rdf)
   #:use-module (gnu packages readline)
   #:use-module (gnu packages ruby)
   #:use-module (gnu packages serialization)
+  #:use-module (gnu packages sqlite)
   #:use-module (gnu packages tcl)
   #:use-module (gnu packages terminals)
   #:use-module (gnu packages textutils)
@@ -159,28 +162,6 @@ (define-public 4store
 either single machines or networked clusters.")
     (license license:gpl3+)))
 
-(define-public gdbm
-  (package
-    (name "gdbm")
-    (version "1.18")
-    (source (origin
-              (method url-fetch)
-              (uri (string-append "mirror://gnu/gdbm/gdbm-"
-                                  version ".tar.gz"))
-              (sha256
-               (base32
-                "1kimnv12bzjjhaqk4c8w2j6chdj9c6bg21lchaf7abcyfss2r0mq"))))
-    (arguments `(#:configure-flags '("--enable-libgdbm-compat")))
-    (build-system gnu-build-system)
-    (home-page "http://www.gnu.org.ua/software/gdbm")
-    (synopsis
-     "Hash library of database functions compatible with traditional dbm")
-    (description
-     "GDBM is a library for manipulating hashed databases.  It is used to
-store key/value pairs in a file in a manner similar to the Unix dbm library
-and provides interfaces to the traditional file format.")
-    (license license:gpl3+)))
-
 (define-public go-gopkg.in-mgo.v2
   (package
     (name "go-gopkg.in-mgo.v2")
@@ -227,109 +208,6 @@ (define-public go-gopkg.in-mgo.v2
     (home-page "http://labix.org/mgo")
     (license license:bsd-2)))
 
-(define-public bdb
-  (package
-    (name "bdb")
-    (version "6.2.32")
-    (source (origin
-              (method url-fetch)
-              (uri (string-append "http://download.oracle.com/berkeley-db/db-"
-                                  version ".tar.gz"))
-              (sha256
-               (base32
-                "1yx8wzhch5wwh016nh0kfxvknjkafv6ybkqh6nh7lxx50jqf5id9"))))
-    (build-system gnu-build-system)
-    (outputs '("out"                             ; programs, libraries, headers
-               "doc"))                           ; 94 MiB of HTML docs
-    (arguments
-     '(#:tests? #f                            ; no check target available
-       #:disallowed-references ("doc")
-       #:phases
-       (modify-phases %standard-phases
-         (replace 'configure
-           (lambda* (#:key outputs #:allow-other-keys)
-             (let ((out (assoc-ref outputs "out"))
-                   (doc (assoc-ref outputs "doc")))
-               ;; '--docdir' is not honored, so we need to patch.
-               (substitute* "dist/Makefile.in"
-                 (("docdir[[:blank:]]*=.*")
-                  (string-append "docdir = " doc "/share/doc/bdb")))
-
-               (invoke "./dist/configure"
-                       (string-append "--prefix=" out)
-                       (string-append "CONFIG_SHELL=" (which "bash"))
-                       (string-append "SHELL=" (which "bash"))
-
-                       ;; Remove 7 MiB of .a files.
-                       "--disable-static"
-
-                       ;; The compatibility mode is needed by some packages,
-                       ;; notably iproute2.
-                       "--enable-compat185"
-
-                       ;; The following flag is needed so that the inclusion
-                       ;; of db_cxx.h into C++ files works; it leads to
-                       ;; HAVE_CXX_STDHEADERS being defined in db_cxx.h.
-                       "--enable-cxx")))))))
-    (synopsis "Berkeley database")
-    (description
-     "Berkeley DB is an embeddable database allowing developers the choice of
-SQL, Key/Value, XML/XQuery or Java Object storage for their data model.")
-    ;; Starting with version 6, BDB is distributed under AGPL3. Many individual
-    ;; files are covered by the 3-clause BSD license.
-    (license (list license:agpl3+ license:bsd-3))
-    (home-page
-     "http://www.oracle.com/us/products/database/berkeley-db/overview/index.html")))
-
-(define-public bdb-5.3
-  (package (inherit bdb)
-    (name "bdb")
-    (version "5.3.28")
-    (license (license:non-copyleft "file://LICENSE"
-                                   "See LICENSE in the distribution."))
-    (source (origin
-              (method url-fetch)
-              (uri (string-append "http://download.oracle.com/berkeley-db/db-"
-                                  version ".tar.gz"))
-              (sha256
-               (base32
-                "0a1n5hbl7027fbz5lm0vp0zzfp1hmxnz14wx3zl9563h83br5ag0"))))
-    (arguments
-     `(#:tests? #f                            ; no check target available
-       #:disallowed-references ("doc")
-       #:phases
-       (modify-phases %standard-phases
-         (replace 'configure
-           (lambda* (#:key outputs #:allow-other-keys)
-             (let ((out (assoc-ref outputs "out"))
-                   (doc (assoc-ref outputs "doc")))
-               ;; '--docdir' is not honored, so we need to patch.
-               (substitute* "dist/Makefile.in"
-                 (("docdir[[:blank:]]*=.*")
-                  (string-append "docdir = " doc "/share/doc/bdb")))
-
-               (invoke "./dist/configure"
-                       (string-append "--prefix=" out)
-                       (string-append "CONFIG_SHELL=" (which "bash"))
-                       (string-append "SHELL=" (which "bash"))
-
-                       ;; Bdb doesn't recognize aarch64 as an architecture.
-                       ,@(if (string=? "aarch64-linux" (%current-system))
-                             '("--build=aarch64-unknown-linux-gnu")
-                             '())
-
-                       ;; Remove 7 MiB of .a files.
-                       "--disable-static"
-
-                       ;; The compatibility mode is needed by some packages,
-                       ;; notably iproute2.
-                       "--enable-compat185"
-
-                       ;; The following flag is needed so that the inclusion
-                       ;; of db_cxx.h into C++ files works; it leads to
-                       ;; HAVE_CXX_STDHEADERS being defined in db_cxx.h.
-                       "--enable-cxx")))))))))
-
 (define-public es-dump-restore
   (package
     (name "es-dump-restore")
@@ -1144,87 +1022,6 @@ (define-public sqlcrush
 changes.")
       (license license:gpl3+)))) ; no headers, see README.md
 
-(define-public sqlite
-  (package
-   (name "sqlite")
-   (replacement sqlite-3.26.0)
-   (version "3.24.0")
-   (source (origin
-            (method url-fetch)
-            (uri (let ((numeric-version
-                        (match (string-split version #\.)
-                          ((first-digit other-digits ...)
-                           (string-append first-digit
-                                          (string-pad-right
-                                           (string-concatenate
-                                            (map (cut string-pad <> 2 #\0)
-                                                 other-digits))
-                                           6 #\0))))))
-                   (string-append "https://sqlite.org/2018/sqlite-autoconf-"
-                                  numeric-version ".tar.gz")))
-            (sha256
-             (base32
-              "0jmprv2vpggzhy7ma4ynmv1jzn3pfiwzkld0kkg6hvgvqs44xlfr"))))
-   (build-system gnu-build-system)
-   (inputs `(("readline" ,readline)))
-   (arguments
-    `(#:configure-flags
-      ;; Add -DSQLITE_SECURE_DELETE, -DSQLITE_ENABLE_UNLOCK_NOTIFY and
-      ;; -DSQLITE_ENABLE_DBSTAT_VTAB to CFLAGS.  GNU Icecat will refuse
-      ;; to use the system SQLite unless these options are enabled.
-      (list (string-append "CFLAGS=-O2 -DSQLITE_SECURE_DELETE "
-                           "-DSQLITE_ENABLE_UNLOCK_NOTIFY "
-                           "-DSQLITE_ENABLE_DBSTAT_VTAB"))))
-   (home-page "https://www.sqlite.org/")
-   (synopsis "The SQLite database management system")
-   (description
-    "SQLite is a software library that implements a self-contained, serverless,
-zero-configuration, transactional SQL database engine.  SQLite is the most
-widely deployed SQL database engine in the world.  The source code for SQLite
-is in the public domain.")
-   (license license:public-domain)))
-
-(define-public sqlite-3.26.0
-  (package (inherit sqlite)
-    (version "3.26.0")
-    (source (origin
-              (method url-fetch)
-              (uri (let ((numeric-version
-                          (match (string-split version #\.)
-                            ((first-digit other-digits ...)
-                             (string-append first-digit
-                                            (string-pad-right
-                                             (string-concatenate
-                                              (map (cut string-pad <> 2 #\0)
-                                                   other-digits))
-                                             6 #\0))))))
-                     (string-append "https://sqlite.org/2018/sqlite-autoconf-"
-                                    numeric-version ".tar.gz")))
-              (sha256
-               (base32
-                "0pdzszb4sp73hl36siiv3p300jvfvbcdxi2rrmkwgs6inwznmajx"))))))
-
-;; This is used by Tracker.
-(define-public sqlite-with-fts5
-  (package/inherit sqlite
-    (name "sqlite-with-fts5")
-    (arguments
-     (substitute-keyword-arguments (package-arguments sqlite)
-       ((#:configure-flags flags)
-        `(cons "--enable-fts5" ,flags))))))
-
-;; This is used by Qt.
-(define-public sqlite-with-column-metadata
-  (package/inherit sqlite
-    (name "sqlite-with-column-metadata")
-    (arguments
-     (substitute-keyword-arguments (package-arguments sqlite)
-       ((#:configure-flags flags)
-        `(list (string-append "CFLAGS=-O2 -DSQLITE_SECURE_DELETE "
-                              "-DSQLITE_ENABLE_UNLOCK_NOTIFY "
-                              "-DSQLITE_ENABLE_DBSTAT_VTAB "
-                              "-DSQLITE_ENABLE_COLUMN_METADATA")))))))
-
 (define-public tdb
   (package
     (name "tdb")

gnu/packages/datastructures.scm

@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015, 2016, 2019 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2016, 2017 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2016, 2017, 2019 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2018 Meiyo Peng <meiyo.peng@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -123,18 +123,18 @@ (define-public ssdeep
 (define-public liburcu
   (package
     (name "liburcu")
-    (version "0.10.1")
+    (version "0.10.2")
     (source (origin
               (method url-fetch)
               (uri (string-append "https://www.lttng.org/files/urcu/"
                                   "userspace-rcu-" version ".tar.bz2"))
               (sha256
                (base32
-                "01pbg67qy5hcssy2yi0ckqapzfclgdq93li2rmzw4pa3wh5j42cw"))))
+                "1k31faqz9plx5dwxq8g1fnczxda1is4s1x4ph0gjrq3gmy6qixmk"))))
     (build-system gnu-build-system)
     (native-inputs
      `(("perl" ,perl)))                 ; for tests
-    (home-page "http://liburcu.org/")
+    (home-page "https://liburcu.org/")
     (synopsis "User-space RCU data synchronisation library")
     (description "liburcu is a user-space @dfn{Read-Copy-Update} (RCU) data
 synchronisation library.  It provides read-side access that scales linearly

gnu/packages/dav.scm

@@ -25,7 +25,8 @@ (define-module (gnu packages dav)
   #:use-module (gnu packages)
   #:use-module (gnu packages check)
   #:use-module (gnu packages python)
-  #:use-module (gnu packages python-web))
+  #:use-module (gnu packages python-web)
+  #:use-module (gnu packages python-xyz))
 
 (define-public radicale
   (package

gnu/packages/dbm.scm

@@ -0,0 +1,159 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2015 Andreas Enge <andreas@enge.fr>
+;;; Copyright © 2016, 2017, 2018 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2017, 2018 Marius Bakke <mbakke@fastmail.com>
+;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
+;;;
+;;; 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 packages dbm)
+  #:use-module (gnu packages)
+  #:use-module ((guix licenses) #:prefix license:)
+  #:use-module (guix packages)
+  #:use-module (guix download)
+  #:use-module (guix build-system gnu)
+  #:use-module (guix utils))
+
+;;; Commentary:
+;;;
+;;; This module has been separated from (gnu packages databases) to reduce the
+;;; number of module references for core packages.
+
+(define-public bdb
+  (package
+    (name "bdb")
+    (version "6.2.32")
+    (source (origin
+              (method url-fetch)
+              (uri (string-append "http://download.oracle.com/berkeley-db/db-"
+                                  version ".tar.gz"))
+              (sha256
+               (base32
+                "1yx8wzhch5wwh016nh0kfxvknjkafv6ybkqh6nh7lxx50jqf5id9"))))
+    (build-system gnu-build-system)
+    (outputs '("out"                             ; programs, libraries, headers
+               "doc"))                           ; 94 MiB of HTML docs
+    (arguments
+     '(#:tests? #f                            ; no check target available
+       #:disallowed-references ("doc")
+       #:phases
+       (modify-phases %standard-phases
+         (replace 'configure
+           (lambda* (#:key outputs #:allow-other-keys)
+             (let ((out (assoc-ref outputs "out"))
+                   (doc (assoc-ref outputs "doc")))
+               ;; '--docdir' is not honored, so we need to patch.
+               (substitute* "dist/Makefile.in"
+                 (("docdir[[:blank:]]*=.*")
+                  (string-append "docdir = " doc "/share/doc/bdb")))
+
+               (invoke "./dist/configure"
+                       (string-append "--prefix=" out)
+                       (string-append "CONFIG_SHELL=" (which "bash"))
+                       (string-append "SHELL=" (which "bash"))
+
+                       ;; Remove 7 MiB of .a files.
+                       "--disable-static"
+
+                       ;; The compatibility mode is needed by some packages,
+                       ;; notably iproute2.
+                       "--enable-compat185"
+
+                       ;; The following flag is needed so that the inclusion
+                       ;; of db_cxx.h into C++ files works; it leads to
+                       ;; HAVE_CXX_STDHEADERS being defined in db_cxx.h.
+                       "--enable-cxx")))))))
+    (synopsis "Berkeley database")
+    (description
+     "Berkeley DB is an embeddable database allowing developers the choice of
+SQL, Key/Value, XML/XQuery or Java Object storage for their data model.")
+    ;; Starting with version 6, BDB is distributed under AGPL3. Many individual
+    ;; files are covered by the 3-clause BSD license.
+    (license (list license:agpl3+ license:bsd-3))
+    (home-page
+     "http://www.oracle.com/us/products/database/berkeley-db/overview/index.html")))
+
+(define-public bdb-5.3
+  (package (inherit bdb)
+    (name "bdb")
+    (version "5.3.28")
+    (license (license:non-copyleft "file://LICENSE"
+                                   "See LICENSE in the distribution."))
+    (source (origin
+              (method url-fetch)
+              (uri (string-append "http://download.oracle.com/berkeley-db/db-"
+                                  version ".tar.gz"))
+              (sha256
+               (base32
+                "0a1n5hbl7027fbz5lm0vp0zzfp1hmxnz14wx3zl9563h83br5ag0"))))
+    (arguments
+     `(#:tests? #f                            ; no check target available
+       #:disallowed-references ("doc")
+       #:phases
+       (modify-phases %standard-phases
+         (replace 'configure
+           (lambda* (#:key outputs #:allow-other-keys)
+             (let ((out (assoc-ref outputs "out"))
+                   (doc (assoc-ref outputs "doc")))
+               ;; '--docdir' is not honored, so we need to patch.
+               (substitute* "dist/Makefile.in"
+                 (("docdir[[:blank:]]*=.*")
+                  (string-append "docdir = " doc "/share/doc/bdb")))
+
+               (invoke "./dist/configure"
+                       (string-append "--prefix=" out)
+                       (string-append "CONFIG_SHELL=" (which "bash"))
+                       (string-append "SHELL=" (which "bash"))
+
+                       ;; Bdb doesn't recognize aarch64 as an architecture.
+                       ,@(if (string=? "aarch64-linux" (%current-system))
+                             '("--build=aarch64-unknown-linux-gnu")
+                             '())
+
+                       ;; Remove 7 MiB of .a files.
+                       "--disable-static"
+
+                       ;; The compatibility mode is needed by some packages,
+                       ;; notably iproute2.
+                       "--enable-compat185"
+
+                       ;; The following flag is needed so that the inclusion
+                       ;; of db_cxx.h into C++ files works; it leads to
+                       ;; HAVE_CXX_STDHEADERS being defined in db_cxx.h.
+                       "--enable-cxx")))))))))
+
+(define-public gdbm
+  (package
+    (name "gdbm")
+    (version "1.18")
+    (source (origin
+              (method url-fetch)
+              (uri (string-append "mirror://gnu/gdbm/gdbm-"
+                                  version ".tar.gz"))
+              (sha256
+               (base32
+                "1kimnv12bzjjhaqk4c8w2j6chdj9c6bg21lchaf7abcyfss2r0mq"))))
+    (arguments `(#:configure-flags '("--enable-libgdbm-compat")))
+    (build-system gnu-build-system)
+    (home-page "http://www.gnu.org.ua/software/gdbm")
+    (synopsis
+     "Hash library of database functions compatible with traditional dbm")
+    (description
+     "GDBM is a library for manipulating hashed databases.  It is used to
+store key/value pairs in a file in a manner similar to the Unix dbm library
+and provides interfaces to the traditional file format.")
+    (license license:gpl3+)))

gnu/packages/dc.scm

@@ -23,7 +23,7 @@ (define-module (gnu packages dc)
   #:use-module (gnu packages glib)
   #:use-module (gnu packages ncurses)
   #:use-module (gnu packages pkg-config)
-  #:use-module (gnu packages databases)
+  #:use-module (gnu packages sqlite)
   #:use-module (gnu packages tls)
   #:use-module (guix packages)
   #:use-module (guix download)

gnu/packages/debug.scm

@@ -285,7 +285,8 @@ (define-public stress-make
        ;; patch-* phases work properly, we unpack the source first, then
        ;; repack before the configure phase.
        (let ((make-dir (string-append "make-" (package-version gnu-make))))
-         `(#:configure-flags '("--with-make-tar=./make.tar.xz")
+         `(#:configure-flags '("--with-make-tar=./make.tar.xz"
+                               "make_cv_sys_gnu_glob=yes")
            #:phases
            (modify-phases %standard-phases
              (add-after 'unpack 'unpack-make

gnu/packages/direct-connect.scm

@@ -27,7 +27,7 @@ (define-module (gnu packages direct-connect)
   #:use-module (gnu packages gnome)
   #:use-module (gnu packages gtk)
   #:use-module (gnu packages pkg-config)
-  #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages tls)
   #:use-module (gnu packages version-control))
 

gnu/packages/disk.scm

@@ -38,7 +38,6 @@ (define-module (gnu packages disk)
   #:use-module (gnu packages check)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages cryptsetup)
-  #:use-module (gnu packages databases)
   #:use-module (gnu packages docbook)
   #:use-module (gnu packages documentation)
   #:use-module (gnu packages elf)
@@ -55,7 +54,9 @@ (define-module (gnu packages disk)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages popt)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages readline)
+  #:use-module (gnu packages sqlite)
   #:use-module (gnu packages swig)
   #:use-module (gnu packages vim)
   #:use-module (gnu packages w3m)

gnu/packages/django.scm

@@ -32,6 +32,7 @@ (define-module (gnu packages django)
   #:use-module (gnu packages check)
   #:use-module (gnu packages python)
   #:use-module (gnu packages python-web)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages time))
 
 (define-public python-django
@@ -196,7 +197,7 @@ (define-public python-django-filter
        (modify-phases %standard-phases
          (replace 'check
            (lambda _
-             (zero? (system* "python" "runtests.py")))))))
+             (invoke "python" "runtests.py"))))))
     (native-inputs
      `(("python-django" ,python-django)
        ("python-djangorestframework" ,python-djangorestframework)

gnu/packages/dlang.scm

@@ -36,6 +36,7 @@ (define-module (gnu packages dlang)
   #:use-module (gnu packages libedit)
   #:use-module (gnu packages llvm)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages textutils))
 
 (define-public rdmd

gnu/packages/docker.scm

@@ -37,6 +37,7 @@ (define-module (gnu packages docker)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
   #:use-module (gnu packages python-web)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages version-control)
   #:use-module (gnu packages virtualization))
 
@@ -517,7 +518,6 @@ (define-public docker-cli
              (let* ((out (assoc-ref outputs "out"))
                     (out-bin (string-append out "/bin")))
                (chdir "build")
-               (install-file (readlink "docker") out-bin)
                (install-file "docker" out-bin)
                #t))))))
     (native-inputs

gnu/packages/ebook.scm

@@ -47,8 +47,10 @@ (define-module (gnu packages ebook)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
   #:use-module (gnu packages python-web)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages qt)
   #:use-module (gnu packages serialization)
+  #:use-module (gnu packages sqlite)
   #:use-module (gnu packages time)
   #:use-module (gnu packages tls)
   #:use-module (gnu packages web)

gnu/packages/education.scm

@@ -27,7 +27,6 @@ (define-module (gnu packages education)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages compression)
-  #:use-module (gnu packages databases)
   #:use-module (gnu packages freedesktop)
   #:use-module (gnu packages gettext)
   #:use-module (gnu packages glib)
@@ -40,6 +39,7 @@ (define-module (gnu packages education)
   #:use-module (gnu packages python)
   #:use-module (gnu packages qt)
   #:use-module (gnu packages sdl)
+  #:use-module (gnu packages sqlite)
   #:use-module (gnu packages texinfo)
   #:use-module (gnu packages xorg)
   #:use-module (gnu packages xml)

gnu/packages/elf.scm

@@ -34,6 +34,7 @@ (define-module (gnu packages elf)
   #:use-module (gnu packages m4)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages texinfo)
   #:use-module (gnu packages xml))
 

gnu/packages/emulators.scm

@@ -8,7 +8,7 @@
 ;;; Copyright © 2016, 2017, 2018 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2017, 2018 Nicolas Goaziou <mail@nicolasgoaziou.fr>
 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
-;;; Copyright © 2017, 2018 Rutger Helling <rhelling@mykolab.com>
+;;; Copyright © 2017, 2018, 2019 Rutger Helling <rhelling@mykolab.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -41,7 +41,6 @@ (define-module (gnu packages emulators)
   #:use-module (gnu packages backup)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages curl)
-  #:use-module (gnu packages databases)
   #:use-module (gnu packages fonts)
   #:use-module (gnu packages fontutils)
   #:use-module (gnu packages freedesktop)
@@ -65,8 +64,10 @@ (define-module (gnu packages emulators)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages pulseaudio)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages qt)
   #:use-module (gnu packages sdl)
+  #:use-module (gnu packages sqlite)
   #:use-module (gnu packages texinfo)
   #:use-module (gnu packages textutils)
   #:use-module (gnu packages tls)
@@ -237,26 +238,23 @@ (define-public dolphin-emu
 (define-public dosbox
   (package
     (name "dosbox")
-    (version "0.74.svn3947")
+    (version "0.74-2")
     (source (origin
-              (method svn-fetch)
+              (method url-fetch)
-              (uri (svn-reference
+              (uri (string-append "https://sourceforge.net/projects/dosbox"
-                    (url "http://svn.code.sf.net/p/dosbox/code-0/dosbox/trunk/")
+                                  "/files/dosbox/" version "/dosbox-"
-                    (revision 3947)))
+                                  version ".tar.gz/download"))
-              (file-name (string-append name "-" version "-checkout"))
+              (file-name (string-append name "-" version ".tar.gz"))
-              ;; Use SVN head, since the last release (2010) is incompatible
-              ;; with GCC 4.8+ (see
-              ;; <https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=624976>).
               (sha256
                (base32
-                "1p918j6090d1nkvgq7ifvmn506zrdmyi32y7p3ms40d5ssqjg8fj"))))
+                "1ksp1b5szi0vy4x55rm3j1y9wq5mlslpy8llpg87rpdyjlsk0xvh"))))
     (build-system gnu-build-system)
     (arguments
      `(#:phases (modify-phases %standard-phases
                   (add-after
                    'unpack 'autogen.sh
                    (lambda _
-                     (zero? (system* "sh" "autogen.sh")))))))
+                     (invoke "sh" "autogen.sh"))))))
     (native-inputs
      `(("autoconf" ,autoconf)
        ("automake" ,automake)))

gnu/packages/engineering.scm

@@ -75,6 +75,7 @@ (define-module (gnu packages engineering)
   #:use-module (gnu packages perl)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages qt)
   #:use-module (gnu packages readline)
   #:use-module (gnu packages swig)

gnu/packages/enlightenment.scm

@@ -55,6 +55,7 @@ (define-module (gnu packages enlightenment)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages pulseaudio)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages tls)
   #:use-module (gnu packages video)
   #:use-module (gnu packages xdisorg)

gnu/packages/file-systems.scm

@@ -35,7 +35,6 @@ (define-module (gnu packages file-systems)
   #:use-module (gnu packages check)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages curl)
-  #:use-module (gnu packages databases)
   #:use-module (gnu packages datastructures)
   #:use-module (gnu packages documentation)
   #:use-module (gnu packages docbook)
@@ -45,6 +44,7 @@ (define-module (gnu packages file-systems)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
   #:use-module (gnu packages readline)
+  #:use-module (gnu packages sqlite)
   #:use-module (gnu packages tls)
   #:use-module (gnu packages xml))
 
@@ -248,6 +248,41 @@ (define-public curlftpfs
      "This is a file system client based on the FTP File Transfer Protocol.")
     (license license:gpl2+)))
 
+(define-public libnfs
+  (package
+    (name "libnfs")
+    (version "3.0.0")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/sahlberg/libnfs.git")
+                    (commit (string-append "libnfs-" version))))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "115p55y2cbs92z5lmcnjx1v29lwinpgq4sha9v1kq1vd8674h404"))))
+    (build-system gnu-build-system)
+    (home-page "https://github.com/sahlberg/libnfs")
+    (native-inputs
+     `(("autoconf" ,autoconf)
+       ("automake" ,automake)
+       ("libtool" ,libtool)
+       ("pkg-config" ,pkg-config)))
+    (synopsis "Client library for accessing NFS shares")
+    (description "LIBNFS is a client library for accessing NFS shares over a
+network.  LIBNFS offers three different APIs, for different use :
+
+@enumerate
+@item RAW, a fully asynchronous low level RPC library for NFS protocols.  This
+  API provides very flexible and precise control of the RPC issued.
+@item NFS ASYNC, a fully asynchronous library for high level vfs functions
+@item NFS SYNC, a synchronous library for high level vfs functions.
+@end enumerate\n")
+    (license (list license:lgpl2.1+ ; library
+                   license:gpl3+    ; tests
+                   license:bsd-3    ; copied nsf4 files
+                   ))))
+
 (define-public apfs-fuse
   (let ((commit "c7036a3030d128bcecefc1eabc47c039ccfdcec9")
         (revision "0"))

gnu/packages/finance.scm

@@ -44,6 +44,7 @@ (define-module (gnu packages finance)
   #:use-module (gnu packages documentation)
   #:use-module (gnu packages dns)
   #:use-module (gnu packages emacs)
+  #:use-module (gnu packages dbm)
   #:use-module (gnu packages graphviz)
   #:use-module (gnu packages groff)
   #:use-module (gnu packages libedit)
@@ -58,6 +59,7 @@ (define-module (gnu packages finance)
   #:use-module (gnu packages python)
   #:use-module (gnu packages python-crypto)
   #:use-module (gnu packages python-web)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages qt)
   #:use-module (gnu packages readline)
   #:use-module (gnu packages texinfo)
@@ -342,7 +344,7 @@ (define-public electron-cash
   (package
     (inherit electrum)
     (name "electron-cash")
-    (version "3.3.1")
+    (version "3.3.4")
     (source
      (origin
        (method url-fetch)
@@ -353,7 +355,7 @@ (define-public electron-cash
                            ".tar.gz"))
        (sha256
         (base32
-         "1jdy89rfdwc2jadx3rqj5yvynpcn90cx6482ax9f1cj9gfxp9j2b"))
+         "0ipl6vf2n9a5n556sx2z57s7wdvg05xwjvz67kff9nmbx4s8vjyf"))
        (modules '((guix build utils)))
        (snippet
         '(begin

gnu/packages/fltk.scm

@@ -31,6 +31,7 @@ (define-module (gnu packages fltk)
   #:use-module (gnu packages gtk) ;for "cairo"
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix git-download)

gnu/packages/fonts.scm

@@ -19,7 +19,7 @@
 ;;; Copyright © 2017 Alex Griffin <a@ajgrf.com>
 ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2017 Brendan Tildesley <brendan.tildesley@openmailbox.org>
-;;; Copyright © 2017, 2018 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2017, 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
 ;;; Copyright © 2017 Mohammed Sadiq <sadiq@sadiqpk.org>
 ;;; Copyright © 2018 Charlie Ritter <chewzerita@posteo.net>
 ;;; Copyright © 2018 Gabriel Hondet <gabrielhondet@gmail.com>
@@ -1163,39 +1163,13 @@ (define-public font-dosis
     (version "1.7")
     (source
      (origin
-       (method url-fetch)
+       (method url-fetch/zipbomb)
        (uri (string-append "http://www.impallari.com/media/releases/dosis-"
                            "v" version ".zip"))
        (sha256
         (base32
          "1qhci68f68mf87jd69vjf9qjq3wydgw1q7ivn3amjb65ls1s0c4s"))))
-    (build-system trivial-build-system)
+    (build-system font-build-system)
-    (arguments
-     `(#:modules ((guix build utils))
-       #:builder (begin
-                   (use-modules (guix build utils)
-                                (srfi srfi-26))
-
-                   (let ((PATH     (string-append (assoc-ref %build-inputs
-                                                             "unzip")
-                                                  "/bin"))
-                         (ttf-dir (string-append %output
-                                                 "/share/fonts/truetype"))
-                         (otf-dir (string-append %output
-                                                 "/share/fonts/opentype")))
-                     (setenv "PATH" PATH)
-                     (invoke "unzip" (assoc-ref %build-inputs "source"))
-
-                     (mkdir-p ttf-dir)
-                     (mkdir-p otf-dir)
-                     (for-each (lambda (ttf)
-                                 (install-file ttf ttf-dir))
-                               (find-files "." "\\.ttf$"))
-                     (for-each (lambda (otf)
-                                 (install-file otf otf-dir))
-                               (find-files "." "\\.otf$"))
-                     #t))))
-    (native-inputs `(("unzip" ,unzip)))
     (home-page "http://www.impallari.com/dosis")
     (synopsis "Very simple, rounded, sans serif family")
     (description

gnu/packages/fontutils.scm

@@ -36,6 +36,7 @@ (define-module (gnu packages fontutils)
   #:use-module (gnu packages autotools)
   #:use-module (gnu packages gettext)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages image)
   #:use-module (gnu packages bison)
   #:use-module (gnu packages flex)

gnu/packages/fpga.scm

@@ -2,6 +2,7 @@
 ;;; Copyright © 2016 Danny Milosavljevic <dannym@scratchpost.org>
 ;;; Copyright © 2016, 2017 Theodoros Foradis <theodoros@foradis.org>
 ;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2019 Amin Bandali <bandali@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -119,7 +120,7 @@ (define-public iverilog
 (define-public yosys
   (package
     (name "yosys")
-    (version "0.7")
+    (version "0.8")
     (source (origin
               (method git-fetch)
               (uri (git-reference
@@ -128,7 +129,7 @@ (define-public yosys
                     (recursive? #t))) ; for the ‘iverilog’ submodule
               (sha256
                 (base32
-                   "1ssrpgw0j9qlm52g1hsbb9fsww4vnwi0l7zvvky7a8w7wamddky0"))
+                   "1qwbp8gynlklawzvpa4gdn2x0hs8zln0s3kxjqkhfcjfxffdcpvv"))
               (file-name (git-file-name name version))
               (modules '((guix build utils)))
               (snippet
@@ -211,8 +212,8 @@ (define-public yosys
     (license license:isc)))
 
 (define-public icestorm
-  (let ((commit "12b2295c9087d94b75e374bb205ae4d76cf17e2f")
+  (let ((commit "c0cbae88ab47a3879aacf80d53b6a85710682a6b")
-        (revision "1"))
+        (revision "2"))
    (package
     (name "icestorm")
     (version (string-append "0.0-" revision "-" (string-take commit 9)))
@@ -224,7 +225,7 @@ (define-public icestorm
               (file-name (string-append name "-" version "-checkout"))
               (sha256
                 (base32
-                   "1mmzlqvap6w8n4qzv3idvy51arkgn03692ssplwncy3akjrbsd2b"))))
+                   "0bqm0rpywm64yvbq75klpyzb1g9sdsp1kvdlyqg4hvm8jw9w8lya"))))
     (build-system gnu-build-system)
     (arguments
      `(#:tests? #f ; no unit tests that don't need an FPGA exist.
@@ -256,33 +257,31 @@ (define-public icestorm
     (license license:isc))))
 
 (define-public arachne-pnr
-  (let ((commit "52e69ed207342710080d85c7c639480e74a021d7")
+  (let ((commit "840bdfdeb38809f9f6af4d89dd7b22959b176fdd")
-        (revision "1"))
+        (revision "2"))
    (package
     (name "arachne-pnr")
     (version (string-append "0.0-" revision "-" (string-take commit 9)))
     (source (origin
               (method git-fetch)
               (uri (git-reference
-                     (url "https://github.com/cseed/arachne-pnr.git")
+                     (url "https://github.com/YosysHQ/arachne-pnr.git")
                      (commit commit)))
               (file-name (string-append name "-" version "-checkout"))
               (sha256
                 (base32
-                   "15bdw5yxj76lxrwksp6liwmr6l1x77isf4bs50ys9rsnmiwh8c3w"))))
+                   "1dqvjvgvsridybishv4pnigw9gypxh7r7nrqp9z9qq92v7c5rxzl"))))
     (build-system gnu-build-system)
     (arguments
      `(#:test-target "test"
+       #:make-flags
+       (list (string-append "DESTDIR=" (assoc-ref %outputs "out"))
+             (string-append "ICEBOX=" (string-append
+                                       (assoc-ref %build-inputs "icestorm")
+                                       "/share/icebox")))
        #:phases (modify-phases %standard-phases
        (replace 'configure
          (lambda* (#:key outputs inputs #:allow-other-keys)
-           (substitute* '("Makefile")
-             (("DESTDIR = .*") (string-append "DESTDIR = "
-                                             (assoc-ref outputs "out")
-                                             "\n"))
-             (("ICEBOX = .*") (string-append "ICEBOX = "
-                                             (assoc-ref inputs "icestorm")
-                                             "/share/icebox\n")))
            (substitute* '("./tests/fsm/generate.py"
                           "./tests/combinatorial/generate.py")
              (("#!/usr/bin/python") "#!/usr/bin/python2"))
@@ -294,7 +293,7 @@ (define-public arachne-pnr
        ("yosys" ,yosys) ; for tests
        ("perl" ,perl) ; for shasum
        ("python-2" ,python-2))) ; for tests
-    (home-page "https://github.com/cseed/arachne-pnr")
+    (home-page "https://github.com/YosysHQ/arachne-pnr")
     (synopsis "Place-and-Route tool for FPGAs")
     (description "Arachne-PNR is a Place-and-Route Tool For FPGAs.")
     (license license:gpl2))))

gnu/packages/freedesktop.scm

@@ -49,7 +49,6 @@ (define-module (gnu packages freedesktop)
   #:use-module (gnu packages check)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages cryptsetup)
-  #:use-module (gnu packages databases)
   #:use-module (gnu packages disk)
   #:use-module (gnu packages docbook)
   #:use-module (gnu packages documentation)
@@ -71,6 +70,8 @@ (define-module (gnu packages freedesktop)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages polkit)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
+  #:use-module (gnu packages sqlite)
   #:use-module (gnu packages valgrind)
   #:use-module (gnu packages w3m)
   #:use-module (gnu packages web)

gnu/packages/ftp.scm

@@ -29,7 +29,6 @@ (define-module (gnu packages ftp)
   #:use-module (gnu packages autotools)
   #:use-module (gnu packages check)
   #:use-module (gnu packages compression)
-  #:use-module (gnu packages databases)
   #:use-module (gnu packages freedesktop)
   #:use-module (gnu packages gettext)
   #:use-module (gnu packages glib)
@@ -39,6 +38,7 @@ (define-module (gnu packages ftp)
   #:use-module (gnu packages nettle)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages readline)
+  #:use-module (gnu packages sqlite)
   #:use-module (gnu packages tls)
   #:use-module (gnu packages wxwidgets)
   #:use-module (gnu packages xml))

gnu/packages/game-development.scm

@@ -46,13 +46,13 @@ (define-module (gnu packages game-development)
   #:use-module (gnu packages boost)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages curl)
-  #:use-module (gnu packages databases)
   #:use-module (gnu packages documentation)
   #:use-module (gnu packages fltk)
   #:use-module (gnu packages fonts)
   #:use-module (gnu packages fontutils)
   #:use-module (gnu packages freedesktop)
   #:use-module (gnu packages fribidi)
+  #:use-module (gnu packages dbm)
   #:use-module (gnu packages gl)
   #:use-module (gnu packages glib)
   #:use-module (gnu packages gnome)
@@ -72,6 +72,7 @@ (define-module (gnu packages game-development)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages pulseaudio)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages qt)
   #:use-module (gnu packages sdl)
   #:use-module (gnu packages stb)

gnu/packages/games.scm

@@ -19,7 +19,7 @@
 ;;; Copyright © 2016 Albin Söderqvist <albin@fripost.org>
 ;;; Copyright © 2016, 2017, 2018 Kei Kebreau <kkebreau@posteo.net>
 ;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
-;;; Copyright © 2016, 2017, 2018 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2016, 2017, 2018, 2019 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2016 Steve Webber <webber.sl@gmail.com>
 ;;; Copyright © 2017 Adonay "adfeno" Felipe Nogueira <https://libreplanet.org/wiki/User:Adfeno> <adfeno@hyperbola.info>
@@ -79,7 +79,6 @@ (define-module (gnu packages games)
   #:use-module (gnu packages curl)
   #:use-module (gnu packages crypto)
   #:use-module (gnu packages cyrus-sasl)
-  #:use-module (gnu packages databases)
   #:use-module (gnu packages documentation)
   #:use-module (gnu packages docbook)
   #:use-module (gnu packages flex)
@@ -125,11 +124,13 @@ (define-module (gnu packages games)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages pulseaudio)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages qt)
   #:use-module (gnu packages readline)
   #:use-module (gnu packages shells)
   #:use-module (gnu packages sdl)
   #:use-module (gnu packages serialization)
+  #:use-module (gnu packages sqlite)
   #:use-module (gnu packages swig)
   #:use-module (gnu packages tcl)
   #:use-module (gnu packages texinfo)
@@ -151,6 +152,7 @@ (define-module (gnu packages games)
   #:use-module (guix build-system go)
   #:use-module (guix build-system haskell)
   #:use-module (guix build-system meson)
+  #:use-module (guix build-system scons)
   #:use-module (guix build-system python)
   #:use-module (guix build-system cmake)
   #:use-module (guix build-system trivial))
@@ -3660,7 +3662,7 @@ (define-public mrrescue
 (define-public hyperrogue
   (package
     (name "hyperrogue")
-    (version "10.5")
+    (version "10.5d")
     ;; When updating this package, be sure to update the "hyperrogue-data"
     ;; origin in native-inputs.
     (source (origin
@@ -3671,7 +3673,7 @@ (define-public hyperrogue
                     "-src.tgz"))
               (sha256
                (base32
-                "04wk50f51xrb9vszwil4ivkfpy7xc6nw3gnp90hbna2zqi2jnvb8"))))
+                "1ls055v4pv2xmn2a8lav7wl370zn0wsd91q41bk0amxd168kcndy"))))
     (build-system gnu-build-system)
     (arguments
      `(#:tests? #f ; no check target
@@ -3748,7 +3750,7 @@ (define-public hyperrogue
              "-win.zip"))
            (sha256
             (base32
-             "0r6xvnr7b56iv27n8z10qmxhsz5h7w6ayhxkz3xinlvch84bk708"))))
+             "13n9hcvf9yv7kjghm5jhjpwq1kh94i4bgvcczky9kvdvw1y9278n"))))
        ("unzip" ,unzip)))
     (inputs
      `(("font-dejavu" ,font-dejavu)
@@ -5955,3 +5957,59 @@ (define-public quadrapassel
 complete lines.  You score by dropping blocks fast and completing lines.  As
 your score gets higher, you level up and the blocks fall faster.")
     (license license:gpl2+)))
+
+(define-public endless-sky
+  (package
+    (name "endless-sky")
+    (version "0.9.8")
+    (source
+      (origin
+        (method git-fetch)
+        (uri (git-reference
+               (url "https://github.com/endless-sky/endless-sky")
+               (commit (string-append "v" version))))
+        (file-name (git-file-name name version))
+        (sha256
+         (base32
+          "0i36lawypikbq8vvzfis1dn7yf6q0d2s1cllshfn7kmjb6pqfi6c"))))
+    (build-system scons-build-system)
+    (arguments
+     `(#:scons ,scons-python2
+       #:scons-flags (list (string-append "PREFIX=" (assoc-ref %outputs "out")))
+       #:tests? #f ; no tests
+       #:phases
+       (modify-phases %standard-phases
+         (add-after 'unpack 'patch-resource-locations
+           (lambda* (#:key outputs #:allow-other-keys)
+             (substitute* "source/Files.cpp"
+               (("/usr/local/")
+                (string-append (assoc-ref outputs "out") "/")))
+             #t))
+         (add-after 'unpack 'patch-scons
+           (lambda _
+             (substitute* "SConstruct"
+               ;; Keep environmental variables
+               (("Environment\\(\\)")
+                "Environment(ENV = os.environ)")
+               ;; Install into %out/bin
+               (("games\"") "bin\""))
+             #t)))))
+    (inputs
+     `(("glew" ,glew)
+       ("libjpeg" ,libjpeg-turbo)
+       ("libmad" ,libmad)
+       ("libpng" ,libpng)
+       ("openal" ,openal)
+       ("sdl2" ,sdl2)))
+    (home-page "https://endless-sky.github.io/")
+    (synopsis "2D space trading and combat game")
+    (description "Endless Sky is a 2D space trading and combat game.  Explore
+other star systems.  Earn money by trading, carrying passengers, or completing
+missions.  Use your earnings to buy a better ship or to upgrade the weapons and
+engines on your current one.  Blow up pirates.  Take sides in a civil war.  Or
+leave human space behind and hope to find friendly aliens whose culture is more
+civilized than your own.")
+    (license (list license:gpl3+
+                   license:cc-by-sa3.0
+                   license:cc-by-sa4.0
+                   license:public-domain))))

gnu/packages/geo.scm

@@ -52,6 +52,8 @@ (define-module (gnu packages geo)
   #:use-module (gnu packages perl)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
+  #:use-module (gnu packages sqlite)
   #:use-module (gnu packages web)
   #:use-module (gnu packages webkit)
   #:use-module (gnu packages wxwidgets)

gnu/packages/gl.scm

@@ -43,6 +43,7 @@ (define-module (gnu packages gl)
   #:use-module (gnu packages llvm)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages tls)
   #:use-module (gnu packages video)
   #:use-module (gnu packages xdisorg)

gnu/packages/gnome.scm

@@ -75,6 +75,7 @@ (define-module (gnu packages gnome)
   #:use-module (gnu packages curl)
   #:use-module (gnu packages cyrus-sasl)
   #:use-module (gnu packages databases)
+  #:use-module (gnu packages dbm)
   #:use-module (gnu packages djvu)
   #:use-module (gnu packages dns)
   #:use-module (gnu packages documentation)
@@ -120,10 +121,12 @@ (define-module (gnu packages gnome)
   #:use-module (gnu packages python)
   #:use-module (gnu packages python-crypto)
   #:use-module (gnu packages python-web)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages rdesktop)
   #:use-module (gnu packages scanner)
   #:use-module (gnu packages selinux)
   #:use-module (gnu packages slang)
+  #:use-module (gnu packages sqlite)
   #:use-module (gnu packages ssh)
   #:use-module (gnu packages xml)
   #:use-module (gnu packages gl)
@@ -7377,3 +7380,50 @@ (define-public ghex
 hexadecimal or ASCII.  It is useful for editing binary files in general.")
     (home-page "https://wiki.gnome.org/Apps/Ghex")
     (license license:gpl2)))
+
+(define-public libdazzle
+  (package
+    (name "libdazzle")
+    (version "3.28.5")
+    (source (origin
+              (method url-fetch)
+              (uri (string-append "mirror://gnome/sources/" name "/"
+                                  (version-major+minor version) "/"
+                                  name "-" version ".tar.xz"))
+              (sha256
+               (base32
+                "08qdwv2flywnh6kibkyv0pnm67pk8xlmjh4yqx6hf13hyhkxkqgg"))))
+    (build-system meson-build-system)
+    (arguments
+     `(#:phases
+       (modify-phases %standard-phases
+         (add-after 'unpack 'disable-failing-test
+           (lambda _
+             ;; Disable failing test.
+             (substitute* "tests/meson.build"
+               (("test\\('test-application") "#"))
+             #t))
+         (add-before 'check 'pre-check
+           (lambda _
+             ;; Tests require a running X server.
+             (system "Xvfb :1 &")
+             (setenv "DISPLAY" ":1")
+             #t)))))
+    (native-inputs
+     `(("glib" ,glib "bin") ; glib-compile-resources
+       ("pkg-config" ,pkg-config)
+       ;; For tests
+       ("xorg-server" ,xorg-server)))
+    (inputs
+     `(("glib" ,glib)
+       ("gobject-introspection" ,gobject-introspection)
+       ("gtk+" ,gtk+)
+       ("vala" ,vala)))
+    (home-page "https://gitlab.gnome.org/GNOME/libdazzle")
+    (synopsis "Companion library to GObject and Gtk+")
+    (description "The libdazzle library is a companion library to GObject and
+Gtk+.  It provides various features that the authors wish were in the
+underlying library but cannot for various reasons.  In most cases, they are
+wildly out of scope for those libraries.  In other cases, they are not quite
+generic enough to work for everyone.")
+    (license license:gpl3+)))

gnu/packages/gnunet.scm

@@ -2,7 +2,7 @@
 ;;; Copyright © 2013, 2014, 2015 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
 ;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2015, 2017 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2015, 2017, 2019 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2016 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2016, 2017, 2018 Nils Gillmann <ng0@n0.is>
@@ -53,7 +53,7 @@ (define-module (gnu packages gnunet)
   #:use-module (gnu packages perl)
   #:use-module (gnu packages pulseaudio)
   #:use-module (gnu packages python)
-  #:use-module (gnu packages databases)
+  #:use-module (gnu packages sqlite)
   #:use-module (gnu packages tls)
   #:use-module (gnu packages video)
   #:use-module (gnu packages web)
@@ -189,16 +189,16 @@ (define-public libmicrohttpd
 (define-public gnurl
   (package
    (name "gnurl")
-   (version "7.62.0")
+   (version "7.63.0")
    (source (origin
             (method url-fetch)
             (uri (string-append "mirror://gnu/gnunet/" name "-" version ".tar.Z"))
             (sha256
              (base32
-              "1n258my5q4rxv140xvb1qh6vsh42ii0i8p7f2m15szqabm89487q"))))
+              "021b3pdfnqywk5q07y48kxyz7g4jjg35dk3cv0ps0x50qjr4ix33"))))
    (build-system gnu-build-system)
    (outputs '("out"
-              "doc"))                             ; 1.5 MiB of man3 pages
+              "doc"))                             ; 1.7 MiB of man3 pages
    (inputs `(("gnutls" ,gnutls/dane)
              ("libidn" ,libidn)
              ("zlib" ,zlib)))
@@ -238,6 +238,8 @@ (define-public gnurl
 supports HTTP, HTTPS and GnuTLS.")
    (license (license:non-copyleft "file://COPYING"
                                   "See COPYING in the distribution."))
+   (properties '((ftp-server . "ftp.gnu.org")
+                 (ftp-directory . "/gnunet")))
    (home-page "https://gnunet.org/gnurl")))
 
 (define-public gnunet

gnu/packages/gnupg.scm

@@ -48,16 +48,17 @@ (define-module (gnu packages gnupg)
   #:use-module (gnu packages perl-check)
   #:use-module (gnu packages pth)
   #:use-module (gnu packages python)
+  #:use-module (gnu packages python-xyz)
   #:use-module (gnu packages qt)
   #:use-module (gnu packages readline)
   #:use-module (gnu packages compression)
-  #:use-module (gnu packages databases)
   #:use-module (gnu packages gtk)
   #:use-module (gnu packages glib)
   #:use-module (gnu packages gnome)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages ncurses)
   #:use-module (gnu packages security-token)
+  #:use-module (gnu packages sqlite)
   #:use-module (gnu packages swig)
   #:use-module (gnu packages texinfo)
   #:use-module (gnu packages tls)