From a1b49b3b45e5484cb93419be3711b6ab85495bee Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sun, 24 Mar 2024 09:30:06 +0000
Subject: Rework the cached compressions system

The initial implementation was flawed since guix assumes that any
compression mentioned in the narinfo will be available for the
lifetime of the narinfo, and the nar-herder was deleting cached
compressions without taking this in to account.

This commit adds support for scheduling the removal of a cached
compression and this schedule is used to inform the TTLs for narinfos.

I'm unsure of the value in caching narinfos so maybe some of this
complexity can be removed in the future.
---
 scripts/nar-herder.in | 68 ++++++++++++++++++++++++++++++++++++++-------------
 1 file changed, 51 insertions(+), 17 deletions(-)

(limited to 'scripts')

diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in
index e81da92..e4ce9c2 100644
--- a/scripts/nar-herder.in
+++ b/scripts/nar-herder.in
@@ -208,18 +208,49 @@
                               arg
                               (alist-delete 'cached-compression-nar-source
                                             result))))
-
-        (option '("ttl") #t #f
+        (option '("cached-compressions-unused-removal-duration") #t #f
                 (lambda (opt name arg result)
-                  (let ((duration (string->duration arg)))
-                    (unless duration
-                      (simple-format (current-error-port)
-                                     "~A: invalid duration\n"
-                                     arg)
+                  (alist-cons
+                   'cached-compression-unused-removal-duration
+                   (match (string-split arg #\=)
+                     ((_)
+                      (simple-format
+                       (current-error-port)
+                       "cached-compressions-unused-removal-duration: you must specify compression and value\n")
                       (exit 1))
-                    (alist-cons 'narinfo-ttl (time-second duration)
-                                result))))
-        (option '("new-ttl") #t #f
+                     ((type duration-string)
+                      (cons (string->symbol type)
+                            (let ((duration (string->duration duration-string)))
+                              (unless duration
+                                (simple-format
+                                 (current-error-port)
+                                 "~A: cached-compressions-unused-removal-duration: invalid duration\n"
+                                 arg)
+                                (exit 1))
+
+                              duration))))
+                   result)))
+        (option '("cached-compressions-ttl") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'cached-compression-ttl
+                              (match (string-split arg #\=)
+                                ((_)
+                                 (simple-format
+                                  (current-error-port)
+                                  "cached-compressions-ttl: you must specify compression and value\n")
+                                 (exit 1))
+                                ((type ttl-string)
+                                 (let ((duration (string->duration ttl-string)))
+                                   (unless duration
+                                     (simple-format (current-error-port)
+                                                    "~A: invalid duration\n"
+                                                    arg)
+                                     (exit 1))
+
+                                   (cons (string->symbol type)
+                                         (time-second duration)))))
+                              result)))
+        (option '("cached-compressions-new-ttl") #t #f
                 (lambda (opt name arg result)
                   (let ((duration (string->duration arg)))
                     (unless duration
@@ -227,9 +258,14 @@
                                      "~A: invalid duration\n"
                                      arg)
                       (exit 1))
-                    (alist-cons 'new-narinfo-ttl (time-second duration)
+                    (alist-cons 'cached-compression-new-ttl
+                                (match (string-split arg #\=)
+                                  ((type size)
+                                   (cons (string->symbol type)
+                                         (time-second duration))))
                                 result))))
-        (option '("cached-compressions-ttl") #t #f
+
+        (option '("ttl") #t #f
                 (lambda (opt name arg result)
                   (let ((duration (string->duration arg)))
                     (unless duration
@@ -237,10 +273,9 @@
                                      "~A: invalid duration\n"
                                      arg)
                       (exit 1))
-                    (alist-cons 'cached-compressions-narinfo-ttl
-                                (time-second duration)
+                    (alist-cons 'narinfo-ttl (time-second duration)
                                 result))))
-        (option '("new-cached-compressions-ttl") #t #f
+        (option '("new-ttl") #t #f
                 (lambda (opt name arg result)
                   (let ((duration (string->duration arg)))
                     (unless duration
@@ -248,8 +283,7 @@
                                      "~A: invalid duration\n"
                                      arg)
                       (exit 1))
-                    (alist-cons 'new-cached-compressions-narinfo-ttl
-                                (time-second duration)
+                    (alist-cons 'new-narinfo-ttl (time-second duration)
                                 result))))
         (option '("negative-ttl") #t #f
                 (lambda (opt name arg result)
-- 
cgit v1.2.3