[bug#42193] [WIP 6/6] WIP services: Add kernel-module-configuration service.

[Brice Waegeneire <brice@waegenei.re>]

---
 gnu/services/linux.scm      | 166 +++++++++++++++++++++++++++++++++++-
 gnu/tests/linux-modules.scm |  67 +++++++++------
 2 files changed, 208 insertions(+), 25 deletions(-)

diff --git a/gnu/services/linux.scm b/gnu/services/linux.scm
index 7ea30a1270..9773dd5072 100644
--- a/gnu/services/linux.scm
+++ b/gnu/services/linux.scm
@@ -45,7 +45,22 @@
 
             kernel-module-loader-service-type
 
-            modprobe-service-type))
+            modprobe-service-type
+
+            kernel-module
+            kernel-module?
+            kernel-module-name
+            kernel-module-package
+            kernel-module-aliases
+            kernel-module-install
+            kernel-module-remove
+            kernel-module-pre-dependencies
+            kernel-module-post-dependencies
+            kernel-module-blacklist?
+            kernel-module-load?
+            kernel-module-is-builtin?
+            kernel-module->kernel-arguments
+            kernel-module-configuration-service-type))
 
 \f
 ;;;
@@ -151,6 +166,9 @@ representation."
                  (rnrs io ports)
                  ,@%default-modules))
       (start
+       ;; TODO Verify that we are loading a loadable kernel and not a builtin
+       ;; one looking in
+       ;; /run/booted-system/kernel/lib/modules/5.4.39/modules.builtin
        #~(lambda _
            (cond
             ((null? '#$kernel-modules) #t)
@@ -227,3 +245,149 @@ files."
                              modprobe-environment)))
    (compose concatenate)
    (extend append)))
+
+\f
+;;;
+;;; Kernel module configuration.
+;;;
+
+;; NOTE Maybe have sperate records betwwen <kernel-builtin-module> and
+;; <kernel-lodable-module>
+(define-record-type* <kernel-module>
+  kernel-module make-kernel-module
+  kernel-module?
+  (name               kernel-module-name) ; string
+  ;; For out-of-tree modules
+  (package            kernel-module-package
+                      (default #f))     ; #f | <package>
+  ;; NOTE Maybe use an alist instead
+  (options            kernel-module-options
+                      (default '()))    ; list of strings
+  (aliases            kernel-module-aliases
+                      (default '()))    ; list of strings
+  (install            kernel-module-install
+                      (default #f))     ; #f | string
+  (remove             kernel-module-remove
+                      (default #f))     ; #f | string
+  (pre-dependencies   kernel-module-pre-dependencies
+                      (default '()))    ; list of strings
+  (post-dependencies  kernel-module-post-dependencies
+                      (default '()))    ; list of strings
+  (blacklist?         kernel-module-blacklist?
+                      (default #f)) ; boolean
+  ;; NOTE Only possible if it's not built-in
+  ;; TODO maybe trow an error when it's set to true on a built-in module
+  (load?              kernel-module-load?
+                      (default #f)))                ; boolean
+
+;; FIXME use 'modules.builtin' instead
+(define (kernel-module-is-builtin? module)
+  (if (kernel-module-package module) #f
+      #t))
+
+(define (kernel-module->kernel-arguments module)
+  "Return a list of kernel arguments for MODULE."
+  (match-record module <kernel-module>
+    (name options blacklist?)
+    (filter (lambda (s) (not (string-null? s)))
+            (list (if blacklist? (string-append name ".blacklist=yes") "")
+                  (if (null? options) ""
+                      (map (lambda (option)
+                             (string-append name "." option))
+                           options))))))
+
+(define (kernel-module->config module)
+  "Return a config string for MODULE."
+  (match-record module <kernel-module>
+    (name options aliases install remove pre-dependencies
+          post-dependencies blacklist?)
+    (string-concatenate
+     (list (if (null? options) ""
+               (format #f "options ~a~{ ~a~}\n" name options))
+           (if blacklist? (format #f "blacklist ~a\n" name)
+               "")
+           (if (null? aliases) ""
+               (map (lambda (alias)
+                      (format #f "alias ~a ~a\n" alias name))
+                    aliases))
+           (if install (format #f "install ~a ~a\n" name install)
+               "")
+           (if remove (format #f "remove ~a ~a\n" name remove)
+               "")
+           (if (null? pre-dependencies) ""
+               (map (lambda (dependency)
+                      (format #f "softdep ~a :pre ~a\n"
+                              name dependency))
+                    pre-dependencies))
+           (if (null? post-dependencies) ""
+               (map (lambda (dependency)
+                      (format #f "softdep ~a :post ~a\n"
+                              name dependency))
+                    post-dependencies))))))
+
+(define (string-underscorize s)
+  "Replace '-' characters by '_' in string S."
+  (string-map (lambda (c) (if (char=? c #\-) #\_ c)) s))
+
+(define (kernel-modules->config-files modules)
+  "Return a list of pairs of file name and gexp, to be used by 'file-union',
+from MODULES."
+  (define (kernel-module->filename-gexp module)
+    (let ((config (kernel-module->config module))
+          (name (kernel-module-name module)))
+      (if (string-null? config) #f
+          (list (string-append name ".conf")
+                (plain-file (string-append name ".conf") config)))))
+  (filter-map
+   (lambda (module)
+     (let ((module (kernel-module
+                    (inherit module)
+                    ;; XXX The kernel replace '-' by '_' in module name, we do
+                    ;; the same to make name collision visible, that would
+                    ;; otherwise be hidden.
+                    (name (string-underscorize (kernel-module-name module))))))
+       (if (kernel-module-is-builtin? module) #f
+           (kernel-module->filename-gexp module))))
+   modules))
+
+(define (kernel-modules->packages modules)
+  "Return a list of packages from MODULES."
+  (filter-map (lambda (module)
+                (kernel-module-package module))
+              modules))
+
+(define (kernel-modules-to-load modules)
+  "Return a list of loadable module names, from MODULES, to be loaded."
+  (filter-map (lambda (module)
+                (if (and (not (kernel-module-is-builtin? module))
+                         (kernel-module-load? module))
+                    (kernel-module-name module)
+                    #f))
+              modules))
+
+(define kernel-module-configuration-service-type
+  (service-type
+   (name 'kernel-module-configuration)
+   (description
+    "Configure kernel modules, in similar manner as @file{modprobe.d}.")
+   (default-value '())
+   (extensions
+    (list (service-extension modprobe-service-type
+                             kernel-modules->config-files)
+          (service-extension kernel-profile-service-type
+                             kernel-modules->packages)
+          (service-extension kernel-module-loader-service-type
+                             kernel-modules-to-load)))
+   (compose concatenate)
+   (extend append)))
+
+;; TODO Make a naked modprobe call use MODPROBE_OPTIONS environment or
+;; /proc/sys/kernel/modprobe
+
+;; TODO write a helper to load a module from guile using modprobe command from
+;; '/proc/sys/kernel/modprobe' or %modprobe-wrapper. See linux-module-builder
+;; maybe.
+
+;; NOTE Throw an error when kernel-module-name isn't unique?  It may already
+;; do it by itself already because 2 loadable module will try to create
+;; separeta config file with the same name.
diff --git a/gnu/tests/linux-modules.scm b/gnu/tests/linux-modules.scm
index 22e9a0c65c..296066e68f 100644
--- a/gnu/tests/linux-modules.scm
+++ b/gnu/tests/linux-modules.scm
@@ -32,6 +32,7 @@
   #:use-module (guix monads)
   #:use-module (guix store)
   #:use-module (guix utils)
+  #:use-module (srfi srfi-1)
   #:export (%test-loadable-kernel-modules-0
             %test-loadable-kernel-modules-1
             %test-loadable-kernel-modules-2))
@@ -66,19 +67,18 @@ that MODULES are actually loaded."
                        (member module modules string=?))
                      '#$modules))))))
 
-(define* (run-loadable-kernel-modules-test module-packages module-names)
-  "Run a test of an OS having MODULE-PACKAGES, and verify that MODULE-NAMES
-are loaded in memory."
+(define* (run-loadable-kernel-modules-test modules)
+  "Run a test of an OS having MODULES and verify that they are loaded in
+memory."
   (define os
     (marionette-operating-system
      (operating-system
-      (inherit (simple-operating-system))
-      (services (cons* (service kernel-module-loader-service-type module-names)
-                       (simple-service 'kernel-module-packages
-                                       kernel-profile-service-type
-                                       module-packages)
-                       (operating-system-user-services
-                        (simple-operating-system)))))
+       (inherit (simple-operating-system))
+       (services (cons* (service kernel-module-loader-service-type)
+                        (service kernel-module-configuration-service-type
+                                 modules)
+                        (operating-system-user-services
+                         (simple-operating-system)))))
      #:imported-modules '((guix combinators))))
   (define vm (virtual-machine os))
   (define (test script)
@@ -97,15 +97,20 @@ are loaded in memory."
              marionette))
           (test-end)
           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
-  (gexp->derivation "loadable-kernel-modules"
-                    (test (modules-loaded?-program os module-names))))
+  (let ((modules (filter-map (lambda (module)
+                               (if (kernel-module-load? module)
+                                   (kernel-module-name module)
+                                   #f))
+                      modules)))
+    (gexp->derivation "loadable-kernel-modules"
+                      (test (modules-loaded?-program os modules)))))
 
 (define %test-loadable-kernel-modules-0
   (system-test
    (name "loadable-kernel-modules-0")
    (description "Tests loadable kernel modules facility of <operating-system>
 with no extra modules.")
-   (value (run-loadable-kernel-modules-test '() '()))))
+   (value (run-loadable-kernel-modules-test '()))))
 
 (define %test-loadable-kernel-modules-1
   (system-test
@@ -113,8 +118,11 @@ with no extra modules.")
    (description "Tests loadable kernel modules facility of <operating-system>
 with one extra module.")
    (value (run-loadable-kernel-modules-test
-           (list ddcci-driver-linux)
-           '("ddcci")))))
+           (list (kernel-module
+                  (name "ddcci")
+                  (package ddcci-driver-linux)
+                  (options '("delay=606"))
+                  (load? #t)))))))
 
 (define %test-loadable-kernel-modules-2
   (system-test
@@ -122,12 +130,23 @@ with one extra module.")
    (description "Tests loadable kernel modules facility of <operating-system>
 with two extra modules.")
    (value (run-loadable-kernel-modules-test
-           (list acpi-call-linux-module
-                 (package
-                   (inherit ddcci-driver-linux)
-                   (arguments
-                    `(#:linux #f
-                      ,@(strip-keyword-arguments '(#:linux)
-                                                 (package-arguments
-                                                  ddcci-driver-linux))))))
-           '("acpi_call" "ddcci")))))
+           (list (kernel-module
+                  (name "ddcci")
+                  ;; XXX Verify that kernel modules are built with the correct
+                  ;; kernel
+                  (package (package
+                             (inherit ddcci-driver-linux)
+                             (arguments
+                              `(#:linux #f
+                                ,@(strip-keyword-arguments '(#:linux)
+                                                           (package-arguments
+                                                            ddcci-driver-linux))))))
+                  (load? #t))
+                 (kernel-module
+                  (name "acpi_call")
+                  (package acpi-call-linux-module)
+                  (load? #t))
+                 ;; TODO Test that a module isn't loaded
+                 (kernel-module
+                  (name "radeon")
+                  (blacklist? #t)))))))
-- 
2.26.2