diff options
Diffstat (limited to 'nar-herder/cached-compression.scm')
-rw-r--r-- | nar-herder/cached-compression.scm | 100 |
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 () |