[bug#37868] [PATCH v2 2/2] system: Add kernel-module-packages to operating-system.

[Danny Milosavljevic <dannym@scratchpost.org>]

* gnu/system.scm (<operating-system>): Add kernel-module-packages.
(operating-system-directory-base-entries): Use it.
* guix/profiles.scm (linux-module-database): New procedure.  Export it.
---
 gnu/system.scm    | 26 +++++++++++++---
 guix/profiles.scm | 76 ++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 97 insertions(+), 5 deletions(-)

diff --git a/gnu/system.scm b/gnu/system.scm
index 01baa248a2..b1cd278044 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019 Meiyo Peng <meiyo.peng@gmail.com>
+;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -164,6 +165,8 @@
 
   (kernel operating-system-kernel                 ; package
           (default linux-libre))
+  (kernel-module-packages operating-system-kernel-module-packages
+                    (default '()))                ; list of packages
   (kernel-arguments operating-system-user-kernel-arguments
                     (default '("quiet")))         ; list of gexps/strings
   (bootloader operating-system-bootloader)        ; <bootloader-configuration>
@@ -468,10 +471,25 @@ OS."
   "Return the basic entries of the 'system' directory of OS for use as the
 value of the SYSTEM-SERVICE-TYPE service."
   (let ((locale (operating-system-locale-directory os)))
-    (mlet %store-monad ((kernel -> (operating-system-kernel os))
-                        (initrd -> (operating-system-initrd-file os))
-                        (params    (operating-system-boot-parameters-file os)))
-      (return `(("kernel" ,kernel)
+    (mlet* %store-monad ((kernel -> (operating-system-kernel os))
+                         (kernel-module-packages ->
+                          (operating-system-kernel-module-packages os))
+                         (kernel*
+                          (if (null? kernel-module-packages)
+                              kernel
+                              (profile-derivation
+                               (packages->manifest
+                                (cons kernel kernel-module-packages))
+                               #:hooks (list linux-module-database)
+                               #:locales? #f
+                               #:allow-collisions? #f
+                               #:relative-symlinks? #t
+                               ; TODO: system, target.
+                               #:system #f
+                               #:target #f)))
+                         (initrd -> (operating-system-initrd-file os))
+                         (params    (operating-system-boot-parameters-file os)))
+      (return `(("kernel" ,kernel*)
                 ("parameters" ,params)
                 ("initrd" ,initrd)
                 ("locale" ,locale))))))   ;used by libc
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 0d38b2513f..3e25cd7639 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -10,6 +10,7 @@
 ;;; Copyright © 2017 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2019 Kyle Meyer <kyle@kyleam.com>
 ;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -139,7 +140,9 @@
             %current-profile
             ensure-profile-directory
             canonicalize-profile
-            user-friendly-profile))
+            user-friendly-profile
+
+            linux-module-database))
 
 ;;; Commentary:
 ;;;
@@ -1137,6 +1140,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