guix/cve.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 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 i18n)
  23   #:use-module ((guix diagnostics) #:select (formatted-message))
  24   #:use-module (json)
  25   #:use-module (web uri)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (srfi srfi-9)
  28   #:use-module (srfi srfi-11)
  29   #:use-module (srfi srfi-19)
  30   #:use-module (srfi srfi-26)
  31   #:use-module (srfi srfi-34)
  32   #:use-module (srfi srfi-35)
  33   #:use-module (ice-9 match)
  34   #:use-module (ice-9 regex)
  35   #:use-module (ice-9 vlist)
  36   #:export (json->cve-items
  37
  38             cve-item?
  39             cve-item-cve
  40             cve-item-configurations
  41             cve-item-published-date
  42             cve-item-last-modified-date
  43
  44             cve?
  45             cve-id
  46             cve-data-type
  47             cve-data-format
  48             cve-references
  49
  50             cve-reference?
  51             cve-reference-url
  52             cve-reference-tags
  53
  54             vulnerability?
  55             vulnerability-id
  56             vulnerability-packages
  57
  58             json->vulnerabilities
  59             current-vulnerabilities
  60             vulnerabilities->lookup-proc))
  61
  62 ;;; Commentary:
  63 ;;;
  64 ;;; This modules provides the tools to fetch, parse, and digest part of the
  65 ;;; Common Vulnerabilities and Exposures (CVE) feeds provided by the US NIST
  66 ;;; at <https://nvd.nist.gov/vuln/data-feeds>.
  67 ;;;
  68 ;;; Code:
  69
  70 (define (string->date* str)
  71   (string->date str "~Y-~m-~dT~H:~M~z"))
  72
  73 (define-json-mapping <cve-item> cve-item cve-item?
  74   json->cve-item
  75   (cve            cve-item-cve "cve" json->cve)   ;<cve>
  76   (configurations cve-item-configurations         ;list of sexps
  77                   "configurations" configuration-data->cve-configurations)
  78   (published-date cve-item-published-date
  79                   "publishedDate" string->date*)
  80   (last-modified-date cve-item-last-modified-date
  81                       "lastModifiedDate" string->date*))
  82
  83 (define-json-mapping <cve> cve cve?
  84   json->cve
  85   (id             cve-id "CVE_data_meta"          ;string
  86                   (cut assoc-ref <> "ID"))
  87   (data-type      cve-data-type                   ;'CVE
  88                   "data_type" string->symbol)
  89   (data-format    cve-data-format                 ;'MITRE
  90                   "data_format" string->symbol)
  91   (references     cve-references                  ;list of <cve-reference>
  92                   "references" reference-data->cve-references))
  93
  94 (define-json-mapping <cve-reference> cve-reference cve-reference?
  95   json->cve-reference
  96   (url            cve-reference-url)              ;string
  97   (tags           cve-reference-tags              ;list of strings
  98                   "tags" vector->list))
  99
 100 (define (reference-data->cve-references alist)
 101   (map json->cve-reference
 102        ;; Normally "reference_data" is always present but rejected CVEs such
 103        ;; as CVE-2020-10020 can lack it.
 104        (vector->list (or (assoc-ref alist "reference_data") '#()))))
 105
 106 (define %cpe-package-rx
 107   ;; For applications: "cpe:2.3:a:VENDOR:PACKAGE:VERSION", or sometimes
 108   ;; "cpe:2.3:a:VENDOR:PACKAGE:VERSION:PATCH-LEVEL".
 109   (make-regexp "^cpe:2\\.3:a:([^:]+):([^:]+):([^:]+):([^:]+):"))
 110
 111 (define (cpe->package-name cpe)
 112   "Converts the Common Platform Enumeration (CPE) string CPE to a package
 113 name, in a very naive way.  Return two values: the package name, and its
 114 version string.  Return #f and #f if CPE does not look like an application CPE
 115 string."
 116   (cond ((regexp-exec %cpe-package-rx cpe)
 117          =>
 118          (lambda (matches)
 119            (values (match:substring matches 2)
 120                    (match (match:substring matches 3)
 121                      ("*" '_)
 122                      (version
 123                       (string-append version
 124                                      (match (match:substring matches 4)
 125                                        ("" "")
 126                                        (patch-level
 127                                         ;; Drop the colon from things like
 128                                         ;; "cpe:2.3:a:openbsd:openssh:6.8:p1".
 129                                         (string-drop patch-level 1)))))))))
 130         (else
 131          (values #f #f))))
 132
 133 (define (cpe-match->cve-configuration alist)
 134   "Convert ALIST, a \"cpe_match\" alist, into an sexp representing the package
 135 and versions matched.  Return #f if ALIST doesn't correspond to an application
 136 package."
 137   (let ((cpe    (assoc-ref alist "cpe23Uri"))
 138         (starti (assoc-ref alist "versionStartIncluding"))
 139         (starte (assoc-ref alist "versionStartExcluding"))
 140         (endi   (assoc-ref alist "versionEndIncluding"))
 141         (ende   (assoc-ref alist "versionEndExcluding")))
 142     ;; Normally "cpe23Uri" is here in each "cpe_match" item, but CVE-2020-0534
 143     ;; has a configuration that lacks it.
 144     (and cpe
 145          (let-values (((package version) (cpe->package-name cpe)))
 146            (and package
 147                 `(,package
 148                    ,(cond ((and (or starti starte) (or endi ende))
 149                            `(and ,(if starti `(>= ,starti) `(> ,starte))
 150                                  ,(if endi `(<= ,endi) `(< ,ende))))
 151                           (starti `(>= ,starti))
 152                           (starte `(> ,starte))
 153                           (endi   `(<= ,endi))
 154                           (ende   `(< ,ende))
 155                           (else   version))))))))
 156
 157 (define (configuration-data->cve-configurations alist)
 158   "Given ALIST, a JSON dictionary for the baroque \"configurations\"
 159 element found in CVEs, return an sexp such as (\"binutils\" (<
 160 \"2.31\")) that represents matching configurations."
 161   (define string->operator
 162     (match-lambda
 163       ("OR" 'or)
 164       ("AND" 'and)))
 165
 166   (define (node->configuration node)
 167     (let ((operator (string->operator (assoc-ref node "operator"))))
 168       (cond
 169        ((assoc-ref node "cpe_match")
 170         =>
 171         (lambda (matches)
 172           (let ((matches (vector->list matches)))
 173             (match (filter-map cpe-match->cve-configuration
 174                                matches)
 175               (()    #f)
 176               ((one) one)
 177               (lst   (cons operator lst))))))
 178        ((assoc-ref node "children")               ;typically for 'and'
 179         =>
 180         (lambda (children)
 181           (match (filter-map node->configuration (vector->list children))
 182             (()    #f)
 183             ((one) one)
 184             (lst   (cons operator lst)))))
 185        (else
 186         #f))))
 187
 188   (let ((nodes (vector->list (assoc-ref alist "nodes"))))
 189     (filter-map node->configuration nodes)))
 190
 191 (define (json->cve-items json)
 192   "Parse JSON, an input port or a string, and return a list of <cve-item>
 193 records."
 194   (let* ((alist   (json->scm json))
 195          (type    (assoc-ref alist "CVE_data_type"))
 196          (format  (assoc-ref alist "CVE_data_format"))
 197          (version (assoc-ref alist "CVE_data_version")))
 198     (unless (equal? type "CVE")
 199       (raise (condition (&message
 200                          (message "invalid CVE feed")))))
 201     (unless (equal? format "MITRE")
 202       (raise (formatted-message (G_ "unsupported CVE format: '~a'")
 203                                 format)))
 204     (unless (equal? version "4.0")
 205       (raise (formatted-message (G_ "unsupported CVE data version: '~a'")
 206                                 version)))
 207
 208     (map json->cve-item
 209          (vector->list (assoc-ref alist "CVE_Items")))))
 210
 211 (define (version-matches? version sexp)
 212   "Return true if VERSION, a string, matches SEXP."
 213   (match sexp
 214     ('_
 215      #t)
 216     ((? string? expected)
 217      (version-prefix? expected version))
 218     (('or sexps ...)
 219      (any (cut version-matches? version <>) sexps))
 220     (('and sexps ...)
 221      (every (cut version-matches? version <>) sexps))
 222     (('< max)
 223      (version>? max version))
 224     (('<= max)
 225      (version>=? max version))
 226     (('> min)
 227      (version>? version min))
 228     (('>= min)
 229      (version>=? version min))))
 230
 231 \f
 232 ;;;
 233 ;;; High-level interface.
 234 ;;;
 235
 236 (define %now
 237   (current-date))
 238 (define %current-year
 239   (date-year %now))
 240 (define %past-year
 241   (- %current-year 1))
 242
 243 (define (yearly-feed-uri year)
 244   "Return the URI for the CVE feed for YEAR."
 245   (string->uri
 246    (string-append "https://nvd.nist.gov/feeds/json/cve/1.1/nvdcve-1.1-"
 247                   (number->string year) ".json.gz")))
 248
 249 (define %current-year-ttl
 250   ;; According to <https://nvd.nist.gov/download.cfm#CVE_FEED>, feeds are
 251   ;; updated "approximately every two hours."
 252   (* 60 30))
 253
 254 (define %past-year-ttl
 255   ;; Update the previous year's database more and more infrequently.
 256   (* 3600 24 (date-month %now)))
 257
 258 (define-record-type <vulnerability>
 259   (vulnerability id packages)
 260   vulnerability?
 261   (id         vulnerability-id)             ;string
 262   (packages   vulnerability-packages))      ;((p1 sexp1) (p2 sexp2) ...)
 263
 264 (define vulnerability->sexp
 265   (match-lambda
 266     (($ <vulnerability> id packages)
 267      `(v ,id ,packages))))
 268
 269 (define sexp->vulnerability
 270   (match-lambda
 271     (('v id (packages ...))
 272      (vulnerability id packages))))
 273
 274 (define (cve-configuration->package-list config)
 275   "Parse CONFIG, a config sexp, and return a list of the form (P SEXP)
 276 where P is a package name and SEXP expresses constraints on the matching
 277 versions."
 278   (let loop ((config config)
 279              (packages '()))
 280     (match config
 281       (('or configs ...)
 282        (fold loop packages configs))
 283       (('and config _ ...)                        ;XXX
 284        (loop config packages))
 285       (((? string? package) '_)                   ;any version
 286        (cons `(,package _)
 287              (alist-delete package packages)))
 288       (((? string? package) sexp)
 289        (let ((previous (assoc-ref packages package)))
 290          (if previous
 291              (cons `(,package (or ,sexp ,@previous))
 292                    (alist-delete package packages))
 293              (cons `(,package ,sexp) packages)))))))
 294
 295 (define (merge-package-lists lst)
 296   "Merge the list in LST, each of which has the form (p sexp), where P
 297 is the name of a package and SEXP is an sexp that constrains matching
 298 versions."
 299   (fold (lambda (plist result)                    ;XXX: quadratic
 300           (fold (match-lambda*
 301                   (((package version) result)
 302                    (match (assoc-ref result package)
 303                      (#f
 304                       (cons `(,package ,version) result))
 305                      ((previous)
 306                       (cons `(,package (or ,version ,previous))
 307                             (alist-delete package result))))))
 308                 result
 309                 plist))
 310         '()
 311         lst))
 312
 313 (define (cve-item->vulnerability item)
 314   "Return a <vulnerability> corresponding to ITEM, a <cve-item> record;
 315 return #f if ITEM does not list any configuration or if it does not list
 316 any \"a\" (application) configuration."
 317   (let ((id (cve-id (cve-item-cve item))))
 318     (match (cve-item-configurations item)
 319       (()                                         ;no configurations
 320        #f)
 321       ((configs ...)
 322        (vulnerability id
 323                       (merge-package-lists
 324                        (map cve-configuration->package-list configs)))))))
 325
 326 (define (json->vulnerabilities json)
 327   "Parse JSON, an input port or a string, and return the list of
 328 vulnerabilities found therein."
 329   (filter-map cve-item->vulnerability (json->cve-items json)))
 330
 331 (define (write-cache input cache)
 332   "Read vulnerabilities as gzipped JSON from INPUT, and write it as a compact
 333 sexp to CACHE."
 334   (call-with-decompressed-port 'gzip input
 335     (lambda (input)
 336       (define vulns
 337         (json->vulnerabilities input))
 338
 339       (write `(vulnerabilities
 340                1                                  ;format version
 341                ,(map vulnerability->sexp vulns))
 342              cache))))
 343
 344 (define* (fetch-vulnerabilities year ttl #:key (timeout 10))
 345   "Return the list of <vulnerability> for YEAR, assuming the on-disk cache has
 346 the given TTL (fetch from the NIST web site when TTL has expired)."
 347   (define (cache-miss uri)
 348     (format (current-error-port) "fetching CVE database for ~a...~%" year))
 349
 350   (define (read* port)
 351     ;; Disable read options to avoid populating the source property weak
 352     ;; table, which speeds things up, saves memory, and works around
 353     ;; <https://lists.gnu.org/archive/html/guile-devel/2017-09/msg00031.html>.
 354     (let ((options (read-options)))
 355       (dynamic-wind
 356         (lambda ()
 357           (read-disable 'positions))
 358         (lambda ()
 359           (read port))
 360         (lambda ()
 361           (read-options options)))))
 362
 363   ;; Note: We used to keep the original JSON files in cache but parsing it
 364   ;; would take typically ~15s for a year of data.  Thus, we instead store a
 365   ;; summarized version thereof as an sexp, which can be parsed in 1s or so.
 366   (let* ((port (http-fetch/cached (yearly-feed-uri year)
 367                                   #:ttl ttl
 368                                   #:write-cache write-cache
 369                                   #:cache-miss cache-miss
 370                                   #:timeout timeout))
 371          (sexp (read* port)))
 372     (close-port port)
 373     (match sexp
 374       (('vulnerabilities 1 vulns)
 375        (map sexp->vulnerability vulns)))))
 376
 377 (define* (current-vulnerabilities #:key (timeout 10))
 378   "Return the current list of Common Vulnerabilities and Exposures (CVE) as
 379 published by the US NIST.  TIMEOUT specifies the timeout in seconds for
 380 connection establishment."
 381   (let ((past-years (unfold (cut > <> 3)
 382                             (lambda (n)
 383                               (- %current-year n))
 384                             1+
 385                             1))
 386         (past-ttls  (unfold (cut > <> 3)
 387                             (lambda (n)
 388                               (* n %past-year-ttl))
 389                             1+
 390                             1)))
 391     (append-map (cut fetch-vulnerabilities <> <> #:timeout timeout)
 392                 (cons %current-year past-years)
 393                 (cons %current-year-ttl past-ttls))))
 394
 395 (define (vulnerabilities->lookup-proc vulnerabilities)
 396   "Return a lookup procedure built from VULNERABILITIES that takes a package
 397 name and optionally a version number.  When the version is omitted, the lookup
 398 procedure returns a list of vulnerabilities; otherwise, it returns a list of
 399 vulnerabilities affecting the given package version."
 400   (define table
 401     ;; Map package names to lists of version/vulnerability pairs.
 402     (fold (lambda (vuln table)
 403             (match vuln
 404               (($ <vulnerability> id packages)
 405                (fold (lambda (package table)
 406                        (match package
 407                          ((name . versions)
 408                           (vhash-cons name (cons vuln versions)
 409                                       table))))
 410                      table
 411                      packages))))
 412           vlist-null
 413           vulnerabilities))
 414
 415   (lambda* (package #:optional version)
 416     (vhash-fold* (if version
 417                      (lambda (pair result)
 418                        (match pair
 419                          ((vuln sexp)
 420                           (if (version-matches? version sexp)
 421                               (cons vuln result)
 422                               result))))
 423                      (lambda (pair result)
 424                        (match pair
 425                          ((vuln . _)
 426                           (cons vuln result)))))
 427                  '()
 428                  package table)))
 429
 430
 431 ;;; cve.scm ends here