me
/
guix
Archived
1
0
Fork 0
Code

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.
master
Ludovic Courtès 2021-05-11 15:01:00 +02:00
parent dc3504913d
commit 938ffcbb05
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 63 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
doc/guix.texi
View File

@ -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

30
guix/scripts/publish.scm
View File

@ -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>
;;;
@ -101,6 +101,8 @@ Publish ~a over HTTP.\n") %store-directory)
--workers=N use N workers to bake items"))
(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_ "
@ -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:

32
tests/publish.scm
View File

@ -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")))