[bug#37868] [PATCH] guix: Allow multiple packages to provide Linux modules in the system profile.

[Danny Milosavljevic]

* guix/profiles.scm (linux-module-database): New procedure.
(%default-profile-hooks): Add it.
* gnu/system.scm (operating-system-profile): Add kernel to what
profile-service-type gives.
* gnu/services.scm (%modprobe-wrapper): Use that profile.
* guix/build/linux-module-build-system.scm (install): Disable DEPMOD.
---
 gnu/services.scm                         |  7 ++-
 gnu/system.scm                           |  8 ++-
 guix/build/linux-module-build-system.scm |  5 +-
 guix/profiles.scm                        | 75 +++++++++++++++++++++++-
 4 files changed, 87 insertions(+), 8 deletions(-)

diff --git a/gnu/services.scm b/gnu/services.scm
index 6ee05d4580..2a6d2bc464 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -491,7 +491,12 @@ ACTIVATION-SCRIPT-TYPE."
     (program-file "modprobe"
                   #~(begin
                       (setenv "LINUX_MODULE_DIRECTORY"
-                              "/run/booted-system/kernel/lib/modules")
+                              (if (file-exists?
+                                   "/run/booted-system/profile/lib/modules")
+                                  "/run/booted-system/profile/lib/modules"
+                                  ;; Provides compatibility with previous
+                                  ;; Guix generations.
+                                  "/run/booted-system/kernel/lib/modules"))
                       (apply execl #$modprobe
                              (cons #$modprobe (cdr (command-line))))))))
 
diff --git a/gnu/system.scm b/gnu/system.scm
index a353b1a5c8..66270b38bb 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -887,12 +887,14 @@ we're running in the final root."
 (define* (operating-system-profile os)
   "Return a derivation that builds the system profile of OS."
   (mlet* %store-monad
-      ((services -> (operating-system-services os))
+      ((kernel -> (operating-system-kernel os))
+       (services -> (operating-system-services os))
        (profile (fold-services services
-                               #:target-type profile-service-type)))
+                               #:target-type
+                               profile-service-type)))
     (match profile
       (("profile" profile)
-       (return profile)))))
+       (return (cons kernel profile)))))) ; FIXME: Doesn't work for some 
reason.  I don't think this place is ever reached.
 
 (define (operating-system-root-file-system os)
   "Return the root file system of OS."
diff --git a/guix/build/linux-module-build-system.scm 
b/guix/build/linux-module-build-system.scm
index cd76df2de7..e4e6993a49 100644
--- a/guix/build/linux-module-build-system.scm
+++ b/guix/build/linux-module-build-system.scm
@@ -60,15 +60,14 @@
 ;; part.
 (define* (install #:key inputs native-inputs outputs #:allow-other-keys)
   (let* ((out (assoc-ref outputs "out"))
-         (moddir (string-append out "/lib/modules"))
-         (kmod (assoc-ref (or native-inputs inputs) "kmod")))
+         (moddir (string-append out "/lib/modules")))
     ;; Install kernel modules
     (mkdir-p moddir)
     (invoke "make" "-C"
             (string-append (assoc-ref inputs "linux-module-builder")
                            "/lib/modules/build")
             (string-append "M=" (getcwd))
-            (string-append "DEPMOD=" kmod "/bin/depmod")
+            "DEPMOD=true" ; disable depmod.
             (string-append "MODULE_DIR=" moddir)
             (string-append "INSTALL_PATH=" out)
             (string-append "INSTALL_MOD_PATH=" out)
diff --git a/guix/profiles.scm b/guix/profiles.scm
index cd3b21e390..fd77392588 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -9,6 +9,7 @@
 ;;; Copyright © 2017 Huang Ying <address@hidden>
 ;;; Copyright © 2017 Maxim Cournoyer <address@hidden>
 ;;; Copyright © 2019 Kyle Meyer <address@hidden>
+;;; Copyright © 2019 Danny Milosavljevic <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -1125,6 +1126,77 @@ for both major versions of GTK+."
                               (hook . gtk-im-modules)))
           (return #f)))))
 
+(define (linux-module-database manifest)
+  (mlet %store-monad
+    ((kmod (manifest-lookup-package manifest "kmod")))
+    (define build
+      (with-imported-modules '((guix build utils)
+                               (guix build union))
+       #~(begin
+          (use-modules (srfi srfi-1)
+                       (srfi srfi-26)
+                       (guix build utils)
+                       (guix build union)
+                       (ice-9 ftw)
+                       (ice-9 match))
+          (let* ((inputs '#$(manifest-inputs manifest))
+                 (input-files (lambda (path)
+                                (filter file-exists?
+                                  (map (cut string-append <> path) inputs))))
+                 (module-directories (input-files "/lib/modules"))
+                 (System.maps (input-files "/System.map"))
+                 (Module.symverss (input-files "/Module.symvers"))
+                 (directory-entries (lambda (directory-name)
+                                       (filter (lambda (basename)
+                                                 (not (string-prefix? "."
+                                                                      
basename)))
+                                               (scandir directory-name))))
+                 ;; Note: Should result in one entry.
+                 (versions (append-map directory-entries module-directories)))
+              ;; TODO: if len(module-directories) == 1: return 
module-directories[0]
+              (mkdir-p (string-append #$output "/lib/modules"))
+              ;; Iterate over each kernel version directory (usually one).
+              (for-each (lambda (version)
+                          (let ((destination-directory (string-append #$output 
"/lib/modules/" version)))
+                            (when (not (file-exists? destination-directory)) ; 
unique
+                              (union-build destination-directory
+                                           ;; All directories with the same 
version as us.
+                                           (filter-map (lambda (directory-name)
+                                                         (if (member version
+                                                                     
(directory-entries directory-name))
+                                                             (string-append 
directory-name "/" version)
+                                                             #f))
+                                                       module-directories)
+                                           #:create-all-directories? #t)
+                              ;; Delete generated files (they will be 
recreated shortly).
+                              (for-each (lambda (basename)
+                                          (when (string-prefix? "modules." 
basename)
+                                            (false-if-file-not-found
+                                              (delete-file
+                                               (string-append
+                                                destination-directory "/"
+                                                basename)))))
+                                        (directory-entries 
destination-directory))
+                              (unless (zero? (system* (string-append #$kmod 
"/bin/depmod")
+                                                      "-e" ; Report symbols 
that aren't supplied
+                                                      "-w" ; Warn on duplicates
+                                                      "-b" #$output ; 
destination-directory
+                                                      "-F" (match System.maps
+                                                            ((x) x))
+                                                      "-E" (match 
Module.symverss
+                                                            ((x) x))
+                                                      version))
+                                (display "FAILED\n" (current-error-port))
+                                (exit #f)))))
+                        versions)
+              (exit #t)))))
+    (gexp->derivation "linux-module-database" build
+                      #:local-build? #t
+                      #:substitutable? #f
+                      #:properties
+                      `((type . profile-hook)
+                        (hook . linux-module-database)))))
+
 (define (xdg-desktop-database manifest)
   "Return a derivation that builds the @file{mimeinfo.cache} database from
 desktop files.  It's used to query what applications can handle a given
@@ -1425,7 +1497,8 @@ MANIFEST."
         gtk-im-modules
         texlive-configuration
         xdg-desktop-database
-        xdg-mime-database))
+        xdg-mime-database
+        linux-module-database))
 
 (define* (profile-derivation manifest
                              #:key