Don't block the removal-channel when running a full pass

2 files changed, 94 insertions, 76 deletions

diff --git a/nar-herder/server.scm b/nar-herder/server.scm
index 61f11e3..4b5f710 100644
--- a/nar-herder/server.scm
+++ b/nar-herder/server.scm
@@ -817,17 +817,17 @@
                         (spawn-fiber
                          (lambda ()
                            (sleep 60)
-                           (put-message removal-channel
-                                        `(remove-from-storage ,file))
+                           (removal-channel-remove-nar-from-storage removal-channel
+                                                                    file)
                            (sleep (* 5 60))
-                           (put-message removal-channel
-                                        `(remove-from-storage ,file))
+                           (removal-channel-remove-nar-from-storage removal-channel
+                                                                    file)
                            (sleep (* 15 60))
-                           (put-message removal-channel
-                                        `(remove-from-storage ,file))
+                           (removal-channel-remove-nar-from-storage removal-channel
+                                                                    file)
                            (sleep 3600)
-                           (put-message removal-channel
-                                        `(remove-from-storage ,file))))))))))
+                           (removal-channel-remove-nar-from-storage removal-channel
+                                                                    file)))))))))
 
               (start-recent-change-listener-fiber
                database
diff --git a/nar-herder/storage.scm b/nar-herder/storage.scm
index a40e125..fc49b2d 100644
--- a/nar-herder/storage.scm
+++ b/nar-herder/storage.scm
@@ -43,6 +43,8 @@
             initialise-storage-metrics
             check-storage
 
+            removal-channel-remove-nar-from-storage
+
             start-nar-removal-fiber
             start-mirroring-fiber))
 
@@ -365,6 +367,12 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
       (lambda _
         (close-port port)))))
 
+(define (removal-channel-remove-nar-from-storage
+         channel file)
+  (let ((reply (make-channel)))
+    (put-message channel (list 'remove-from-storage reply file))
+    (get-message reply)))
+
 (define (start-nar-removal-fiber database
                                  storage-root storage-limit
                                  metrics-registry
@@ -373,6 +381,9 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
     (make-gauge-metric metrics-registry
                        "storage_size_bytes"))
 
+  (define removal-channel
+    (make-channel))
+
   (define (check-removal-criteria nar criteria)
     (define narinfo
       (database-select-narinfo-for-file database (assq-ref nar 'url)))
@@ -442,22 +453,19 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
                   ((storage-size . removed-count)
                    (if (and (> storage-size storage-limit)
                             (nar-can-be-removed? nar))
-                       (begin
-                         (remove-nar-from-storage
-                          storage-root
-                          (uri-decode
-                           (assq-ref nar 'url)))
-
-                         (update-nar-files-metric
-                          metrics-registry
-                          '()
-                          #:removed-count 1)
-
-                         (let ((storage-size-estimate
-                                (- storage-size
-                                   (assq-ref nar 'size))))
-                           (cons storage-size-estimate
-                                 (+ removed-count 1))))
+                       (let ((response
+                              (removal-channel-remove-nar-from-storage
+                               removal-channel
+                               (assq-ref nar 'url))))
+
+                         (if (eq? response 'removed)
+                             (let ((storage-size-estimate
+                                    (- storage-size
+                                       (assq-ref nar 'size))))
+                               (cons storage-size-estimate
+                                     (+ removed-count 1)))
+                             (cons storage-size
+                                   removed-count)))
                        (cons storage-size
                              removed-count)))))
               (cons initial-storage-size 0)
@@ -472,58 +480,68 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
   (when (null? nar-removal-criteria)
     (error "must be some removal criteria"))
 
-  (let ((channel (make-channel)))
-    (spawn-fiber
-     (lambda ()
-       (while #t
-         (match (get-message channel)
-           ('full-pass
-            (with-exception-handler
-                (lambda (exn)
-                  (log-msg 'ERROR "nar removal pass failed " exn))
-              run-removal-pass
-              #:unwind? #t))
-           (('remove-from-storage file)
-            (with-exception-handler
-                (lambda (exn)
-                  (log-msg 'ERROR "nar remove from storage failed ("
-                           file "): " exn))
-              (lambda ()
-                (with-throw-handler #t
-                  (lambda ()
-                    (when (and
-                           (file-exists?
-                            (string-append storage-root
-                                           (uri-decode file)))
-                           (nar-can-be-removed?
-                            `((url . ,file))))
-                      (remove-nar-from-storage
-                       storage-root
-                       (uri-decode file))))
-                  (lambda _
-                    (backtrace))))
-              #:unwind? #t))
-           (('remove file)
-            (with-exception-handler
-                (lambda (exn)
-                  (log-msg 'ERROR "failed to remove " file ": " exn))
-              (lambda ()
-                ;; TODO: Do more checking at this point
-                (remove-nar-from-storage
-                 storage-root
-                 (uri-decode file))
-                (update-nar-files-metric metrics-registry
-                                         '()
-                                         #:removed-count 1))
-              #:unwind? #t))))))
-
-    (spawn-fiber
-     (lambda ()
-       (while #t
-         (put-message channel 'full-pass)
-         (sleep (* 60 60 24)))))
-
-    channel))
+  (spawn-fiber
+   (lambda ()
+     (while #t
+       (match (get-message removal-channel)
+         (('remove-from-storage reply file)
+          (with-exception-handler
+              (lambda (exn)
+                (log-msg 'ERROR "nar remove from storage failed ("
+                         file "): " exn)
+                (put-message reply
+                             (cons 'exn exn)))
+            (lambda ()
+              (with-throw-handler #t
+                (lambda ()
+                  (cond
+                   ((not (file-exists?
+                          (string-append storage-root
+                                         (uri-decode file))))
+                    (put-message reply 'does-not-exist))
+                   ((not (nar-can-be-removed?
+                          `((url . ,file))))
+                    (put-message reply
+                                 'removal-criteria-not-met))
+                   (else
+                    (remove-nar-from-storage
+                     storage-root
+                     (uri-decode file))
+
+                    (update-nar-files-metric
+                     metrics-registry
+                     '()
+                     #:removed-count 1)
+
+                    (put-message reply 'removed))))
+                (lambda _
+                  (backtrace))))
+            #:unwind? #t))
+         (('remove file)
+          (with-exception-handler
+              (lambda (exn)
+                (log-msg 'ERROR "failed to remove " file ": " exn))
+            (lambda ()
+              ;; TODO: Do more checking at this point
+              (remove-nar-from-storage
+               storage-root
+               (uri-decode file))
+              (update-nar-files-metric metrics-registry
+                                       '()
+                                       #:removed-count 1))
+            #:unwind? #t))))))
+
+  (spawn-fiber
+   (lambda ()
+     (while #t
+       (with-exception-handler
+           (lambda (exn)
+             (log-msg 'ERROR "nar removal pass failed " exn))
+         run-removal-pass
+         #:unwind? #t)
+       (sleep (* 60 60 24)))))
+
+  removal-channel)
 
 (define (start-mirroring-fiber database mirror storage-limit storage-root
                                metrics-registry)