;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(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)
  #:export (vulnerability?
            vulnerability-id
            vulnerability-packages

            xml->vulnerabilities
            current-vulnerabilities
            vulnerabilities->lookup-proc))

;;; Commentary:
;;;
;;; This modules provides the tools to fetch, parse, and digest part of the
;;; Common Vulnerabilities and Exposures (CVE) feeds provided by the US NIST
;;; at <https://nvd.nist.gov/download.cfm#CVE_FEED>.
;;;
;;; Code:

(define-record-type <vulnerability>
  (vulnerability id packages)
  vulnerability?
  (id         vulnerability-id)                   ;string
  (packages   vulnerability-packages))            ;((p1 v1 v2 v3) (p2 v1) ...)

(define %now
  (current-date))
(define %current-year
  (date-year %now))
(define %past-year
  (- %current-year 1))

(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-"
                  (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))

(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 uri)))
    (dynamic-wind
      (const #t)
      (lambda ()
        (call-with-decompressed-port 'gzip port
          (lambda (port)
            (setvbuf port _IOFBF 65536)
            (proc port))))
      (lambda ()
        (close-port port)))))

(define %cpe-package-rx
  ;; The CPE syntax as defined in the CPE 2.2 specs from
  ;; <https://cpe.mitre.org/specification/2.2/cpe-specification_2.2.pdf>.
  ;;
  ;; For applications: "cpe:/a:VENDOR:PACKAGE:VERSION", or sometimes
  ;; "cpe/a:VENDOR:PACKAGE:VERSION:PATCH-LEVEL"; in some cases, simply
  ;; "cpe:/a:VENDOR:PACKAGE", meaning that the affected versions are not
  ;; specified.
  (make-regexp "^c[pP][eE]:/[aA]:([^:]+):(.*)"))

(define %not-colon
  (char-set-complement (char-set #\:)))

(define (cpe->package-name cpe)
  "Converts the Common Platform Enumeration (CPE) string CPE to a package
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 (rx-match)
           (match (string-tokenize (match:substring rx-match 2)
                                   %not-colon)
             ((package)
              ;; No version component, as in
              ;; "cpe:/a:littlecms:little_cms_color_engine".
              (values package 'any))
             ((package version _ ...)
              ;; Ignore the "patch level" part if there is one, as in
              ;; "cpe:/a:openbsd:openssh:6.8:p1".
              (values package version)))))
        (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\"))
"
  (define (version-cons v lst)
    (cond ((eq? v 'any) 'any)
          ((eq? lst 'any) 'any)
          (else (cons v lst))))

  (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 (version-cons version versions) tail)
                       (alist-cons name (version-cons version '()) result)))
                  (()
                   (alist-cons name (version-cons version '()) result)))
                result)))
        '()
        (sort products string<?)))

(define %parse-vulnerability-feed
  ;; Parse the XML vulnerability feed from
  ;; <https://nvd.nist.gov/download.cfm#CVE_FEED> and return a list of
  ;; vulnerability objects.
  (ssax:make-parser NEW-LEVEL-SEED
                    (lambda (elem-gi attributes namespaces expected-content
                                     seed)
                      (match elem-gi
                        ((name-space . 'entry)
                         (cons (assoc-ref attributes 'id) seed))
                        ((name-space . 'vulnerable-software-list)
                         (cons '() seed))
                        ((name-space . 'product)
                         (cons 'product seed))
                        (x seed)))

                    FINISH-ELEMENT
                    (lambda (elem-gi attributes namespaces parent-seed
                                     seed)
                      (match elem-gi
                        ((name-space . 'entry)
                         (match seed
                           (((? string? id) . rest)
                            ;; Some entries have no vulnerable-software-list.
                            rest)
                           ((products id . rest)
                            (match (cpe->product-alist products)
                              (()
                               ;; No application among PRODUCTS.
                               rest)
                              (packages
                               (cons (vulnerability id packages)
                                     rest))))))
                        (x
                         seed)))

                    CHAR-DATA-HANDLER
                    (lambda (str _ seed)
                      (match seed
                        (('product software-list . rest)
                         ;; Add STR to the vulnerable software list this
                         ;; <product> tag is part of.
                         (cons (cons str software-list) rest))
                        (x x)))))

(define (xml->vulnerabilities port)
  "Read from PORT an XML feed of vulnerabilities and return a list of
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 (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)))))

  (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 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)
            (match vuln
              (($ <vulnerability> id packages)
               (fold (lambda (package table)
                       (match package
                         ((name . versions)
                          (vhash-cons name (cons vuln versions)
                                      table))))
                     table
                     packages))))
          vlist-null
          vulnerabilities))

  (lambda* (package #:optional version)
    (vhash-fold* (if version
                     (lambda (pair result)
                       (match pair
                         ((vuln . 'any)
                          (cons vuln result))
                         ((vuln . versions)
                          (if (member version versions)
                              (cons vuln result)
                              result))))
                     (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