From 676713e9d943ad2e912a7faad1b01522f9f7884b Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Fri, 15 Mar 2024 15:54:34 +0000
Subject: Add more TTL options

I'm really not sure about this caching stuff, but these options should
provide the flexibility to change the TTLs the nar-herder advertises
gracefully.
---
 nar-herder/server.scm | 24 +++++++++++++++---------
 scripts/nar-herder.in | 32 ++++++++++++++++++++++++++++++++
 2 files changed, 47 insertions(+), 9 deletions(-)

diff --git a/nar-herder/server.scm b/nar-herder/server.scm
index 2c68dad..d84424d 100644
--- a/nar-herder/server.scm
+++ b/nar-herder/server.scm
@@ -222,7 +222,8 @@
       "\n"))))
 
 (define* (make-request-handler database storage-root
-                               #:key ttl negative-ttl logger
+                               #:key base-ttl base-cached-compressions-ttl
+                               negative-ttl logger
                                metrics-registry
                                maybe-trigger-creation-of-compressed-nars)
   (define hostname
@@ -797,14 +798,19 @@
                      (assq-ref opts 'host) ":" (assq-ref opts 'port))
 
             (run-server/patched
-             (make-request-handler database
-                                   canonical-storage
-                                   #:ttl (assq-ref opts 'narinfo-ttl)
-                                   #:negative-ttl (assq-ref opts 'narinfo-negative-ttl)
-                                   #:logger lgr
-                                   #:metrics-registry metrics-registry
-                                   #:maybe-trigger-creation-of-compressed-nars
-                                   maybe-trigger-creation-of-compressed-nars)
+             (make-request-handler
+              database
+              canonical-storage
+              #:base-ttl (or (assq-ref opts 'narinfo-new-ttl)
+                             (assq-ref opts 'narinfo-ttl))
+              #:base-cached-compressions-ttl
+              (or (assq-ref opts 'new-cached-compressions-narinfo-ttl)
+                  (assq-ref opts 'cached-compressions-narinfo-ttl))
+              #:negative-ttl (assq-ref opts 'narinfo-negative-ttl)
+              #:logger lgr
+              #:metrics-registry metrics-registry
+              #:maybe-trigger-creation-of-compressed-nars
+              maybe-trigger-creation-of-compressed-nars)
              #:host (assq-ref opts 'host)
              #:port (assq-ref opts 'port))
 
diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in
index cfa4fe7..e81da92 100644
--- a/scripts/nar-herder.in
+++ b/scripts/nar-herder.in
@@ -219,6 +219,38 @@
                       (exit 1))
                     (alist-cons 'narinfo-ttl (time-second duration)
                                 result))))
+        (option '("new-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 'new-narinfo-ttl (time-second duration)
+                                result))))
+        (option '("cached-compressions-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 'cached-compressions-narinfo-ttl
+                                (time-second duration)
+                                result))))
+        (option '("new-cached-compressions-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 'new-cached-compressions-narinfo-ttl
+                                (time-second duration)
+                                result))))
         (option '("negative-ttl") #t #f
                 (lambda (opt name arg result)
                   (let ((duration (string->duration arg)))
-- 
cgit v1.2.3