02/08: installer: Produce an 'initrd-modules' field if needed.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 50247be5f4633a4c3446cddbd3515d027853ec0d
Author: Ludovic Courtès <address@hidden>
Date:   Tue Mar 26 23:06:51 2019 +0100

    installer: Produce an 'initrd-modules' field if needed.
    
    * gnu/installer/parted.scm (root-user-partition?): New procedure.
    (bootloader-configuration): Use it.
    (user-partition-missing-modules, initrd-configuration): New procedures.
    (user-partitions->configuration): Call 'initrd-configuration'.o
    * gnu/installer.scm (not-config?): Rename to...
    (module-to-import?): ... this.  Add cases to exclude non-installer and
    non-build (gnu …) modules.
    (installer-program)[installer-builder]: Add GUIX to the extension list.
---
 gnu/installer.scm        | 20 +++++++++++++-------
 gnu/installer/parted.scm | 45 ++++++++++++++++++++++++++++++++++++++-------
 2 files changed, 51 insertions(+), 14 deletions(-)

diff --git a/gnu/installer.scm b/gnu/installer.scm
index 02f26ee..584ca38 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -43,13 +43,17 @@
   #:use-module (srfi srfi-1)
   #:export (installer-program))
 
-(define not-config?
-  ;; Select (guix …) and (gnu …) modules, except (guix config).
+(define module-to-import?
+  ;; Return true for modules that should be imported.  For (gnu system …) and
+  ;; (gnu packages …) modules, we simply add the whole 'guix' package via
+  ;; 'with-extensions' (to avoid having to rebuild it all), which is why these
+  ;; modules are excluded here.
   (match-lambda
     (('guix 'config) #f)
-    (('guix rest ...) #t)
-    (('gnu rest ...) #t)
-    (rest #f)))
+    (('gnu 'installer _ ...) #t)
+    (('gnu 'build _ ...) #t)
+    (('guix 'build _ ...) #t)
+    (_ #f)))
 
 (define* (build-compiled-file name locale-builder)
   "Return a file-like object that evalutes the gexp LOCALE-BUILDER and store
@@ -296,13 +300,15 @@ selected keymap."
      "gnu/installer"))
 
   (define installer-builder
+    ;; Note: Include GUIX as an extension to get all the (gnu system …), (gnu
+    ;; packages …), etc. modules.
     (with-extensions (list guile-gcrypt guile-newt
                            guile-parted guile-bytestructures
-                           guile-json)
+                           guile-json guile-git guix)
       (with-imported-modules `(,@(source-module-closure
                                   `(,@modules
                                     (guix build utils))
-                                  #:select? not-config?)
+                                  #:select? module-to-import?)
                                ((guix config) => ,(make-config.scm)))
         #~(begin
             (use-modules (gnu installer record)
diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm
index b9eaa79..7cc2217 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 <address@hidden>
+;;; Copyright © 2019 Ludovic Courtès <address@hidden>
 ;;;
 ;;; 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,15 +1248,16 @@ 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?)
@@ -1264,6 +1270,30 @@ from (gnu system mapped-devices) and return it."
        ;; <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."
   (let* ((swap-user-partitions (find-swap-user-partitions user-partitions))
@@ -1271,6 +1301,7 @@ from (gnu system mapped-devices) and return it."
          (encrypted-partitions
           (filter user-partition-crypt-label user-partitions)))
     `((bootloader ,@(bootloader-configuration user-partitions))
+      ,@(initrd-configuration user-partitions)
       ,@(if (null? swap-devices)
             '()
             `((swap-devices (list ,@swap-devices))))