gnu/build/linux-modules.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (gnu build linux-modules)
  21   #:use-module (guix elf)
  22   #:use-module (guix glob)
  23   #:use-module (guix build syscalls)
  24   #:use-module ((guix build utils) #:select (find-files))
  25   #:use-module (rnrs io ports)
  26   #:use-module (rnrs bytevectors)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-11)
  29   #:use-module (srfi srfi-26)
  30   #:use-module (ice-9 vlist)
  31   #:use-module (ice-9 match)
  32   #:use-module (ice-9 rdelim)
  33   #:export (dot-ko
  34             ensure-dot-ko
  35             module-aliases
  36             module-dependencies
  37             module-soft-dependencies
  38             normalize-module-name
  39             file-name->module-name
  40             find-module-file
  41             recursive-module-dependencies
  42             modules-loaded
  43             module-loaded?
  44             load-linux-module*
  45
  46             current-module-debugging-port
  47
  48             device-module-aliases
  49             known-module-aliases
  50             matching-modules
  51             missing-modules))
  52
  53 ;;; Commentary:
  54 ;;;
  55 ;;; Tools to deal with Linux kernel modules.
  56 ;;;
  57 ;;; Code:
  58
  59 (define current-module-debugging-port
  60   (make-parameter (%make-void-port "w")))
  61
  62 (define (section-contents elf section)
  63   "Return the contents of SECTION in ELF as a bytevector."
  64   (let ((contents (make-bytevector (elf-section-size section))))
  65     (bytevector-copy! (elf-bytes elf) (elf-section-offset section)
  66                       contents 0
  67                       (elf-section-size section))
  68     contents))
  69
  70 (define %not-nul
  71   (char-set-complement (char-set #\nul)))
  72
  73 (define (nul-separated-string->list str)
  74   "Split STR at occurrences of the NUL character and return the resulting
  75 string list."
  76   (string-tokenize str %not-nul))
  77
  78 (define (key=value->pair str)
  79   "Assuming STR has the form \"KEY=VALUE\", return a pair like (KEY
  80 . \"VALUE\")."
  81   (let ((= (string-index str #\=)))
  82     (cons (string->symbol (string-take str =))
  83           (string-drop str (+ 1 =)))))
  84
  85 (define (modinfo-section-contents file)
  86   "Return the contents of the '.modinfo' section of FILE as a list of
  87 key/value pairs.."
  88   (let* ((bv      (call-with-input-file file get-bytevector-all))
  89          (elf     (parse-elf bv))
  90          (section (elf-section-by-name elf ".modinfo"))
  91          (modinfo (section-contents elf section)))
  92     (map key=value->pair
  93          (nul-separated-string->list (utf8->string modinfo)))))
  94
  95 (define %not-comma
  96   (char-set-complement (char-set #\,)))
  97
  98 (define (module-dependencies file)
  99   "Return the list of modules that FILE depends on.  The returned list
 100 contains module names, not actual file names."
 101   (let ((info (modinfo-section-contents file)))
 102     (match (assq 'depends info)
 103       (('depends . what)
 104        (string-tokenize what %not-comma)))))
 105
 106 (define not-softdep-whitespace
 107   (char-set-complement (char-set #\space #\tab)))
 108
 109 (define (module-soft-dependencies file)
 110   "Return the list of modules that can be preloaded, and then the list of
 111 modules that can be postloaded, of the soft dependencies of module FILE."
 112   ;; TEXT: "pre: baz blubb foo post: bax bar"
 113   (define (parse-softdep text)
 114     (let loop ((value '())
 115                (tokens (string-tokenize text not-softdep-whitespace))
 116                (section #f))
 117       (match tokens
 118        ((token rest ...)
 119         (if (string=? (string-take-right token 1) ":") ; section
 120             (loop value rest (string-trim-both (string-drop-right token 1)))
 121             (loop (cons (cons section token) value) rest section)))
 122        (()
 123         value))))
 124
 125   ;; Note: Multiple 'softdep sections are allowed.
 126   (let* ((info (modinfo-section-contents file))
 127          (entries (concatenate
 128                    (filter-map (match-lambda
 129                                 (('softdep . value)
 130                                  (parse-softdep value))
 131                                 (_ #f))
 132                                (modinfo-section-contents file)))))
 133     (let-values (((pres posts)
 134                   (partition (match-lambda
 135                               (("pre" . _) #t)
 136                               (("post" . _) #f))
 137                              entries)))
 138       (values (map (match-lambda
 139                     ((_ . value) value))
 140                    pres)
 141               (map (match-lambda
 142                     ((_ . value) value))
 143                    posts)))))
 144
 145 (define (module-aliases file)
 146   "Return the list of aliases of module FILE."
 147   (let ((info (modinfo-section-contents file)))
 148     (filter-map (match-lambda
 149                  (('alias . value)
 150                   value)
 151                  (_ #f))
 152                 (modinfo-section-contents file))))
 153
 154 (define dot-ko
 155   (cut string-append <> ".ko"))
 156
 157 (define (ensure-dot-ko name)
 158   "Return NAME with a '.ko' prefix appended, unless it already has it."
 159   (if (string-suffix? ".ko" name)
 160       name
 161       (dot-ko name)))
 162
 163 (define (normalize-module-name module)
 164   "Return the \"canonical\" name for MODULE, replacing hyphens with
 165 underscores."
 166   ;; See 'modname_normalize' in libkmod.
 167   (string-map (lambda (chr)
 168                 (case chr
 169                   ((#\-) #\_)
 170                   (else chr)))
 171               module))
 172
 173 (define (file-name->module-name file)
 174   "Return the module name corresponding to FILE, stripping the trailing '.ko'
 175 and normalizing it."
 176   (normalize-module-name (basename file ".ko")))
 177
 178 (define (find-module-file directory module)
 179   "Lookup module NAME under DIRECTORY, and return its absolute file name.
 180 NAME can be a file name with or without '.ko', or it can be a module name.
 181 Raise an error if it could not be found.
 182
 183 Module names can differ from file names in interesting ways; for instance,
 184 module names usually (always?) use underscores as the inter-word separator,
 185 whereas file names often, but not always, use hyphens.  Examples:
 186 \"usb-storage.ko\", \"serpent_generic.ko\"."
 187   (define names
 188     ;; List of possible file names.  XXX: It would of course be cleaner to
 189     ;; have a database that maps module names to file names and vice versa,
 190     ;; but everyone seems to be doing hacks like this one.  Oh well!
 191     (map ensure-dot-ko
 192          (delete-duplicates
 193           (list module
 194                 (normalize-module-name module)
 195                 (string-map (lambda (chr) ;converse of 'normalize-module-name'
 196                               (case chr
 197                                 ((#\_) #\-)
 198                                 (else chr)))
 199                             module)))))
 200
 201   (match (find-files directory
 202                      (lambda (file stat)
 203                        (member (basename file) names)))
 204     ((file)
 205      file)
 206     (()
 207      (error "kernel module not found" module directory))
 208     ((_ ...)
 209      (error "several modules by that name" module directory))))
 210
 211 (define* (recursive-module-dependencies files
 212                                         #:key (lookup-module dot-ko))
 213   "Return the topologically-sorted list of file names of the modules depended
 214 on by FILES, recursively.  File names of modules are determined by applying
 215 LOOKUP-MODULE to the module name."
 216   (let loop ((files   files)
 217              (result  '())
 218              (visited vlist-null))
 219     (match files
 220       (()
 221        (delete-duplicates (reverse result)))
 222       ((head . tail)
 223        (let* ((visited? (vhash-assoc head visited))
 224               (deps     (if visited?
 225                             '()
 226                             (map lookup-module (module-dependencies head))))
 227               (visited  (if visited?
 228                             visited
 229                             (vhash-cons head #t visited))))
 230          (loop (append deps tail)
 231                (append result deps) visited))))))
 232
 233 (define %not-newline
 234   (char-set-complement (char-set #\newline)))
 235
 236 (define (modules-loaded)
 237   "Return the list of names of currently loaded Linux modules."
 238   (let* ((contents (call-with-input-file "/proc/modules"
 239                      get-string-all))
 240          (lines    (string-tokenize contents %not-newline)))
 241     (match (map string-tokenize lines)
 242       (((modules . _) ...)
 243        modules))))
 244
 245 (define (module-black-list)
 246   "Return the black list of modules that must not be loaded.  This black list
 247 is specified using 'modprobe.blacklist=MODULE1,MODULE2,...' on the kernel
 248 command line; it is honored by libkmod for users that pass
 249 'KMOD_PROBE_APPLY_BLACKLIST', which includes 'modprobe --use-blacklist' and
 250 udev."
 251   (define parameter
 252     "modprobe.blacklist=")
 253
 254   (let ((command (call-with-input-file "/proc/cmdline"
 255                    get-string-all)))
 256     (append-map (lambda (arg)
 257                   (if (string-prefix? parameter arg)
 258                       (string-tokenize (string-drop arg (string-length parameter))
 259                                        %not-comma)
 260                       '()))
 261                 (string-tokenize command))))
 262
 263 (define (module-loaded? module)
 264   "Return #t if MODULE is already loaded.  MODULE must be a Linux module name,
 265 not a file name."
 266   (member module (modules-loaded)))
 267
 268 (define* (load-linux-module* file
 269                              #:key
 270                              (recursive? #t)
 271                              (lookup-module dot-ko)
 272                              (black-list (module-black-list)))
 273   "Load Linux module from FILE, the name of a '.ko' file; return true on
 274 success, false otherwise.  When RECURSIVE? is true, load its dependencies
 275 first (à la 'modprobe'.)  The actual files containing modules depended on are
 276 obtained by calling LOOKUP-MODULE with the module name.  Modules whose name
 277 appears in BLACK-LIST are not loaded."
 278   (define (black-listed? module)
 279     (let ((result (member module black-list)))
 280       (when result
 281         (format (current-module-debugging-port)
 282                 "not loading module '~a' because it's black-listed~%"
 283                 module))
 284       result))
 285
 286   (define (load-dependencies file)
 287     (let ((dependencies (module-dependencies file)))
 288       (every (cut load-linux-module* <>
 289                   #:lookup-module lookup-module
 290                   #:black-list black-list)
 291              (map lookup-module dependencies))))
 292
 293   (and (not (black-listed? (file-name->module-name file)))
 294        (or (not recursive?)
 295            (load-dependencies file))
 296        (let ((fd #f))
 297          (format (current-module-debugging-port)
 298                  "loading Linux module from '~a'...~%" file)
 299
 300          (catch 'system-error
 301            (lambda ()
 302              (set! fd (open-fdes file O_RDONLY))
 303              (load-linux-module/fd fd)
 304              (close-fdes fd)
 305              #t)
 306            (lambda args
 307              ;; If this module was already loaded and we're in modprobe style, ignore
 308              ;; the error.
 309              (when fd (close-fdes fd))
 310              (or (and recursive? (= EEXIST (system-error-errno args)))
 311                  (apply throw args)))))))
 312
 313 \f
 314 ;;;
 315 ;;; Device modules.
 316 ;;;
 317
 318 ;; Copied from (guix utils).  FIXME: Factorize.
 319 (define (readlink* file)
 320   "Call 'readlink' until the result is not a symlink."
 321   (define %max-symlink-depth 50)
 322
 323   (let loop ((file  file)
 324              (depth 0))
 325     (define (absolute target)
 326       (if (absolute-file-name? target)
 327           target
 328           (string-append (dirname file) "/" target)))
 329
 330     (if (>= depth %max-symlink-depth)
 331         file
 332         (call-with-values
 333             (lambda ()
 334               (catch 'system-error
 335                 (lambda ()
 336                   (values #t (readlink file)))
 337                 (lambda args
 338                   (let ((errno (system-error-errno args)))
 339                     (if (or (= errno EINVAL))
 340                         (values #f file)
 341                         (apply throw args))))))
 342           (lambda (success? target)
 343             (if success?
 344                 (loop (absolute target) (+ depth 1))
 345                 file))))))
 346
 347 ;; See 'major' and 'minor' in <sys/sysmacros.h>.
 348
 349 (define (stat->device-major st)
 350   (ash (logand #xfff00 (stat:rdev st)) -8))
 351
 352 (define (stat->device-minor st)
 353   (logand #xff (stat:rdev st)))
 354
 355 (define %not-slash
 356   (char-set-complement (char-set #\/)))
 357
 358 (define (read-uevent port)
 359   "Read a /sys 'uevent' file from PORT and return an alist where each car is a
 360 key such as 'MAJOR or 'DEVTYPE and each cdr is the corresponding value."
 361   (let loop ((result '()))
 362     (match (read-line port)
 363       ((? eof-object?)
 364        (reverse result))
 365       (line
 366        (loop (cons (key=value->pair line) result))))))
 367
 368 (define (device-module-aliases device)
 369   "Return the list of module aliases required by DEVICE, a /dev file name, as
 370 in this example:
 371
 372   (device-module-aliases \"/dev/sda\")
 373   => (\"scsi:t-0x00\" \"pci:v00008086d00009D03sv0000103Csd000080FAbc01sc06i01\")
 374
 375 The modules corresponding to these aliases can then be found using
 376 'matching-modules'."
 377   ;; The approach is adapted from
 378   ;; <https://unix.stackexchange.com/questions/97676/how-to-find-the-driver-module-associated-with-a-device-on-linux>.
 379   (let* ((st        (stat device))
 380          (type      (stat:type st))
 381          (major     (stat->device-major st))
 382          (minor     (stat->device-minor st))
 383          (sys-name  (string-append "/sys/dev/"
 384                                    (case type
 385                                      ((block-special) "block")
 386                                      ((char-special)  "char")
 387                                      (else (symbol->string type)))
 388                                    "/" (number->string major) ":"
 389                                    (number->string minor)))
 390          (directory (canonicalize-path (readlink* sys-name))))
 391     (let loop ((components (string-tokenize directory %not-slash))
 392                (aliases    '()))
 393       (match components
 394         (("sys" "devices" _)
 395          (reverse aliases))
 396         ((head ... _)
 397          (let ((uevent (string-append (string-join components "/" 'prefix)
 398                                       "/uevent")))
 399            (if (file-exists? uevent)
 400                (let ((props (call-with-input-file uevent read-uevent)))
 401                  (match (assq-ref props 'MODALIAS)
 402                    (#f    (loop head aliases))
 403                    (alias (loop head (cons alias aliases)))))
 404                (loop head aliases))))))))
 405
 406 (define (read-module-aliases port)
 407   "Read from PORT data in the Linux 'modules.alias' file format.  Return a
 408 list of alias/module pairs where each alias is a glob pattern as like the
 409 result of:
 410
 411   (string->compiled-sglob \"scsi:t-0x01*\")
 412
 413 and each module is a module name like \"snd_hda_intel\"."
 414   (define (comment? str)
 415     (string-prefix? "#" str))
 416
 417   (define (tokenize str)
 418     ;; Lines have the form "alias ALIAS MODULE", where ALIAS can contain
 419     ;; whitespace.  This is why we don't use 'string-tokenize'.
 420     (let* ((str   (string-trim-both str))
 421            (left  (string-index str #\space))
 422            (right (string-rindex str #\space)))
 423       (list (string-take str left)
 424             (string-trim-both (substring str left right))
 425             (string-trim-both (string-drop str right)))))
 426
 427   (let loop ((aliases '()))
 428     (match (read-line port)
 429       ((? eof-object?)
 430        (reverse aliases))
 431       ((? comment?)
 432        (loop aliases))
 433       (line
 434        (match (tokenize line)
 435          (("alias" alias module)
 436           (loop (alist-cons (string->compiled-sglob alias) module
 437                             aliases)))
 438          (()                                      ;empty line
 439           (loop aliases)))))))
 440
 441 (define (current-kernel-directory)
 442   "Return the directory of the currently running Linux kernel."
 443   (string-append (or (getenv "LINUX_MODULE_DIRECTORY")
 444                      "/run/booted-system/kernel/lib/modules")
 445                  "/" (utsname:release (uname))))
 446
 447 (define (current-alias-file)
 448   "Return the absolute file name of the default 'modules.alias' file."
 449   (string-append (current-kernel-directory) "/modules.alias"))
 450
 451 (define* (known-module-aliases #:optional (alias-file (current-alias-file)))
 452   "Return the list of alias/module pairs read from ALIAS-FILE.  Each alias is
 453 actually a pattern."
 454   (call-with-input-file alias-file read-module-aliases))
 455
 456 (define* (matching-modules alias
 457                            #:optional (known-aliases (known-module-aliases)))
 458   "Return the list of modules that match ALIAS according to KNOWN-ALIASES.
 459 ALIAS is a string like \"scsi:t-0x00\" as returned by
 460 'device-module-aliases'."
 461   (filter-map (match-lambda
 462                 ((pattern . module)
 463                  (and (glob-match? pattern alias)
 464                       module)))
 465               known-aliases))
 466
 467 (define* (missing-modules device modules-provided)
 468   "Assuming MODULES-PROVIDED lists kernel modules that are already
 469 provided--e.g., in the initrd, return the list of missing kernel modules that
 470 are required to access DEVICE."
 471   (define aliases
 472     ;; Attempt to load 'modules.alias' from the current kernel, assuming we're
 473     ;; on Guix System, and assuming that corresponds to the kernel we'll be
 474     ;; installing.
 475     (known-module-aliases))
 476
 477   (if aliases
 478       (let* ((modules  (delete-duplicates
 479                         (append-map (cut matching-modules <> aliases)
 480                                     (device-module-aliases device))))
 481
 482              ;; Module names (not file names) are supposed to use underscores
 483              ;; instead of hyphens.  MODULES is a list of module names, whereas
 484              ;; LINUX-MODULES is file names without '.ko', so normalize them.
 485              (provided (map file-name->module-name modules-provided)))
 486         (remove (cut member <> provided) modules))
 487       '()))
 488
 489 ;;; linux-modules.scm ends here