;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#: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)
(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))
(define (yearly-feed-uri year)
"Return the URI for the CVE feed for YEAR."
(string->uri
- (string-append "https://static.nvd.nist.gov/feeds/xml/cve/nvdcve-2.0-"
+ (string-append "https://nvd.nist.gov/feeds/xml/cve/nvdcve-2.0-"
(number->string year) ".xml.gz")))
(define %current-year-ttl
;; According to <https://nvd.nist.gov/download.cfm#CVE_FEED>, feeds are
;; updated "approximately every two hours."
- (* 3600 3))
+ (* 60 30))
(define %past-year-ttl
;; Update the previous year's database more and more infrequently.
- (* 3600 24 2 (date-month %now)))
-
-(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)))
- (dynamic-wind
- (const #t)
- (lambda ()
- (call-with-decompressed-port 'gzip port
- (lambda (port)
- (setvbuf port _IOFBF 65536)
- (proc port))))
- (lambda ()
- (close-port port)))))
+ (* 3600 24 (date-month %now)))
(define %cpe-package-rx
;; For applications: "cpe:/a:VENDOR:PACKAGE:VERSION", or sometimes
(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
;; 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)))
vulnerability objects."
(reverse (%parse-vulnerability-feed port '())))
+(define vulnerability->sexp
+ (match-lambda
+ (($ <vulnerability> id packages)
+ `(v ,id ,packages))))
+
+(define sexp->vulnerability
+ (match-lambda
+ (('v id (packages ...))
+ (vulnerability id packages))))
+
+(define (write-cache input cache)
+ "Read vulnerabilities as gzipped XML from INPUT, and write it as a compact
+sexp to CACHE."
+ (call-with-decompressed-port 'gzip input
+ (lambda (input)
+ ;; XXX: The SSAX "error port" is used to send pointless warnings such as
+ ;; "warning: Skipping PI". Turn that off.
+ (define vulns
+ (parameterize ((current-ssax-error-port (%make-void-port "w")))
+ (xml->vulnerabilities input)))
+
+ (write `(vulnerabilities
+ 1 ;format version
+ ,(map vulnerability->sexp vulns))
+ cache))))
+
+(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)."
+ (define (cache-miss uri)
+ (format (current-error-port) "fetching CVE database for ~a...~%" year))
+
+ (define (read* port)
+ ;; Disable read options to avoid populating the source property weak
+ ;; table, which speeds things up, saves memory, and works around
+ ;; <https://lists.gnu.org/archive/html/guile-devel/2017-09/msg00031.html>.
+ (let ((options (read-options)))
+ (dynamic-wind
+ (lambda ()
+ (read-disable 'positions))
+ (lambda ()
+ (read port))
+ (lambda ()
+ (read-options options)))))
+
+ ;; 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.
+ (let* ((port (http-fetch/cached (yearly-feed-uri year)
+ #:ttl ttl
+ #:write-cache write-cache
+ #:cache-miss cache-miss))
+ (sexp (read* port)))
+ (close-port port)
+ (match sexp
+ (('vulnerabilities 1 vulns)
+ (map sexp->vulnerability vulns)))))
+
(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
- (lambda (port)
- ;; XXX: The SSAX "error port" is used to send pointless warnings such as
- ;; "warning: Skipping PI". Turn that off.
- (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)))
+ (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)
(($ <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))))
(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)))
-;;; Local Variables:
-;;; eval: (put 'call-with-cve-port 'scheme-indent-function 2)
-;;; End:
-
;;; cve.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff