guix/cve.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix cve)
  20   #:use-module (guix utils)
  21   #:use-module (guix http-client)
  22   #:use-module ((guix build utils) #:select (mkdir-p))
  23   #:use-module (sxml ssax)
  24   #:use-module (web uri)
  25   #:use-module (srfi srfi-1)
  26   #:use-module (srfi srfi-9)
  27   #:use-module (srfi srfi-11)
  28   #:use-module (srfi srfi-19)
  29   #:use-module (srfi srfi-26)
  30   #:use-module (ice-9 match)
  31   #:use-module (ice-9 regex)
  32   #:use-module (ice-9 vlist)
  33   #:export (vulnerability?
  34             vulnerability-id
  35             vulnerability-packages
  36
  37             xml->vulnerabilities
  38             current-vulnerabilities
  39             vulnerabilities->lookup-proc))
  40
  41 ;;; Commentary:
  42 ;;;
  43 ;;; This modules provides the tools to fetch, parse, and digest part of the
  44 ;;; Common Vulnerabilities and Exposures (CVE) feeds provided by the US NIST
  45 ;;; at <https://nvd.nist.gov/download.cfm#CVE_FEED>.
  46 ;;;
  47 ;;; Code:
  48
  49 (define-record-type <vulnerability>
  50   (vulnerability id packages)
  51   vulnerability?
  52   (id         vulnerability-id)                   ;string
  53   (packages   vulnerability-packages))            ;((p1 v1 v2 v3) (p2 v1) ...)
  54
  55 (define %now
  56   (current-date))
  57 (define %current-year
  58   (date-year %now))
  59 (define %past-year
  60   (- %current-year 1))
  61
  62 (define (yearly-feed-uri year)
  63   "Return the URI for the CVE feed for YEAR."
  64   (string->uri
  65    (string-append "https://static.nvd.nist.gov/feeds/xml/cve/nvdcve-2.0-"
  66                   (number->string year) ".xml.gz")))
  67
  68 (define %current-year-ttl
  69   ;; According to <https://nvd.nist.gov/download.cfm#CVE_FEED>, feeds are
  70   ;; updated "approximately every two hours."
  71   (* 3600 3))
  72
  73 (define %past-year-ttl
  74   ;; Update the previous year's database more and more infrequently.
  75   (* 3600 24 2 (date-month %now)))
  76
  77 (define (call-with-cve-port uri ttl proc)
  78   "Pass PROC an input port from which to read the CVE stream."
  79   (let ((port (http-fetch uri)))
  80     (dynamic-wind
  81       (const #t)
  82       (lambda ()
  83         (call-with-decompressed-port 'gzip port
  84           (lambda (port)
  85             (setvbuf port _IOFBF 65536)
  86             (proc port))))
  87       (lambda ()
  88         (close-port port)))))
  89
  90 (define %cpe-package-rx
  91   ;; For applications: "cpe:/a:VENDOR:PACKAGE:VERSION", or sometimes
  92   ;; "cpe/a:VENDOR:PACKAGE:VERSION:PATCH-LEVEL".
  93   (make-regexp "^cpe:/a:([^:]+):([^:]+):([^:]+)((:.+)?)"))
  94
  95 (define (cpe->package-name cpe)
  96   "Converts the Common Platform Enumeration (CPE) string CPE to a package
  97 name, in a very naive way.  Return two values: the package name, and its
  98 version string.  Return #f and #f if CPE does not look like an application CPE
  99 string."
 100   (cond ((regexp-exec %cpe-package-rx (string-trim-both cpe))
 101          =>
 102          (lambda (matches)
 103            (values (match:substring matches 2)
 104                    (string-append (match:substring matches 3)
 105                                   (match (match:substring matches 4)
 106                                     ("" "")
 107                                     (patch-level
 108                                      ;; Drop the colon from things like
 109                                      ;; "cpe:/a:openbsd:openssh:6.8:p1".
 110                                      (string-drop patch-level 1)))))))
 111         (else
 112          (values #f #f))))
 113
 114 (define (cpe->product-alist products)
 115   "Given PRODUCTS, a list of CPE names, return the subset limited to the
 116 applications listed in PRODUCTS, with names converted to package names:
 117
 118   (cpe->product-alist
 119     '(\"cpe:/a:gnu:libtasn1:4.7\" \"cpe:/a:gnu:libtasn1:4.6\" \"cpe:/a:gnu:cpio:2.11\"))
 120   => ((\"libtasn1\" \"4.7\" \"4.6\") (\"cpio\" \"2.11\"))
 121 "
 122   (fold (lambda (product result)
 123           (let-values (((name version) (cpe->package-name product)))
 124             (if name
 125                 (match result
 126                   (((previous . versions) . tail)
 127                    ;; Attempt to coalesce NAME and PREVIOUS.
 128                    (if (string=? name previous)
 129                        (alist-cons name (cons version versions) tail)
 130                        (alist-cons name (list version) result)))
 131                   (()
 132                    (alist-cons name (list version) result)))
 133                 result)))
 134         '()
 135         (sort products string<?)))
 136
 137 (define %parse-vulnerability-feed
 138   ;; Parse the XML vulnerability feed from
 139   ;; <https://nvd.nist.gov/download.cfm#CVE_FEED> and return a list of
 140   ;; vulnerability objects.
 141   (ssax:make-parser NEW-LEVEL-SEED
 142                     (lambda (elem-gi attributes namespaces expected-content
 143                                      seed)
 144                       (match elem-gi
 145                         ((name-space . 'entry)
 146                          (cons (assoc-ref attributes 'id) seed))
 147                         ((name-space . 'vulnerable-software-list)
 148                          (cons '() seed))
 149                         ((name-space . 'product)
 150                          (cons 'product seed))
 151                         (x seed)))
 152
 153                     FINISH-ELEMENT
 154                     (lambda (elem-gi attributes namespaces parent-seed
 155                                      seed)
 156                       (match elem-gi
 157                         ((name-space . 'entry)
 158                          (match seed
 159                            (((? string? id) . rest)
 160                             ;; Some entries have no vulnerable-software-list.
 161                             rest)
 162                            ((products id . rest)
 163                             (match (cpe->product-alist products)
 164                               (()
 165                                ;; No application among PRODUCTS.
 166                                rest)
 167                               (packages
 168                                (cons (vulnerability id packages)
 169                                      rest))))))
 170                         (x
 171                          seed)))
 172
 173                     CHAR-DATA-HANDLER
 174                     (lambda (str _ seed)
 175                       (match seed
 176                         (('product software-list . rest)
 177                          ;; Add STR to the vulnerable software list this
 178                          ;; <product> tag is part of.
 179                          (cons (cons str software-list) rest))
 180                         (x x)))))
 181
 182 (define (xml->vulnerabilities port)
 183   "Read from PORT an XML feed of vulnerabilities and return a list of
 184 vulnerability objects."
 185   (reverse (%parse-vulnerability-feed port '())))
 186
 187 (define vulnerability->sexp
 188   (match-lambda
 189     (($ <vulnerability> id packages)
 190      `(v ,id ,packages))))
 191
 192 (define sexp->vulnerability
 193   (match-lambda
 194     (('v id (packages ...))
 195      (vulnerability id packages))))
 196
 197 (define (fetch-vulnerabilities year ttl)
 198   "Return the list of <vulnerability> for YEAR, assuming the on-disk cache has
 199 the given TTL (fetch from the NIST web site when TTL has expired)."
 200   ;; Note: We used to keep the original XML files in cache but parsing it
 201   ;; would take typically ~15s for a year of data.  Thus, we instead store a
 202   ;; summarized version thereof as an sexp, which can be parsed in 1s or so.
 203   (define cache
 204     (string-append (cache-directory) "/cve/" (number->string year)))
 205
 206   (define (do-fetch)
 207     (call-with-cve-port (yearly-feed-uri year) ttl
 208       (lambda (port)
 209         ;; XXX: The SSAX "error port" is used to send pointless warnings such as
 210         ;; "warning: Skipping PI".  Turn that off.
 211         (format (current-error-port) "fetching CVE database for ~a...~%" year)
 212         (parameterize ((current-ssax-error-port (%make-void-port "w")))
 213           (xml->vulnerabilities port)))))
 214
 215   (define (update-cache)
 216     (mkdir-p (dirname cache))
 217     (let ((vulns (do-fetch)))
 218       (with-atomic-file-output cache
 219         (lambda (port)
 220           (write `(vulnerabilities
 221                    1                              ;format version
 222                    ,(map vulnerability->sexp vulns))
 223                  port)))
 224       vulns))
 225
 226   (define (old? file)
 227     ;; Return true if PORT has passed TTL.
 228     (let* ((s   (stat file))
 229            (now (current-time time-utc)))
 230       (< (+ (stat:mtime s) ttl) (time-second now))))
 231
 232   (define (read* port)
 233     ;; Disable read options to avoid populating the source property weak
 234     ;; table, which speeds things up, saves memory, and works around
 235     ;; <https://lists.gnu.org/archive/html/guile-devel/2017-09/msg00031.html>.
 236     (let ((options (read-options)))
 237       (dynamic-wind
 238         (lambda ()
 239           (read-disable 'positions))
 240         (lambda ()
 241           (read port))
 242         (lambda ()
 243           (read-options options)))))
 244
 245   (catch 'system-error
 246     (lambda ()
 247       (if (old? cache)
 248           (update-cache)
 249           (match (call-with-input-file cache read*)
 250             (('vulnerabilities 1 vulns)
 251              (map sexp->vulnerability vulns))
 252             (x
 253              (update-cache)))))
 254     (lambda args
 255       (update-cache))))
 256
 257 (define (current-vulnerabilities)
 258   "Return the current list of Common Vulnerabilities and Exposures (CVE) as
 259 published by the US NIST."
 260   (let ((past-years (unfold (cut > <> 3)
 261                             (lambda (n)
 262                               (- %current-year n))
 263                             1+
 264                             1))
 265         (past-ttls  (unfold (cut > <> 3)
 266                             (lambda (n)
 267                               (* n %past-year-ttl))
 268                             1+
 269                             1)))
 270     (append-map fetch-vulnerabilities
 271                 (cons %current-year past-years)
 272                 (cons %current-year-ttl past-ttls))))
 273
 274 (define (vulnerabilities->lookup-proc vulnerabilities)
 275   "Return a lookup procedure built from VULNERABILITIES that takes a package
 276 name and optionally a version number.  When the version is omitted, the lookup
 277 procedure returns a list of vulnerabilities; otherwise, it returns a list of
 278 vulnerabilities affecting the given package version."
 279   (define table
 280     ;; Map package names to lists of version/vulnerability pairs.
 281     (fold (lambda (vuln table)
 282             (match vuln
 283               (($ <vulnerability> id packages)
 284                (fold (lambda (package table)
 285                        (match package
 286                          ((name . versions)
 287                           (vhash-cons name (cons vuln versions)
 288                                       table))))
 289                      table
 290                      packages))))
 291           vlist-null
 292           vulnerabilities))
 293
 294   (lambda* (package #:optional version)
 295     (vhash-fold* (if version
 296                      (lambda (pair result)
 297                        (match pair
 298                          ((vuln . versions)
 299                           (if (member version versions)
 300                               (cons vuln result)
 301                               result))))
 302                      (lambda (pair result)
 303                        (match pair
 304                          ((vuln . _)
 305                           (cons vuln result)))))
 306                  '()
 307                  package table)))
 308
 309
 310 ;;; Local Variables:
 311 ;;; eval: (put 'call-with-cve-port 'scheme-indent-function 2)
 312 ;;; End:
 313
 314 ;;; cve.scm ends here