[bug#30604] [PATCH v10 5/6] linux-initrd: Provide our own 'modprobe' program.

[Ludovic Courtès]

This allows us to load modules on demand when the kernel asks for them.

* gnu/system/linux-initrd.scm (modprobe-program): New variable.
(flat-linux-module-directory): Call 'write-module-alias-database'.
(raw-initrd): Pass #:modprobe to 'boot-system'.
(expression->initrd): Copy "closure" to $out/references.
* gnu/build/linux-boot.scm (boot-system): Add #:modprobe and honor it.
Call 'load-needed-linux-modules'.
* gnu/system/vm.scm (qemu-image): Add #:linux parameter.  Define
'modprobe-wrapper' and pass it to 'activate-modprobe'.  Pass #:linux to
'expression->derivation-in-linux-vm'.

Co-authored-by: Danny Milosavljevic <address@hidden>
---
 gnu/build/linux-boot.scm    | 13 +++++--
 gnu/system/linux-initrd.scm | 86 +++++++++++++++++++++++++++++++++++++++++----
 gnu/system/vm.scm           | 21 +++++++++++
 3 files changed, 111 insertions(+), 9 deletions(-)

diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index df0b2b2d1..eedc4bb9d 100644
--- a/gnu/build/linux-boot.scm
+++ b/gnu/build/linux-boot.scm
@@ -435,6 +435,7 @@ bailing out.~%root contents: ~s~%" (scandir "/"))
 
 
 (define* (boot-system #:key
+                      modprobe
                       (linux-modules '())
                       linux-module-directory
                       qemu-guest-networking?
@@ -449,6 +450,9 @@ QEMU-GUEST-NETWORKING? is true, calling PRE-MOUNT, mounting 
the file systems
 specified in MOUNTS, and finally booting into the new root if any.  The initrd
 supports kernel command-line options '--load', '--root', and '--repl'.
 
+MODPROBE must be #f or a program to install as the modprobe program that the
+kernel will invoke when it needs to load modules.
+
 Mount the root file system, specified by the '--root' command-line argument,
 if any.
 
@@ -482,9 +486,14 @@ upon error."
        (when (member "--repl" args)
          (start-repl))
 
+       (when modprobe
+         ;; Tell the kernel to invoke MODPROBE.
+         (call-with-output-file "/proc/sys/kernel/modprobe"
+           (lambda (port)
+             (display modprobe port))))
+
        (display "loading kernel modules...\n")
-       (load-linux-modules-from-directory linux-modules
-                                          linux-module-directory)
+       (load-needed-linux-modules linux-module-directory)
 
        (when qemu-guest-networking?
          (unless (configure-qemu-networking)
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 1eb5f5130..6b7883c2c 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -63,6 +63,75 @@
 ;;;
 ;;; Code:
 
+(define* (modprobe-program linux-module-directory #:key
+                           (guile %guile-static-stripped))
+  "Return a minimal implementation of 'modprobe' for our initrd that looks up
+modules in LINUX-MODULE-DIRECTORY.  This program will be invoked by the kernel
+when modules need to be loaded."
+  (define program
+    (with-imported-modules (source-module-closure
+                            '((gnu build linux-modules)))
+      #~(begin
+          (use-modules (gnu build linux-modules)
+                       (ice-9 match)
+                       (srfi srfi-1)
+                       (srfi srfi-26)
+                       (srfi srfi-37))
+
+          (define option-spec
+            (list (option '(#\q "quiet") #f #f
+                          (lambda (opt name arg result)
+                            (alist-cons 'quiet? #t result)))))
+
+          (define options
+            ;; Alist of options and non-option arguments.
+            (args-fold (cdr (program-arguments))
+                       option-spec
+                       (lambda (opt name arg result)
+                         (error "unrecognized option" name))
+                       (lambda (arg result)
+                         (alist-cons 'argument arg result))
+                       '()))
+
+          (define aliases
+            ;; The list of aliases we are asked to load.
+            (filter-map (match-lambda
+                          (('argument . alias) alias)
+                          (_ #f))
+                        options))
+
+          (define linux-module-directory
+            ;; The module directory.  Note: We expect a flat directory here.
+            #$linux-module-directory)
+
+          (define %known-aliases
+            ;; The alias database.
+            (known-module-aliases
+             (string-append linux-module-directory "/modules.alias")))
+
+          (define (device-aliases->module-names aliases)
+            ;; Return the list of module names for the subset of ALIASES that
+            ;; appears in %KNOWN-ALIASES.
+            (append-map (cut matching-modules <> %known-aliases)
+                        aliases))
+
+          (when (assq-ref options 'quiet?)
+            (current-error-port (%make-void-port "w"))
+            (current-output-port (%make-void-port "w")))
+
+          (let ((modules (device-aliases->module-names aliases)))
+            (call-with-output-file "/dev/kmsg"
+              (lambda (port)
+                (format port "modprobe[~a]: aliases ~s; modules ~s; args ~s~%"
+                        (getpid) aliases modules (program-arguments))))
+
+            (when (< (length modules) (length aliases))
+              (error "alias resolution failed" aliases))
+
+            (load-linux-modules-from-directory (reverse modules)
+                                               linux-module-directory)))))
+
+  (program-file "modprobe" program #:guile guile))
 
 (define* (expression->initrd exp
                              #:key
@@ -89,16 +158,16 @@ the derivations referenced by EXP are automatically copied 
to the initrd."
           (mkdir #$output)
 
           ;; The guile used in the initrd must be present in the store, so
-          ;; that module loading works once the root is switched.
+          ;; that module loading works once the root is switched.  Similarly,
+          ;; the 'modprobe' program installed in /proc/sys/kernel/modprobe by
+          ;; the initrd, if any, must be present after switch root.
           ;;
           ;; To ensure that is the case, add an explicit reference to the
           ;; guile package used in the initrd to the output.
           ;;
-          ;; This fixes guix-patches bug #28399, "Fix mysql activation, and
+          ;; This fixes <https://bugs.gnu.org/28399>, "Fix mysql activation, 
and
           ;; add a basic test".
-          (call-with-output-file (string-append #$ output "/references")
-            (lambda (port)
-              (simple-format port "~A\n" #$guile)))
+          (copy-file "closure" (string-append #$output "/references"))
 
           (build-initrd (string-append #$output "/initrd")
                         #:guile #$guile
@@ -153,7 +222,9 @@ MODULES and taken from LINUX."
                       (copy-file module
                                  (string-append #$output "/"
                                                 (basename module))))
-                    (delete-duplicates modules)))))
+                    (delete-duplicates modules))
+
+          (write-module-alias-database #$output))))
 
   (computed-file "linux-modules" build-exp))
 
@@ -222,7 +293,8 @@ upon error."
              (set-path-environment-variable "PATH" '("bin" "sbin")
                                             '#$helper-packages)))
 
-         (boot-system #:mounts
+         (boot-system #:modprobe #$(modprobe-program kodir)
+                      #:mounts
                       (map spec->file-system
                            '#$(map file-system->spec file-systems))
                       #:pre-mount (lambda ()
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 4360adf15..ecb7ed506 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -249,6 +249,7 @@ INPUTS is a list of inputs (as for packages)."
 (define* (qemu-image #:key
                      (name "qemu-image")
                      (system (%current-system))
+                     (linux linux-libre)
                      (qemu qemu-minimal)
                      (disk-image-size 'guess)
                      (disk-image-format "qcow2")
@@ -275,18 +276,37 @@ INPUTS is a list of inputs (as for packages).  When 
COPY-INPUTS? is true, copy
 all of INPUTS into the image being built.  When REGISTER-CLOSURES? is true,
 register INPUTS in the store database of the image so that Guix can be used in
 the image."
+  (define modprobe-wrapper
+    ;; Wrapper for the 'modprobe' command that knows where modules live.
+    (let ((modprobe (file-append kmod "/bin/modprobe")))
+      (program-file "modprobe"
+                    #~(begin
+                        (setenv "LINUX_MODULE_DIRECTORY"
+                                #$(file-append linux "/lib/modules"))
+                        (apply execl #$modprobe
+                               (cons #$modprobe (cdr (command-line))))))))
+
+
   (expression->derivation-in-linux-vm
    name
    (with-imported-modules (source-module-closure '((gnu build bootloader)
                                                    (gnu build vm)
+                                                   (gnu build activation)
                                                    (guix build utils)))
      #~(begin
          (use-modules (gnu build bootloader)
                       (gnu build vm)
+                      ((gnu build activation) #:select (activate-modprobe))
                       (guix build utils)
                       (srfi srfi-26)
                       (ice-9 binary-ports))
 
+         ;; We may need to lazy-load modules.  The initrd installs a
+         ;; 'modprobe' that can only search through the modules available in
+         ;; the initrd, but here we want to be able to use all the modules of
+         ;; LINUX.  Thus, install a real 'modprobe'.
+         (activate-modprobe #$modprobe-wrapper)
+
          (let ((inputs
                 '#$(append (list qemu parted e2fsprogs dosfstools)
                            (map canonical-package
@@ -361,6 +381,7 @@ the image."
                                    #$(bootloader-installer bootloader))
              (reboot)))))
    #:system system
+   #:linux linux
    #:make-disk-image? #t
    #:disk-image-size disk-image-size
    #:disk-image-format disk-image-format
-- 
2.16.2