publish: Add '--negative-ttl'.

* guix/scripts/publish.scm (show-help, %options): Add '--negative-ttl'.
(render-narinfo, render-narinfo/cached, make-request-handler): Add #:negative-ttl
and honor it.
(run-publish-server): Add #:narinfo-negative-ttl and honor it.
(guix-publish): Honor '--negative-ttl'.
* tests/publish.scm ("negative TTL", "no negative TTL"): New tests.

1 files changed, 31 insertions, 1 deletions

diff --git a/tests/publish.scm b/tests/publish.scm
index 3e67c435ac..c3d086995a 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
 ;;; Copyright © 2020 by Amar M. Singh <nly@disroot.org>
-;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -700,6 +700,36 @@ References: ~%"
             (= (response-content-length response) (stat:size (stat log)))
             (first (response-content-type response))))))
 
+(test-equal "negative TTL"
+  `(404 42)
+
+  (call-with-temporary-directory
+   (lambda (cache)
+     (let ((thread (with-separate-output-ports
+                    (call-with-new-thread
+                     (lambda ()
+                       (guix-publish "--port=6786" "-C0"
+                                     "--negative-ttl=42s"))))))
+       (wait-until-ready 6786)
+
+       (let* ((base     "http://localhost:6786/")
+              (url      (string-append base (make-string 32 #\z)
+                                       ".narinfo"))
+              (response (http-get url)))
+         (list (response-code response)
+               (match (assq-ref (response-headers response) 'cache-control)
+                 ((('max-age . ttl)) ttl)
+                 (_ #f))))))))
+
+(test-equal "no negative TTL"
+  `(404 #f)
+  (let* ((uri      (publish-uri
+                    (string-append "/" (make-string 32 #\z)
+                                   ".narinfo")))
+         (response (http-get uri)))
+    (list (response-code response)
+          (assq-ref (response-headers response) 'cache-control))))
+
 (test-equal "/log/NAME not found"
   404
   (let ((uri (publish-uri "/log/does-not-exist")))