diff options
Diffstat (limited to 'gnu/build/linux-modules.scm')
| -rw-r--r-- | gnu/build/linux-modules.scm | 159 |
1 files changed, 158 insertions, 1 deletions
diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm index 115a17c64e..4a6d4ff089 100644 --- a/gnu/build/linux-modules.scm +++ b/gnu/build/linux-modules.scm @@ -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 |