[bug#31442] [PATCH 2/5] packages: Add 'package-patched-vulnerabilities'.

[Ludovic Courtès]

* guix/packages.scm (patch-file-name): New procedure.
(%vulnerability-regexp): New variable.
(package-patched-vulnerabilities): New procedure.
* guix/scripts/lint.scm (patch-file-name): Remove.
(check-vulnerabilities): Adjust to use
'package-patched-vulnerabilities'.
* tests/packages.scm ("package-patched-vulnerabilities"): New test.
---
 guix/packages.scm     | 28 ++++++++++++++++++++++++++++
 guix/scripts/lint.scm | 23 ++++-------------------
 tests/packages.scm    | 15 +++++++++++++++
 3 files changed, 47 insertions(+), 19 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index e0ab72086..f536597ae 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -35,6 +35,7 @@
   #:use-module (guix sets)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
+  #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-11)
@@ -106,6 +107,7 @@
             package-cross-derivation
             package-output
             package-grafts
+            package-patched-vulnerabilities
             package/inherit
 
             transitive-input-references
@@ -394,6 +396,32 @@ DELIMITER (a string), you can customize what will appear 
between the name and
 the version.  By default, DELIMITER is \"@\"."
   (string-append (package-name package) delimiter (package-version package)))
 
+(define (patch-file-name patch)
+  "Return the basename of PATCH's file name, or #f if the file name could not
+be determined."
+  (match patch
+    ((? string?)
+     (basename patch))
+    ((? origin?)
+     (and=> (origin-actual-file-name patch) basename))))
+
+(define %vulnerability-regexp
+  ;; Regexp matching a CVE identifier in patch file names.
+  (make-regexp "CVE-[0-9]{4}-[0-9]+"))
+
+(define (package-patched-vulnerabilities package)
+  "Return the list of patched vulnerabilities of PACKAGE as a list of CVE
+identifiers.  The result is inferred from the file names of patches."
+  (define (patch-vulnerabilities patch)
+    (map (cut match:substring <> 0)
+         (list-matches %vulnerability-regexp patch)))
+
+  (let ((patches (filter-map patch-file-name
+                             (or (and=> (package-source package)
+                                        origin-patches)
+                                 '()))))
+    (append-map patch-vulnerabilities patches)))
+
 (define (%standard-patch-inputs)
   (let* ((canonical (module-ref (resolve-interface '(gnu packages base))
                                 'canonical-package))
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index cd802985d..e477bf0dd 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 Cyril Roelandt <address@hidden>
 ;;; Copyright © 2014, 2015 Eric Bavier <address@hidden>
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès 
<address@hidden>
 ;;; Copyright © 2015, 2016 Mathieu Lirzin <address@hidden>
 ;;; Copyright © 2016 Danny Milosavljevic <address@hidden>
 ;;; Copyright © 2016 Hartmut Goebel <address@hidden>
@@ -809,15 +809,6 @@ descriptions maintained upstream."
      (emit-warning package (G_ "invalid license field")
                    'license))))
 
-(define (patch-file-name patch)
-  "Return the basename of PATCH's file name, or #f if the file name could not
-be determined."
-  (match patch
-    ((? string?)
-     (basename patch))
-    ((? origin?)
-     (and=> (origin-actual-file-name patch) basename))))
-
 (define (call-with-networking-fail-safe message error-value proc)
   "Call PROC catching any network-related errors.  Upon a networking error,
 display a message including MESSAGE and return ERROR-VALUE."
@@ -878,20 +869,14 @@ the NIST server non-fatal."
       (()
        #t)
       ((vulnerabilities ...)
-       (let* ((patches   (filter-map patch-file-name
-                                     (or (and=> (package-source package)
-                                                origin-patches)
-                                         '())))
+       (let* ((patched    (package-patched-vulnerabilities package))
               (known-safe (or (assq-ref (package-properties package)
                                         'lint-hidden-cve)
                               '()))
               (unpatched (remove (lambda (vuln)
                                    (let ((id (vulnerability-id vuln)))
-                                     (or
-                                       (find (cute string-contains
-                                                   <> id)
-                                             patches)
-                                       (member id known-safe))))
+                                     (or (member id patched)
+                                         (member id known-safe))))
                                  vulnerabilities)))
          (unless (null? unpatched)
            (emit-warning package
diff --git a/tests/packages.scm b/tests/packages.scm
index 9e19c3992..642a3efa5 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -941,6 +941,21 @@
                    ((("x" dep))
                     (eq? dep findutils)))))))))
 
+(test-equal "package-patched-vulnerabilities"
+  '(("CVE-2015-1234")
+    ("CVE-2016-1234" "CVE-2018-4567")
+    ())
+  (let ((p1 (dummy-package "pi"
+              (source (dummy-origin
+                       (patches (list "/a/b/pi-CVE-2015-1234.patch"))))))
+        (p2 (dummy-package "pi"
+              (source (dummy-origin
+                       (patches (list
+                                 
"/a/b/pi-CVE-2016-1234-CVE-2018-4567.patch"))))))
+        (p3 (dummy-package "pi" (source (dummy-origin)))))
+    (map package-patched-vulnerabilities
+         (list p1 p2 p3))))
+
 (test-eq "fold-packages" hello
   (fold-packages (lambda (p r)
                    (if (string=? (package-name p) "hello")
-- 
2.17.0