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.

3 files changed, 63 insertions, 9 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index bfc714c5b68..a10943f2d55 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -12703,6 +12703,16 @@ Additionally, when @option{--cache} is used, cached entries that have
 not been accessed for @var{ttl} and that no longer have a corresponding
 item in the store, may be deleted.
 
+@item --negative-ttl=@var{ttl}
+Similarly produce @code{Cache-Control} HTTP headers to advertise the
+time-to-live (TTL) of @emph{negative} lookups---missing store items, for
+which the HTTP 404 code is returned.  By default, no negative TTL is
+advertised.
+
+This parameter can help adjust server load and substitute latency by
+instructing cooperating clients to be more or less patient when a store
+item is missing.
+
 @item --cache-bypass-threshold=@var{size}
 When used in conjunction with @option{--cache}, store items smaller than
 @var{size} are immediately available, even when they are not yet in
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 39bb224cad2..ef6fa5f074a 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/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 © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
@@ -102,6 +102,8 @@ Publish ~a over HTTP.\n") %store-directory)
   (display (G_ "
       --ttl=TTL          announce narinfos can be cached for TTL seconds"))
   (display (G_ "
+      --negative-ttl=TTL announce missing narinfos can be cached for TTL seconds"))
+  (display (G_ "
       --nar-path=PATH    use PATH as the prefix for nar URLs"))
   (display (G_ "
       --public-key=FILE  use FILE as the public key for signatures"))
@@ -224,6 +226,13 @@ usage."
                       (leave (G_ "~a: invalid duration~%") arg))
                     (alist-cons 'narinfo-ttl (time-second duration)
                                 result))))
+        (option '("negative-ttl") #t #f
+                (lambda (opt name arg result)
+                  (let ((duration (string->duration arg)))
+                    (unless duration
+                      (leave (G_ "~a: invalid duration~%") arg))
+                    (alist-cons 'narinfo-negative-ttl (time-second duration)
+                                result))))
         (option '("nar-path") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'nar-path arg result)))
@@ -390,14 +399,14 @@ References: ~a~%"
 
 (define* (render-narinfo store request hash
                          #:key ttl (compressions (list %no-compression))
-                         (nar-path "nar"))
+                         (nar-path "nar") negative-ttl)
   "Render metadata for the store path corresponding to HASH.  If TTL is true,
 advertise it as the maximum validity period (in seconds) via the
 'Cache-Control' header.  This allows 'guix substitute' to cache it for an
 appropriate duration.  NAR-PATH specifies the prefix for nar URLs."
   (let ((store-path (hash-part->path store hash)))
     (if (string-null? store-path)
-        (not-found request #:phrase "")
+        (not-found request #:phrase "" #:ttl negative-ttl)
         (values `((content-type . (application/x-nix-narinfo))
                   ,@(if ttl
                         `((cache-control (max-age . ,ttl)))
@@ -512,7 +521,7 @@ interpreted as the basename of a store item."
 
 (define* (render-narinfo/cached store request hash
                                 #:key ttl (compressions (list %no-compression))
-                                (nar-path "nar")
+                                (nar-path "nar") negative-ttl
                                 cache pool)
   "Respond to the narinfo request for REQUEST.  If the narinfo is available in
 CACHE, then send it; otherwise, return 404 and \"bake\" that nar and narinfo
@@ -536,7 +545,7 @@ requested using POOL."
                                                 #:compression
                                                 (first compressions)))))
     (cond ((string-null? item)
-           (not-found request))
+           (not-found request #:ttl negative-ttl))
           ((file-exists? cached)
            ;; Narinfo is in cache, send it.
            (values `((content-type . (application/x-nix-narinfo))
@@ -584,7 +593,7 @@ requested using POOL."
                           #:phrase "We're baking it"
                           #:ttl 300)))          ;should be available within 5m
           (else
-           (not-found request #:phrase "")))))
+           (not-found request #:phrase "" #:ttl negative-ttl)))))
 
 (define (compress-nar cache item compression)
   "Save in directory CACHE the nar for ITEM compressed with COMPRESSION."
@@ -974,7 +983,7 @@ methods, return the applicable compression."
 (define* (make-request-handler store
                                #:key
                                cache pool
-                               narinfo-ttl
+                               narinfo-ttl narinfo-negative-ttl
                                (nar-path "nar")
                                (compressions (list %no-compression)))
   (define compression-type?
@@ -1006,10 +1015,12 @@ methods, return the applicable compression."
                                       #:cache cache
                                       #:pool pool
                                       #:ttl narinfo-ttl
+                                      #:negative-ttl narinfo-negative-ttl
                                       #:nar-path nar-path
                                       #:compressions compressions)
                (render-narinfo store request hash
                                #:ttl narinfo-ttl
+                               #:negative-ttl narinfo-negative-ttl
                                #:nar-path nar-path
                                #:compressions compressions)))
           ;; /nar/file/NAME/sha256/HASH
@@ -1068,7 +1079,7 @@ methods, return the applicable compression."
                              #:key
                              advertise? port
                              (compressions (list %no-compression))
-                             (nar-path "nar") narinfo-ttl
+                             (nar-path "nar") narinfo-ttl narinfo-negative-ttl
                              cache pool)
   (when advertise?
     (let ((name (service-name)))
@@ -1084,6 +1095,7 @@ methods, return the applicable compression."
                                     #:pool pool
                                     #:nar-path nar-path
                                     #:narinfo-ttl narinfo-ttl
+                                    #:narinfo-negative-ttl narinfo-negative-ttl
                                     #:compressions compressions)
               concurrent-http-server
               `(#:socket ,socket)))
@@ -1127,6 +1139,7 @@ methods, return the applicable compression."
            (user        (assoc-ref opts 'user))
            (port        (assoc-ref opts 'port))
            (ttl         (assoc-ref opts 'narinfo-ttl))
+           (negative-ttl (assoc-ref opts 'narinfo-negative-ttl))
            (compressions (match (filter-map (match-lambda
                                               (('compression . compression)
                                                compression)
@@ -1192,6 +1205,7 @@ consider using the '--user' option!~%")))
                                                            "publish worker"))
                               #:nar-path nar-path
                               #:compressions compressions
+                              #:narinfo-negative-ttl negative-ttl
                               #:narinfo-ttl ttl))))))
 
 ;;; Local Variables:
diff --git a/tests/publish.scm b/tests/publish.scm
index 3e67c435acf..c3d086995ab 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")))