02/02: substitute: Honor the 'max-age' of 'Cache-Control' headers.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 23d60ba65c137abf472a25db7317154abfc4af4d
Author: Ludovic Courtès <address@hidden>
Date:   Wed Mar 16 15:31:18 2016 +0100

    substitute: Honor the 'max-age' of 'Cache-Control' headers.
    
    This allows substitute servers to tell 'guix substitute' how long they
    can cache narinfo lookups.
    
    * guix/scripts/substitute.scm (cache-narinfo!): Add 'ttl' parameter.
    [cache-entry]: Honor it.
    (fetch-narinfos)[handle-narinfo-response]: Check the 'Cache-Control'
    header of RESPONSE and pass its 'max-age' value to 'cache-narinfo!'.
---
 guix/scripts/substitute.scm |   23 +++++++++++++----------
 1 files changed, 13 insertions(+), 10 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 4b009d8..b707acc 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -108,9 +108,8 @@ disabled!~%"))
 
 (define %narinfo-ttl
   ;; Number of seconds during which cached narinfo lookups are considered
-  ;; valid.  This is a reasonable default value (corresponds to the TTL for
-  ;; nginx's .nar cache on hydra.gnu.org) but we'd rather want publishers to
-  ;; state what their TTL is in /nix-cache-info.  (XXX)
+  ;; valid for substitute servers that do not advertise a TTL via the
+  ;; 'Cache-Control' response header.
   (* 36 3600))
 
 (define %narinfo-negative-ttl
@@ -471,9 +470,10 @@ for PATH."
     (lambda _
       (values #f #f))))
 
-(define (cache-narinfo! cache-url path narinfo)
-  "Cache locally NARNIFO for PATH, which originates from CACHE-URL.  NARINFO
-may be #f, in which case it indicates that PATH is unavailable at CACHE-URL."
+(define (cache-narinfo! cache-url path narinfo ttl)
+  "Cache locally NARNIFO for PATH, which originates from CACHE-URL, with the
+given TTL (a number of seconds or #f).  NARINFO may be #f, in which case it
+indicates that PATH is unavailable at CACHE-URL."
   (define now
     (current-time time-monotonic))
 
@@ -481,7 +481,8 @@ may be #f, in which case it indicates that PATH is 
unavailable at CACHE-URL."
     `(narinfo (version 2)
               (cache-uri ,cache-uri)
               (date ,(time-second now))
-              (ttl ,%narinfo-ttl)                 ;TODO: Make this per-entry.
+              (ttl ,(or ttl
+                        (if narinfo %narinfo-ttl %narinfo-negative-ttl)))
               (value ,(and=> narinfo narinfo->string))))
 
   (let ((file (narinfo-cache-file cache-url path)))
@@ -584,13 +585,15 @@ if file doesn't exist, and the narinfo otherwise."
         (set! done (+ 1 done)))))
 
   (define (handle-narinfo-response request response port result)
-    (let ((len (response-content-length response)))
+    (let* ((len    (response-content-length response))
+           (cache  (response-cache-control response))
+           (ttl    (and cache (assoc-ref cache 'max-age))))
       ;; Make sure to read no more than LEN bytes since subsequent bytes may
       ;; belong to the next response.
       (case (response-code response)
         ((200)                                     ; hit
          (let ((narinfo (read-narinfo port url #:size len)))
-           (cache-narinfo! url (narinfo-path narinfo) narinfo)
+           (cache-narinfo! url (narinfo-path narinfo) narinfo ttl)
            (update-progress!)
            (cons narinfo result)))
         ((404)                                     ; failure
@@ -601,7 +604,7 @@ if file doesn't exist, and the narinfo otherwise."
                (read-to-eof port))
            (cache-narinfo! url
                            (find (cut string-contains <> hash-part) paths)
-                           #f)
+                           #f ttl)
            (update-progress!)
            result))
         (else                                      ; transient failure