linux-modules: Add 'device-module-aliases' and related procedures.

* gnu/build/linux-modules.scm (readlink*, stat->device-major)
(stat->device-minor): New procedures.
(%not-slash): New variable.
(read-uevent, device-module-aliases, read-module-aliases)
(current-alias-file, known-module-aliases, matching-modules): New
procedures.
This commit is contained in:
Ludovic Courtès 2018-02-16 18:51:16 +01:00
parent f14c933df1
commit 8661ad2743
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 158 additions and 1 deletions

View File

@ -19,6 +19,7 @@
(define-module (gnu build linux-modules)
#:use-module (guix elf)
#:use-module (guix glob)
#:use-module (guix build syscalls)
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
@ -26,6 +27,7 @@
#:use-module (srfi srfi-26)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:export (dot-ko
ensure-dot-ko
module-dependencies
@ -34,7 +36,11 @@
module-loaded?
load-linux-module*
current-module-debugging-port))
current-module-debugging-port
device-module-aliases
known-module-aliases
matching-modules))
;;; Commentary:
;;;
@ -213,4 +219,155 @@ appears in BLACK-LIST are not loaded."
(or (and recursive? (= EEXIST (system-error-errno args)))
(apply throw args)))))))
;;;
;;; 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)))))))
(define (current-alias-file)
"Return the absolute file name of the default 'modules.alias' file."
(string-append (or (getenv "LINUX_MODULE_DIRECTORY")
"/run/booted-system/kernel/lib/modules")
"/" (utsname:release (uname))
"/" "modules.alias"))
(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))
;;; linux-modules.scm ends here