guix/cve.scm

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