diff options
| author | Christopher Baines <mail@cbaines.net> | 2022-01-22 17:03:04 +0000 |
|---|---|---|
| committer | Christopher Baines <mail@cbaines.net> | 2022-02-02 09:44:51 +0000 |
| commit | ce1dac19ef1790cc371fb3acb679a6ca871e4142 (patch) | |
| tree | 2c6c6494973d36fec8023f61a330380e79e32a60 | |
| parent | 3fdd97406d41e1d4d09d87d3e3fc31ea11f66937 (diff) | |
| download | nar-herder-ce1dac19ef1790cc371fb3acb679a6ca871e4142.tar nar-herder-ce1dac19ef1790cc371fb3acb679a6ca871e4142.tar.gz | |
Support specifying TTL's for narinfo responses
Using the same approach as guix publish.
| -rw-r--r-- | nar-herder/server.scm | 14 | ||||
| -rw-r--r-- | scripts/nar-herder.in | 27 |
2 files changed, 36 insertions, 5 deletions
diff --git a/nar-herder/server.scm b/nar-herder/server.scm index cab780c..8455d72 100644 --- a/nar-herder/server.scm +++ b/nar-herder/server.scm @@ -44,7 +44,8 @@ (("") '()) (() '())))) -(define (make-request-handler database storage-root) +(define* (make-request-handler database storage-root + #:key ttl negative-ttl) (define (narinfo? str) (and (= (string-length str) 40) @@ -65,9 +66,16 @@ database (string-take narinfo 32)))) (if narinfo-contents - (values '((content-type . (text/plain))) + (values `((content-type . (text/plain)) + ,@(if ttl + `((cache-control (max-age . ,ttl))) + '())) narinfo-contents) - (values (build-response #:code 404) + (values (build-response #:code 404 + #:headers (if negative-ttl + `((cache-control + (max-age . ,negative-ttl))) + '())) "404")))) (('GET (? narinfo? narinfo) "info") (let ((narinfo-contents diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in index a969910..1cc5a67 100644 --- a/scripts/nar-herder.in +++ b/scripts/nar-herder.in @@ -48,7 +48,7 @@ (fibers) (fibers conditions) (fibers web server) - ((guix ui) #:select (read/eval)) + ((guix ui) #:select (read/eval string->duration)) (guix progress) (guix narinfo) (guix derivations) @@ -116,6 +116,27 @@ (cons (string->symbol sym) rest))) result))) + (option '("ttl") #t #f + (lambda (opt name arg result) + (let ((duration (string->duration arg))) + (unless duration + (simple-format (current-error-port) + "~A: invalid duration\n" + arg) + (exit 1)) + (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 + (simple-format (current-error-port) + "~A: invalid duration\n" + arg) + (exit 1)) + (alist-cons 'narinfo-negative-ttl (time-second duration) + result)))) + (option '("recent-changes-limit") #t #f (lambda (opt name arg result) (alist-cons 'recent-changes-limit @@ -318,6 +339,8 @@ "starting server\n") (run-server (make-request-handler database - canonical-storage) + canonical-storage + #:ttl (assq-ref opts 'narinfo-ttl) + #:negative-ttl (assq-ref opts 'narinfo-negative-ttl)) #:host (assq-ref opts 'host) #:port (assq-ref opts 'port)))))) |