cve: Add cpe-vendor and lint-hidden-cpe-vendors properties.

* guix/cve.scm: Exploit cpe vendors information.
(cpe->package-name): Rename to...
(cpe->package-identifier): Renamed from cpe->package-name. Use
cpe_vendor:cpe_name in place or cpe_name.
(vulnerabily-matches?): 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.
(write-cache, fetch-vulnerabilities): Update the format version.

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

* tests/cve.scm (%expected-vulnerabilities): Adapt variable to changes
in guix/cve.scm.

Signed-off-by: Zheng Junjie <z572@z572.online>

3 files changed, 115 insertions, 71 deletions

diff --git a/guix/cve.scm b/guix/cve.scm
index 9e1cf5b587..6a6d8406bf 100644
--- a/guix/cve.scm
+++ b/guix/cve.scm
@@ -25,11 +25,11 @@
   #:use-module (web uri)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-71)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 vlist)
@@ -108,15 +108,16 @@
   ;; "cpe:2.3:a:VENDOR:PACKAGE:VERSION:PATCH-LEVEL".
   (make-regexp "^cpe:2\\.3:a:([^:]+):([^:]+):([^:]+):([^:]+):"))
 
-(define (cpe->package-name cpe)
+(define (cpe->package-identifier 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."
+identifier, in a very naive way.  Return three values: the CPE vendor, the
+package name, and its version string.
+Return three #f values if CPE does not look like an application CPE string."
   (cond ((regexp-exec %cpe-package-rx cpe)
          =>
          (lambda (matches)
-           (values (match:substring matches 2)
+           (values (match:substring matches 1)
+                   (match:substring matches 2)
                    (match (match:substring matches 3)
                      ("*" '_)
                      (version
@@ -128,7 +129,7 @@ string."
                                         ;; "cpe:2.3:a:openbsd:openssh:6.8:p1".
                                         (string-drop patch-level 1)))))))))
         (else
-         (values #f #f))))
+         (values #f #f #f))))
 
 (define (cpe-match->cve-configuration alist)
   "Convert ALIST, a \"cpe_match\" alist, into an sexp representing the package
@@ -142,17 +143,18 @@ package."
     ;; 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 ((vendor package version (cpe->package-identifier cpe)))
            (and package
-                `(,package
-                   ,(cond ((and (or starti starte) (or endi ende))
-                           `(and ,(if starti `(>= ,starti) `(> ,starte))
-                                 ,(if endi `(<= ,endi) `(< ,ende))))
-                          (starti `(>= ,starti))
-                          (starte `(> ,starte))
-                          (endi   `(<= ,endi))
-                          (ende   `(< ,ende))
-                          (else   version))))))))
+                `(,vendor
+                  ,package
+                  ,(cond ((and (or starti starte) (or endi ende))
+                          `(and ,(if starti `(>= ,starti) `(> ,starte))
+                                ,(if endi `(<= ,endi) `(< ,ende))))
+                         (starti `(>= ,starti))
+                         (starte `(> ,starte))
+                         (endi   `(<= ,endi))
+                         (ende   `(< ,ende))
+                         (else   version))))))))
 
 (define (configuration-data->cve-configurations alist)
   "Given ALIST, a JSON dictionary for the baroque \"configurations\"
@@ -228,6 +230,30 @@ records."
     (('>= min)
      (version>=? version min))))
 
+(define (vulnerability-matches? vuln vendor hidden-vendors)
+  "Checks if a VENDOR matches at least one of <vulnerability> VULN
+packages.  When VENDOR is #f, ignore packages that have a vendor among
+HIDDEN-VENDORS."
+  (define hidden-vendor?
+    (if (list? hidden-vendors)
+        (cut member <> hidden-vendors)
+        (const #f)))
+  (define vendor=?
+    (if vendor
+        (cut string=? <> vendor)
+        (const #f)))
+
+  (match vuln
+    (($ <vulnerability> id packages)
+     (any (match-lambda
+            ((? vendor=?)
+             #t)
+            ((? hidden-vendor?)
+             #f)
+            (otherwise
+             (not vendor)))
+          (map car packages)))))  ;candidate vendors
+
 
 ;;;
 ;;; High-level interface.
@@ -259,7 +285,7 @@ records."
   (vulnerability id packages)
   vulnerability?
   (id         vulnerability-id)             ;string
-  (packages   vulnerability-packages))      ;((p1 sexp1) (p2 sexp2) ...)
+  (packages   vulnerability-packages))      ;((v1 p1 sexp1) (v2 p2 sexp2) ...)
 
 (define vulnerability->sexp
   (match-lambda
@@ -271,40 +297,52 @@ records."
     (('v id (packages ...))
      (vulnerability id packages))))
 
+(define sexp-v1->vulnerability
+  (match-lambda
+    (('v id (packages ...))
+     (vulnerability id (map (cut cons #f <>) packages)))))
+
+(define vendor-tuple?
+  (match-lambda
+    ((vendor package _)
+     #t)
+    (otherwise
+     #f)))
+
 (define (cve-configuration->package-list config)
-  "Parse CONFIG, a config sexp, and return a list of the form (P SEXP)
-where P is a package name and SEXP expresses constraints on the matching
-versions."
+  "Parse CONFIG, a config sexp, and return a list of the form (V P SEXP)
+where V is a CPE vendor, P is a package name and SEXP expresses constraints on
+the matching versions."
   (let loop ((config config)
-             (packages '()))
+             (results '()))
     (match config
       (('or configs ...)
-       (fold loop packages configs))
-      (('and config _ ...)                        ;XXX
-       (loop config packages))
-      (((? string? package) '_)                   ;any version
-       (cons `(,package _)
-             (alist-delete package packages)))
-      (((? string? package) sexp)
-       (let ((previous (assoc-ref packages package)))
-         (if previous
-             (cons `(,package (or ,sexp ,@previous))
-                   (alist-delete package packages))
-             (cons `(,package ,sexp) packages)))))))
+       (fold loop results configs))
+      (('and config _ ...)                            ;XXX
+       (loop config results))
+      (((? string? vendor) (? string? package) '_)  ;any version
+       (cons `(,vendor ,package _) (remove vendor-tuple? results)))
+      (((? string? vendor) (? string? package) sexp)
+       (match (assoc-ref (assoc-ref results vendor) package)
+         ((previous)
+          (cons `(,vendor ,package (or ,sexp ,previous))
+                (remove vendor-tuple? results)))
+         (_
+          (cons `(,vendor ,package ,sexp) results)))))))
 
 (define (merge-package-lists lst)
-  "Merge the list in LST, each of which has the form (p sexp), where P
-is the name of a package and SEXP is an sexp that constrains matching
-versions."
+  "Merge the list in LST, each of which has the form (V P SEXP), where V is a
+CPE vendor, P is the name of a package and SEXP is an sexp that constrains
+matching versions."
   (fold (lambda (plist result)                    ;XXX: quadratic
           (fold (match-lambda*
-                  (((package version) result)
-                   (match (assoc-ref result package)
-                     (#f
-                      (cons `(,package ,version) result))
-                     ((previous)
-                      (cons `(,package (or ,version ,previous))
-                            (alist-delete package result))))))
+                  (((vendor package version) result)
+                   (match (assoc-ref result vendor)
+                     (((? (cut string=? package <>)) previous)
+                      (cons `(,vendor ,package (or ,version ,previous))
+                            (remove vendor-tuple? result)))
+                     (_
+                      (cons `(,vendor ,package ,version) result)))))
                 result
                 plist))
         '()
@@ -337,7 +375,7 @@ sexp to CACHE."
         (json->vulnerabilities input))
 
       (write `(vulnerabilities
-               1                                  ;format version
+               2                                  ;format version
                ,(map vulnerability->sexp vulns))
              cache))))
 
@@ -371,8 +409,10 @@ the given TTL (fetch from the NIST web site when TTL has expired)."
          (sexp (read* port)))
     (close-port port)
     (match sexp
-      (('vulnerabilities 1 vulns)
-       (map sexp->vulnerability vulns)))))
+      (('vulnerabilities 2 vulns)
+       (map sexp->vulnerability vulns))
+      (('vulnerabilities 1 vulns)  ;old format, lacks vendor info
+       (map sexp-v1->vulnerability vulns)))))
 
 (define* (current-vulnerabilities #:key (timeout 10))
   "Return the current list of Common Vulnerabilities and Exposures (CVE) as
@@ -404,7 +444,7 @@ vulnerabilities affecting the given package version."
               (($ <vulnerability> id packages)
                (fold (lambda (package table)
                        (match package
-                         ((name . versions)
+                         ((vendor name . versions)
                           (vhash-cons name (cons vuln versions)
                                       table))))
                      table
@@ -412,20 +452,18 @@ vulnerabilities affecting the given package version."
           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 #:optional version #:key (vendor #f) (hidden-vendors '()))
+    (vhash-fold*
+     (lambda (pair result)
+       (match pair
+         ((vuln sexp)
+          (if (and (or (and (not vendor) (null? hidden-vendors))
+                       (vulnerability-matches? vuln vendor hidden-vendors))
+                   (or (not 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 d4d08f7af4..deea25c5ce 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1595,8 +1595,14 @@ CVE vulnerabilities from '~a': ~a (~a)~%")
                          (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
+         #: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..90ada2b647 100644
--- a/tests/cve.scm
+++ b/tests/cve.scm
@@ -34,19 +34,19 @@
    (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.2" (or "18.21-s3" "18.21-s4")))))
    (vulnerability "CVE-2019-0005"
-                  '(("junos" (or "18.11" "18.1"))))
+                  '(("juniper" "junos" (or "18.1" "18.11"))))
    ;; 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.
    ))