| 1 | |
| 2 | |
| 3 | |
| 4 | |
| 5 | |
| 6 | |
| 7 | |
| 8 | |
| 9 | |
| 10 | |
| 11 | |
| 12 | |
| 13 | |
| 14 | |
| 15 | |
| 16 | |
| 17 | |
| 18 | |
| 19 | |
| 20 | |
| 21 | |
| 22 |
|
| 23 | |
| 24 | |
| 25 | |
| 26 | |
| 27 | |
| 28 |
|
| 29 | (define-module (gnu build linux-modules)
|
| 30 | #:use-module (guix elf)
|
| 31 | #:use-module (guix glob)
|
| 32 | #:use-module (guix build syscalls)
|
| 33 | #:use-module ((guix build utils) #:select (find-files invoke))
|
| 34 | #:use-module (guix build union)
|
| 35 | #:autoload (zlib) (call-with-gzip-input-port)
|
| 36 | #:autoload (zstd) (call-with-zstd-input-port)
|
| 37 | #:use-module (rnrs io ports)
|
| 38 | #:use-module (rnrs bytevectors)
|
| 39 | #:use-module (srfi srfi-1)
|
| 40 | #:use-module (srfi srfi-9 gnu)
|
| 41 | #:use-module (srfi srfi-11)
|
| 42 | #:use-module (srfi srfi-26)
|
| 43 | #:use-module (ice-9 ftw)
|
| 44 | #:use-module (ice-9 vlist)
|
| 45 | #:use-module (ice-9 match)
|
| 46 | #:use-module (ice-9 rdelim)
|
| 47 | #:autoload (ice-9 pretty-print) (pretty-print)
|
| 48 | #:export (dot-ko
|
| 49 | ensure-dot-ko
|
| 50 | module-formal-name
|
| 51 | module-aliases
|
| 52 | module-dependencies
|
| 53 | module-soft-dependencies
|
| 54 | normalize-module-name
|
| 55 | file-name->module-name
|
| 56 | find-module-file
|
| 57 | recursive-module-dependencies
|
| 58 | modules-loaded
|
| 59 | module-loaded?
|
| 60 | load-linux-module*
|
| 61 | load-linux-modules-from-directory
|
| 62 |
|
| 63 | pci-devices
|
| 64 | pci-device?
|
| 65 | pci-device-vendor
|
| 66 | pci-device-id
|
| 67 | pci-device-class
|
| 68 | pci-device-module-alias
|
| 69 | storage-pci-device?
|
| 70 | network-pci-device?
|
| 71 | display-pci-device?
|
| 72 | load-pci-device-database
|
| 73 |
|
| 74 | current-module-debugging-port
|
| 75 |
|
| 76 | device-module-aliases
|
| 77 | known-module-aliases
|
| 78 | matching-modules
|
| 79 | missing-modules
|
| 80 |
|
| 81 | write-module-name-database
|
| 82 | write-module-alias-database
|
| 83 | write-module-device-database
|
| 84 |
|
| 85 | make-linux-module-directory))
|
| 86 |
|
| 87 | (define current-module-debugging-port
|
| 88 | (make-parameter (%make-void-port "w")))
|
| 89 |
|
| 90 | (define (section-contents elf section)
|
| 91 | "Return the contents of SECTION in ELF as a bytevector."
|
| 92 | (let ((contents (make-bytevector (elf-section-size section))))
|
| 93 | (bytevector-copy! (elf-bytes elf) (elf-section-offset section)
|
| 94 | contents 0
|
| 95 | (elf-section-size section))
|
| 96 | contents))
|
| 97 |
|
| 98 | (define %not-nul
|
| 99 | (char-set-complement (char-set #\nul)))
|
| 100 |
|
| 101 | (define (nul-separated-string->list str)
|
| 102 | "Split STR at occurrences of the NUL character and return the resulting
|
| 103 | string list."
|
| 104 | (string-tokenize str %not-nul))
|
| 105 |
|
| 106 | (define (key=value->pair str)
|
| 107 | "Assuming STR has the form \"KEY=VALUE\", return a pair like (KEY
|
| 108 | . \"VALUE\")."
|
| 109 | (let ((= (string-index str #\=)))
|
| 110 | (cons (string->symbol (string-take str =))
|
| 111 | (string-drop str (+ 1 =)))))
|
| 112 |
|
| 113 | |
| 114 | |
| 115 | (define module-regex "\\.ko(\\.gz|\\.xz|\\.zst)?$")
|
| 116 |
|
| 117 | (define (modinfo-section-contents file)
|
| 118 | "Return the contents of the '.modinfo' section of FILE as a list of
|
| 119 | key/value pairs.."
|
| 120 | (define (decompress-file decompressor file)
|
| 121 | (let ((port (open-file file "r0")))
|
| 122 | (dynamic-wind
|
| 123 | (lambda ()
|
| 124 | #t)
|
| 125 | (lambda ()
|
| 126 | (decompressor port get-bytevector-all))
|
| 127 | (lambda ()
|
| 128 | (close-port port)))))
|
| 129 |
|
| 130 | (define (get-bytevector file)
|
| 131 | (cond
|
| 132 | ((string-suffix? ".ko.gz" file)
|
| 133 | (decompress-file call-with-gzip-input-port file))
|
| 134 | ((string-suffix? ".ko.zst" file)
|
| 135 | (decompress-file call-with-zstd-input-port file))
|
| 136 | (else
|
| 137 | (call-with-input-file file get-bytevector-all))))
|
| 138 |
|
| 139 | (let* ((bv (get-bytevector file))
|
| 140 | (elf (parse-elf bv))
|
| 141 | (section (elf-section-by-name elf ".modinfo"))
|
| 142 | (modinfo (section-contents elf section)))
|
| 143 | (map key=value->pair
|
| 144 | (nul-separated-string->list (utf8->string modinfo)))))
|
| 145 |
|
| 146 | (define %not-comma
|
| 147 | (char-set-complement (char-set #\,)))
|
| 148 |
|
| 149 | (define (module-formal-name file)
|
| 150 | "Return the module name of FILE as it appears in its info section. Usually
|
| 151 | the module name is the same as the base name of FILE, modulo hyphens and minus
|
| 152 | the \".ko[.gz|.xz]\" extension."
|
| 153 | (match (assq 'name (modinfo-section-contents file))
|
| 154 | (('name . name) name)
|
| 155 | (#f #f)))
|
| 156 |
|
| 157 | (define (module-dependencies file)
|
| 158 | "Return the list of modules that FILE depends on. The returned list
|
| 159 | contains module names, not actual file names."
|
| 160 | (let ((info (modinfo-section-contents file)))
|
| 161 | (match (assq 'depends info)
|
| 162 | (('depends . what)
|
| 163 | (string-tokenize what %not-comma)))))
|
| 164 |
|
| 165 | (define not-softdep-whitespace
|
| 166 | (char-set-complement (char-set #\space #\tab)))
|
| 167 |
|
| 168 | (define (module-soft-dependencies file)
|
| 169 | "Return the list of modules that can be preloaded, and then the list of
|
| 170 | modules that can be postloaded, of the soft dependencies of module FILE."
|
| 171 | |
| 172 | (define (parse-softdep text)
|
| 173 | (let loop ((value '())
|
| 174 | (tokens (string-tokenize text not-softdep-whitespace))
|
| 175 | (section #f))
|
| 176 | (match tokens
|
| 177 | ((token rest ...)
|
| 178 | (if (string=? (string-take-right token 1) ":") |
| 179 | (loop value rest (string-trim-both (string-drop-right token 1)))
|
| 180 | (loop (cons (cons section token) value) rest section)))
|
| 181 | (()
|
| 182 | value))))
|
| 183 |
|
| 184 | |
| 185 | (let* ((info (modinfo-section-contents file))
|
| 186 | (entries (concatenate
|
| 187 | (filter-map (match-lambda
|
| 188 | (('softdep . value)
|
| 189 | (parse-softdep value))
|
| 190 | (_ #f))
|
| 191 | (modinfo-section-contents file)))))
|
| 192 | (let-values (((pres posts)
|
| 193 | (partition (match-lambda
|
| 194 | (("pre" . _) #t)
|
| 195 | (("post" . _) #f))
|
| 196 | entries)))
|
| 197 | (values (map (match-lambda
|
| 198 | ((_ . value) value))
|
| 199 | pres)
|
| 200 | (map (match-lambda
|
| 201 | ((_ . value) value))
|
| 202 | posts)))))
|
| 203 |
|
| 204 | (define (module-aliases file)
|
| 205 | "Return the list of aliases of module FILE."
|
| 206 | (let ((info (modinfo-section-contents file)))
|
| 207 | (filter-map (match-lambda
|
| 208 | (('alias . value)
|
| 209 | value)
|
| 210 | (_ #f))
|
| 211 | (modinfo-section-contents file))))
|
| 212 |
|
| 213 | (define (strip-extension filename)
|
| 214 | (let ((extension (string-index filename #\.)))
|
| 215 | (if extension
|
| 216 | (string-take filename extension)
|
| 217 | filename)))
|
| 218 |
|
| 219 | (define* (dot-ko name #:optional compression)
|
| 220 | (let ((suffix (match compression
|
| 221 | ('xz ".ko.xz")
|
| 222 | ('gzip ".ko.gz")
|
| 223 | ('zstd ".ko.zst")
|
| 224 | (else ".ko"))))
|
| 225 | (string-append name suffix)))
|
| 226 |
|
| 227 | (define (ensure-dot-ko name compression)
|
| 228 | "Return NAME with a '.ko[.gz|.xz|.zst]' suffix appended, unless it already has
|
| 229 | it."
|
| 230 | (if (string-contains name ".ko")
|
| 231 | name
|
| 232 | (dot-ko name compression)))
|
| 233 |
|
| 234 | (define (normalize-module-name module)
|
| 235 | "Return the \"canonical\" name for MODULE, replacing hyphens with
|
| 236 | underscores."
|
| 237 | |
| 238 | (string-map (lambda (chr)
|
| 239 | (case chr
|
| 240 | ((#\-) #\_)
|
| 241 | (else chr)))
|
| 242 | module))
|
| 243 |
|
| 244 | (define (file-name->module-name file)
|
| 245 | "Return the module name corresponding to FILE, stripping the trailing
|
| 246 | '.ko[.gz|.xz|.zst]' and normalizing it."
|
| 247 | (normalize-module-name (strip-extension (basename file))))
|
| 248 |
|
| 249 | (define (find-module-file directory module)
|
| 250 | "Lookup module NAME under DIRECTORY, and return its absolute file name.
|
| 251 | NAME can be a file name with or without '.ko', or it can be a module name.
|
| 252 | Raise an error if it could not be found.
|
| 253 |
|
| 254 | Module names can differ from file names in interesting ways; for instance,
|
| 255 | module names usually (always?) use underscores as the inter-word separator,
|
| 256 | whereas file names often, but not always, use hyphens. Examples:
|
| 257 | \"usb-storage.ko\", \"serpent_generic.ko\"."
|
| 258 | (define names
|
| 259 | |
| 260 | |
| 261 | |
| 262 | (delete-duplicates
|
| 263 | (list module
|
| 264 | (normalize-module-name module)
|
| 265 | (string-map (lambda (chr) |
| 266 | (case chr
|
| 267 | ((#\_) #\-)
|
| 268 | (else chr)))
|
| 269 | module))))
|
| 270 |
|
| 271 | (match (find-files directory
|
| 272 | (lambda (file stat)
|
| 273 | (member (strip-extension
|
| 274 | (basename file)) names)))
|
| 275 | ((file)
|
| 276 | file)
|
| 277 | (()
|
| 278 | (error "kernel module not found" module directory))
|
| 279 | ((_ ...)
|
| 280 | (error "several modules by that name" module directory))))
|
| 281 |
|
| 282 | (define* (recursive-module-dependencies files
|
| 283 | #:key (lookup-module dot-ko))
|
| 284 | "Return the topologically-sorted list of file names of the modules depended
|
| 285 | on by FILES, recursively. File names of modules are determined by applying
|
| 286 | LOOKUP-MODULE to the module name."
|
| 287 | (let loop ((files files)
|
| 288 | (result '())
|
| 289 | (visited vlist-null))
|
| 290 | (match files
|
| 291 | (()
|
| 292 | (delete-duplicates (reverse result)))
|
| 293 | ((head . tail)
|
| 294 | (let* ((visited? (vhash-assoc head visited))
|
| 295 | (deps (if visited?
|
| 296 | '()
|
| 297 | (map lookup-module (module-dependencies head))))
|
| 298 | (visited (if visited?
|
| 299 | visited
|
| 300 | (vhash-cons head #t visited))))
|
| 301 | (loop (append deps tail)
|
| 302 | (append result deps) visited))))))
|
| 303 |
|
| 304 | (define %not-newline
|
| 305 | (char-set-complement (char-set #\newline)))
|
| 306 |
|
| 307 | (define (modules-loaded)
|
| 308 | "Return the list of names of currently loaded Linux modules."
|
| 309 | (let* ((contents (call-with-input-file "/proc/modules"
|
| 310 | get-string-all))
|
| 311 | (lines (string-tokenize contents %not-newline)))
|
| 312 | (match (map string-tokenize lines)
|
| 313 | (((modules . _) ...)
|
| 314 | modules))))
|
| 315 |
|
| 316 | (define (module-black-list)
|
| 317 | "Return the black list of modules that must not be loaded. This black list
|
| 318 | is specified using 'modprobe.blacklist=MODULE1,MODULE2,...' on the kernel
|
| 319 | command line; it is honored by libkmod for users that pass
|
| 320 | 'KMOD_PROBE_APPLY_BLACKLIST', which includes 'modprobe --use-blacklist' and
|
| 321 | udev."
|
| 322 | (define parameter
|
| 323 | "modprobe.blacklist=")
|
| 324 |
|
| 325 | (let ((command (call-with-input-file "/proc/cmdline"
|
| 326 | get-string-all)))
|
| 327 | (append-map (lambda (arg)
|
| 328 | (if (string-prefix? parameter arg)
|
| 329 | (string-tokenize (string-drop arg (string-length parameter))
|
| 330 | %not-comma)
|
| 331 | '()))
|
| 332 | (string-tokenize command))))
|
| 333 |
|
| 334 | (define (module-loaded? module)
|
| 335 | "Return #t if MODULE is already loaded. MODULE must be a Linux module name,
|
| 336 | not a file name."
|
| 337 | (member module (modules-loaded)))
|
| 338 |
|
| 339 | (define* (load-linux-module* file
|
| 340 | #:key
|
| 341 | (recursive? #t)
|
| 342 | (lookup-module dot-ko)
|
| 343 | (black-list (module-black-list)))
|
| 344 | "Load Linux module from FILE, the name of a '.ko[.gz|.xz|.zst]' file; return
|
| 345 | true on success, false otherwise. When RECURSIVE? is true, load its
|
| 346 | dependencies first (à la 'modprobe'.) The actual files containing modules
|
| 347 | depended on are obtained by calling LOOKUP-MODULE with the module name.
|
| 348 | Modules whose name appears in BLACK-LIST are not loaded."
|
| 349 | (define (black-listed? module)
|
| 350 | (let ((result (member module black-list)))
|
| 351 | (when result
|
| 352 | (format (current-module-debugging-port)
|
| 353 | "not loading module '~a' because it's black-listed~%"
|
| 354 | module))
|
| 355 | result))
|
| 356 |
|
| 357 | (define (load-dependencies file)
|
| 358 | (let ((dependencies (module-dependencies file)))
|
| 359 | (every (cut load-linux-module* <>
|
| 360 | #:lookup-module lookup-module
|
| 361 | #:black-list black-list)
|
| 362 | (map lookup-module dependencies))))
|
| 363 |
|
| 364 | (and (not (black-listed? (file-name->module-name file)))
|
| 365 | (or (not recursive?)
|
| 366 | (load-dependencies file))
|
| 367 | (let ((fd #f))
|
| 368 | (format (current-module-debugging-port)
|
| 369 | "loading Linux module from '~a'...~%" file)
|
| 370 |
|
| 371 | (catch 'system-error
|
| 372 | (lambda ()
|
| 373 | (set! fd (open-fdes file O_RDONLY))
|
| 374 | (load-linux-module/fd fd)
|
| 375 | (close-fdes fd)
|
| 376 | #t)
|
| 377 | (lambda args
|
| 378 | (when fd (close-fdes fd))
|
| 379 | (let ((errno (system-error-errno args)))
|
| 380 | (or (and recursive? |
| 381 | (member errno
|
| 382 | (list EEXIST |
| 383 | EINVAL))) |
| 384 | (apply throw args))))))))
|
| 385 |
|
| 386 | (define (load-linux-modules-from-directory modules directory)
|
| 387 | "Load MODULES and their dependencies from DIRECTORY, a directory containing
|
| 388 | the '.ko' files. The '.ko' suffix is automatically added to MODULES if
|
| 389 | needed."
|
| 390 | (define module-name->file-name
|
| 391 | (module-name-lookup directory))
|
| 392 |
|
| 393 | (for-each (lambda (module)
|
| 394 | (when (file-exists? module)
|
| 395 | (load-linux-module* module
|
| 396 | #:lookup-module module-name->file-name)))
|
| 397 | (map module-name->file-name modules)))
|
| 398 |
|
| 399 |
|
| 400 | |
| 401 | |
| 402 | |
| 403 |
|
| 404 | |
| 405 | (define (readlink* file)
|
| 406 | "Call 'readlink' until the result is not a symlink."
|
| 407 | (define %max-symlink-depth 50)
|
| 408 |
|
| 409 | (let loop ((file file)
|
| 410 | (depth 0))
|
| 411 | (define (absolute target)
|
| 412 | (if (absolute-file-name? target)
|
| 413 | target
|
| 414 | (string-append (dirname file) "/" target)))
|
| 415 |
|
| 416 | (if (>= depth %max-symlink-depth)
|
| 417 | file
|
| 418 | (call-with-values
|
| 419 | (lambda ()
|
| 420 | (catch 'system-error
|
| 421 | (lambda ()
|
| 422 | (values #t (readlink file)))
|
| 423 | (lambda args
|
| 424 | (let ((errno (system-error-errno args)))
|
| 425 | (if (or (= errno EINVAL))
|
| 426 | (values #f file)
|
| 427 | (apply throw args))))))
|
| 428 | (lambda (success? target)
|
| 429 | (if success?
|
| 430 | (loop (absolute target) (+ depth 1))
|
| 431 | file))))))
|
| 432 |
|
| 433 | |
| 434 |
|
| 435 | (define (stat->device-major st)
|
| 436 | (ash (logand #xfff00 (stat:rdev st)) -8))
|
| 437 |
|
| 438 | (define (stat->device-minor st)
|
| 439 | (logand #xff (stat:rdev st)))
|
| 440 |
|
| 441 | (define %not-slash
|
| 442 | (char-set-complement (char-set #\/)))
|
| 443 |
|
| 444 | (define (read-uevent port)
|
| 445 | "Read a /sys 'uevent' file from PORT and return an alist where each car is a
|
| 446 | key such as 'MAJOR or 'DEVTYPE and each cdr is the corresponding value."
|
| 447 | (let loop ((result '()))
|
| 448 | (match (read-line port)
|
| 449 | ((? eof-object?)
|
| 450 | (reverse result))
|
| 451 | (line
|
| 452 | (loop (cons (key=value->pair line) result))))))
|
| 453 |
|
| 454 | |
| 455 | (define-immutable-record-type <pci-device>
|
| 456 | (pci-device vendor device class module-alias)
|
| 457 | pci-device?
|
| 458 | (vendor pci-device-vendor) |
| 459 | (device pci-device-id) |
| 460 | (class pci-device-class) |
| 461 | (module-alias pci-device-module-alias)) |
| 462 |
|
| 463 | (define (pci-device-class-predicate mask bits)
|
| 464 | (lambda (device)
|
| 465 | "Return true if DEVICE has the chosen class."
|
| 466 | (= (logand mask (pci-device-class device)) bits)))
|
| 467 |
|
| 468 | (define storage-pci-device? |
| 469 | (pci-device-class-predicate #xff0000 #x010000))
|
| 470 | (define network-pci-device? |
| 471 | (pci-device-class-predicate #xff0000 #x020000))
|
| 472 | (define display-pci-device? |
| 473 | (pci-device-class-predicate #xff0000 #x030000))
|
| 474 |
|
| 475 | (define (pci-devices)
|
| 476 | "Return the list of PCI devices of the system (<pci-device> records)."
|
| 477 | (define (read-hex port)
|
| 478 | (let ((line (read-line port)))
|
| 479 | (and (string? line)
|
| 480 | (string-prefix? "0x" line)
|
| 481 | (string->number (string-drop line 2) 16))))
|
| 482 |
|
| 483 | (filter-map (lambda (directory)
|
| 484 | (define properties
|
| 485 | (call-with-input-file (string-append directory "/uevent")
|
| 486 | read-uevent))
|
| 487 | (define vendor
|
| 488 | (call-with-input-file (string-append directory "/vendor")
|
| 489 | read-hex))
|
| 490 | (define device
|
| 491 | (call-with-input-file (string-append directory "/device")
|
| 492 | read-hex))
|
| 493 | (define class
|
| 494 | (call-with-input-file (string-append directory "/class")
|
| 495 | read-hex))
|
| 496 |
|
| 497 | (pci-device vendor device class
|
| 498 | (assq-ref properties 'MODALIAS)))
|
| 499 | (find-files "/sys/bus/pci/devices"
|
| 500 | #:stat lstat)))
|
| 501 |
|
| 502 | (define (read-pci-device-database port)
|
| 503 | "Parse the 'pci.ids' database that ships with the pciutils package and is
|
| 504 | maintained at <https://pci-ids.ucw.cz/>."
|
| 505 | (define (comment? str)
|
| 506 | (string-prefix? "#" (string-trim str)))
|
| 507 | (define (blank? str)
|
| 508 | (string-null? (string-trim-both str)))
|
| 509 | (define (device? str)
|
| 510 | (eqv? #\tab (string-ref str 0)))
|
| 511 | (define (subvendor? str)
|
| 512 | (string-prefix? "\t\t" str))
|
| 513 | (define (class? str)
|
| 514 | (string-prefix? "C " str))
|
| 515 | (define (parse-id-line str)
|
| 516 | (let* ((str (string-trim-both str))
|
| 517 | (space (string-index str char-set:whitespace)))
|
| 518 | (values (string->number (string-take str space) 16)
|
| 519 | (string-trim (string-drop str (+ 1 space))))))
|
| 520 | (define (finish vendor vendor-id devices table)
|
| 521 | (fold (lambda (device table)
|
| 522 | (match device
|
| 523 | ((device-id . name)
|
| 524 | (vhash-consv (logior (ash vendor-id 16) device-id)
|
| 525 | (cons vendor name)
|
| 526 | table))))
|
| 527 | table
|
| 528 | devices))
|
| 529 |
|
| 530 | (let loop ((table vlist-null)
|
| 531 | (vendor-id #f)
|
| 532 | (vendor #f)
|
| 533 | (devices '()))
|
| 534 | (match (read-line port)
|
| 535 | ((? eof-object?)
|
| 536 | (let ((table (if (and vendor vendor-id)
|
| 537 | (finish vendor vendor-id devices table)
|
| 538 | table)))
|
| 539 | (lambda (vendor device)
|
| 540 | (match (vhash-assv (logior (ash vendor 16) device) table)
|
| 541 | (#f
|
| 542 | (values #f #f))
|
| 543 | ((_ . (vendor . name))
|
| 544 | (values vendor name))))))
|
| 545 | ((? comment?)
|
| 546 | (loop table vendor-id vendor devices))
|
| 547 | ((? blank?)
|
| 548 | (loop table vendor-id vendor devices))
|
| 549 | ((? subvendor?) |
| 550 | (loop table vendor-id vendor devices))
|
| 551 | ((? class?) |
| 552 | (loop table vendor-id vendor devices))
|
| 553 | ((? device? line)
|
| 554 | (let-values (((id name) (parse-id-line line)))
|
| 555 | (loop table vendor-id vendor
|
| 556 | (if (and vendor-id vendor) |
| 557 | (alist-cons id name devices)
|
| 558 | devices))))
|
| 559 | (line
|
| 560 | (let ((table (if (and vendor vendor-id)
|
| 561 | (finish vendor vendor-id devices table)
|
| 562 | table)))
|
| 563 | (let-values (((vendor-id vendor) (parse-id-line line)))
|
| 564 | (loop table vendor-id vendor '())))))))
|
| 565 |
|
| 566 | (define (load-pci-device-database file)
|
| 567 | "Read the 'pci.ids' database at FILE (get it from the pciutils package or
|
| 568 | from <https://pci-ids.ucw.cz/>) and return a lookup procedure that takes a PCI
|
| 569 | vendor ID and a device ID (two integers) and returns the vendor name and
|
| 570 | device name as two values."
|
| 571 | (let ((port (open-file file "r0")))
|
| 572 | (call-with-gzip-input-port port
|
| 573 | read-pci-device-database)))
|
| 574 |
|
| 575 | (define (device-module-aliases device)
|
| 576 | "Return the list of module aliases required by DEVICE, a /dev file name, as
|
| 577 | in this example:
|
| 578 |
|
| 579 | (device-module-aliases \"/dev/sda\")
|
| 580 | => (\"scsi:t-0x00\" \"pci:v00008086d00009D03sv0000103Csd000080FAbc01sc06i01\")
|
| 581 |
|
| 582 | The modules corresponding to these aliases can then be found using
|
| 583 | 'matching-modules'."
|
| 584 | |
| 585 | |
| 586 | (let* ((st (stat device))
|
| 587 | (type (stat:type st))
|
| 588 | (major (stat->device-major st))
|
| 589 | (minor (stat->device-minor st))
|
| 590 | (sys-name (string-append "/sys/dev/"
|
| 591 | (case type
|
| 592 | ((block-special) "block")
|
| 593 | ((char-special) "char")
|
| 594 | (else (symbol->string type)))
|
| 595 | "/" (number->string major) ":"
|
| 596 | (number->string minor)))
|
| 597 | (directory (canonicalize-path (readlink* sys-name))))
|
| 598 | (let loop ((components (string-tokenize directory %not-slash))
|
| 599 | (aliases '()))
|
| 600 | (match components
|
| 601 | (("sys" "devices" _)
|
| 602 | (reverse aliases))
|
| 603 | ((head ... _)
|
| 604 | (let ((uevent (string-append (string-join components "/" 'prefix)
|
| 605 | "/uevent")))
|
| 606 | (if (file-exists? uevent)
|
| 607 | (let ((props (call-with-input-file uevent read-uevent)))
|
| 608 | (match (assq-ref props 'MODALIAS)
|
| 609 | (#f (loop head aliases))
|
| 610 | (alias (loop head (cons alias aliases)))))
|
| 611 | (loop head aliases))))))))
|
| 612 |
|
| 613 | (define (read-module-aliases port)
|
| 614 | "Read from PORT data in the Linux 'modules.alias' file format. Return a
|
| 615 | list of alias/module pairs where each alias is a glob pattern as like the
|
| 616 | result of:
|
| 617 |
|
| 618 | (string->compiled-sglob \"scsi:t-0x01*\")
|
| 619 |
|
| 620 | and each module is a module name like \"snd_hda_intel\"."
|
| 621 | (define (comment? str)
|
| 622 | (string-prefix? "#" str))
|
| 623 |
|
| 624 | (define (tokenize str)
|
| 625 | |
| 626 | |
| 627 | (let* ((str (string-trim-both str))
|
| 628 | (left (string-index str #\space))
|
| 629 | (right (string-rindex str #\space)))
|
| 630 | (list (string-take str left)
|
| 631 | (string-trim-both (substring str left right))
|
| 632 | (string-trim-both (string-drop str right)))))
|
| 633 |
|
| 634 | (let loop ((aliases '()))
|
| 635 | (match (read-line port)
|
| 636 | ((? eof-object?)
|
| 637 | (reverse aliases))
|
| 638 | ((? comment?)
|
| 639 | (loop aliases))
|
| 640 | (line
|
| 641 | (match (tokenize line)
|
| 642 | (("alias" alias module)
|
| 643 | (loop (alist-cons (string->compiled-sglob alias) module
|
| 644 | aliases)))
|
| 645 | (() |
| 646 | (loop aliases)))))))
|
| 647 |
|
| 648 | (define (current-kernel-directory)
|
| 649 | "Return the directory of the currently running Linux kernel."
|
| 650 | (string-append (or (getenv "LINUX_MODULE_DIRECTORY")
|
| 651 | "/run/booted-system/kernel/lib/modules")
|
| 652 | "/" (utsname:release (uname))))
|
| 653 |
|
| 654 | (define (current-alias-file)
|
| 655 | "Return the absolute file name of the default 'modules.alias' file."
|
| 656 | (string-append (current-kernel-directory) "/modules.alias"))
|
| 657 |
|
| 658 | (define* (known-module-aliases #:optional (alias-file (current-alias-file)))
|
| 659 | "Return the list of alias/module pairs read from ALIAS-FILE. Each alias is
|
| 660 | actually a pattern."
|
| 661 | (call-with-input-file alias-file read-module-aliases))
|
| 662 |
|
| 663 | (define* (matching-modules alias
|
| 664 | #:optional (known-aliases (known-module-aliases)))
|
| 665 | "Return the list of modules that match ALIAS according to KNOWN-ALIASES.
|
| 666 | ALIAS is a string like \"scsi:t-0x00\" as returned by
|
| 667 | 'device-module-aliases'."
|
| 668 | (filter-map (match-lambda
|
| 669 | ((pattern . module)
|
| 670 | (and (glob-match? pattern alias)
|
| 671 | module)))
|
| 672 | known-aliases))
|
| 673 |
|
| 674 | (define* (missing-modules device modules-provided)
|
| 675 | "Assuming MODULES-PROVIDED lists kernel modules that are already
|
| 676 | provided--e.g., in the initrd, return the list of missing kernel modules that
|
| 677 | are required to access DEVICE."
|
| 678 | (define aliases
|
| 679 | |
| 680 | |
| 681 | |
| 682 | (known-module-aliases))
|
| 683 |
|
| 684 | (if aliases
|
| 685 | (let* ((modules (delete-duplicates
|
| 686 | (append-map (cut matching-modules <> aliases)
|
| 687 | (device-module-aliases device))))
|
| 688 |
|
| 689 | |
| 690 | |
| 691 | |
| 692 | (provided (map file-name->module-name modules-provided)))
|
| 693 | (remove (cut member <> provided) modules))
|
| 694 | '()))
|
| 695 |
|
| 696 |
|
| 697 | |
| 698 | |
| 699 | |
| 700 |
|
| 701 | (define* (module-name->file-name/guess directory name
|
| 702 | #:key compression)
|
| 703 | "Guess the file name corresponding to NAME, a module name. That doesn't
|
| 704 | always work because sometimes underscores in NAME map to hyphens (e.g.,
|
| 705 | \"input-leds.ko\"), sometimes not (e.g., \"mac_hid.ko\"). If the module is
|
| 706 | compressed then COMPRESSED can be set to 'zstd, 'xz or 'gzip, depending on the
|
| 707 | compression type."
|
| 708 | (string-append directory "/" (ensure-dot-ko name compression)))
|
| 709 |
|
| 710 | (define (module-name-lookup directory)
|
| 711 | "Return a one argument procedure that takes a module name (e.g.,
|
| 712 | \"input_leds\") and returns its absolute file name (e.g.,
|
| 713 | \"/.../input-leds.ko\")."
|
| 714 | (define (guess-file-name name)
|
| 715 | (let ((names (list
|
| 716 | (module-name->file-name/guess directory name)
|
| 717 | (module-name->file-name/guess directory name
|
| 718 | #:compression 'zstd)
|
| 719 | (module-name->file-name/guess directory name
|
| 720 | #:compression 'xz)
|
| 721 | (module-name->file-name/guess directory name
|
| 722 | #:compression 'gzip))))
|
| 723 | (or (find file-exists? names)
|
| 724 | (first names))))
|
| 725 |
|
| 726 | (catch 'system-error
|
| 727 | (lambda ()
|
| 728 | (define mapping
|
| 729 | (call-with-input-file (string-append directory "/modules.name")
|
| 730 | read))
|
| 731 |
|
| 732 | (lambda (name)
|
| 733 | (or (assoc-ref mapping name)
|
| 734 | (guess-file-name name))))
|
| 735 | (lambda args
|
| 736 | (if (= ENOENT (system-error-errno args))
|
| 737 | (cut guess-file-name <>)
|
| 738 | (apply throw args)))))
|
| 739 |
|
| 740 | (define (write-module-name-database directory)
|
| 741 | "Write a database that maps \"module names\" as they appear in the relevant
|
| 742 | ELF section of '.ko[.gz|.xz|.zst]' files, to actual file names. This format
|
| 743 | is Guix-specific. It aims to deal with inconsistent naming, in particular
|
| 744 | hyphens vs. underscores."
|
| 745 | (define mapping
|
| 746 | (map (lambda (file)
|
| 747 | (match (module-formal-name file)
|
| 748 | (#f (cons (strip-extension (basename file)) file))
|
| 749 | (name (cons name file))))
|
| 750 | (find-files directory module-regex)))
|
| 751 |
|
| 752 | (call-with-output-file (string-append directory "/modules.name")
|
| 753 | (lambda (port)
|
| 754 | (display ";; Module name to file name mapping.
|
| 755 | ;;
|
| 756 | ;; This format is Guix-specific; it is not supported by upstream Linux tools.
|
| 757 | \n"
|
| 758 | port)
|
| 759 | (pretty-print mapping port))))
|
| 760 |
|
| 761 | (define (write-module-alias-database directory)
|
| 762 | "Traverse the '.ko[.gz|.xz|.zst]' files in DIRECTORY and create the
|
| 763 | corresponding 'modules.alias' file."
|
| 764 | (define aliases
|
| 765 | (map (lambda (file)
|
| 766 | (cons (file-name->module-name file) (module-aliases file)))
|
| 767 | (find-files directory module-regex)))
|
| 768 |
|
| 769 | (call-with-output-file (string-append directory "/modules.alias")
|
| 770 | (lambda (port)
|
| 771 | (display "# Aliases extracted from modules themselves.\n" port)
|
| 772 | (for-each (match-lambda
|
| 773 | ((module . aliases)
|
| 774 | (for-each (lambda (alias)
|
| 775 | (format port "alias ~a ~a\n" alias module))
|
| 776 | aliases)))
|
| 777 | aliases))))
|
| 778 |
|
| 779 | (define (aliases->device-tuple aliases)
|
| 780 | "Traverse ALIASES, a list of module aliases, and search for
|
| 781 | \"char-major-M-N\", \"block-major-M-N\", or \"devname:\" aliases. When they
|
| 782 | are found, return a tuple (DEVNAME TYPE MAJOR MINOR), otherwise return #f."
|
| 783 | (define (char/block-major? alias)
|
| 784 | (or (string-prefix? "char-major-" alias)
|
| 785 | (string-prefix? "block-major-" alias)))
|
| 786 |
|
| 787 | (define (char/block-major->tuple alias)
|
| 788 | (match (string-tokenize alias %not-dash)
|
| 789 | ((type "major" (= string->number major) (= string->number minor))
|
| 790 | (list (match type
|
| 791 | ("char" "c")
|
| 792 | ("block" "b"))
|
| 793 | major minor))))
|
| 794 |
|
| 795 | (let* ((devname (any (lambda (alias)
|
| 796 | (and (string-prefix? "devname:" alias)
|
| 797 | (string-drop alias 8)))
|
| 798 | aliases))
|
| 799 | (major/minor (match (find char/block-major? aliases)
|
| 800 | (#f #f)
|
| 801 | (str (char/block-major->tuple str)))))
|
| 802 | (and devname major/minor
|
| 803 | (cons devname major/minor))))
|
| 804 |
|
| 805 | (define %not-dash
|
| 806 | (char-set-complement (char-set #\-)))
|
| 807 |
|
| 808 | (define (write-module-device-database directory)
|
| 809 | "Traverse the '.ko[.gz|.xz|.zst]' files in DIRECTORY and create the
|
| 810 | corresponding 'modules.devname' file. This file contains information about
|
| 811 | modules that can be loaded on-demand, such as file system modules."
|
| 812 | (define aliases
|
| 813 | (filter-map (lambda (file)
|
| 814 | (match (aliases->device-tuple (module-aliases file))
|
| 815 | (#f #f)
|
| 816 | (tuple (cons (file-name->module-name file) tuple))))
|
| 817 | (find-files directory module-regex)))
|
| 818 |
|
| 819 | (call-with-output-file (string-append directory "/modules.devname")
|
| 820 | (lambda (port)
|
| 821 | (display "# Device nodes to trigger on-demand module loading.\n" port)
|
| 822 | (for-each (match-lambda
|
| 823 | ((module devname type major minor)
|
| 824 | (format port "~a ~a ~a~a:~a~%"
|
| 825 | module devname type major minor)))
|
| 826 | aliases))))
|
| 827 |
|
| 828 | (define (depmod version directory)
|
| 829 | "Given an (existing) DIRECTORY, invoke depmod on it for
|
| 830 | kernel version VERSION."
|
| 831 | (let ((destination-directory (string-append directory "/lib/modules/"
|
| 832 | version))
|
| 833 | |
| 834 | (maps-file (string-append directory "/System.map"))
|
| 835 | |
| 836 | (symvers-file (string-append directory "/Module.symvers")))
|
| 837 | |
| 838 | (for-each (lambda (basename)
|
| 839 | (when (and (string-prefix? "modules." basename)
|
| 840 | |
| 841 | (not (string=? "modules.builtin" basename))
|
| 842 | |
| 843 | (not (string=? "modules.order" basename)))
|
| 844 | (delete-file (string-append destination-directory "/"
|
| 845 | basename))))
|
| 846 | (scandir destination-directory))
|
| 847 | (invoke "depmod"
|
| 848 | "-e" |
| 849 | |
| 850 | "-b" directory
|
| 851 | "-F" maps-file
|
| 852 | |
| 853 | version)))
|
| 854 |
|
| 855 | (define (make-linux-module-directory inputs version output)
|
| 856 | "Create a new directory OUTPUT and ensure that the directory
|
| 857 | OUTPUT/lib/modules/VERSION can be used as a source of Linux
|
| 858 | kernel modules for the first kmod in PATH now to eventually
|
| 859 | load. Take modules to put into OUTPUT from INPUTS.
|
| 860 |
|
| 861 | Right now that means it creates @code{modules.*.bin} which
|
| 862 | @command{modprobe} will use to find loadable modules."
|
| 863 | (union-build output inputs #:create-all-directories? #t)
|
| 864 | (depmod version output))
|
| 865 |
|
| 866 | |