aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-06-09 23:33:20 +0200
committerLudovic Courtès <ludo@gnu.org>2016-06-09 23:34:56 +0200
commite4c7a5f7c87b2927f1092108f181f44c96377633 (patch)
tree50939cf246449a160150bf4ca81b75239847f3f5
parent638c5b79397aba92ab3211a1ea3b3418e112ec66 (diff)
downloadguix-e4c7a5f7c87b2927f1092108f181f44c96377633.tar
guix-e4c7a5f7c87b2927f1092108f181f44c96377633.tar.gz
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'.
-rw-r--r--doc/guix.texi10
-rw-r--r--guix/scripts/publish.scm36
2 files changed, 38 insertions, 8 deletions
diff --git a/doc/guix.texi b/doc/guix.texi
index 9b36468557..1f766fc13b 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.
+@item --ttl=@var{ttl}
+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
+@var{ttl}. 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 --repl[=@var{port}]
@itemx -r [@var{port}]
Spawn a Guile REPL server (@pxref{REPL Servers,,, guile, GNU Guile
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)))))