mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-18 21:46:35 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source 
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!'.
This commit is contained in:
Ludovic Courtès 2016-03-16 15:31:18 +01:00
parent 1cf7e31898
commit 23d60ba65c
1 changed files with 13 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
guix/scripts/substitute.scm
View file

@ -108,9 +108,8 @@ (define %allow-unauthenticated-substitutes?
(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 @@ (define cache-file
(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 @@ (define (cache-entry cache-uri narinfo)
`(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 @@ (define update-progress!
(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 @@ (define (handle-narinfo-response request response port result)
(read-to-eof port))
(cache-narinfo! url
(find (cut string-contains <> hash-part) paths)
#f)
#f ttl)
(update-progress!)
result))
(else ; transient failure