From 3b05aa5f924c6c199ac8da0653223ad9ef55ce83 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 15 Apr 2024 14:32:40 +0100 Subject: Don't block the removal-channel when running a full pass --- nar-herder/server.scm | 16 ++--- nar-herder/storage.scm | 154 +++++++++++++++++++++++++++---------------------- 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) -- cgit v1.2.3