diff options
Diffstat (limited to 'guix/cve.scm')
| -rw-r--r-- | guix/cve.scm | 156 |
1 files changed, 123 insertions, 33 deletions
diff --git a/guix/cve.scm b/guix/cve.scm index 8e76f42f0d..088e39837a 100644 --- a/guix/cve.scm +++ b/guix/cve.scm @@ -19,11 +19,14 @@ (define-module (guix cve) #:use-module (guix utils) #:use-module (guix http-client) + #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (sxml ssax) #: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 (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 vlist) @@ -46,8 +49,8 @@ (define-record-type <vulnerability> (vulnerability id packages) vulnerability? - (id vulnerability-id) - (packages vulnerability-packages)) + (id vulnerability-id) ;string + (packages vulnerability-packages)) ;((p1 v1 v2 v3) (p2 v1) ...) (define %now (current-date)) @@ -73,7 +76,7 @@ (define (call-with-cve-port uri ttl proc) "Pass PROC an input port from which to read the CVE stream." - (let ((port (http-fetch/cached uri #:ttl ttl))) + (let ((port (http-fetch uri))) (dynamic-wind (const #t) (lambda () @@ -91,18 +94,45 @@ (define (cpe->package-name cpe) "Converts the Common Platform Enumeration (CPE) string CPE to a package -name, in a very naive way. Return #f if CPE does not look like an application -CPE string." - (and=> (regexp-exec %cpe-package-rx (string-trim-both cpe)) +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." + (cond ((regexp-exec %cpe-package-rx (string-trim-both cpe)) + => (lambda (matches) - (cons (match:substring matches 2) - (string-append (match:substring matches 3) - (match (match:substring matches 4) - ("" "") - (patch-level - ;; Drop the colon from things like - ;; "cpe:/a:openbsd:openssh:6.8:p1". - (string-drop patch-level 1)))))))) + (values (match:substring matches 2) + (string-append (match:substring matches 3) + (match (match:substring matches 4) + ("" "") + (patch-level + ;; Drop the colon from things like + ;; "cpe:/a:openbsd:openssh:6.8:p1". + (string-drop patch-level 1))))))) + (else + (values #f #f)))) + +(define (cpe->product-alist products) + "Given PRODUCTS, a list of CPE names, return the subset limited to the +applications listed in PRODUCTS, with names converted to package names: + + (cpe->product-alist + '(\"cpe:/a:gnu:libtasn1:4.7\" \"cpe:/a:gnu:libtasn1:4.6\" \"cpe:/a:gnu:cpio:2.11\")) + => ((\"libtasn1\" \"4.7\" \"4.6\") (\"cpio\" \"2.11\")) +" + (fold (lambda (product result) + (let-values (((name version) (cpe->package-name product))) + (if name + (match result + (((previous . versions) . tail) + ;; Attempt to coalesce NAME and PREVIOUS. + (if (string=? name previous) + (alist-cons name (cons version versions) tail) + (alist-cons name (list version) result))) + (() + (alist-cons name (list version) result))) + result))) + '() + (sort products string<?))) (define %parse-vulnerability-feed ;; Parse the XML vulnerability feed from @@ -130,12 +160,12 @@ CPE string." ;; Some entries have no vulnerable-software-list. rest) ((products id . rest) - (match (filter-map cpe->package-name products) + (match (cpe->product-alist products) (() ;; No application among PRODUCTS. rest) (packages - (cons (vulnerability id (reverse packages)) + (cons (vulnerability id packages) rest)))))) (x seed))) @@ -154,28 +184,85 @@ CPE string." vulnerability objects." (reverse (%parse-vulnerability-feed port '()))) -(define (current-vulnerabilities) - "Return the current list of Common Vulnerabilities and Exposures (CVE) as -published by the US NIST." - (define (read-vulnerabilities uri ttl) - (call-with-cve-port uri ttl +(define vulnerability->sexp + (match-lambda + (($ <vulnerability> id packages) + `(v ,id ,packages)))) + +(define sexp->vulnerability + (match-lambda + (('v id (packages ...)) + (vulnerability id packages)))) + +(define (fetch-vulnerabilities year ttl) + "Return the list of <vulnerability> for YEAR, assuming the on-disk cache has +the given TTL (fetch from the NIST web site when TTL has expired)." + ;; Note: We used to keep the original XML files in cache but parsing it + ;; would take typically ~15s for a year of data. Thus, we instead store a + ;; summarized version thereof as an sexp, which can be parsed in 1s or so. + (define cache + (string-append (cache-directory) "/cve/" (number->string year))) + + (define (do-fetch) + (call-with-cve-port (yearly-feed-uri year) ttl (lambda (port) ;; XXX: The SSAX "error port" is used to send pointless warnings such as ;; "warning: Skipping PI". Turn that off. + (format (current-error-port) "fetching CVE database for ~a...~%" year) (parameterize ((current-ssax-error-port (%make-void-port "w"))) (xml->vulnerabilities port))))) - (append-map read-vulnerabilities - (list (yearly-feed-uri %past-year) - (yearly-feed-uri %current-year)) - (list %past-year-ttl - %current-year-ttl))) + (define (update-cache) + (mkdir-p (dirname cache)) + (let ((vulns (do-fetch))) + (with-atomic-file-output cache + (lambda (port) + (write `(vulnerabilities + 1 ;format version + ,(map vulnerability->sexp vulns)) + port))) + vulns)) + + (define (old? file) + ;; Return true if PORT has passed TTL. + (let* ((s (stat file)) + (now (current-time time-utc))) + (< (+ (stat:mtime s) ttl) (time-second now)))) + + (catch 'system-error + (lambda () + (if (old? cache) + (update-cache) + (match (call-with-input-file cache read) + (('vulnerabilities 1 vulns) + (map sexp->vulnerability vulns)) + (x + (update-cache))))) + (lambda args + (update-cache)))) + +(define (current-vulnerabilities) + "Return the current list of Common Vulnerabilities and Exposures (CVE) as +published by the US NIST." + (let ((past-years (unfold (cut > <> 3) + (lambda (n) + (- %current-year n)) + 1+ + 1)) + (past-ttls (unfold (cut > <> 3) + (lambda (n) + (* n %past-year-ttl)) + 1+ + 1))) + (append-map fetch-vulnerabilities + (cons %current-year past-years) + (cons %current-year-ttl past-ttls)))) (define (vulnerabilities->lookup-proc vulnerabilities) "Return a lookup procedure built from VULNERABILITIES that takes a package name and optionally a version number. When the version is omitted, the lookup -procedure returns a list of version/vulnerability pairs; otherwise, it returns -a list of vulnerabilities affection the given package version." +procedure returns a list of vulnerabilities; otherwise, it returns a list of +vulnerabilities affecting the given package version." (define table ;; Map package names to lists of version/vulnerability pairs. (fold (lambda (vuln table) @@ -183,8 +270,8 @@ a list of vulnerabilities affection the given package version." (($ <vulnerability> id packages) (fold (lambda (package table) (match package - ((name . version) - (vhash-cons name (cons version vuln) + ((name . versions) + (vhash-cons name (cons vuln versions) table)))) table packages)))) @@ -195,11 +282,14 @@ a list of vulnerabilities affection the given package version." (vhash-fold* (if version (lambda (pair result) (match pair - ((v . vuln) - (if (string=? v version) + ((vuln . versions) + (if (member version versions) (cons vuln result) result)))) - cons) + (lambda (pair result) + (match pair + ((vuln . _) + (cons vuln result))))) '() package table))) |