Store less in memory when scheduling the removal of cached nars

1 files changed, 44 insertions, 56 deletions

diff --git a/nar-herder/cached-compression.scm b/nar-herder/cached-compression.scm
index 1167b0a..45511e3 100644
--- a/nar-herder/cached-compression.scm
+++ b/nar-herder/cached-compression.scm
@@ -431,65 +431,53 @@
           (not (member filename '("." ".."))))))))
 
   (define (schedule-removal compression compression-details)
-    (let* ((files
-            (let ((files
-                   (with-time-logging "files-to-schedule-for-removal"
-                     (files-to-schedule-for-removal compression-details))))
-              (log-msg 'INFO "cached-compression-schedule-removal-fiber "
-                       "looking at " (length files) " files")
-              files))
-           (all-cached-narinfo-file-details
-            (with-time-logging "getting all-cached-narinfo-file-details"
-              (map
-               (lambda (file)
-                 (database-select-cached-narinfo-file-by-hash
-                  database
-                  (string-take file 32)  ; hash part
-                  compression))
-               files)))
-           (existing-scheduled-removals
-            (with-time-logging "getting existing-scheduled-removals"
-              (map
-               (lambda (cached-narinfo-file-details)
-                 (database-select-scheduled-cached-narinfo-removal
-                  database
-                  (assq-ref cached-narinfo-file-details 'id)))
-               all-cached-narinfo-file-details)))
-           (count-metric
-            (metrics-registry-fetch-metric
-             metrics-registry
-             "database_scheduled_cached_narinfo_removal_total")))
+    (let ((files
+           (let ((files
+                  (with-time-logging "files-to-schedule-for-removal"
+                    (files-to-schedule-for-removal compression-details))))
+             (log-msg 'INFO "cached-compression-schedule-removal-fiber "
+                      "looking at " (length files) " files")
+             files))
+          (count-metric
+           (metrics-registry-fetch-metric
+            metrics-registry
+            "database_scheduled_cached_narinfo_removal_total")))
 
       (with-time-logging "inserting scheduled-cached-narinfo-removals"
         (for-each
-         (lambda (file cached-narinfo-file-details existing-scheduled-removal)
-           (unless existing-scheduled-removal
-             (let ((removal-time
-                    ;; The earliest this can be removed is the current
-                    ;; time, plus the TTL
-                    (add-duration
-                     (current-time)
-                     (make-time time-duration
-                                0
-                                (or (assq-ref compression-details 'ttl)
-                                    base-ttl)))))
-               (database-insert-scheduled-cached-narinfo-removal
-                database
-                (assq-ref cached-narinfo-file-details 'id)
-                removal-time)
-
-               (metric-increment count-metric))))
-         files
-         all-cached-narinfo-file-details
-         existing-scheduled-removals))
-
-      (when (any not existing-scheduled-removals)
-        ;; Wake the cached compression removal fiber in case one of
-        ;; the new scheduled removals is before it's scheduled to wake
-        ;; up
-        (put-message
-         cached-compression-removal-fiber-wakeup-channel
-         #t))))
+         (lambda (file)
+           (let* ((cached-narinfo-file-details
+                   (database-select-cached-narinfo-file-by-hash
+                    database
+                    (string-take file 32)  ; hash part
+                    compression))
+                  (existing-scheduled-removal
+                   (database-select-scheduled-cached-narinfo-removal
+                    database
+                    (assq-ref cached-narinfo-file-details 'id))))
+             (unless existing-scheduled-removal
+               (let ((removal-time
+                      ;; The earliest this can be removed is the current
+                      ;; time, plus the TTL
+                      (add-duration
+                       (current-time)
+                       (make-time time-duration
+                                  0
+                                  (or (assq-ref compression-details 'ttl)
+                                      base-ttl)))))
+                 (database-insert-scheduled-cached-narinfo-removal
+                  database
+                  (assq-ref cached-narinfo-file-details 'id)
+                  removal-time)
+
+                 (metric-increment count-metric)))))
+         files))
+
+      ;; Wake the cached compression removal fiber in case one of
+      ;; the new scheduled removals is before it's scheduled to wake
+      ;; up
+      (put-message cached-compression-removal-fiber-wakeup-channel
+                   #t)))
 
   (spawn-fiber
    (lambda ()