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 ;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (gnu build linux-modules)
  22   #:use-module (guix elf)
  23   #:use-module (guix glob)
  24   #:use-module (guix build syscalls)
  25   #:use-module ((guix build utils) #:select (find-files invoke))
  26   #:use-module (guix build union)
  27   #:autoload   (zlib) (call-with-gzip-input-port)
  28   #:use-module (rnrs io ports)
  29   #:use-module (rnrs bytevectors)
  30   #:use-module (srfi srfi-1)
  31   #:use-module (srfi srfi-11)
  32   #:use-module (srfi srfi-26)
  33   #:use-module (ice-9 ftw)
  34   #:use-module (ice-9 vlist)
  35   #:use-module (ice-9 match)
  36   #:use-module (ice-9 rdelim)
  37   #:autoload   (ice-9 pretty-print) (pretty-print)
  38   #:export (dot-ko
  39             ensure-dot-ko
  40             module-formal-name
  41             module-aliases
  42             module-dependencies
  43             module-soft-dependencies
  44             normalize-module-name
  45             file-name->module-name
  46             find-module-file
  47             recursive-module-dependencies
  48             modules-loaded
  49             module-loaded?
  50             load-linux-module*
  51             load-linux-modules-from-directory
  52
  53             current-module-debugging-port
  54
  55             device-module-aliases
  56             known-module-aliases
  57             matching-modules
  58             missing-modules
  59
  60             write-module-name-database
  61             write-module-alias-database
  62             write-module-device-database
  63
  64             make-linux-module-directory))
  65
  66 ;;; Commentary:
  67 ;;;
  68 ;;; Tools to deal with Linux kernel modules.
  69 ;;;
  70 ;;; Code:
  71
  72 (define current-module-debugging-port
  73   (make-parameter (%make-void-port "w")))
  74
  75 (define (section-contents elf section)
  76   "Return the contents of SECTION in ELF as a bytevector."
  77   (let ((contents (make-bytevector (elf-section-size section))))
  78     (bytevector-copy! (elf-bytes elf) (elf-section-offset section)
  79                       contents 0
  80                       (elf-section-size section))
  81     contents))
  82
  83 (define %not-nul
  84   (char-set-complement (char-set #\nul)))
  85
  86 (define (nul-separated-string->list str)
  87   "Split STR at occurrences of the NUL character and return the resulting
  88 string list."
  89   (string-tokenize str %not-nul))
  90
  91 (define (key=value->pair str)
  92   "Assuming STR has the form \"KEY=VALUE\", return a pair like (KEY
  93 . \"VALUE\")."
  94   (let ((= (string-index str #\=)))
  95     (cons (string->symbol (string-take str =))
  96           (string-drop str (+ 1 =)))))
  97
  98 ;; Matches kernel modules, without compression, with GZIP compression or with
  99 ;; XZ compression.
 100 (define module-regex "\\.ko(\\.gz|\\.xz)?$")
 101
 102 (define (modinfo-section-contents file)
 103   "Return the contents of the '.modinfo' section of FILE as a list of
 104 key/value pairs.."
 105   (define (get-bytevector file)
 106     (cond
 107      ((string-suffix? ".ko.gz" file)
 108       (let ((port (open-file file "r0")))
 109         (dynamic-wind
 110           (lambda ()
 111             #t)
 112           (lambda ()
 113             (call-with-gzip-input-port port get-bytevector-all))
 114           (lambda ()
 115             (close-port port)))))
 116      (else
 117       (call-with-input-file file get-bytevector-all))))
 118
 119   (let* ((bv      (get-bytevector file))
 120          (elf     (parse-elf bv))
 121          (section (elf-section-by-name elf ".modinfo"))
 122          (modinfo (section-contents elf section)))
 123     (map key=value->pair
 124          (nul-separated-string->list (utf8->string modinfo)))))
 125
 126 (define %not-comma
 127   (char-set-complement (char-set #\,)))
 128
 129 (define (module-formal-name file)
 130   "Return the module name of FILE as it appears in its info section.  Usually
 131 the module name is the same as the base name of FILE, modulo hyphens and minus
 132 the \".ko[.gz|.xz]\" extension."
 133   (match (assq 'name (modinfo-section-contents file))
 134     (('name . name) name)
 135     (#f #f)))
 136
 137 (define (module-dependencies file)
 138   "Return the list of modules that FILE depends on.  The returned list
 139 contains module names, not actual file names."
 140   (let ((info (modinfo-section-contents file)))
 141     (match (assq 'depends info)
 142       (('depends . what)
 143        (string-tokenize what %not-comma)))))
 144
 145 (define not-softdep-whitespace
 146   (char-set-complement (char-set #\space #\tab)))
 147
 148 (define (module-soft-dependencies file)
 149   "Return the list of modules that can be preloaded, and then the list of
 150 modules that can be postloaded, of the soft dependencies of module FILE."
 151   ;; TEXT: "pre: baz blubb foo post: bax bar"
 152   (define (parse-softdep text)
 153     (let loop ((value '())
 154                (tokens (string-tokenize text not-softdep-whitespace))
 155                (section #f))
 156       (match tokens
 157        ((token rest ...)
 158         (if (string=? (string-take-right token 1) ":") ; section
 159             (loop value rest (string-trim-both (string-drop-right token 1)))
 160             (loop (cons (cons section token) value) rest section)))
 161        (()
 162         value))))
 163
 164   ;; Note: Multiple 'softdep sections are allowed.
 165   (let* ((info (modinfo-section-contents file))
 166          (entries (concatenate
 167                    (filter-map (match-lambda
 168                                 (('softdep . value)
 169                                  (parse-softdep value))
 170                                 (_ #f))
 171                                (modinfo-section-contents file)))))
 172     (let-values (((pres posts)
 173                   (partition (match-lambda
 174                               (("pre" . _) #t)
 175                               (("post" . _) #f))
 176                              entries)))
 177       (values (map (match-lambda
 178                     ((_ . value) value))
 179                    pres)
 180               (map (match-lambda
 181                     ((_ . value) value))
 182                    posts)))))
 183
 184 (define (module-aliases file)
 185   "Return the list of aliases of module FILE."
 186   (let ((info (modinfo-section-contents file)))
 187     (filter-map (match-lambda
 188                  (('alias . value)
 189                   value)
 190                  (_ #f))
 191                 (modinfo-section-contents file))))
 192
 193 (define (strip-extension filename)
 194   (let ((extension (string-index filename #\.)))
 195     (if extension
 196         (string-take filename extension)
 197         filename)))
 198
 199 (define (dot-ko name compression)
 200   (let ((suffix (match compression
 201                   ('xz   ".ko.xz")
 202                   ('gzip ".ko.gz")
 203                   (else  ".ko"))))
 204     (string-append name suffix)))
 205
 206 (define (ensure-dot-ko name compression)
 207   "Return NAME with a '.ko[.gz|.xz]' suffix appended, unless it already has
 208 it."
 209   (if (string-contains name ".ko")
 210       name
 211       (dot-ko name compression)))
 212
 213 (define (normalize-module-name module)
 214   "Return the \"canonical\" name for MODULE, replacing hyphens with
 215 underscores."
 216   ;; See 'modname_normalize' in libkmod.
 217   (string-map (lambda (chr)
 218                 (case chr
 219                   ((#\-) #\_)
 220                   (else chr)))
 221               module))
 222
 223 (define (file-name->module-name file)
 224   "Return the module name corresponding to FILE, stripping the trailing
 225 '.ko[.gz|.xz]' and normalizing it."
 226   (normalize-module-name (strip-extension (basename file))))
 227
 228 (define (find-module-file directory module)
 229   "Lookup module NAME under DIRECTORY, and return its absolute file name.
 230 NAME can be a file name with or without '.ko', or it can be a module name.
 231 Raise an error if it could not be found.
 232
 233 Module names can differ from file names in interesting ways; for instance,
 234 module names usually (always?) use underscores as the inter-word separator,
 235 whereas file names often, but not always, use hyphens.  Examples:
 236 \"usb-storage.ko\", \"serpent_generic.ko\"."
 237   (define names
 238     ;; List of possible file names.  XXX: It would of course be cleaner to
 239     ;; have a database that maps module names to file names and vice versa,
 240     ;; but everyone seems to be doing hacks like this one.  Oh well!
 241     (delete-duplicates
 242      (list module
 243            (normalize-module-name module)
 244            (string-map (lambda (chr) ;converse of 'normalize-module-name'
 245                          (case chr
 246                            ((#\_) #\-)
 247                            (else chr)))
 248                        module))))
 249
 250   (match (find-files directory
 251                      (lambda (file stat)
 252                        (member (strip-extension
 253                                 (basename file)) names)))
 254     ((file)
 255      file)
 256     (()
 257      (error "kernel module not found" module directory))
 258     ((_ ...)
 259      (error "several modules by that name" module directory))))
 260
 261 (define* (recursive-module-dependencies files
 262                                         #:key (lookup-module dot-ko))
 263   "Return the topologically-sorted list of file names of the modules depended
 264 on by FILES, recursively.  File names of modules are determined by applying
 265 LOOKUP-MODULE to the module name."
 266   (let loop ((files   files)
 267              (result  '())
 268              (visited vlist-null))
 269     (match files
 270       (()
 271        (delete-duplicates (reverse result)))
 272       ((head . tail)
 273        (let* ((visited? (vhash-assoc head visited))
 274               (deps     (if visited?
 275                             '()
 276                             (map lookup-module (module-dependencies head))))
 277               (visited  (if visited?
 278                             visited
 279                             (vhash-cons head #t visited))))
 280          (loop (append deps tail)
 281                (append result deps) visited))))))
 282
 283 (define %not-newline
 284   (char-set-complement (char-set #\newline)))
 285
 286 (define (modules-loaded)
 287   "Return the list of names of currently loaded Linux modules."
 288   (let* ((contents (call-with-input-file "/proc/modules"
 289                      get-string-all))
 290          (lines    (string-tokenize contents %not-newline)))
 291     (match (map string-tokenize lines)
 292       (((modules . _) ...)
 293        modules))))
 294
 295 (define (module-black-list)
 296   "Return the black list of modules that must not be loaded.  This black list
 297 is specified using 'modprobe.blacklist=MODULE1,MODULE2,...' on the kernel
 298 command line; it is honored by libkmod for users that pass
 299 'KMOD_PROBE_APPLY_BLACKLIST', which includes 'modprobe --use-blacklist' and
 300 udev."
 301   (define parameter
 302     "modprobe.blacklist=")
 303
 304   (let ((command (call-with-input-file "/proc/cmdline"
 305                    get-string-all)))
 306     (append-map (lambda (arg)
 307                   (if (string-prefix? parameter arg)
 308                       (string-tokenize (string-drop arg (string-length parameter))
 309                                        %not-comma)
 310                       '()))
 311                 (string-tokenize command))))
 312
 313 (define (module-loaded? module)
 314   "Return #t if MODULE is already loaded.  MODULE must be a Linux module name,
 315 not a file name."
 316   (member module (modules-loaded)))
 317
 318 (define* (load-linux-module* file
 319                              #:key
 320                              (recursive? #t)
 321                              (lookup-module dot-ko)
 322                              (black-list (module-black-list)))
 323   "Load Linux module from FILE, the name of a '.ko[.gz|.xz]' file; return true
 324 on success, false otherwise.  When RECURSIVE? is true, load its dependencies
 325 first (à la 'modprobe'.)  The actual files containing modules depended on are
 326 obtained by calling LOOKUP-MODULE with the module name.  Modules whose name
 327 appears in BLACK-LIST are not loaded."
 328   (define (black-listed? module)
 329     (let ((result (member module black-list)))
 330       (when result
 331         (format (current-module-debugging-port)
 332                 "not loading module '~a' because it's black-listed~%"
 333                 module))
 334       result))
 335
 336   (define (load-dependencies file)
 337     (let ((dependencies (module-dependencies file)))
 338       (every (cut load-linux-module* <>
 339                   #:lookup-module lookup-module
 340                   #:black-list black-list)
 341              (map lookup-module dependencies))))
 342
 343   (and (not (black-listed? (file-name->module-name file)))
 344        (or (not recursive?)
 345            (load-dependencies file))
 346        (let ((fd #f))
 347          (format (current-module-debugging-port)
 348                  "loading Linux module from '~a'...~%" file)
 349
 350          (catch 'system-error
 351            (lambda ()
 352              (set! fd (open-fdes file O_RDONLY))
 353              (load-linux-module/fd fd)
 354              (close-fdes fd)
 355              #t)
 356            (lambda args
 357              (when fd (close-fdes fd))
 358              (let ((errno (system-error-errno args)))
 359                (or (and recursive?      ; we're operating in ‘modprobe’ style
 360                         (member errno
 361                                 (list EEXIST    ; already loaded
 362                                       EINVAL))) ; unsupported by hardware
 363                    (apply throw args))))))))
 364
 365 (define (load-linux-modules-from-directory modules directory)
 366   "Load MODULES and their dependencies from DIRECTORY, a directory containing
 367 the '.ko' files.  The '.ko' suffix is automatically added to MODULES if
 368 needed."
 369   (define module-name->file-name
 370     (module-name-lookup directory))
 371
 372   (for-each (lambda (module)
 373               (load-linux-module* (module-name->file-name module)
 374                                   #:lookup-module module-name->file-name))
 375             modules))
 376
 377 \f
 378 ;;;
 379 ;;; Device modules.
 380 ;;;
 381
 382 ;; Copied from (guix utils).  FIXME: Factorize.
 383 (define (readlink* file)
 384   "Call 'readlink' until the result is not a symlink."
 385   (define %max-symlink-depth 50)
 386
 387   (let loop ((file  file)
 388              (depth 0))
 389     (define (absolute target)
 390       (if (absolute-file-name? target)
 391           target
 392           (string-append (dirname file) "/" target)))
 393
 394     (if (>= depth %max-symlink-depth)
 395         file
 396         (call-with-values
 397             (lambda ()
 398               (catch 'system-error
 399                 (lambda ()
 400                   (values #t (readlink file)))
 401                 (lambda args
 402                   (let ((errno (system-error-errno args)))
 403                     (if (or (= errno EINVAL))
 404                         (values #f file)
 405                         (apply throw args))))))
 406           (lambda (success? target)
 407             (if success?
 408                 (loop (absolute target) (+ depth 1))
 409                 file))))))
 410
 411 ;; See 'major' and 'minor' in <sys/sysmacros.h>.
 412
 413 (define (stat->device-major st)
 414   (ash (logand #xfff00 (stat:rdev st)) -8))
 415
 416 (define (stat->device-minor st)
 417   (logand #xff (stat:rdev st)))
 418
 419 (define %not-slash
 420   (char-set-complement (char-set #\/)))
 421
 422 (define (read-uevent port)
 423   "Read a /sys 'uevent' file from PORT and return an alist where each car is a
 424 key such as 'MAJOR or 'DEVTYPE and each cdr is the corresponding value."
 425   (let loop ((result '()))
 426     (match (read-line port)
 427       ((? eof-object?)
 428        (reverse result))
 429       (line
 430        (loop (cons (key=value->pair line) result))))))
 431
 432 (define (device-module-aliases device)
 433   "Return the list of module aliases required by DEVICE, a /dev file name, as
 434 in this example:
 435
 436   (device-module-aliases \"/dev/sda\")
 437   => (\"scsi:t-0x00\" \"pci:v00008086d00009D03sv0000103Csd000080FAbc01sc06i01\")
 438
 439 The modules corresponding to these aliases can then be found using
 440 'matching-modules'."
 441   ;; The approach is adapted from
 442   ;; <https://unix.stackexchange.com/questions/97676/how-to-find-the-driver-module-associated-with-a-device-on-linux>.
 443   (let* ((st        (stat device))
 444          (type      (stat:type st))
 445          (major     (stat->device-major st))
 446          (minor     (stat->device-minor st))
 447          (sys-name  (string-append "/sys/dev/"
 448                                    (case type
 449                                      ((block-special) "block")
 450                                      ((char-special)  "char")
 451                                      (else (symbol->string type)))
 452                                    "/" (number->string major) ":"
 453                                    (number->string minor)))
 454          (directory (canonicalize-path (readlink* sys-name))))
 455     (let loop ((components (string-tokenize directory %not-slash))
 456                (aliases    '()))
 457       (match components
 458         (("sys" "devices" _)
 459          (reverse aliases))
 460         ((head ... _)
 461          (let ((uevent (string-append (string-join components "/" 'prefix)
 462                                       "/uevent")))
 463            (if (file-exists? uevent)
 464                (let ((props (call-with-input-file uevent read-uevent)))
 465                  (match (assq-ref props 'MODALIAS)
 466                    (#f    (loop head aliases))
 467                    (alias (loop head (cons alias aliases)))))
 468                (loop head aliases))))))))
 469
 470 (define (read-module-aliases port)
 471   "Read from PORT data in the Linux 'modules.alias' file format.  Return a
 472 list of alias/module pairs where each alias is a glob pattern as like the
 473 result of:
 474
 475   (string->compiled-sglob \"scsi:t-0x01*\")
 476
 477 and each module is a module name like \"snd_hda_intel\"."
 478   (define (comment? str)
 479     (string-prefix? "#" str))
 480
 481   (define (tokenize str)
 482     ;; Lines have the form "alias ALIAS MODULE", where ALIAS can contain
 483     ;; whitespace.  This is why we don't use 'string-tokenize'.
 484     (let* ((str   (string-trim-both str))
 485            (left  (string-index str #\space))
 486            (right (string-rindex str #\space)))
 487       (list (string-take str left)
 488             (string-trim-both (substring str left right))
 489             (string-trim-both (string-drop str right)))))
 490
 491   (let loop ((aliases '()))
 492     (match (read-line port)
 493       ((? eof-object?)
 494        (reverse aliases))
 495       ((? comment?)
 496        (loop aliases))
 497       (line
 498        (match (tokenize line)
 499          (("alias" alias module)
 500           (loop (alist-cons (string->compiled-sglob alias) module
 501                             aliases)))
 502          (()                                      ;empty line
 503           (loop aliases)))))))
 504
 505 (define (current-kernel-directory)
 506   "Return the directory of the currently running Linux kernel."
 507   (string-append (or (getenv "LINUX_MODULE_DIRECTORY")
 508                      "/run/booted-system/kernel/lib/modules")
 509                  "/" (utsname:release (uname))))
 510
 511 (define (current-alias-file)
 512   "Return the absolute file name of the default 'modules.alias' file."
 513   (string-append (current-kernel-directory) "/modules.alias"))
 514
 515 (define* (known-module-aliases #:optional (alias-file (current-alias-file)))
 516   "Return the list of alias/module pairs read from ALIAS-FILE.  Each alias is
 517 actually a pattern."
 518   (call-with-input-file alias-file read-module-aliases))
 519
 520 (define* (matching-modules alias
 521                            #:optional (known-aliases (known-module-aliases)))
 522   "Return the list of modules that match ALIAS according to KNOWN-ALIASES.
 523 ALIAS is a string like \"scsi:t-0x00\" as returned by
 524 'device-module-aliases'."
 525   (filter-map (match-lambda
 526                 ((pattern . module)
 527                  (and (glob-match? pattern alias)
 528                       module)))
 529               known-aliases))
 530
 531 (define* (missing-modules device modules-provided)
 532   "Assuming MODULES-PROVIDED lists kernel modules that are already
 533 provided--e.g., in the initrd, return the list of missing kernel modules that
 534 are required to access DEVICE."
 535   (define aliases
 536     ;; Attempt to load 'modules.alias' from the current kernel, assuming we're
 537     ;; on Guix System, and assuming that corresponds to the kernel we'll be
 538     ;; installing.
 539     (known-module-aliases))
 540
 541   (if aliases
 542       (let* ((modules  (delete-duplicates
 543                         (append-map (cut matching-modules <> aliases)
 544                                     (device-module-aliases device))))
 545
 546              ;; Module names (not file names) are supposed to use underscores
 547              ;; instead of hyphens.  MODULES is a list of module names, whereas
 548              ;; LINUX-MODULES is file names without '.ko', so normalize them.
 549              (provided (map file-name->module-name modules-provided)))
 550         (remove (cut member <> provided) modules))
 551       '()))
 552
 553 \f
 554 ;;;
 555 ;;; Module databases.
 556 ;;;
 557
 558 (define* (module-name->file-name/guess directory name
 559                                        #:key compression)
 560   "Guess the file name corresponding to NAME, a module name.  That doesn't
 561 always work because sometimes underscores in NAME map to hyphens (e.g.,
 562 \"input-leds.ko\"), sometimes not (e.g., \"mac_hid.ko\").  If the module is
 563 compressed then COMPRESSED can be set to 'xz or 'gzip, depending on the
 564 compression type."
 565   (string-append directory "/" (ensure-dot-ko name compression)))
 566
 567 (define (module-name-lookup directory)
 568   "Return a one argument procedure that takes a module name (e.g.,
 569 \"input_leds\") and returns its absolute file name (e.g.,
 570 \"/.../input-leds.ko\")."
 571   (define (guess-file-name name)
 572     (let ((names (list
 573                   (module-name->file-name/guess directory name)
 574                   (module-name->file-name/guess directory name
 575                                                 #:compression 'xz)
 576                   (module-name->file-name/guess directory name
 577                                                 #:compression 'gzip))))
 578       (or (find file-exists? names)
 579           (first names))))
 580
 581   (catch 'system-error
 582     (lambda ()
 583       (define mapping
 584         (call-with-input-file (string-append directory "/modules.name")
 585           read))
 586
 587       (lambda (name)
 588         (or (assoc-ref mapping name)
 589             (guess-file-name name))))
 590     (lambda args
 591       (if (= ENOENT (system-error-errno args))
 592           (cut guess-file-name <>)
 593           (apply throw args)))))
 594
 595 (define (write-module-name-database directory)
 596   "Write a database that maps \"module names\" as they appear in the relevant
 597 ELF section of '.ko[.gz|.xz]' files, to actual file names.  This format is
 598 Guix-specific.  It aims to deal with inconsistent naming, in particular
 599 hyphens vs. underscores."
 600   (define mapping
 601     (map (lambda (file)
 602            (match (module-formal-name file)
 603              (#f   (cons (strip-extension (basename file)) file))
 604              (name (cons name file))))
 605          (find-files directory module-regex)))
 606
 607   (call-with-output-file (string-append directory "/modules.name")
 608     (lambda (port)
 609       (display ";; Module name to file name mapping.
 610 ;;
 611 ;; This format is Guix-specific; it is not supported by upstream Linux tools.
 612 \n"
 613                port)
 614       (pretty-print mapping port))))
 615
 616 (define (write-module-alias-database directory)
 617   "Traverse the '.ko[.gz|.xz]' files in DIRECTORY and create the corresponding
 618 'modules.alias' file."
 619   (define aliases
 620     (map (lambda (file)
 621            (cons (file-name->module-name file) (module-aliases file)))
 622          (find-files directory module-regex)))
 623
 624   (call-with-output-file (string-append directory "/modules.alias")
 625     (lambda (port)
 626       (display "# Aliases extracted from modules themselves.\n" port)
 627       (for-each (match-lambda
 628                   ((module . aliases)
 629                    (for-each (lambda (alias)
 630                                (format port "alias ~a ~a\n" alias module))
 631                              aliases)))
 632                 aliases))))
 633
 634 (define (aliases->device-tuple aliases)
 635   "Traverse ALIASES, a list of module aliases, and search for
 636 \"char-major-M-N\", \"block-major-M-N\", or \"devname:\" aliases.  When they
 637 are found, return a tuple (DEVNAME TYPE MAJOR MINOR), otherwise return #f."
 638   (define (char/block-major? alias)
 639     (or (string-prefix? "char-major-" alias)
 640         (string-prefix? "block-major-" alias)))
 641
 642   (define (char/block-major->tuple alias)
 643     (match (string-tokenize alias %not-dash)
 644       ((type "major" (= string->number major) (= string->number minor))
 645        (list (match type
 646                ("char" "c")
 647                ("block" "b"))
 648              major minor))))
 649
 650   (let* ((devname     (any (lambda (alias)
 651                              (and (string-prefix? "devname:" alias)
 652                                   (string-drop alias 8)))
 653                            aliases))
 654          (major/minor (match (find char/block-major? aliases)
 655                         (#f #f)
 656                         (str (char/block-major->tuple str)))))
 657     (and devname major/minor
 658          (cons devname major/minor))))
 659
 660 (define %not-dash
 661   (char-set-complement (char-set #\-)))
 662
 663 (define (write-module-device-database directory)
 664   "Traverse the '.ko[.gz|.xz]' files in DIRECTORY and create the corresponding
 665 'modules.devname' file.  This file contains information about modules that can
 666 be loaded on-demand, such as file system modules."
 667   (define aliases
 668     (filter-map (lambda (file)
 669                   (match (aliases->device-tuple (module-aliases file))
 670                     (#f #f)
 671                     (tuple (cons (file-name->module-name file) tuple))))
 672                 (find-files directory module-regex)))
 673
 674   (call-with-output-file (string-append directory "/modules.devname")
 675     (lambda (port)
 676       (display "# Device nodes to trigger on-demand module loading.\n" port)
 677       (for-each (match-lambda
 678                   ((module devname type major minor)
 679                    (format port "~a ~a ~a~a:~a~%"
 680                            module devname type major minor)))
 681                 aliases))))
 682
 683 (define (depmod version directory)
 684   "Given an (existing) DIRECTORY, invoke depmod on it for
 685 kernel version VERSION."
 686   (let ((destination-directory (string-append directory "/lib/modules/"
 687                                               version))
 688         ;; Note: "System.map" is an input file.
 689         (maps-file (string-append directory "/System.map"))
 690         ;; Note: "Module.symvers" is an input file.
 691         (symvers-file (string-append directory "/Module.symvers")))
 692     ;; These files will be regenerated by depmod below.
 693     (for-each (lambda (basename)
 694                 (when (and (string-prefix? "modules." basename)
 695                            ;; Note: "modules.builtin" is an input file.
 696                            (not (string=? "modules.builtin" basename))
 697                            ;; Note: "modules.order" is an input file.
 698                            (not (string=? "modules.order" basename)))
 699                   (delete-file (string-append destination-directory "/"
 700                                               basename))))
 701               (scandir destination-directory))
 702     (invoke "depmod"
 703             "-e" ; Report symbols that aren't supplied
 704             ;"-w" ; Warn on duplicates
 705             "-b" directory
 706             "-F" maps-file
 707             ;"-E" symvers-file ; using both "-E" and "-F" is not possible.
 708             version)))
 709
 710 (define (make-linux-module-directory inputs version output)
 711   "Create a new directory OUTPUT and ensure that the directory
 712 OUTPUT/lib/modules/VERSION can be used as a source of Linux
 713 kernel modules for the first kmod in PATH now to eventually
 714 load.  Take modules to put into OUTPUT from INPUTS.
 715
 716 Right now that means it creates @code{modules.*.bin} which
 717 @command{modprobe} will use to find loadable modules."
 718   (union-build output inputs #:create-all-directories? #t)
 719   (depmod version output))
 720
 721 ;;; linux-modules.scm ends here