02/06: cve: Use 'http-fetch/cached' instead of having custom caching.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 7482b98120b5e3380129719f13254b90b18553b9
Author: Ludovic Courtès <address@hidden>
Date:   Wed Nov 15 10:23:38 2017 +0100

    cve: Use 'http-fetch/cached' instead of having custom caching.
    
    That way CVE fetching benefits from 'If-Modified-Since' handling.
    
    * guix/http-client.scm (http-fetch/cached): Add #:write-cache and
     #:cache-miss parameters and honor them.
    * guix/cve.scm (%current-year-ttl, %past-year-ttl): Reduce.
    (call-with-cve-port): Remove.
    (write-cache): New procedure.
    (fetch-vulnerabilities): Rewrite in terms of 'http-fetch/cached'.
---
 guix/cve.scm         | 94 ++++++++++++++++++----------------------------------
 guix/http-client.scm | 13 ++++++--
 2 files changed, 42 insertions(+), 65 deletions(-)

diff --git a/guix/cve.scm b/guix/cve.scm
index 38e5994..070acfe 100644
--- a/guix/cve.scm
+++ b/guix/cve.scm
@@ -19,7 +19,6 @@
 (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)
@@ -68,24 +67,11 @@
 (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 uri)))
-    (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
@@ -194,40 +180,27 @@ vulnerability objects."
     (('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)
+(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 port)))))
+          (xml->vulnerabilities input)))
 
-  (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))
+      (write `(vulnerabilities
+               1                                  ;format version
+               ,(map vulnerability->sexp vulns))
+             cache))))
 
-  (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))))
+(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
@@ -242,17 +215,18 @@ the given TTL (fetch from the NIST web site when TTL has 
expired)."
         (lambda ()
           (read-options options)))))
 
-  (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))))
+  ;; 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
@@ -307,8 +281,4 @@ vulnerabilities affecting the given package version."
                  package table)))
 
 
-;;; Local Variables:
-;;; eval: (put 'call-with-cve-port 'scheme-indent-function 2)
-;;; End:
-
 ;;; cve.scm ends here
diff --git a/guix/http-client.scm b/guix/http-client.scm
index 59788c1..bab3187 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -302,9 +302,15 @@ Raise an '&http-get-error' condition if downloading fails."
                    (base64-encode digest 0 (bytevector-length digest)
                                   #f #f base64url-alphabet))))
 
-(define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?)
+(define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?
+                            (write-cache dump-port)
+                            (cache-miss (const #t)))
   "Like 'http-fetch', return an input port, but cache its contents in
-~/.cache/guix.  The cache remains valid for TTL seconds."
+~/.cache/guix.  The cache remains valid for TTL seconds.
+
+Call WRITE-CACHE with the HTTP input port and the cache output port to write
+the data to cache.  Call CACHE-MISS with URI just before fetching data from
+URI."
   (let ((file (cache-file-for-uri uri)))
     (define (update-cache cache-port)
       (define cache-time
@@ -327,11 +333,12 @@ Raise an '&http-get-error' condition if downloading 
fails."
                      (raise c))))
         (let ((port (http-fetch uri #:text? text?
                                 #:headers headers)))
+          (cache-miss uri)
           (mkdir-p (dirname file))
           (when cache-port
             (close-port cache-port))
           (with-atomic-file-output file
-            (cut dump-port port <>))
+            (cut write-cache port <>))
           (close-port port)
           (open-input-file file))))