Merge branch 'master' into staging

5 files changed, 106 insertions, 14 deletions

diff --git a/gnu/installer/newt/keymap.scm b/gnu/installer/newt/keymap.scm
index 3e765bfdd4..948b54783c 100644
--- a/gnu/installer/newt/keymap.scm
+++ b/gnu/installer/newt/keymap.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -27,7 +28,9 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
-  #:export (run-keymap-page))
+  #:use-module (ice-9 match)
+  #:export (run-keymap-page
+            keyboard-layout->configuration))
 
 (define (run-layout-page layouts layout->text)
   (let ((title (G_ "Layout")))
@@ -120,3 +123,11 @@ names of the selected keyboard layout and variant."
       (list layout (or variant ""))))
   (format-result
    (run-installer-steps #:steps keymap-steps)))
+
+(define (keyboard-layout->configuration keymap)
+  "Return the operating system configuration snippet to install KEYMAP."
+  (match keymap
+    ((name "")
+     `((keyboard-layout (keyboard-layout ,name))))
+    ((name variant)
+     `((keyboard-layout (keyboard-layout ,name ,variant))))))
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index 23fbfcce76..8b3fd488e9 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,6 +30,7 @@
             draw-connecting-page
             run-input-page
             run-error-page
+            run-confirmation-page
             run-listbox-selection-page
             run-scale-page
             run-checkbox-tree-page
@@ -141,6 +143,42 @@ of the page is set to TITLE."
     (newt-set-color COLORSET-ROOT "white" "blue")
     (destroy-form-and-pop form)))
 
+(define* (run-confirmation-page text title
+                                #:key (exit-button-procedure (const #f)))
+  "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))
+         (ok-button (make-button -1 -1 (G_ "Continue")))
+         (exit-button (make-button -1 -1 (G_ "Exit")))
+         (grid (vertically-stacked-grid
+                GRID-ELEMENT-COMPONENT text-box
+                GRID-ELEMENT-SUBGRID
+                (horizontal-stacked-grid
+                 GRID-ELEMENT-COMPONENT ok-button
+                 GRID-ELEMENT-COMPONENT exit-button)))
+         (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)
+               #t)
+              ((components=? argument exit-button)
+               (exit-button-procedure))))))
+        (lambda ()
+          (destroy-form-and-pop form))))))
+
 (define* (run-listbox-selection-page #:key
                                      info-text
                                      title
diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm
index d4c91edc66..373aedd24c 100644
--- a/gnu/installer/newt/partition.scm
+++ b/gnu/installer/newt/partition.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -53,7 +54,12 @@
     (car result)))
 
 (define (draw-formatting-page)
-  "Draw a page to indicate partitions are being formated."
+  "Draw a page asking for confirmation, and then indicating that partitions
+are being formatted."
+  (run-confirmation-page (G_ "We are about to format your hard disk.  All \
+its data will be lost.  Do you wish to continue?")
+                         (G_ "Format disk?")
+                         #:exit-button-procedure button-exit-action)
   (draw-info-page
    (format #f (G_ "Partition formatting is in progress, please wait."))
    (G_ "Preparing partitions")))
diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm
index 642b8c6d8a..7cc2217cbe 100644
--- a/gnu/installer/parted.scm
+++ b/gnu/installer/parted.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,6 +25,10 @@
   #:use-module ((gnu build file-systems)
                 #:select (read-partition-uuid
                           read-luks-partition-uuid))
+  #:use-module ((gnu build linux-modules)
+                #:select (missing-modules))
+  #:use-module ((gnu system linux-initrd)
+                #:select (%base-initrd-modules))
   #:use-module (guix build syscalls)
   #:use-module (guix build utils)
   #:use-module (guix records)
@@ -1243,22 +1248,51 @@ from (gnu system mapped-devices) and return it."
       (target ,label)
       (type luks-device-mapping))))
 
+(define (root-user-partition? partition)
+  "Return true if PARTITION is the root partition."
+  (let ((mount-point (user-partition-mount-point partition)))
+    (and mount-point
+         (string=? mount-point "/"))))
+
 (define (bootloader-configuration user-partitions)
   "Return the bootloader configuration field for USER-PARTITIONS."
-  (let* ((root-partition
-          (find (lambda (user-partition)
-                  (let ((mount-point
-                         (user-partition-mount-point user-partition)))
-                    (and mount-point
-                         (string=? mount-point "/"))))
-                user-partitions))
+  (let* ((root-partition (find root-user-partition?
+                               user-partitions))
          (root-partition-disk (user-partition-disk-file-name root-partition)))
     `((bootloader-configuration
        ,@(if (efi-installation?)
              `((bootloader grub-efi-bootloader)
                (target ,(default-esp-mount-point)))
              `((bootloader grub-bootloader)
-               (target ,root-partition-disk)))))))
+               (target ,root-partition-disk)))
+
+       ;; XXX: Assume we defined the 'keyboard-layout' field of
+       ;; <operating-system> right above.
+       (keyboard-layout keyboard-layout)))))
+
+(define (user-partition-missing-modules user-partitions)
+  "Return the list of kernel modules missing from the default set of kernel
+modules to access USER-PARTITIONS."
+  (let ((devices (filter user-partition-crypt-label user-partitions))
+        (root    (find root-user-partition? user-partitions)))
+    (delete-duplicates
+     (append-map (lambda (device)
+                   (catch 'system-error
+                     (lambda ()
+                       (missing-modules device %base-initrd-modules))
+                     (const '())))
+                 (delete-duplicates
+                  (map user-partition-file-name
+                       (cons root devices)))))))
+
+(define (initrd-configuration user-partitions)
+  "Return an 'initrd-modules' field with everything needed for
+USER-PARTITIONS, or return nothing."
+  (match (user-partition-missing-modules user-partitions)
+    (()
+     '())
+    ((modules ...)
+     `((initrd-modules ',modules)))))
 
 (define (user-partitions->configuration user-partitions)
   "Return the configuration field for USER-PARTITIONS."
@@ -1266,10 +1300,11 @@ from (gnu system mapped-devices) and return it."
          (swap-devices (map user-partition-file-name swap-user-partitions))
          (encrypted-partitions
           (filter user-partition-crypt-label user-partitions)))
-    `(,@(if (null? swap-devices)
+    `((bootloader ,@(bootloader-configuration user-partitions))
+      ,@(initrd-configuration user-partitions)
+      ,@(if (null? swap-devices)
             '()
             `((swap-devices (list ,@swap-devices))))
-      (bootloader ,@(bootloader-configuration user-partitions))
       ,@(if (null? encrypted-partitions)
             '()
             `((mapped-devices
diff --git a/gnu/installer/services.scm b/gnu/installer/services.scm
index ed44b87682..2b6625f6af 100644
--- a/gnu/installer/services.scm
+++ b/gnu/installer/services.scm
@@ -38,13 +38,15 @@
   (list
    (desktop-environment
     (name "GNOME")
-    (snippet '(gnome-desktop-service)))
+    (snippet '(service gnome-desktop-service-type)))
    (desktop-environment
     (name "Xfce")
+    ;; TODO: Use 'xfce-desktop-service-type' when the 'guix' package provides
+    ;; it with a default value.
     (snippet '(xfce-desktop-service)))
    (desktop-environment
     (name "MATE")
-    (snippet '(mate-desktop-service)))
+    (snippet '(service mate-desktop-service-type)))
    (desktop-environment
     (name "Enlightenment")
     (snippet '(service enlightenment-desktop-service-type)))))