nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

publish: Add a 'Cache-Control' header on /nar responses. 

Fixes <https://bugs.gnu.org/33721>.
Reported by Chris Marusich <cmmarusich@gmail.com>.

* guix/scripts/publish.scm (render-nar/cached): Add #:ttl and honor it.
(make-request-handler): Pass #:ttl to 'render-nar/cached'.
* tests/publish.scm ("with cache, uncompressed"): Pass "--ttl=42h" to
'guix publish'.  Check 'Cache-Control' on narinfo response and on nar
response.
This commit is contained in:
Ludovic Courtès 2018-12-17 23:01:51 +01:00
parent a93c160631
commit 9b9de08477
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 24 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
guix/scripts/publish.scm
View File

@ -537,14 +537,19 @@ requested using POOL."
(not-found request))))
(define* (render-nar/cached store cache request store-item
#:key (compression %no-compression))
#:key ttl (compression %no-compression))
"Respond to REQUEST with a nar for STORE-ITEM. If the nar is in CACHE,
return it; otherwise, return 404."
return it; otherwise, return 404. When TTL is true, use it as the
'Cache-Control' expiration time."
(let ((cached (nar-cache-file cache store-item
#:compression compression)))
(if (file-exists? cached)
(values `((content-type . (application/octet-stream
(charset . "ISO-8859-1")))
,@(if ttl
`((cache-control (max-age . ,ttl)))
'())
;; XXX: We're not returning the actual contents, deferring
;; instead to 'http-write'. This is a hack to work around
;; <http://bugs.gnu.org/21093>.
@ -819,6 +824,7 @@ blocking."
%default-gzip-compression))))
(if cache
(render-nar/cached store cache request store-item
#:ttl narinfo-ttl
#:compression compression)
(render-nar store request store-item
#:compression compression)))
@ -829,6 +835,7 @@ blocking."
(if (nar-path? components)
(if cache
(render-nar/cached store cache request store-item
#:ttl narinfo-ttl
#:compression %no-compression)
(render-nar store request store-item
#:compression %no-compression))

17
tests/publish.scm
View File

@ -411,10 +411,12 @@ FileSize: ~a~%"
(random-text))))
(test-equal "with cache, uncompressed"
(list #t
(* 42 3600) ;TTL on narinfo
`(("StorePath" . ,item)
("URL" . ,(string-append "nar/" (basename item)))
("Compression" . "none"))
200 ;nar/…
(* 42 3600) ;TTL on nar/…
(path-info-nar-size
(query-path-info %store item)) ;FileSize
404) ;nar/gzip/…
@ -423,7 +425,7 @@ FileSize: ~a~%"
(let ((thread (with-separate-output-ports
(call-with-new-thread
(lambda ()
(guix-publish "--port=6796" "-C2"
(guix-publish "--port=6796" "-C2" "--ttl=42h"
(string-append "--cache=" cache)))))))
(wait-until-ready 6796)
(let* ((base "http://localhost:6796/")
@ -437,13 +439,19 @@ FileSize: ~a~%"
(and (= 404 (response-code response))
(wait-for-file cached)
(let* ((body (http-get-port url))
(let* ((response (http-get url))
(body (http-get-port url))
(compressed (http-get (string-append base "nar/gzip/"
(basename item))))
(uncompressed (http-get (string-append base "nar/"
(basename item))))
(narinfo (recutils->alist body)))
(list (file-exists? nar)
(match (assq-ref (response-headers response)
'cache-control)
((('max-age . ttl)) ttl)
(_ #f))
(filter (lambda (item)
(match item
(("Compression" . _) #t)
@ -452,6 +460,11 @@ FileSize: ~a~%"
(_ #f)))
narinfo)
(response-code uncompressed)
(match (assq-ref (response-headers uncompressed)
'cache-control)
((('max-age . ttl)) ttl)
(_ #f))
(string->number
(assoc-ref narinfo "FileSize"))
(response-code compressed))))))))))