From 2eea6e7f8ff823c47d611c6ceefea33f5bac67b5 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Wed, 27 Mar 2024 10:48:59 +0000
Subject: Track the number of cached nars scheduled for removal

---
 nar-herder/cached-compression.scm | 38 ++++++++++++++++++++++++++++++++------
 nar-herder/database.scm           | 28 ++++++++++++++++++++++++----
 nar-herder/server.scm             |  1 +
 3 files changed, 57 insertions(+), 10 deletions(-)

diff --git a/nar-herder/cached-compression.scm b/nar-herder/cached-compression.scm
index ac18036..bf82d56 100644
--- a/nar-herder/cached-compression.scm
+++ b/nar-herder/cached-compression.scm
@@ -372,9 +372,15 @@
                          ;; It might not have been scheduled for
                          ;; removal, but remove any schedule that
                          ;; exists
-                         (database-delete-scheduled-cached-narinfo-removal
-                          database
-                          (assq-ref cached-narinfo-details 'id))
+                         (let ((schedule-removed?
+                                (database-delete-scheduled-cached-narinfo-removal
+                                 database
+                                 (assq-ref cached-narinfo-details 'id))))
+                           (when schedule-removed?
+                             (metric-decrement
+                              (metrics-registry-fetch-metric
+                               metrics-registry
+                               "database_scheduled_cached_narinfo_removal_total"))))
 
                          ;; Remove all the database entries first, as
                          ;; that'll stop these files appearing in narinfos
@@ -402,6 +408,7 @@
 ;; and schedule them for removal
 (define (start-cached-compression-schedule-removal-fiber
          database
+         metrics-registry
          cached-compression-management-channel
          enabled-cached-compressions
          cached-compression-removal-fiber-wakeup-channel
@@ -439,7 +446,11 @@
                (database-select-scheduled-cached-narinfo-removal
                 database
                 (assq-ref cached-narinfo-file-details 'id)))
-             all-cached-narinfo-file-details)))
+             all-cached-narinfo-file-details))
+           (count-metric
+            (metrics-registry-fetch-metric
+             metrics-registry
+             "database_scheduled_cached_narinfo_removal_total")))
 
       (for-each
        (lambda (file cached-narinfo-file-details existing-scheduled-removal)
@@ -456,7 +467,9 @@
              (database-insert-scheduled-cached-narinfo-removal
               database
               (assq-ref cached-narinfo-file-details 'id)
-              removal-time))))
+              removal-time)
+
+             (metric-increment count-metric))))
        files
        all-cached-narinfo-file-details
        existing-scheduled-removals)
@@ -480,7 +493,20 @@
                                (assq-ref compression-details
                                          'unused-removal-duration))
                               4))
-                         enabled-cached-compressions)))))
+                         enabled-cached-compressions))))
+           (start-count
+            (database-count-scheduled-cached-narinfo-removal
+             database)))
+
+       (metric-set
+        (or (metrics-registry-fetch-metric
+             metrics-registry
+             "database_scheduled_cached_narinfo_removal_total")
+            (make-gauge-metric
+             metrics-registry
+             "database_scheduled_cached_narinfo_removal_total"))
+        start-count)
+
        (while #t
          (log-msg 'DEBUG "cached-compression-schedule-removal-fiber starting pass")
 
diff --git a/nar-herder/database.scm b/nar-herder/database.scm
index 666c497..75cd049 100644
--- a/nar-herder/database.scm
+++ b/nar-herder/database.scm
@@ -72,6 +72,7 @@
             database-select-scheduled-cached-narinfo-removal
             database-delete-scheduled-cached-narinfo-removal
             database-select-oldest-scheduled-cached-narinfo-removal
+            database-count-scheduled-cached-narinfo-removal
             database-insert-scheduled-cached-narinfo-removal))
 
 (define-record-type <database>
@@ -1484,16 +1485,17 @@ WHERE cached_narinfo_file_id = :cached_narinfo_file_id"
              db
              "
 DELETE FROM scheduled_cached_narinfo_removal
-WHERE cached_narinfo_file_id = :cached_narinfo_file_id"
+WHERE cached_narinfo_file_id = :cached_narinfo_file_id
+RETURNING 1"
              #:cache? #t)))
        (sqlite-bind-arguments
         statement
         #:cached_narinfo_file_id cached-narinfo-file-id)
 
-       (sqlite-step statement)
-       (sqlite-reset statement)
+       (let ((result (->bool (sqlite-step statement))))
+         (sqlite-reset statement)
 
-       #t))))
+         result)))))
 
 (define (database-select-oldest-scheduled-cached-narinfo-removal database)
   (call-with-worker-thread
@@ -1535,6 +1537,24 @@ LIMIT 1"
          (sqlite-reset statement)
          result)))))
 
+(define (database-count-scheduled-cached-narinfo-removal database)
+  (call-with-worker-thread
+   (database-reader-thread-channel database)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+SELECT COUNT(*) FROM scheduled_cached_narinfo_removal"
+             #:cache? #t)))
+
+       (let ((result
+              (vector-ref (sqlite-step statement)
+                          0)))
+         (sqlite-reset statement)
+
+         result)))))
+
 (define (database-insert-scheduled-cached-narinfo-removal database
                                                           cached-narinfo-file-id
                                                           removal-datetime)
diff --git a/nar-herder/server.scm b/nar-herder/server.scm
index 4708c4e..e352737 100644
--- a/nar-herder/server.scm
+++ b/nar-herder/server.scm
@@ -840,6 +840,7 @@
                       enabled-cached-compressions)))
                 (start-cached-compression-schedule-removal-fiber
                  database
+                 metrics-registry
                  cached-compression-management-channel
                  enabled-cached-compressions
                  cached-compression-removal-fiber-wakeup-channel
-- 
cgit v1.2.3