04/08: system: Add (gnu build linux-modules).

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit fcaa5f44a197ab24f288d319dbdd27e2745bb052
Author: Ludovic Courtès <address@hidden>
Date:   Thu Nov 27 23:54:25 2014 +0100

    system: Add (gnu build linux-modules).
    
    * gnu/build/linux-modules.scm: New file.
    * gnu-system.am (GNU_SYSTEM_MODULES): Add it.
---
 gnu-system.am               |    1 +
 gnu/build/linux-modules.scm |  170 +++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 171 insertions(+), 0 deletions(-)

diff --git a/gnu-system.am b/gnu-system.am
index bd1ac5d..6d18823 100644
--- a/gnu-system.am
+++ b/gnu-system.am
@@ -303,6 +303,7 @@ GNU_SYSTEM_MODULES =                                \
   gnu/build/install.scm                                \
   gnu/build/linux-boot.scm                     \
   gnu/build/linux-initrd.scm                   \
+  gnu/build/linux-modules.scm                  \
   gnu/build/vm.scm
 
 
diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm
new file mode 100644
index 0000000..0fa09b2
--- /dev/null
+++ b/gnu/build/linux-modules.scm
@@ -0,0 +1,170 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 Ludovic Courtès <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu build linux-modules)
+  #:use-module (guix elf)
+  #:use-module (rnrs io ports)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 match)
+  #:export (dot-ko
+            ensure-dot-ko
+            module-dependencies
+            recursive-module-dependencies
+            modules-loaded
+            module-loaded?
+            load-linux-module*
+
+            current-module-debugging-port))
+
+;;; Commentary:
+;;;
+;;; Tools to deal with Linux kernel modules.
+;;;
+;;; Code:
+
+(define current-module-debugging-port
+  (make-parameter (%make-void-port "w")))
+
+(define (section-contents elf section)
+  "Return the contents of SECTION in ELF as a bytevector."
+  (let* ((modinfo  (elf-section-by-name elf ".modinfo"))
+         (contents (make-bytevector (elf-section-size modinfo))))
+    (bytevector-copy! (elf-bytes elf) (elf-section-offset modinfo)
+                      contents 0
+                      (elf-section-size modinfo))
+    contents))
+
+(define %not-nul
+  (char-set-complement (char-set #\nul)))
+
+(define (nul-separated-string->list str)
+  "Split STR at occurrences of the NUL character and return the resulting
+string list."
+  (string-tokenize str %not-nul))
+
+(define (key=value->pair str)
+  "Assuming STR has the form \"KEY=VALUE\", return a pair like (KEY
+. \"VALUE\")."
+  (let ((= (string-index str #\=)))
+    (cons (string->symbol (string-take str =))
+          (string-drop str (+ 1 =)))))
+
+(define (modinfo-section-contents file)
+  "Return the contents of the '.modinfo' section of FILE as a list of
+key/value pairs.."
+  (let* ((bv      (call-with-input-file file get-bytevector-all))
+         (elf     (parse-elf bv))
+         (modinfo (section-contents elf ".modinfo")))
+    (map key=value->pair
+         (nul-separated-string->list (utf8->string modinfo)))))
+
+(define %not-comma
+  (char-set-complement (char-set #\,)))
+
+(define (module-dependencies file)
+  "Return the list of modules that FILE depends on.  The returned list
+contains module names, not actual file names."
+  (let ((info (modinfo-section-contents file)))
+    (match (assq 'depends info)
+      (('depends . what)
+       (string-tokenize what %not-comma)))))
+
+(define dot-ko
+  (cut string-append <> ".ko"))
+
+(define (ensure-dot-ko name)
+  "Return NAME with a '.ko' prefix appended, unless it already has it."
+  (if (string-suffix? ".ko" name)
+      name
+      (dot-ko name)))
+
+(define* (recursive-module-dependencies files
+                                        #:key (lookup-module dot-ko))
+  "Return the topologically-sorted list of file names of the modules depended
+on by FILES, recursively.  File names of modules are determined by applying
+LOOKUP-MODULE to the module name."
+  (let loop ((files   files)
+             (result  '())
+             (visited vlist-null))
+    (match files
+      (()
+       (delete-duplicates (reverse result)))
+      ((head . tail)
+       (let* ((visited? (vhash-assoc head visited))
+              (deps     (if visited?
+                            '()
+                            (map lookup-module (module-dependencies head))))
+              (visited  (if visited?
+                            visited
+                            (vhash-cons head #t visited))))
+         (loop (append deps tail)
+               (append result deps) visited))))))
+
+(define %not-newline
+  (char-set-complement (char-set #\newline)))
+
+(define (modules-loaded)
+  "Return the list of names of currently loaded Linux modules."
+  (let* ((contents (call-with-input-file "/proc/modules"
+                     get-string-all))
+         (lines    (string-tokenize contents %not-newline)))
+    (match (map string-tokenize lines)
+      (((modules . _) ...)
+       modules))))
+
+(define (module-loaded? module)
+  "Return #t if MODULE is already loaded.  MODULE must be a Linux module name,
+not a file name."
+  (member module (modules-loaded)))
+
+(define* (load-linux-module* file
+                             #:key
+                             (recursive? #t)
+                             (lookup-module dot-ko))
+  "Load Linux module from FILE, the name of a `.ko' file.  When RECURSIVE? is
+true, load its dependencies first (Ã  la 'modprobe'.)  The actual files
+containing modules depended on are obtained by calling LOOKUP-MODULE with the
+module name."
+  (define (slurp module)
+    ;; TODO: Use 'mmap' to reduce memory usage.
+    (call-with-input-file file get-bytevector-all))
+
+  (when recursive?
+    (for-each (cut load-linux-module* <> #:lookup-module lookup-module)
+              (map lookup-module (module-dependencies file))))
+
+  (format (current-module-debugging-port)
+          "loading Linux module from '~a'...~%" file)
+
+  (catch 'system-error
+    (lambda ()
+      (load-linux-module (slurp file)))
+    (lambda args
+      ;; If this module was already loaded and we're in modprobe style, ignore
+      ;; the error.
+
+      ;; FIXME: Use errno once 'guile-linux-syscalls.patch' provides a useful
+      ;; errno here.
+      (unless (and recursive?
+                   (module-loaded? (string-drop-right (basename file) 3)))
+        (apply throw args)))))
+
+;;; linux-modules.scm ends here