Merge remote-tracking branch 'origin/master' into core-updates

 Conflicts:
	doc/guix.texi
	gnu/local.mk
	gnu/packages/admin.scm
	gnu/packages/base.scm
	gnu/packages/chromium.scm
	gnu/packages/compression.scm
	gnu/packages/databases.scm
	gnu/packages/diffoscope.scm
	gnu/packages/freedesktop.scm
	gnu/packages/gnome.scm
	gnu/packages/gnupg.scm
	gnu/packages/guile.scm
	gnu/packages/inkscape.scm
	gnu/packages/llvm.scm
	gnu/packages/openldap.scm
	gnu/packages/pciutils.scm
	gnu/packages/ruby.scm
	gnu/packages/samba.scm
	gnu/packages/sqlite.scm
	gnu/packages/statistics.scm
	gnu/packages/syndication.scm
	gnu/packages/tex.scm
	gnu/packages/tls.scm
	gnu/packages/version-control.scm
	gnu/packages/xml.scm
	guix/build-system/copy.scm
	guix/scripts/home.scm

1 files changed, 134 insertions, 1 deletions

diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm
index 053720574b..3b1f512663 100644
--- a/gnu/build/linux-modules.scm
+++ b/gnu/build/linux-modules.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2016, 2018, 2019, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org>
 ;;;
@@ -28,6 +28,7 @@
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 ftw)
@@ -50,6 +51,17 @@
             load-linux-module*
             load-linux-modules-from-directory
 
+            pci-devices
+            pci-device?
+            pci-device-vendor
+            pci-device-id
+            pci-device-class
+            pci-device-module-alias
+            storage-pci-device?
+            network-pci-device?
+            display-pci-device?
+            load-pci-device-database
+
             current-module-debugging-port
 
             device-module-aliases
@@ -429,6 +441,127 @@ key such as 'MAJOR or 'DEVTYPE and each cdr is the corresponding value."
       (line
        (loop (cons (key=value->pair line) result))))))
 
+;; PCI device known to the Linux kernel.
+(define-immutable-record-type <pci-device>
+  (pci-device vendor device class module-alias)
+  pci-device?
+  (vendor       pci-device-vendor)                ;integer
+  (device       pci-device-id)                    ;integer
+  (class        pci-device-class)                 ;integer
+  (module-alias pci-device-module-alias))         ;string | #f
+
+(define (pci-device-class-predicate mask bits)
+  (lambda (device)
+    "Return true if DEVICE has the chosen class."
+    (= (logand mask (pci-device-class device)) bits)))
+
+(define storage-pci-device?                   ;"Mass storage controller" class
+  (pci-device-class-predicate #xff0000 #x010000))
+(define network-pci-device?                       ;"Network controller" class
+  (pci-device-class-predicate #xff0000 #x020000))
+(define display-pci-device?                       ;"Display controller" class
+  (pci-device-class-predicate #xff0000 #x030000))
+
+(define (pci-devices)
+  "Return the list of PCI devices of the system (<pci-device> records)."
+  (define (read-hex port)
+    (let ((line (read-line port)))
+      (and (string? line)
+           (string-prefix? "0x" line)
+           (string->number (string-drop line 2) 16))))
+
+  (filter-map (lambda (directory)
+                (define properties
+                  (call-with-input-file (string-append directory "/uevent")
+                    read-uevent))
+                (define vendor
+                  (call-with-input-file (string-append directory "/vendor")
+                    read-hex))
+                (define device
+                  (call-with-input-file (string-append directory "/device")
+                    read-hex))
+                (define class
+                  (call-with-input-file (string-append directory "/class")
+                    read-hex))
+
+                (pci-device vendor device class
+                            (assq-ref properties 'MODALIAS)))
+              (find-files "/sys/bus/pci/devices"
+                          #:stat lstat)))
+
+(define (read-pci-device-database port)
+  "Parse the 'pci.ids' database that ships with the pciutils package and is
+maintained at <https://pci-ids.ucw.cz/>."
+  (define (comment? str)
+    (string-prefix? "#" (string-trim str)))
+  (define (blank? str)
+    (string-null? (string-trim-both str)))
+  (define (device? str)
+    (eqv? #\tab (string-ref str 0)))
+  (define (subvendor? str)
+    (string-prefix? "\t\t" str))
+  (define (class? str)
+    (string-prefix? "C " str))
+  (define (parse-id-line str)
+    (let* ((str   (string-trim-both str))
+           (space (string-index str char-set:whitespace)))
+      (values (string->number (string-take str space) 16)
+              (string-trim (string-drop str (+ 1 space))))))
+  (define (finish vendor vendor-id devices table)
+    (fold (lambda (device table)
+            (match device
+              ((device-id . name)
+               (vhash-consv (logior (ash vendor-id 16) device-id)
+                            (cons vendor name)
+                            table))))
+          table
+          devices))
+
+  (let loop ((table vlist-null)
+             (vendor-id #f)
+             (vendor #f)
+             (devices '()))
+    (match (read-line port)
+      ((? eof-object?)
+       (let ((table (if (and vendor vendor-id)
+                        (finish vendor vendor-id devices table)
+                        table)))
+         (lambda (vendor device)
+           (match (vhash-assv (logior (ash vendor 16) device) table)
+             (#f
+              (values #f #f))
+             ((_ . (vendor . name))
+              (values vendor name))))))
+      ((? comment?)
+       (loop table vendor-id vendor devices))
+      ((? blank?)
+       (loop table vendor-id vendor devices))
+      ((? subvendor?)                             ;currently ignored
+       (loop table vendor-id vendor devices))
+      ((? class?)                                 ;currently ignored
+       (loop table vendor-id vendor devices))
+      ((? device? line)
+       (let-values (((id name) (parse-id-line line)))
+         (loop table vendor-id vendor
+               (if (and vendor-id vendor)         ;class or device?
+                   (alist-cons id name devices)
+                   devices))))
+      (line
+       (let ((table (if (and vendor vendor-id)
+                        (finish vendor vendor-id devices table)
+                        table)))
+         (let-values (((vendor-id vendor) (parse-id-line line)))
+           (loop table vendor-id vendor '())))))))
+
+(define (load-pci-device-database file)
+  "Read the 'pci.ids' database at FILE (get it from the pciutils package or
+from <https://pci-ids.ucw.cz/>) and return a lookup procedure that takes a PCI
+vendor ID and a device ID (two integers) and returns the vendor name and
+device name as two values."
+  (let ((port (open-file file "r0")))
+    (call-with-gzip-input-port port
+      read-pci-device-database)))
+
 (define (device-module-aliases device)
   "Return the list of module aliases required by DEVICE, a /dev file name, as
 in this example: