[bug#30604] [PATCH v8 7/7] linux-initrd: Factorize %modprobe and flat-linux-module-directory.

[Danny Milosavljevic <dannym@scratchpost.org>]

* gnu/build/linux-modules.scm (module-aliases->module-file-names): New
procedure.
* gnu/system/linux-initrd.scm (%modprobe): Use
module-aliases->module-file-names.
(flat-linux-module-directory): Use module-aliases->module-file-names.
---
 gnu/build/linux-modules.scm |  56 +++++++++++++++++++++-
 gnu/system/linux-initrd.scm | 110 ++++++++++++++++++--------------------------
 2 files changed, 100 insertions(+), 66 deletions(-)

diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm
index af217c974..44059ad93 100644
--- a/gnu/build/linux-modules.scm
+++ b/gnu/build/linux-modules.scm
@@ -21,6 +21,7 @@
   #:use-module (guix elf)
   #:use-module (guix glob)
   #:use-module (guix build syscalls)
+  #:use-module (guix build utils) ; find-files
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
@@ -28,9 +29,12 @@
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 ftw)
   #:export (dot-ko
             ensure-dot-ko
             module-aliases
+            module-aliases->module-file-names
             module-dependencies
             recursive-module-dependencies
             modules-loaded
@@ -385,7 +389,7 @@ ALIAS is a string like \"scsi:t-0x00\" as returned by
 
 (define (install-module-files module-files output)
   "Install MODULE-FILES to OUTPUT.
-Precondition: OUTPUT is an empty directory."
+Precondition: OUTPUT is an empty directory except for \"modules.builtin\"."
   (let ((aliases
          (map (lambda (module-file-name)
                 (format #t "copying '~a'...~%" module-file-name)
@@ -431,4 +435,54 @@ Precondition: OUTPUT is an empty directory."
             (_ #f))
            aliases))))))
 
+(define (module-aliases->module-file-names linux aliases)
+  "Resolve ALIASES to module file names, including their dependencies (which will appear
+first).  Each alias will map to a list of module file names.
+LINUX is the directory containing \"lib\"."
+  (define (string->regexp str)
+    ;; Return a regexp that matches STR exactly.
+    (string-append "^" (regexp-quote str) "$"))
+
+  (define module-dir
+    (string-append linux "/lib/modules"))
+
+  (define (find-only-entry directory)
+    (match (scandir directory)
+     (("." ".." basename)
+      (string-append directory "/" basename))))
+
+  (define linux-release-module-directory
+    (find-only-entry module-dir))
+
+  (define known-module-aliases*
+    (known-module-aliases
+     (string-append linux-release-module-directory
+                    "/modules.alias")))
+  (define (resolve-alias alias)
+    "If possible, resolve ALIAS to a list of module names.
+Otherwise return just ALIAS as possible module names."
+    (match (delete-duplicates (matching-modules alias
+                                                known-module-aliases*))
+           (()
+            (list alias))
+           (items
+            items)))
+
+  (define (lookup module)
+    (let ((name (ensure-dot-ko module)))
+      (match (find-files module-dir (string->regexp name))
+             ((file)
+              file)
+             (()
+              (error "module not found" name module-dir))
+             ((_ ...)
+              (error "several modules by that name"
+                     name module-dir)))))
+  (append-map (lambda (alias)
+                (let ((modules (map lookup (resolve-alias alias))))
+                  (append (recursive-module-dependencies modules
+                                                         #:lookup-module
+                                                         lookup) modules)))
+              aliases))
+
 ;;; linux-modules.scm ends here
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 8050ac47e..dc826c63e 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -58,35 +58,14 @@
 
 (define* (%modprobe linux-module-directory #:key
                     (guile %guile-static-stripped))
+  "Minimal implementation of modprobe for our initrd.
+LINUX-MODULE-DIRECTORY is the directory that contains \"lib\"."
   (program-file "modprobe"
     (with-imported-modules (source-module-closure
                             '((gnu build linux-modules)))
       #~(begin
           (use-modules (gnu build linux-modules) (ice-9 getopt-long)
-                       (ice-9 match) (srfi srfi-1) (ice-9 ftw))
-          (define (find-only-entry directory)
-            (match (scandir directory)
-             (("." ".." basename)
-              (string-append directory "/" basename))))
-          (define (resolve-alias alias)
-            (let* ((linux-release-module-directory
-                    (find-only-entry (string-append "/lib/modules"))))
-              (match (delete-duplicates (matching-modules alias
-                      (known-module-aliases
-                        (string-append linux-release-module-directory
-                                       "/modules.alias"))))
-               (()
-                (error "no alias by that name" alias))
-               (items
-                items))))
-          (define (lookup-module module)
-            (let* ((linux-release-module-directory
-                    (find-only-entry (string-append "/lib/modules")))
-                   (file-name (string-append linux-release-module-directory
-                                             "/" (ensure-dot-ko module))))
-              (if (file-exists? file-name)
-                  file-name
-                  (error "no module file found for module" module))))
+                       (ice-9 match) (srfi srfi-1))
           (define option-spec
            '((quiet    (single-char #\q) (value #f))))
           (define options
@@ -98,22 +77,31 @@
             (for-each (match-lambda
                         (('quiet . #t)
                          #f)
-                        ((() modules ...)
-                         (for-each (lambda (alias)
-                                     (catch #t
-                                       (lambda ()
-                                         (let ((modules (resolve-alias alias)))                                           (for-each (lambda (module)
-                                                       (load-linux-module*
-                                                        (lookup-module module)
-                                                        #:lookup-module
-                                                        lookup-module))
-                                                     modules)))
-                                       (lambda (key . args)
-                                         (display (cons* key args)
-                                                  (current-error-port))
-                                         (newline (current-error-port))
-                                         (set! exit-status 1))))
-                                   modules)))
+                        ((() aliases ...)
+                         (catch #t
+                           (lambda ()
+                             (let ((module-file-names
+                                    (module-aliases->module-file-names
+                                     #$linux-module-directory aliases)))
+                               (for-each (lambda (name)
+                                           (catch 'system-error
+                                             (lambda ()
+                                               (when (not (load-linux-module* name
+                                                                              #:recursive?
+                                                                              #f))
+                                                 (set! exit-status 1)))
+                                             (lambda (key . args)
+                                               (when (not (= EEXIST
+                                                             (system-error-errno
+                                                              (cons key args))))
+                                                 (print-exception (current-error-port)
+                                                                  #f key args)
+                                                 (set! exit-status 1)))))
+                                         module-file-names)))
+                           (lambda (key . args)
+                             (print-exception (current-error-port)
+                                              #f key args)
+                             (set! exit-status 1)))))
                       options)
             (exit exit-status))))
   #:guile guile))
@@ -173,17 +161,17 @@ the derivations referenced by EXP are automatically copied to the initrd."
                     #:references-graphs `(("init-closure" ,init)
                                           ("modprobe-closure" ,modprobe))))
 
-(define (flat-linux-module-directory linux modules)
-  "Return a flat directory containing the Linux kernel modules listed in
-MODULES and taken from LINUX."
+(define (flat-linux-module-directory linux aliases)
+  "Return a flat directory containing the Linux kernel modules resolved by
+ALIASES and taken from LINUX."
   (define build-exp
     (with-imported-modules (source-module-closure
                             '((guix build utils)
                               (gnu build linux-modules)))
       #~(begin
-          (use-modules (ice-9 match) (ice-9 regex) (ice-9 ftw)
+          (use-modules (ice-9 match) (ice-9 ftw)
                        (srfi srfi-1)
-                       (guix build utils)
+                       (guix build utils) ; TODO: Remove
                        (gnu build linux-modules))
 
           (define (string->regexp str)
@@ -193,33 +181,25 @@ MODULES and taken from LINUX."
           (define module-dir
             (string-append #$linux "/lib/modules"))
 
-          (define (lookup module)
-            (let ((name (ensure-dot-ko module)))
-              (match (find-files module-dir (string->regexp name))
-                ((file)
-                 file)
-                (()
-                 (error "module not found" name module-dir))
-                ((_ ...)
-                 (error "several modules by that name"
-                        name module-dir)))))
+          (define (find-only-entry directory)
+            (match (scandir directory)
+             (("." ".." basename)
+              (string-append directory "/" basename))))
+
+          (define linux-release-module-directory
+            (find-only-entry module-dir))
 
           (define modules
-            (let ((modules (map lookup '#$modules)))
-              (append modules
-                      (recursive-module-dependencies modules
-                                                     #:lookup-module lookup))))
+            (module-aliases->module-file-names #$linux '#$aliases))
 
           (define version
-            (match
-             (filter
-              (lambda (name)
-                (not (string-prefix? "." name)))
-              (scandir module-dir))
-             ((item) item)))
+            (basename linux-release-module-directory))
 
           (let ((output (string-append #$output "/lib/modules/" version)))
             (mkdir-p output)
+            (install-file
+             (string-append linux-release-module-directory "/modules.builtin")
+             output)
             (install-module-files (delete-duplicates modules) output))
           #t)))
   (computed-file "linux-modules" build-exp))