diff options
| -rw-r--r-- | nar-herder/cached-compression.scm | 2 | ||||
| -rw-r--r-- | nar-herder/database.scm | 96 | ||||
| -rw-r--r-- | nar-herder/mirror.scm | 19 | ||||
| -rw-r--r-- | nar-herder/server.scm | 13 | ||||
| -rw-r--r-- | nar-herder/storage.scm | 33 | ||||
| -rw-r--r-- | scripts/nar-herder.in | 33 |
6 files changed, 121 insertions, 75 deletions
diff --git a/nar-herder/cached-compression.scm b/nar-herder/cached-compression.scm index 375fdaa..5c257dc 100644 --- a/nar-herder/cached-compression.scm +++ b/nar-herder/cached-compression.scm @@ -411,7 +411,7 @@ (put-message reply #t)) (loop (alist-cons - cached-bytes-by-compression + compression updated-bytes (alist-delete compression cached-bytes-by-compression))))))))) diff --git a/nar-herder/database.scm b/nar-herder/database.scm index 4fa145f..ded7c2c 100644 --- a/nar-herder/database.scm +++ b/nar-herder/database.scm @@ -472,42 +472,82 @@ PRAGMA optimize;"))) readonly? (immediate? (not readonly?))) (define (run-proc-within-transaction db) - (with-exception-handler - (lambda (exn) - (match (exception-args exn) - (('sqlite-exec 5 msg) - (simple-format (current-error-port) "warning: sqlite error: ~A\n" msg) - (run-proc-within-transaction db)) - (_ - (simple-format (current-error-port) - "exception starting transaction\n") - (raise-exception exn)))) - (lambda () - (sqlite-exec db (if immediate? - "BEGIN IMMEDIATE TRANSACTION;" - "BEGIN TRANSACTION;")) - (with-exception-handler - (lambda (exn) - (simple-format (current-error-port) - "error: sqlite rolling back transaction\n") - (sqlite-exec db "ROLLBACK TRANSACTION;") - (raise-exception exn)) - (lambda () - (call-with-values + (define (attempt-begin) + (with-exception-handler + (lambda (exn) + (match (exception-args exn) + (('sqlite-exec 5 msg) + (simple-format + (current-error-port) + "warning: issue starting transaction (code: 5, proc: ~A): ~A\n" + proc msg) + #f) + (_ + (simple-format (current-error-port) + "exception starting transaction: ~A\n" exn) + (raise-exception exn)))) + (lambda () + (sqlite-exec db (if immediate? + "BEGIN IMMEDIATE TRANSACTION;" + "BEGIN TRANSACTION;")) + #t) + #:unwind? #t)) + + (define (attempt-commit) + (with-exception-handler + (lambda (exn) + (match (exception-args exn) + (('sqlite-exec 5 msg) + (simple-format + (current-error-port) + "warning: attempt commit (code: 5, proc: ~A): ~A\n" + proc msg) + #f) + (_ + (simple-format (current-error-port) + "exception committing transaction: ~A\n" exn) + (raise-exception exn)))) + (lambda () + (sqlite-exec db "COMMIT TRANSACTION;") + #t) + #:unwind? #t)) + + (if (attempt-begin) + (call-with-values + (lambda () + (with-exception-handler + (lambda (exn) + (simple-format (current-error-port) + "error: sqlite rolling back transaction (~A)\n" + exn) + (sqlite-exec db "ROLLBACK TRANSACTION;") + (raise-exception exn)) (lambda () (parameterize ((%current-transaction-proc proc)) (proc-with-duration-timing db))) - (lambda vals - (sqlite-exec db "COMMIT TRANSACTION;") - (apply values vals)))) - #:unwind? #t)) - #:unwind? #t)) + #:unwind? #t)) + (lambda vals + (let loop ((success? (attempt-commit))) + (if success? + (apply values vals) + (loop (attempt-commit)))))) + + ;; Database is busy, so retry + (run-proc-within-transaction db))) (define (proc-with-duration-timing db) (let ((start-time (get-internal-real-time))) (call-with-values (lambda () - (proc db)) + (with-throw-handler #t + (lambda () + (proc db)) + (lambda (key . args) + (simple-format + (current-error-port) + "exception in transaction: ~A: ~A\n" + key args) + (backtrace)))) (lambda vals (let ((duration-seconds (/ (- (get-internal-real-time) start-time) 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/server.scm b/nar-herder/server.scm index fecf166..f9a8c32 100644 --- a/nar-herder/server.scm +++ b/nar-herder/server.scm @@ -776,7 +776,7 @@ (start-fetch-changes-fiber database metrics-registry - canonical-storage + canonical-storage ; might be #f, but that's fine here mirror cached-compression-management-channel) @@ -817,9 +817,16 @@ (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) + (when mirror-channel - (put-message mirror-channel - `(fetch ,file))) + (spawn-fiber + (lambda () + (put-message mirror-channel + `(fetch ,file))))) (when removal-channel (spawn-fiber (lambda () diff --git a/nar-herder/storage.scm b/nar-herder/storage.scm index fc49b2d..df8ec4d 100644 --- a/nar-herder/storage.scm +++ b/nar-herder/storage.scm @@ -41,6 +41,7 @@ remove-nar-files-by-hash initialise-storage-metrics + update-nar-files-metric check-storage removal-channel-remove-nar-from-storage @@ -91,6 +92,8 @@ (define (get-storage-size storage-root) (define enter? (const #t)) (define (leaf name stat result) + ;; Allow other fibers to run + (sleep 0) (+ result (or (and=> (stat:blocks stat) (lambda (blocks) @@ -166,8 +169,7 @@ (unrecognised-files . ,(hash-map->list (lambda (key _) key) files-hash))))) -;; TODO Maybe remove the metrics-registry argument? -(define* (fold-nar-files database storage-root metrics-registry +(define* (fold-nar-files database storage-root proc init #:key stored?) (define stored-files-count 0) @@ -181,8 +183,10 @@ (uri-decode (assq-ref nar 'url))) (nar-stored? - (file-exists? - (string-append storage-root url)))) + (if storage-root + (file-exists? + (string-append storage-root url)) + #f))) (if nar-stored? (set! stored-files-count (1+ stored-files-count)) @@ -202,7 +206,8 @@ (define* (update-nar-files-metric metrics-registry nar-file-counts - #:key fetched-count removed-count) + #:key fetched-count removed-count + not-stored-addition-count) ;; Avoid incrementing or decrementing the metric if it hasn't been ;; set yet @@ -245,6 +250,11 @@ #:label-values '((stored . "true"))) (metric-increment nar-files-metric #:by removed-count + #:label-values '((stored . "false")))) + + (when not-stored-addition-count + (metric-increment nar-files-metric + #:by not-stored-addition-count #:label-values '((stored . "false"))))))) (define (initialise-storage-metrics database storage-root metrics-registry) @@ -258,7 +268,6 @@ (fold-nar-files database storage-root - metrics-registry (const #f) #f #:stored? 'both))) @@ -279,7 +288,6 @@ (fold-nar-files database storage-root - metrics-registry (lambda (file _) (let* ((full-filename (string-append storage-root @@ -447,7 +455,6 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (fold-nar-files database storage-root - metrics-registry (lambda (nar result) (match result ((storage-size . removed-count) @@ -616,7 +623,6 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (fold-nar-files database storage-root - metrics-registry (lambda (file result) (log-msg 'DEBUG "considering " (assq-ref file 'url)) @@ -694,7 +700,6 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (fold-nar-files database storage-root - metrics-registry (lambda (nar _) (put-message channel (assq-ref nar 'url)) @@ -742,10 +747,10 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (lambda (exn) (log-msg 'ERROR "failed to mirror " file ": " exn)) (lambda () - (fetch-file file) - (update-nar-files-metric metrics-registry - '() - #:fetched-count 1)) + (unless (file-exists? + (string-append storage-root + (uri-decode file))) + (fetch-file file))) #:unwind? #t)))))) (spawn-fiber diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in index 67515dc..fafcf9f 100644 --- a/scripts/nar-herder.in +++ b/scripts/nar-herder.in @@ -458,11 +458,14 @@ (port-log (make <port-log> #:port (current-output-port) #:formatter - (lambda (lvl time str) + ;; In guile-lib v0.2.8 onwards, the formatter is + ;; called with more arguments + (lambda args ; lvl, time, str (format #f "~a (~5a): ~a~%" - (strftime "%F %H:%M:%S" (localtime time)) - lvl - str))))) + (strftime "%F %H:%M:%S" (localtime + (second args))) + (first args) + (third args)))))) (add-handler! lgr port-log) (open-log! lgr) @@ -524,11 +527,14 @@ (port-log (make <port-log> #:port (current-output-port) #:formatter - (lambda (lvl time str) + ;; In guile-lib v0.2.8 onwards, the formatter is + ;; called with more arguments + (lambda args ; lvl, time, str (format #f "~a (~5a): ~a~%" - (strftime "%F %H:%M:%S" (localtime time)) - lvl - str)))) + (strftime "%F %H:%M:%S" (localtime + (second args))) + (first args) + (third args))))) (metrics-registry (make-metrics-registry #:namespace "narherder"))) @@ -567,11 +573,14 @@ (port-log (make <port-log> #:port (current-output-port) #:formatter - (lambda (lvl time str) + ;; In guile-lib v0.2.8 onwards, the formatter is + ;; called with more arguments + (lambda args ; lvl, time, str (format #f "~a (~5a): ~a~%" - (strftime "%F %H:%M:%S" (localtime time)) - lvl - str))))) + (strftime "%F %H:%M:%S" (localtime + (second args))) + (first args) + (third args)))))) (add-handler! lgr port-log) (open-log! lgr) |