[bug#74034] [PATCH v2 01/16] guix: cve: Add cpe-vendor and lint-hidden-cpe-vendors properties.

[Nicolas Graves]

* guix/cve.scm: Exploit cpe vendors information.
(cpe->package-name): Rename to cpe->package and use
cpe_vendor:cpe_name in place or cpe_name.
(filter-vendors): Add helper function.
(vulnerabilities->lookup-proc): Extract cpe_name for table
hashes. Add vendor and hidden-vendor arguments. Adapt condition to
pass vulnerabilities to result in the fold.

* guix/lint.scm (package-vulnerabilities): Use additional arguments
from vulnerabilities->lookup-proc.

* tests/cve.scm: Adapt tests.
---
 guix/cve.scm  | 71 +++++++++++++++++++++++++++++++++------------------
 guix/lint.scm | 11 ++++++--
 tests/cve.scm | 30 +++++++++++-----------
 3 files changed, 70 insertions(+), 42 deletions(-)

diff --git a/guix/cve.scm b/guix/cve.scm
index 9e1cf5b587..a2335f15ef 100644
--- a/guix/cve.scm
+++ b/guix/cve.scm
@@ -106,22 +106,22 @@ (define (reference-data->cve-references alist)
 (define %cpe-package-rx
   ;; For applications: "cpe:2.3:a:VENDOR:PACKAGE:VERSION", or sometimes
   ;; "cpe:2.3:a:VENDOR:PACKAGE:VERSION:PATCH-LEVEL".
-  (make-regexp "^cpe:2\\.3:a:([^:]+):([^:]+):([^:]+):([^:]+):"))
+  (make-regexp "^cpe:2\\.3:a:([^:]+:[^:]+):([^:]+):([^:]+):"))
 
-(define (cpe->package-name cpe)
+(define (cpe->package cpe)
   "Converts the Common Platform Enumeration (CPE) string CPE to a package
-name, in a very naive way.  Return two values: the package name, and its
-version string.  Return #f and #f if CPE does not look like an application CPE
-string."
+name, in a very naive way.  Return two values: the package identifier
+(composed from the CPE vendor and the package name), and its version string.
+Return #f and #f if CPE does not look like an application CPE string."
   (cond ((regexp-exec %cpe-package-rx cpe)
          =>
          (lambda (matches)
-           (values (match:substring matches 2)
-                   (match (match:substring matches 3)
+           (values (match:substring matches 1)
+                   (match (match:substring matches 2)
                      ("*" '_)
                      (version
                       (string-append version
-                                     (match (match:substring matches 4)
+                                     (match (match:substring matches 3)
                                        ("" "")
                                        (patch-level
                                         ;; Drop the colon from things like
@@ -142,7 +142,7 @@ (define (cpe-match->cve-configuration alist)
     ;; Normally "cpe23Uri" is here in each "cpe_match" item, but CVE-2020-0534
     ;; has a configuration that lacks it.
     (and cpe
-         (let-values (((package version) (cpe->package-name cpe)))
+         (let-values (((package version) (cpe->package cpe)))
            (and package
                 `(,package
                    ,(cond ((and (or starti starte) (or endi ende))
@@ -228,6 +228,24 @@ (define (version-matches? version sexp)
     (('>= min)
      (version>=? version min))))
 
+(define (filter-vendors vuln vendor hidden-vendors)
+
+  (define (vendor-matches? vendor+name)
+    (if vendor
+        (string-prefix? (string-append vendor ":") vendor+name)
+        (if hidden-vendors
+            (not (any (lambda (v)
+                        (string-prefix? (string-append v ":") vendor+name))
+                      hidden-vendors))
+            #t)))
+
+  (match vuln
+    (($ <vulnerability> id packages)
+     (any (match-lambda
+            (((? vendor-matches? vendor+name) . _)  #t)
+            (_                                      #f))
+          packages))))
+
 
 ;;;
 ;;; High-level interface.
@@ -404,28 +422,31 @@ (define table
               (($ <vulnerability> id packages)
                (fold (lambda (package table)
                        (match package
-                         ((name . versions)
-                          (vhash-cons name (cons vuln versions)
+                         ((vendor+name . versions)
+                          (vhash-cons (match (string-split vendor+name #\:)
+                                        ((vendor name) name)
+                                        ((name)        name))
+                                      (cons vuln versions)
                                       table))))
                      table
                      packages))))
           vlist-null
           vulnerabilities))
 
-  (lambda* (package #:optional version)
-    (vhash-fold* (if version
-                     (lambda (pair result)
-                       (match pair
-                         ((vuln sexp)
-                          (if (version-matches? version sexp)
-                              (cons vuln result)
-                              result))))
-                     (lambda (pair result)
-                       (match pair
-                         ((vuln . _)
-                          (cons vuln result)))))
-                 '()
-                 package table)))
+  (lambda* (package #:key (version #f) (vendor #f) (hidden-vendors #f))
+    (vhash-fold*
+     (lambda (pair result)
+       (match pair
+         ((vuln sexp)
+          (if (and (or (not (or vendor hidden-vendors))
+                       (and (or vendor hidden-vendors)
+                            (filter-vendors vuln vendor hidden-vendors)))
+                   (or (not version)
+                       (and version (version-matches? version sexp))))
+              (cons vuln result)
+              result))))
+     '()
+     package table)))
 
 
 ;;; cve.scm ends here
diff --git a/guix/lint.scm b/guix/lint.scm
index 8c6c20c723..db3f59e3ec 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1551,8 +1551,15 @@ (define package-vulnerabilities
                          (package-name package)))
             (version (or (assoc-ref (package-properties package)
                                     'cpe-version)
-                         (package-version package))))
-        ((force lookup) name version)))))
+                         (package-version package)))
+            (vendor (assoc-ref (package-properties package)
+                               'cpe-vendor))
+            (hidden-vendors (assoc-ref (package-properties package)
+                                       'lint-hidden-cpe-vendors)))
+        ((force lookup) name
+         #:version version
+         #:vendor vendor
+         #:hidden-vendors hidden-vendors)))))
 
 ;; Prevent Guile 3 from inlining this procedure so we can mock it in tests.
 (set! package-vulnerabilities package-vulnerabilities)
diff --git a/tests/cve.scm b/tests/cve.scm
index b69da0e120..0b6346a4d4 100644
--- a/tests/cve.scm
+++ b/tests/cve.scm
@@ -34,19 +34,19 @@ (define %expected-vulnerabilities
    (vulnerability "CVE-2019-0001"
                   ;; Only the "a" CPE configurations are kept; the "o"
                   ;; configurations are discarded.
-                  '(("junos" (or "18.21-s4" (or "18.21-s3" "18.2")))))
+                  '(("juniper:junos" (or "18.21-s4" (or "18.21-s3" "18.2")))))
    (vulnerability "CVE-2019-0005"
-                  '(("junos" (or "18.11" "18.1"))))
+                  '(("juniper:junos" (or "18.11" "18.1"))))
    ;; CVE-2019-0005 has no "a" configurations.
    (vulnerability "CVE-2019-14811"
-                  '(("ghostscript" (< "9.28"))))
+                  '(("artifex:ghostscript" (< "9.28"))))
    (vulnerability "CVE-2019-17365"
-                  '(("nix" (<= "2.3"))))
+                  '(("nixos:nix" (<= "2.3"))))
    (vulnerability "CVE-2019-1010180"
-                  '(("gdb" _)))                   ;any version
+                  '(("gnu:gdb" _)))                   ;any version
    (vulnerability "CVE-2019-1010204"
-                  '(("binutils" (and (>= "2.21") (<= "2.31.1")))
-                    ("binutils_gold" (and (>= "1.11") (<= "1.16")))))
+                  '(("gnu:binutils" (and (>= "2.21") (<= "2.31.1")))
+                    ("gnu:binutils_gold" (and (>= "1.11") (<= "1.16")))))
    ;; CVE-2019-18192 has no associated configurations.
    ))
 
@@ -92,15 +92,15 @@ (define %expected-vulnerabilities
   (let* ((vulns  (call-with-input-file %sample json->vulnerabilities))
          (lookup (vulnerabilities->lookup-proc vulns)))
     (list (lookup "ghostscript")
-          (lookup "ghostscript" "9.27")
-          (lookup "ghostscript" "9.28")
+          (lookup "ghostscript" #:version "9.27")
+          (lookup "ghostscript" #:version "9.28")
           (lookup "gdb")
-          (lookup "gdb" "42.0")
+          (lookup "gdb" #:version "42.0")
           (lookup "nix")
-          (lookup "nix" "2.4")
-          (lookup "binutils" "2.31.1")
-          (lookup "binutils" "2.10")
-          (lookup "binutils_gold" "1.11")
-          (lookup "binutils" "2.32"))))
+          (lookup "nix" #:version "2.4")
+          (lookup "binutils" #:version "2.31.1")
+          (lookup "binutils" #:version "2.10")
+          (lookup "binutils_gold" #:version "1.11")
+          (lookup "binutils" #:version "2.32"))))
 
 (test-end "cve")
-- 
2.46.0