diff options
author | Christopher Baines <mail@cbaines.net> | 2024-04-15 14:32:40 +0100 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2024-04-15 15:58:17 +0100 |
commit | 3b05aa5f924c6c199ac8da0653223ad9ef55ce83 (patch) | |
tree | d5d37a048d1d0c7eab320c48f286f926d8aefc65 /nar-herder/storage.scm | |
parent | 6ceb0a3b3000ce85a9263833b2398cb44a2871eb (diff) | |
download | nar-herder-3b05aa5f924c6c199ac8da0653223ad9ef55ce83.tar nar-herder-3b05aa5f924c6c199ac8da0653223ad9ef55ce83.tar.gz |
Don't block the removal-channel when running a full pass
Diffstat (limited to 'nar-herder/storage.scm')
-rw-r--r-- | nar-herder/storage.scm | 154 |
1 files changed, 86 insertions, 68 deletions
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) |