Improve handling of cached narinfos when deleting

4 files changed, 81 insertions, 35 deletions

diff --git a/nar-herder/database.scm b/nar-herder/database.scm
index 98c29d5..666c497 100644
--- a/nar-herder/database.scm
+++ b/nar-herder/database.scm
@@ -63,6 +63,7 @@
 
             database-insert-cached-narinfo-file
             database-select-cached-narinfo-file-by-hash
+            database-select-cached-narinfo-file-by-narinfo-id-and-compression
             database-select-cached-narinfo-files-by-narinfo-id
             database-fold-cached-narinfo-files
             database-remove-cached-narinfo-file
@@ -855,17 +856,6 @@ DELETE FROM narinfo_tags WHERE narinfo_id = :narinfo_id"
              (remove-narinfo-references db narinfo-id)
              (remove-tags db narinfo-id)
 
-             (for-each
-              (lambda (cached-details)
-                (database-remove-cached-narinfo-file
-                 database
-                 narinfo-id
-                 (symbol->string
-                  (assq-ref cached-details 'compression))))
-              (database-select-cached-narinfo-files-by-narinfo-id
-               database
-               narinfo-id))
-
              (remove-narinfo-record db narinfo-id)
              #t)
            #f)))))
diff --git a/nar-herder/mirror.scm b/nar-herder/mirror.scm
index 47ae549..a784165 100644
--- a/nar-herder/mirror.scm
+++ b/nar-herder/mirror.scm
@@ -31,6 +31,7 @@
   #:use-module (logging logger)
   #:use-module (json)
   #:use-module (fibers)
+  #:use-module (fibers channels)
   #:use-module (guix narinfo)
   #:use-module ((guix store) #:select (store-path-hash-part))
   #:use-module (nar-herder utils)
@@ -38,8 +39,9 @@
   #:use-module (nar-herder storage)
   #:export (start-fetch-changes-fiber))
 
-(define (start-fetch-changes-fiber database storage-root
-                                   mirror metrics-registry)
+(define (start-fetch-changes-fiber database metrics-registry
+                                   storage-root mirror
+                                   cached-compression-management-channel)
   (define (request-recent-changes)
     (define latest-recent-change
       (database-select-latest-recent-change-datetime database))
@@ -141,18 +143,43 @@
                                   store-path
                                   " (" (assq-ref change-details 'datetime) ")")
 
+                         (let* ((hash (store-path-hash-part store-path))
+                                (narinfo-details
+                                 (database-select-narinfo-by-hash
+                                  database
+                                  hash)))
+
                          (when storage-root
                            (remove-nar-files-by-hash
                             database
                             storage-root
                             metrics-registry
-                            (store-path-hash-part store-path)))
+                            hash))
+
+                         (let ((cached-narinfo-files
+                                (database-select-cached-narinfo-files-by-narinfo-id
+                                 database
+                                 (assq-ref narinfo-details 'id))))
+                           (for-each
+                            (lambda (cached-narinfo-file-details)
+                              ;; TODO Delete the file as well
+
+                              (let ((reply (make-channel)))
+                                (put-message
+                                 cached-compression-management-channel
+                                 (list 'cached-narinfo-removed
+                                       (assq-ref narinfo-details 'id)
+                                       (assq-ref cached-narinfo-files 'compression)
+                                       (assq-ref cached-narinfo-files 'size)
+                                       reply))
+                                (get-message reply)))
+                            cached-narinfo-files))
 
                          (database-remove-narinfo database
                                                   store-path
                                                   #:change-datetime
                                                   (assq-ref change-details
-                                                            'datetime))))
+                                                            'datetime)))))
                       (else
                        (error "unimplemented"))))))
                recent-changes))
diff --git a/nar-herder/server.scm b/nar-herder/server.scm
index 583b4a3..6d9d553 100644
--- a/nar-herder/server.scm
+++ b/nar-herder/server.scm
@@ -768,10 +768,12 @@
                    (and=>
                     (assq-ref opts 'mirror)
                     (lambda (mirror)
-                      (start-fetch-changes-fiber database
-                                                 canonical-storage
-                                                 mirror
-                                                 metrics-registry)
+                      (start-fetch-changes-fiber
+                       database
+                       metrics-registry
+                       canonical-storage
+                       mirror
+                       cached-compression-management-channel)
 
                       (if (assq-ref opts 'storage)
                           (start-mirroring-fiber database
diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in
index e4ce9c2..7e5b35f 100644
--- a/scripts/nar-herder.in
+++ b/scripts/nar-herder.in
@@ -452,22 +452,49 @@
 
      (for-each
       (lambda (store-path)
-        (log-msg 'INFO "removing " store-path)
-
-        (if (assq-ref opts 'storage)
-            (begin
-              (remove-nar-files-by-hash
-               database
-               (assq-ref opts 'storage)
-               metrics-registry
-               (store-path-hash-part store-path)
-               #:error-unless-files-to-remove? #f))
-            (log-msg
-             'WARN "no --storage set, so just removing from the database"))
-
-        (let ((removed? (database-remove-narinfo database store-path)))
-          (unless removed?
-            (log-msg 'WARN store-path " not found to remove"))))
+        (let ((narinfo-details
+               (database-select-narinfo-by-hash
+                database
+                (store-path-hash-part store-path))))
+
+          (if narinfo-details
+              (let ((cached-narinfo-files
+                     (database-select-cached-narinfo-files-by-narinfo-id
+                      database
+                      (assq-ref narinfo-details 'id))))
+
+                (log-msg 'INFO "removing " store-path)
+
+                (if (assq-ref opts 'storage)
+                    (begin
+                      (remove-nar-files-by-hash
+                       database
+                       (assq-ref opts 'storage)
+                       metrics-registry
+                       (store-path-hash-part store-path)
+                       #:error-unless-files-to-remove? #f))
+                    (log-msg
+                     'WARN "no --storage set, so just removing from the database"))
+
+                (for-each
+                 (lambda (cached-narinfo-details)
+                   ;; 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)))
+                 cached-narinfo-files)
+
+                (database-remove-narinfo database store-path))
+              (log-msg 'WARN store-path " not found to remove"))))
       (assq-ref opts 'arguments))))
   (("check" rest ...)
    (let* ((opts (parse-options (append %base-options