publish: Add '--ttl'.

* guix/scripts/publish.scm (show-help, %options): Add --ttl.
(render-narinfo): Add #:ttl and honor it.
(make-request-handler): Add #:narinfo-ttl and honor it.
(run-publish-server): Likewise.
(guix-publish): Honor --ttl, pass it to 'run-publish-server'.

1 files changed, 28 insertions, 8 deletions

diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index ddb579bb17..4c0aa8e419 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -28,6 +28,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
   #:use-module (web http)
@@ -58,6 +59,8 @@ Publish ~a over HTTP.\n") %store-directory)
   (display (_ "
   -u, --user=USER        change privileges to USER as soon as possible"))
   (display (_ "
+      --ttl=TTL          announce narinfos can be cached for TTL seconds"))
+  (display (_ "
   -r, --repl[=PORT]      spawn REPL server on PORT"))
   (newline)
   (display (_ "
@@ -99,6 +102,13 @@ Publish ~a over HTTP.\n") %store-directory)
                     (()
                      (leave (_ "lookup of host '~a' returned nothing")
                             name)))))
+        (option '("ttl") #t #f
+                (lambda (opt name arg result)
+                  (let ((duration (string->duration arg)))
+                    (unless duration
+                      (leave (_ "~a: invalid duration~%") arg))
+                    (alist-cons 'narinfo-ttl (time-second duration)
+                                result))))
         (option '(#\r "repl") #f #t
                 (lambda (opt name arg result)
                   ;; If port unspecified, use default Guile REPL port.
@@ -199,12 +209,18 @@ References: ~a~%"
                         (format port "~a: ~a~%" key value)))
                       %nix-cache-info))))
 
-(define (render-narinfo store request hash)
-  "Render metadata for the store path corresponding to HASH."
+(define* (render-narinfo store request hash #:key 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."
   (let ((store-path (hash-part->path store hash)))
     (if (string-null? store-path)
         (not-found request)
-        (values '((content-type . (application/x-nix-narinfo)))
+        (values `((content-type . (application/x-nix-narinfo))
+                  ,@(if ttl
+                        `((cache-control (max-age . ,ttl)))
+                        '()))
                 (cut display
                      (narinfo-string store store-path (force %private-key))
                      <>)))))
@@ -300,7 +316,7 @@ blocking."
   http-write
   (@@ (web server http) http-close))
 
-(define (make-request-handler store)
+(define* (make-request-handler store #:key narinfo-ttl)
   (lambda (request body)
     (format #t "~a ~a~%"
             (request-method request)
@@ -312,15 +328,18 @@ blocking."
            (render-nix-cache-info))
           ;; /<hash>.narinfo
           (((= extract-narinfo-hash (? string? hash)))
-           (render-narinfo store request hash))
+           ;; TODO: Register roots for HASH that will somehow remain for
+           ;; NARINFO-TTL.
+           (render-narinfo store request hash #:ttl narinfo-ttl))
           ;; /nar/<store-item>
           (("nar" store-item)
            (render-nar store request store-item))
           (_ (not-found request)))
         (not-found request))))
 
-(define (run-publish-server socket store)
-  (run-server (make-request-handler store)
+(define* (run-publish-server socket store
+                             #:key narinfo-ttl)
+  (run-server (make-request-handler store #:narinfo-ttl narinfo-ttl)
               concurrent-http-server
               `(#:socket ,socket)))
 
@@ -358,6 +377,7 @@ blocking."
                                 %default-options))
            (user    (assoc-ref opts 'user))
            (port    (assoc-ref opts 'port))
+           (ttl     (assoc-ref opts 'narinfo-ttl))
            (address (let ((addr (assoc-ref opts 'address)))
                       (make-socket-address (sockaddr:fam addr)
                                            (sockaddr:addr addr)
@@ -384,4 +404,4 @@ consider using the '--user' option!~%")))
       (when repl-port
         (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
       (with-store store
-        (run-publish-server socket store)))))
+        (run-publish-server socket store #:narinfo-ttl ttl)))))