diff options
Diffstat (limited to 'nar-herder')
| -rw-r--r-- | nar-herder/mirror.scm | 19 | ||||
| -rw-r--r-- | nar-herder/recent-changes.scm | 59 | ||||
| -rw-r--r-- | nar-herder/server.scm | 13 | ||||
| -rw-r--r-- | nar-herder/storage.scm | 10 | ||||
| -rw-r--r-- | nar-herder/utils.scm | 15 |
5 files changed, 57 insertions, 59 deletions
diff --git a/nar-herder/mirror.scm b/nar-herder/mirror.scm index a784165..8aae845 100644 --- a/nar-herder/mirror.scm +++ b/nar-herder/mirror.scm @@ -120,23 +120,8 @@ narinfo #:change-datetime (assq-ref change-details - 'datetime)) - - (and=> (metrics-registry-fetch-metric metrics-registry - "nar_files_total") - (lambda (metric) - ;; Just update this metric if it - ;; exists, since if it does, it - ;; should be set to a value - (let ((new-files-count - (length (narinfo-uris narinfo)))) - (metric-increment - metric - #:by new-files-count - ;; TODO This should be - ;; checked, rather than - ;; assumed to be false - #:label-values '((stored . "false")))))))) + 'datetime)))) + ((string=? change "removal") (let ((store-path (assq-ref change-details 'data))) (log-msg 'INFO "processing removal change for " diff --git a/nar-herder/recent-changes.scm b/nar-herder/recent-changes.scm index ccfff93..62bd604 100644 --- a/nar-herder/recent-changes.scm +++ b/nar-herder/recent-changes.scm @@ -137,35 +137,38 @@ (log-msg 'ERROR "exception in recent change listener " exn) #f) (lambda () - (let* ((recent-changes - (database-select-recent-changes database after)) - (unprocessed-recent-changes - (remove + (with-throw-handler #t + (lambda () + (let* ((recent-changes + (database-select-recent-changes database after)) + (unprocessed-recent-changes + (remove + (lambda (change-details) + (member change-details last-processed-recent-changes)) + recent-changes))) + + (unless (null? unprocessed-recent-changes) + (log-msg 'INFO "processing " (length unprocessed-recent-changes) + " recent changes") + + (for-each (lambda (change-details) - (member change-details last-processed-recent-changes)) - recent-changes))) - - (unless (null? unprocessed-recent-changes) - (log-msg 'INFO "processing " (length unprocessed-recent-changes) - " recent changes") - - (metric-increment recent-changes-count-metric - #:by (length unprocessed-recent-changes)) - - (for-each - (lambda (change-details) - (let ((change (assq-ref change-details 'change))) - (cond - ((string=? change "addition") - (process-addition-change change-details)) - ((string=? change "removal") - (process-removal-change change-details)) - (else #f)))) - unprocessed-recent-changes)) - - ;; Use the unprocessed recent changes here to carry - ;; forward all processed changes to the next pass - unprocessed-recent-changes)) + (let ((change (assq-ref change-details 'change))) + (cond + ((string=? change "addition") + (process-addition-change change-details)) + ((string=? change "removal") + (process-removal-change change-details)) + (else #f)))) + unprocessed-recent-changes) + + (metric-increment recent-changes-count-metric + #:by (length unprocessed-recent-changes))) + ;; Use the unprocessed recent changes here to carry + ;; forward all processed changes to the next pass + unprocessed-recent-changes)) + (lambda _ + (backtrace)))) #:unwind? #t) (#f (loop after '())) (recent-changes diff --git a/nar-herder/server.scm b/nar-herder/server.scm index f9a8c32..2e2c1e7 100644 --- a/nar-herder/server.scm +++ b/nar-herder/server.scm @@ -817,10 +817,15 @@ (lambda () (match (get-message addition-channel) (('addition file) - ;; TODO Check if the file is actually not stored - (update-nar-files-metric metrics-registry - '() - #:not-stored-addition-count 1) + (apply update-nar-files-metric + metrics-registry + '() + (if (and canonical-storage + (file-exists? + (string-append canonical-storage + (uri-decode file)))) + '(#:stored-addition-count 1) + '(#:not-stored-addition-count 1))) (when mirror-channel (spawn-fiber diff --git a/nar-herder/storage.scm b/nar-herder/storage.scm index df8ec4d..e85d745 100644 --- a/nar-herder/storage.scm +++ b/nar-herder/storage.scm @@ -207,7 +207,8 @@ (define* (update-nar-files-metric metrics-registry nar-file-counts #:key fetched-count removed-count - not-stored-addition-count) + not-stored-addition-count + stored-addition-count) ;; Avoid incrementing or decrementing the metric if it hasn't been ;; set yet @@ -255,7 +256,12 @@ (when not-stored-addition-count (metric-increment nar-files-metric #:by not-stored-addition-count - #:label-values '((stored . "false"))))))) + #:label-values '((stored . "false")))) + + (when stored-addition-count + (metric-increment nar-files-metric + #:by stored-addition-count + #:label-values '((stored . "true"))))))) (define (initialise-storage-metrics database storage-root metrics-registry) ;; Use a database transaction to block changes diff --git a/nar-herder/utils.scm b/nar-herder/utils.scm index 4755d33..4261b05 100644 --- a/nar-herder/utils.scm +++ b/nar-herder/utils.scm @@ -701,7 +701,7 @@ If already in the worker thread, call PROC immediately." (define &port-timeout (make-exception-type '&port-timeout &external-error - '(port))) + '(thunk port))) (define make-port-timeout-error (record-constructor &port-timeout)) @@ -735,7 +735,7 @@ If already in the worker thread, call PROC immediately." #:key timeout (read-timeout timeout) (write-timeout timeout)) - (define (no-fibers-wait port mode timeout) + (define (no-fibers-wait thunk port mode timeout) (define poll-timeout-ms 200) ;; When the GC runs, it restarts the poll syscall, but the timeout @@ -746,8 +746,7 @@ If already in the worker thread, call PROC immediately." ;; timed out overall. (let ((timeout-internal (+ (get-internal-real-time) - (* internal-time-units-per-second - (/ timeout 1000))))) + (* timeout internal-time-units-per-second)))) (let loop ((poll-value (port-poll port mode poll-timeout-ms))) (if (= poll-value 0) @@ -755,8 +754,8 @@ If already in the worker thread, call PROC immediately." timeout-internal) (raise-exception (if (string=? mode "r") - (make-port-read-timeout-error port) - (make-port-write-timeout-error port))) + (make-port-read-timeout-error thunk port) + (make-port-write-timeout-error thunk port))) (loop (port-poll port mode poll-timeout-ms))) poll-value)))) @@ -772,7 +771,7 @@ If already in the worker thread, call PROC immediately." (lambda () (raise-exception (make-port-read-timeout-error thunk port)))))) - (no-fibers-wait port "r" read-timeout)))) + (no-fibers-wait thunk port "r" read-timeout)))) (current-write-waiter (lambda (port) (if (current-scheduler) @@ -784,5 +783,5 @@ If already in the worker thread, call PROC immediately." (lambda () (raise-exception (make-port-write-timeout-error thunk port)))))) - (no-fibers-wait port "w" write-timeout))))) + (no-fibers-wait thunk port "w" write-timeout))))) (thunk))) |