[bug#47193] [PATCH 2/2] lint: Indicate CVE severity.

[Tobias Geerinckx-Rice via Guix-patches via <guix-patches@gnu.org>]

* guix/cve.scm <cve-item>[cvss3-base-severity]: New field.
(impact-data->cve-cvss3-base-severity): New procedure.
<vulnerability>[severity]: New field.
(vulnerability->sexp, sexp->vulnerability, cve-item->vulnerability)
(write-cache): Bump the format version to 2.
(vulnerabilities->lookup-proc): Adjust accordingly.
* guix/lint.scm (check-vulnerabilities): Indicate CVE severity according
to the output port's terminal capabilities.
---
 guix/cve.scm  | 48 ++++++++++++++++++++++++++++++++----------------
 guix/lint.scm | 32 +++++++++++++++++++++++++++++++-
 2 files changed, 63 insertions(+), 17 deletions(-)

diff --git a/guix/cve.scm b/guix/cve.scm
index b3a8b13a06..3809e4493f 100644
--- a/guix/cve.scm
+++ b/guix/cve.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -38,6 +39,7 @@
             cve-item?
             cve-item-cve
             cve-item-configurations
+            cve-item-cvssv3-base-severity
             cve-item-published-date
             cve-item-last-modified-date
 
@@ -53,6 +55,7 @@
 
             vulnerability?
             vulnerability-id
+            vulnerability-severity
             vulnerability-packages
 
             json->vulnerabilities
@@ -72,13 +75,15 @@
 
 (define-json-mapping <cve-item> cve-item cve-item?
   json->cve-item
-  (cve            cve-item-cve "cve" json->cve)   ;<cve>
-  (configurations cve-item-configurations         ;list of sexps
-                  "configurations" configuration-data->cve-configurations)
-  (published-date cve-item-published-date
-                  "publishedDate" string->date*)
-  (last-modified-date cve-item-last-modified-date
-                      "lastModifiedDate" string->date*))
+  (cve                  cve-item-cve "cve" json->cve) ;<cve>
+  (configurations       cve-item-configurations       ;list of sexps
+                        "configurations" configuration-data->cve-configurations)
+  (cvssv3-base-severity cve-item-cvssv3-base-severity ;string
+                        "impact" impact-data->cve-cvssv3-base-severity)
+  (published-date       cve-item-published-date
+                        "publishedDate" string->date*)
+  (last-modified-date   cve-item-last-modified-date
+                        "lastModifiedDate" string->date*))
 
 (define-json-mapping <cve> cve cve?
   json->cve
@@ -183,6 +188,15 @@ element found in CVEs, return an sexp such as (\"binutils\" (<
   (let ((nodes (vector->list (assoc-ref alist "nodes"))))
     (filter-map node->configuration nodes)))
 
+(define (impact-data->cve-cvssv3-base-severity alist)
+  "Given ALIST, a JSON dictionary for the \"impact\" element found in
+CVEs, return a string indicating its CVSSv3 severity.  This should be
+one of \"NONE\", \"LOW\", \"MEDIUM\", \"HIGH\", or \"CRITICAL\", but we
+return whatever we find, or #F if the severity cannot be determined."
+  (let* ((base-metric-v3 (assoc-ref alist "baseMetricV3"))
+         (cvss-v3        (assoc-ref base-metric-v3 "cvssV3")))
+    (assoc-ref cvss-v3 "baseSeverity")))
+
 (define (json->cve-items json)
   "Parse JSON, an input port or a string, and return a list of <cve-item>
 records."
@@ -251,20 +265,21 @@ records."
   (* 3600 24 (date-month %now)))
 
 (define-record-type <vulnerability>
-  (vulnerability id packages)
+  (vulnerability id severity packages)
   vulnerability?
   (id         vulnerability-id)             ;string
+  (severity   vulnerability-severity)       ;string
   (packages   vulnerability-packages))      ;((p1 sexp1) (p2 sexp2) ...)
 
 (define vulnerability->sexp
   (match-lambda
-    (($ <vulnerability> id packages)
-     `(v ,id ,packages))))
+    (($ <vulnerability> id severity packages)
+     `(v ,id ,severity ,packages))))
 
 (define sexp->vulnerability
   (match-lambda
-    (('v id (packages ...))
-     (vulnerability id packages))))
+    (('v id severity (packages ...))
+     (vulnerability id severity packages))))
 
 (define (cve-configuration->package-list config)
   "Parse CONFIG, a config sexp, and return a list of the form (P SEXP)
@@ -309,12 +324,13 @@ versions."
   "Return a <vulnerability> corresponding to ITEM, a <cve-item> record;
 return #f if ITEM does not list any configuration or if it does not list
 any \"a\" (application) configuration."
-  (let ((id (cve-id (cve-item-cve item))))
+  (let ((id (cve-id (cve-item-cve item)))
+        (severity (cve-item-base-severity item)))
     (match (cve-item-configurations item)
       (()                                         ;no configurations
        #f)
       ((configs ...)
-       (vulnerability id
+       (vulnerability id severity
                       (merge-package-lists
                        (map cve-configuration->package-list configs)))))))
 
@@ -332,7 +348,7 @@ sexp to CACHE."
         (json->vulnerabilities input))
 
       (write `(vulnerabilities
-               1                                  ;format version
+               2                                  ;format version
                ,(map vulnerability->sexp vulns))
              cache))))
 
@@ -396,7 +412,7 @@ vulnerabilities affecting the given package version."
     ;; Map package names to lists of version/vulnerability pairs.
     (fold (lambda (vuln table)
             (match vuln
-              (($ <vulnerability> id packages)
+              (($ <vulnerability> id severity packages)
                (fold (lambda (package table)
                        (match package
                          ((name . versions)
diff --git a/guix/lint.scm b/guix/lint.scm
index ed57e19fe2..f3c4e13052 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -48,6 +48,7 @@
   #:use-module (guix monads)
   #:use-module (guix scripts)
   #:use-module ((guix ui) #:select (texi->plain-text fill-paragraph))
+  #:use-module (guix colors)
   #:use-module (guix gnu-maintenance)
   #:use-module (guix cve)
   #:use-module ((guix swh) #:hide (origin?))
@@ -1165,6 +1166,35 @@ the NIST server non-fatal."
   "Check for known vulnerabilities for PACKAGE.  Obtain the list of
 vulnerability records for PACKAGE by calling PACKAGE-VULNERABILITIES."
 
+  (define severity->color
+    ;; A standard CVE colour gradient is red > orange > yellow > green > none.
+    ;; However, ANSI non-bold YELLOW is actually orange whilst BOLD YELLOW
+    ;; is actual yellow, so BOLD would confusingly be less serious.  Skip it.
+    (match-lambda
+      ("CRITICAL"     (color BOLD RED))
+      ("HIGH"         (color RED))
+      ("MEDIUM"       (color YELLOW))
+      ("LOW"          (color GREEN))
+      (_              (color))))
+
+  (define (colorize-vulnerability vulnerability)
+    ;; If the terminal supports ANSI colours, use them to indicate severity.
+    (colorize-string (vulnerability-id vulnerability)
+                     (severity->color (vulnerability-severity
+                                       vulnerability))))
+
+  (define (simple-format-vulnerability vulnerability)
+    ;; Otherwise, omit colour coding and explicitly append the severity string.
+    (simple-format #f "~a (~a)"
+                   (vulnerability-id vulnerability)
+                   (string-downcase (vulnerability-severity vulnerability))))
+
+  (define format-vulnerability
+    ;; Check once which of the above to use for all PACKAGE vulnerabilities.
+    (if (color-output? (current-output-port))
+        colorize-vulnerability
+        simple-format-vulnerability))
+
   (define (vulnerability< v1 v2)
     (define (string-list< list1 list2)
       (match list1
@@ -1201,7 +1231,7 @@ vulnerability records for PACKAGE by calling PACKAGE-VULNERABILITIES."
               (make-warning
                package
                (G_ "probably vulnerable to ~a")
-               (list (string-join (map vulnerability-id
+               (list (string-join (map format-vulnerability
                                        (sort unpatched vulnerability<))
                                   ", "))))))))))
 
-- 
2.30.1