02/02: publish: Add '--ttl'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit e4c7a5f7c87b2927f1092108f181f44c96377633
Author: Ludovic Courtès <address@hidden>
Date:   Thu Jun 9 23:33:20 2016 +0200

    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'.
---
 doc/guix.texi            |   10 ++++++++++
 guix/scripts/publish.scm |   36 ++++++++++++++++++++++++++++--------
 2 files changed, 38 insertions(+), 8 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 9b36468..1f766fc 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5545,6 +5545,16 @@ accept connections from any interface.
 Change privileges to @var{user} as soon as possible---i.e., once the
 server socket is open and the signing key has been read.
 
address@hidden address@hidden
+Produce @code{Cache-Control} HTTP headers that advertise a time-to-live
+(TTL) of @var{ttl}.  @var{ttl} must denote a duration: @code{5d} means 5
+days, @code{1m} means 1 month, and so on.
+
+This allows the user's Guix to keep substitute information in cache for
address@hidden  However, note that @code{guix publish} does not itself
+guarantee that the store items it provides will indeed remain available
+for as long as @var{ttl}.
+
 @item address@hidden
 @itemx -r address@hidden
 Spawn a Guile REPL server (@pxref{REPL Servers,,, guile, GNU Guile
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index ddb579b..4c0aa8e 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)))))