From 57ca998207b11f4f149470bfd20a159cf119bf49 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Mon, 25 Mar 2024 12:00:10 +0000
Subject: Move all the database operations for cached nars to one fiber

The management fiber. This adds the complexity of replying from the
management fiber, but hopefully having all the database operations in
one place makes things simpler.
---
 nar-herder/cached-compression.scm | 108 +++++++++++++++++++++-----------------
 1 file changed, 61 insertions(+), 47 deletions(-)

(limited to 'nar-herder')

diff --git a/nar-herder/cached-compression.scm b/nar-herder/cached-compression.scm
index 835faf4..0cb7e1d 100644
--- a/nar-herder/cached-compression.scm
+++ b/nar-herder/cached-compression.scm
@@ -297,7 +297,8 @@
                                         (list 'cached-narinfo-added
                                               narinfo-id
                                               compression
-                                              new-bytes))))))))
+                                              new-bytes
+                                              #f))))))))
                  compressions-with-space)))))))
 
     (spawn-fiber
@@ -330,7 +331,7 @@
 
              (((and (or 'cached-narinfo-added 'cached-narinfo-removed)
                     action)
-               narinfo-id compression size)
+               narinfo-id compression size reply)
               (let ((updated-bytes
                      ((if (eq? action 'cached-narinfo-added)
                           +
@@ -351,15 +352,42 @@
                  nar-cache-files
                  #:label-values `((compression . ,compression)))
 
-                (when (eq? action 'cached-narinfo-added)
-                  (database-insert-cached-narinfo-file
-                   database
-                   narinfo-id
-                   size
-                   compression)
+                ;; Use an explicit transaction as it handles the
+                ;; database being busy,
+                (database-call-with-transaction
+                 database
+                 (lambda _
+                   (if (eq? action 'cached-narinfo-added)
+                       (database-insert-cached-narinfo-file
+                        database
+                        narinfo-id
+                        size
+                        compression)
+                       (let ((cached-narinfo-details
+                              (database-select-cached-narinfo-file-by-narinfo-id-and-compression
+                               database
+                               narinfo-id
+                               compression)))
+
+                         ;; 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))
+
+                         ;; Remove all the database entries first, as
+                         ;; that'll stop these files appearing in narinfos
+                         (database-remove-cached-narinfo-file
+                          database
+                          narinfo-id
+                          (symbol->string compression))))))
+
+                (hash-remove! nar-cached-compression-usage-hash-table
+                              narinfo-id)
 
-                  (hash-remove! nar-cached-compression-usage-hash-table
-                                narinfo-id))
+                (when reply
+                  (put-message reply #t))
 
                 (loop (alist-cons
                        cached-bytes-by-compression
@@ -474,34 +502,6 @@
          cached-compression-management-channel
          enabled-cached-compressions)
 
-  (define (remove id narinfo-id compression store-path)
-    ;; Use an explicit transaction as it handles the
-    ;; database being busy,
-    (database-call-with-transaction
-     database
-     (lambda _
-       (database-delete-scheduled-cached-narinfo-removal
-        database
-        id)
-
-       ;; Remove all the database entries first, as
-       ;; that'll stop these files appearing in narinfos
-       (database-remove-cached-narinfo-file
-        database
-        narinfo-id
-        (symbol->string compression))))
-
-    (let ((directory
-           (assq-ref (assq-ref enabled-cached-compressions
-                               compression)
-                     'directory)))
-      (let ((filename
-             (string-append
-              directory "/"
-              (basename store-path))))
-        (log-msg 'DEBUG "deleting " filename)
-        (delete-file filename))))
-
   (define wakeup-channel
     (make-channel))
 
@@ -527,14 +527,29 @@
                                     'size))
                     (store-path (assq-ref scheduled-cached-narinfo-removal
                                           'store-path)))
-                (remove id narinfo-id compression store-path)
-
-                (put-message
-                 cached-compression-management-channel
-                 (list 'cached-narinfo-removed
-                       narinfo-id
-                       compression
-                       size)))
+                (let ((reply (make-channel)))
+                  (put-message
+                   cached-compression-management-channel
+                   (list 'cached-narinfo-removed
+                         narinfo-id
+                         compression
+                         size
+                         reply))
+
+                  ;; Wait for the management fiber to delete the
+                  ;; database entry before removing the file.
+                  (get-message reply))
+
+                (let ((directory
+                       (assq-ref (assq-ref enabled-cached-compressions
+                                           compression)
+                                 'directory)))
+                  (let ((filename
+                         (string-append
+                          directory "/"
+                          (basename store-path))))
+                    (log-msg 'DEBUG "deleting " filename)
+                    (delete-file filename))))
 
               (let ((duration
                      (time-difference
@@ -549,7 +564,6 @@
           ;; Sleep until woken
           (get-message wakeup-channel))))
 
-
   (spawn-fiber
    (lambda ()
      (while #t
-- 
cgit v1.2.3