Package: guix-patches;
Reported by: Nicolas Graves <ngraves <at> ngraves.fr>
Date: Fri, 7 Mar 2025 18:41:03 UTC
Severity: normal
Tags: patch
Done: Nicolas Graves <ngraves <at> ngraves.fr>
Bug is archived. No further changes may be made.
To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 76823 in the body.
You can then email your comments to 76823 AT debbugs.gnu.org in the normal way.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix-patches <at> gnu.org:bug#76823; Package guix-patches.
(Fri, 07 Mar 2025 18:41:03 GMT) Full text and rfc822 format available.Nicolas Graves <ngraves <at> ngraves.fr>:guix-patches <at> gnu.org.
(Fri, 07 Mar 2025 18:41:03 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Nicolas Graves <ngraves <at> ngraves.fr> To: 76819 <at> debbugs.gnu.org Cc: Nicolas Graves via Guix-patches via <guix-patches <at> gnu.org> Subject: [PATCH v7 01/35] cve: Add cpe-vendor and lint-hidden-cpe-vendors properties. Date: Fri, 7 Mar 2025 19:38:30 +0100
From: Nicolas Graves via Guix-patches via <guix-patches <at> gnu.org>
* 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.
---
guix/cve.scm | 160 ++++++++++++++++++++++++++++++--------------------
guix/lint.scm | 10 +++-
tests/cve.scm | 14 ++---
3 files changed, 112 insertions(+), 72 deletions(-)
diff --git a/guix/cve.scm b/guix/cve.scm
index 9e1cf5b587..5ea5219190 100644
--- a/guix/cve.scm
+++ b/guix/cve.scm
@@ -25,11 +25,11 @@ (define-module (guix cve)
#: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 @@ (define %cpe-package-rx
;; "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 @@ (define (cpe->package-name cpe)
;; "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 @@ (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 ((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,25 @@ (define (version-matches? version sexp)
(('>= 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)))
+
+ (match vuln
+ (($ <vulnerability> id packages)
+ (any (match-lambda
+ ((? (lambda (candidate)
+ (and vendor
+ (string=? candidate vendor)))) #t)
+ ((? hidden-vendor?) #f)
+ (otherwise (not vendor)))
+ (map car packages))))) ;candidate vendors
+
;;;
;;; High-level interface.
@@ -259,7 +280,7 @@ (define-record-type <vulnerability>
(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 +292,53 @@ (define sexp->vulnerability
(('v id (packages ...))
(vulnerability id packages))))
+(define sexp-v1->vulnerability
+ (match-lambda
+ (('v id (packages ...))
+ (vulnerability id (map (cut cons #f <>) packages)))))
+
(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) sexp)
+ (let ((pruned-results (remove (match-lambda
+ ((vendor package _) #t)
+ (otherwise #f))
+ results)))
+ (match sexp
+ ('_ ;any version
+ (cons `(,vendor ,package _) pruned-results))
+ (_
+ (match (assoc-ref (assoc-ref results vendor) package)
+ ((previous)
+ (cons `(,vendor ,package (or ,sexp ,previous)) pruned-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 (match-lambda
+ ((vendor package _) #t)
+ (otherwise #f))
+ result)))
+ (_
+ (cons `(,vendor ,package ,version) result)))))
result
plist))
'()
@@ -337,7 +371,7 @@ (define vulns
(json->vulnerabilities input))
(write `(vulnerabilities
- 1 ;format version
+ 2 ;format version
,(map vulnerability->sexp vulns))
cache))))
@@ -371,8 +405,10 @@ (define (read* port)
(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,28 +440,26 @@ (define table
(($ <vulnerability> id packages)
(fold (lambda (package table)
(match package
- ((name . versions)
- (vhash-cons name (cons vuln versions)
+ ((vendor name versions)
+ (vhash-cons 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 #: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 d54db725b5..095694ed49 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1585,8 +1585,14 @@ (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
+ #: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 @@ (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.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.
))
--
2.48.1
Nicolas Graves <ngraves <at> ngraves.fr>
to control <at> debbugs.gnu.org.
(Fri, 07 Mar 2025 19:17:07 GMT) Full text and rfc822 format available.Debbugs Internal Request <help-debbugs <at> gnu.org>
to internal_control <at> debbugs.gnu.org.
(Sat, 05 Apr 2025 11:24:09 GMT) Full text and rfc822 format available.
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.