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.

2 files changed, 24 insertions, 4 deletions

diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index c5326b33da..a236f3e45c 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -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))
diff --git a/tests/publish.scm b/tests/publish.scm
index 0e793c1ee5..79a786e723 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -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))))))))))