#31442 [PATCH 0/5] 'guix health': a tool to report vulnerable packages

Message #20 received at 31442@debbugs.gnu.org (full text, mbox, reply):

Received: (at 31442) by debbugs.gnu.org; 14 May 2018 08:26:17 +0000
From debbugs-submit-bounces@debbugs.gnu.org Mon May 14 04:26:17 2018
Received: from localhost ([127.0.0.1]:33182 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces@debbugs.gnu.org>)
	id 1fI8oD-0007a5-Gr
	for submit@debbugs.gnu.org; Mon, 14 May 2018 04:26:17 -0400
Received: from eggs.gnu.org ([208.118.235.92]:46704)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@gnu.org>) id 1fI8oB-0007Z1-3R
 for 31442@debbugs.gnu.org; Mon, 14 May 2018 04:26:15 -0400
Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
 (envelope-from <ludo@gnu.org>) id 1fI8o0-0002sm-11
 for 31442@debbugs.gnu.org; Mon, 14 May 2018 04:26:10 -0400
X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org
X-Spam-Level: 
X-Spam-Status: No, score=0.8 required=5.0 tests=BAYES_50 autolearn=disabled
 version=3.3.2
Received: from fencepost.gnu.org ([2001:4830:134:3::e]:60789)
 by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from <ludo@gnu.org>)
 id 1fI8nw-0002lu-9D; Mon, 14 May 2018 04:26:00 -0400
Received: from [193.50.110.240] (port=53312 helo=gnu.org)
 by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256)
 (Exim 4.82) (envelope-from <ludo@gnu.org>)
 id 1fI8nv-0007HI-Mk; Mon, 14 May 2018 04:26:00 -0400
From: Ludovic Courtès <ludo@gnu.org>
To: 31442@debbugs.gnu.org
Subject: [PATCH 2/5] packages: Add 'package-patched-vulnerabilities'.
Date: Mon, 14 May 2018 10:25:47 +0200
Message-Id: <20180514082550.1131-2-ludo@gnu.org>
X-Mailer: git-send-email 2.17.0
In-Reply-To: <20180514082550.1131-1-ludo@gnu.org>
References: <20180514082550.1131-1-ludo@gnu.org>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic]
X-Received-From: 2001:4830:134:3::e
X-Spam-Score: -5.0 (-----)
X-Debbugs-Envelope-To: 31442
Cc: Ludovic Courtès <ludo@gnu.org>
X-BeenThere: debbugs-submit@debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request@debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit@debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request@debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request@debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces@debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces@debbugs.gnu.org>
X-Spam-Score: -6.0 (------)

* 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 <tipecaml@gmail.com>
 ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
@@ -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

Send a report that this bug log contains spam.