diff options
author | Christopher Baines <mail@cbaines.net> | 2023-02-06 15:43:04 +0100 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2023-02-06 15:43:04 +0100 |
commit | 562ac009b7ee14f634f384f75468be8ebbac9ce6 (patch) | |
tree | 189b6963e5689cd954532f60633089ce239f2bbf | |
parent | 0ee8c782903717d48c54dfb00ac7496ac06529d8 (diff) | |
download | nar-herder-562ac009b7ee14f634f384f75468be8ebbac9ce6.tar nar-herder-562ac009b7ee14f634f384f75468be8ebbac9ce6.tar.gz |
Handle busy databases in database-call-with-transaction
-rw-r--r-- | nar-herder/database.scm | 94 |
1 files changed, 56 insertions, 38 deletions
diff --git a/nar-herder/database.scm b/nar-herder/database.scm index 5323b6d..1417c24 100644 --- a/nar-herder/database.scm +++ b/nar-herder/database.scm @@ -331,26 +331,60 @@ PRAGMA optimize;"))) (define* (database-call-with-transaction database proc #:key - readonly?) + readonly? + (immediate? (not readonly?))) (define (run-proc-within-transaction db) - (if (%current-transaction-proc) - (proc db) ; already in transaction - (begin - (sqlite-exec db "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 - (lambda () - (parameterize ((%current-transaction-proc proc)) - (proc db))) - (lambda vals - (sqlite-exec db "COMMIT TRANSACTION;") - (apply values vals)))))))) + (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 + (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)) + + (define (proc-with-duration-timing db) + (let ((start-time (get-internal-real-time))) + (call-with-values + (lambda () + (proc db)) + (lambda vals + (let ((duration-seconds + (/ (- (get-internal-real-time) start-time) + internal-time-units-per-second))) + (when (and (not readonly?) + (> duration-seconds 2)) + (display + (format + #f + "warning: ~a:\n took ~4f seconds in transaction\n" + proc + duration-seconds) + (current-error-port))) + + (cons duration-seconds vals)))))) (match (call-with-worker-thread ((if readonly? @@ -358,25 +392,9 @@ PRAGMA optimize;"))) database-writer-thread-channel) database) (lambda (db) - (let ((start-time (get-internal-real-time))) - (call-with-values - (lambda () - (run-proc-within-transaction db)) - (lambda vals - (let ((duration-seconds - (/ (- (get-internal-real-time) start-time) - internal-time-units-per-second))) - (when (and (not readonly?) - (> duration-seconds 2)) - (display - (format - #f - "warning: ~a:\n took ~4f seconds in transaction\n" - proc - duration-seconds) - (current-error-port))) - - (cons duration-seconds vals))))))) + (if (%current-transaction-proc) + (proc-with-duration-timing db) ; already in transaction + (run-proc-within-transaction db)))) ((duration vals ...) (apply values vals)))) |