2014-11-27 22:54:25 +00:00
|
|
|
|
;;; GNU Guix --- Functional package management for GNU
|
2018-02-28 21:02:27 +00:00
|
|
|
|
;;; Copyright © 2014, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
|
2017-04-10 17:18:14 +00:00
|
|
|
|
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
2014-11-27 22:54:25 +00:00
|
|
|
|
;;;
|
|
|
|
|
;;; 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)
|
2018-02-16 17:51:16 +00:00
|
|
|
|
#:use-module (guix glob)
|
2017-04-10 17:18:14 +00:00
|
|
|
|
#:use-module (guix build syscalls)
|
2014-11-27 22:54:25 +00:00
|
|
|
|
#: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)
|
2018-02-16 17:51:16 +00:00
|
|
|
|
#:use-module (ice-9 rdelim)
|
2014-11-27 22:54:25 +00:00
|
|
|
|
#:export (dot-ko
|
|
|
|
|
ensure-dot-ko
|
2018-03-03 13:55:27 +00:00
|
|
|
|
module-aliases
|
2014-11-27 22:54:25 +00:00
|
|
|
|
module-dependencies
|
|
|
|
|
recursive-module-dependencies
|
|
|
|
|
modules-loaded
|
|
|
|
|
module-loaded?
|
|
|
|
|
load-linux-module*
|
|
|
|
|
|
2018-02-16 17:51:16 +00:00
|
|
|
|
current-module-debugging-port
|
|
|
|
|
|
|
|
|
|
device-module-aliases
|
|
|
|
|
known-module-aliases
|
|
|
|
|
matching-modules))
|
2014-11-27 22:54:25 +00:00
|
|
|
|
|
|
|
|
|
;;; 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)))))
|
|
|
|
|
|
2018-03-03 13:55:27 +00:00
|
|
|
|
(define (module-aliases file)
|
|
|
|
|
"Return the list of aliases of module FILE."
|
|
|
|
|
(let ((info (modinfo-section-contents file)))
|
|
|
|
|
(filter-map (match-lambda
|
|
|
|
|
(('alias . value)
|
|
|
|
|
value)
|
|
|
|
|
(_ #f))
|
|
|
|
|
(modinfo-section-contents file))))
|
|
|
|
|
|
2014-11-27 22:54:25 +00:00
|
|
|
|
(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)))
|
|
|
|
|
|
2016-02-21 11:49:27 +00:00
|
|
|
|
(define (normalize-module-name module)
|
|
|
|
|
"Return the \"canonical\" name for MODULE, replacing hyphens with
|
|
|
|
|
underscores."
|
|
|
|
|
;; See 'modname_normalize' in libkmod.
|
|
|
|
|
(string-map (lambda (chr)
|
|
|
|
|
(case chr
|
|
|
|
|
((#\-) #\_)
|
|
|
|
|
(else chr)))
|
|
|
|
|
module))
|
|
|
|
|
|
2016-01-16 13:21:57 +00:00
|
|
|
|
(define (file-name->module-name file)
|
2016-02-21 11:49:27 +00:00
|
|
|
|
"Return the module name corresponding to FILE, stripping the trailing '.ko'
|
|
|
|
|
and normalizing it."
|
|
|
|
|
(normalize-module-name (basename file ".ko")))
|
2016-01-16 13:21:57 +00:00
|
|
|
|
|
2014-11-27 22:54:25 +00:00
|
|
|
|
(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))))
|
|
|
|
|
|
2016-01-16 13:21:57 +00:00
|
|
|
|
(define (module-black-list)
|
|
|
|
|
"Return the black list of modules that must not be loaded. This black list
|
|
|
|
|
is specified using 'modprobe.blacklist=MODULE1,MODULE2,...' on the kernel
|
2016-02-21 11:49:27 +00:00
|
|
|
|
command line; it is honored by libkmod for users that pass
|
|
|
|
|
'KMOD_PROBE_APPLY_BLACKLIST', which includes 'modprobe --use-blacklist' and
|
|
|
|
|
udev."
|
2016-01-16 13:21:57 +00:00
|
|
|
|
(define parameter
|
|
|
|
|
"modprobe.blacklist=")
|
|
|
|
|
|
|
|
|
|
(let ((command (call-with-input-file "/proc/cmdline"
|
|
|
|
|
get-string-all)))
|
|
|
|
|
(append-map (lambda (arg)
|
|
|
|
|
(if (string-prefix? parameter arg)
|
|
|
|
|
(string-tokenize (string-drop arg (string-length parameter))
|
|
|
|
|
%not-comma)
|
|
|
|
|
'()))
|
|
|
|
|
(string-tokenize command))))
|
|
|
|
|
|
2014-11-27 22:54:25 +00:00
|
|
|
|
(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)
|
2016-01-16 13:21:57 +00:00
|
|
|
|
(lookup-module dot-ko)
|
|
|
|
|
(black-list (module-black-list)))
|
|
|
|
|
"Load Linux module from FILE, the name of a '.ko' file; return true on
|
|
|
|
|
success, false otherwise. 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. Modules whose name
|
|
|
|
|
appears in BLACK-LIST are not loaded."
|
|
|
|
|
(define (black-listed? module)
|
|
|
|
|
(let ((result (member module black-list)))
|
|
|
|
|
(when result
|
|
|
|
|
(format (current-module-debugging-port)
|
|
|
|
|
"not loading module '~a' because it's black-listed~%"
|
|
|
|
|
module))
|
|
|
|
|
result))
|
|
|
|
|
|
|
|
|
|
(define (load-dependencies file)
|
|
|
|
|
(let ((dependencies (module-dependencies file)))
|
2018-03-18 17:26:12 +00:00
|
|
|
|
(every (cut load-linux-module* <>
|
|
|
|
|
#:lookup-module lookup-module
|
|
|
|
|
#:black-list black-list)
|
2016-01-16 13:21:57 +00:00
|
|
|
|
(map lookup-module dependencies))))
|
|
|
|
|
|
|
|
|
|
(and (not (black-listed? (file-name->module-name file)))
|
|
|
|
|
(or (not recursive?)
|
|
|
|
|
(load-dependencies file))
|
2018-02-28 21:02:27 +00:00
|
|
|
|
(let ((fd #f))
|
2016-01-16 13:21:57 +00:00
|
|
|
|
(format (current-module-debugging-port)
|
|
|
|
|
"loading Linux module from '~a'...~%" file)
|
|
|
|
|
|
|
|
|
|
(catch 'system-error
|
|
|
|
|
(lambda ()
|
2018-02-28 21:02:27 +00:00
|
|
|
|
(set! fd (open-fdes file O_RDONLY))
|
|
|
|
|
(load-linux-module/fd fd)
|
|
|
|
|
(close-fdes fd)
|
|
|
|
|
#t)
|
2016-01-16 13:21:57 +00:00
|
|
|
|
(lambda args
|
|
|
|
|
;; If this module was already loaded and we're in modprobe style, ignore
|
|
|
|
|
;; the error.
|
2018-02-28 21:02:27 +00:00
|
|
|
|
(when fd (close-fdes fd))
|
2016-01-16 13:21:57 +00:00
|
|
|
|
(or (and recursive? (= EEXIST (system-error-errno args)))
|
|
|
|
|
(apply throw args)))))))
|
2014-11-27 22:54:25 +00:00
|
|
|
|
|
2018-02-16 17:51:16 +00:00
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Device modules.
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
;; Copied from (guix utils). FIXME: Factorize.
|
|
|
|
|
(define (readlink* file)
|
|
|
|
|
"Call 'readlink' until the result is not a symlink."
|
|
|
|
|
(define %max-symlink-depth 50)
|
|
|
|
|
|
|
|
|
|
(let loop ((file file)
|
|
|
|
|
(depth 0))
|
|
|
|
|
(define (absolute target)
|
|
|
|
|
(if (absolute-file-name? target)
|
|
|
|
|
target
|
|
|
|
|
(string-append (dirname file) "/" target)))
|
|
|
|
|
|
|
|
|
|
(if (>= depth %max-symlink-depth)
|
|
|
|
|
file
|
|
|
|
|
(call-with-values
|
|
|
|
|
(lambda ()
|
|
|
|
|
(catch 'system-error
|
|
|
|
|
(lambda ()
|
|
|
|
|
(values #t (readlink file)))
|
|
|
|
|
(lambda args
|
|
|
|
|
(let ((errno (system-error-errno args)))
|
|
|
|
|
(if (or (= errno EINVAL))
|
|
|
|
|
(values #f file)
|
|
|
|
|
(apply throw args))))))
|
|
|
|
|
(lambda (success? target)
|
|
|
|
|
(if success?
|
|
|
|
|
(loop (absolute target) (+ depth 1))
|
|
|
|
|
file))))))
|
|
|
|
|
|
|
|
|
|
;; See 'major' and 'minor' in <sys/sysmacros.h>.
|
|
|
|
|
|
|
|
|
|
(define (stat->device-major st)
|
|
|
|
|
(ash (logand #xfff00 (stat:rdev st)) -8))
|
|
|
|
|
|
|
|
|
|
(define (stat->device-minor st)
|
|
|
|
|
(logand #xff (stat:rdev st)))
|
|
|
|
|
|
|
|
|
|
(define %not-slash
|
|
|
|
|
(char-set-complement (char-set #\/)))
|
|
|
|
|
|
|
|
|
|
(define (read-uevent port)
|
|
|
|
|
"Read a /sys 'uevent' file from PORT and return an alist where each car is a
|
|
|
|
|
key such as 'MAJOR or 'DEVTYPE and each cdr is the corresponding value."
|
|
|
|
|
(let loop ((result '()))
|
|
|
|
|
(match (read-line port)
|
|
|
|
|
((? eof-object?)
|
|
|
|
|
(reverse result))
|
|
|
|
|
(line
|
|
|
|
|
(loop (cons (key=value->pair line) result))))))
|
|
|
|
|
|
|
|
|
|
(define (device-module-aliases device)
|
|
|
|
|
"Return the list of module aliases required by DEVICE, a /dev file name, as
|
|
|
|
|
in this example:
|
|
|
|
|
|
|
|
|
|
(device-module-aliases \"/dev/sda\")
|
|
|
|
|
=> (\"scsi:t-0x00\" \"pci:v00008086d00009D03sv0000103Csd000080FAbc01sc06i01\")
|
|
|
|
|
|
|
|
|
|
The modules corresponding to these aliases can then be found using
|
|
|
|
|
'matching-modules'."
|
|
|
|
|
;; The approach is adapted from
|
|
|
|
|
;; <https://unix.stackexchange.com/questions/97676/how-to-find-the-driver-module-associated-with-a-device-on-linux>.
|
|
|
|
|
(let* ((st (stat device))
|
|
|
|
|
(type (stat:type st))
|
|
|
|
|
(major (stat->device-major st))
|
|
|
|
|
(minor (stat->device-minor st))
|
|
|
|
|
(sys-name (string-append "/sys/dev/"
|
|
|
|
|
(case type
|
|
|
|
|
((block-special) "block")
|
|
|
|
|
((char-special) "char")
|
|
|
|
|
(else (symbol->string type)))
|
|
|
|
|
"/" (number->string major) ":"
|
|
|
|
|
(number->string minor)))
|
|
|
|
|
(directory (canonicalize-path (readlink* sys-name))))
|
|
|
|
|
(let loop ((components (string-tokenize directory %not-slash))
|
|
|
|
|
(aliases '()))
|
|
|
|
|
(match components
|
|
|
|
|
(("sys" "devices" _)
|
|
|
|
|
(reverse aliases))
|
|
|
|
|
((head ... _)
|
|
|
|
|
(let ((uevent (string-append (string-join components "/" 'prefix)
|
|
|
|
|
"/uevent")))
|
|
|
|
|
(if (file-exists? uevent)
|
|
|
|
|
(let ((props (call-with-input-file uevent read-uevent)))
|
|
|
|
|
(match (assq-ref props 'MODALIAS)
|
|
|
|
|
(#f (loop head aliases))
|
|
|
|
|
(alias (loop head (cons alias aliases)))))
|
|
|
|
|
(loop head aliases))))))))
|
|
|
|
|
|
|
|
|
|
(define (read-module-aliases port)
|
|
|
|
|
"Read from PORT data in the Linux 'modules.alias' file format. Return a
|
|
|
|
|
list of alias/module pairs where each alias is a glob pattern as like the
|
|
|
|
|
result of:
|
|
|
|
|
|
|
|
|
|
(compile-glob-pattern \"scsi:t-0x01*\")
|
|
|
|
|
|
|
|
|
|
and each module is a module name like \"snd_hda_intel\"."
|
|
|
|
|
(define (comment? str)
|
|
|
|
|
(string-prefix? "#" str))
|
|
|
|
|
|
|
|
|
|
(define (tokenize str)
|
|
|
|
|
;; Lines have the form "alias ALIAS MODULE", where ALIAS can contain
|
|
|
|
|
;; whitespace. This is why we don't use 'string-tokenize'.
|
|
|
|
|
(let* ((str (string-trim-both str))
|
|
|
|
|
(left (string-index str #\space))
|
|
|
|
|
(right (string-rindex str #\space)))
|
|
|
|
|
(list (string-take str left)
|
|
|
|
|
(string-trim-both (substring str left right))
|
|
|
|
|
(string-trim-both (string-drop str right)))))
|
|
|
|
|
|
|
|
|
|
(let loop ((aliases '()))
|
|
|
|
|
(match (read-line port)
|
|
|
|
|
((? eof-object?)
|
|
|
|
|
(reverse aliases))
|
|
|
|
|
((? comment?)
|
|
|
|
|
(loop aliases))
|
|
|
|
|
(line
|
|
|
|
|
(match (tokenize line)
|
|
|
|
|
(("alias" alias module)
|
|
|
|
|
(loop (alist-cons (compile-glob-pattern alias) module
|
|
|
|
|
aliases)))
|
|
|
|
|
(() ;empty line
|
|
|
|
|
(loop aliases)))))))
|
|
|
|
|
|
2018-03-14 22:09:57 +00:00
|
|
|
|
(define (current-kernel-directory)
|
|
|
|
|
"Return the directory of the currently running Linux kernel."
|
2018-02-16 17:51:16 +00:00
|
|
|
|
(string-append (or (getenv "LINUX_MODULE_DIRECTORY")
|
|
|
|
|
"/run/booted-system/kernel/lib/modules")
|
2018-03-14 22:09:57 +00:00
|
|
|
|
"/" (utsname:release (uname))))
|
|
|
|
|
|
|
|
|
|
(define (current-alias-file)
|
|
|
|
|
"Return the absolute file name of the default 'modules.alias' file."
|
|
|
|
|
(string-append (current-kernel-directory) "/modules.alias"))
|
2018-02-16 17:51:16 +00:00
|
|
|
|
|
|
|
|
|
(define* (known-module-aliases #:optional (alias-file (current-alias-file)))
|
|
|
|
|
"Return the list of alias/module pairs read from ALIAS-FILE. Each alias is
|
|
|
|
|
actually a pattern."
|
|
|
|
|
(call-with-input-file alias-file read-module-aliases))
|
|
|
|
|
|
|
|
|
|
(define* (matching-modules alias
|
|
|
|
|
#:optional (known-aliases (known-module-aliases)))
|
|
|
|
|
"Return the list of modules that match ALIAS according to KNOWN-ALIASES.
|
|
|
|
|
ALIAS is a string like \"scsi:t-0x00\" as returned by
|
|
|
|
|
'device-module-aliases'."
|
|
|
|
|
(filter-map (match-lambda
|
|
|
|
|
((pattern . module)
|
|
|
|
|
(and (glob-match? pattern alias)
|
|
|
|
|
module)))
|
|
|
|
|
known-aliases))
|
|
|
|
|
|
2014-11-27 22:54:25 +00:00
|
|
|
|
;;; linux-modules.scm ends here
|