suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

raco setup: more consistent logging and pausing on db locks

Browse Source
This commit is contained in:
Matthew Flatt 2012-11-25 07:23:59 -07:00
parent 24f358a5d7
commit d47bfc287d
2 changed files with 69 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
collects/setup/doc-db.rkt
View File

@ -16,7 +16,9 @@
doc-db-get-dependencies doc-db-get-dependencies
doc-db-file->connection doc-db-file->connection
doc-db-disconnect doc-db-disconnect
doc-db-clean-files) doc-db-clean-files
doc-db-init-pause
doc-db-pause)
(define-logger doc-db) (define-logger doc-db)
@ -30,6 +32,7 @@
#:busy-retry-limit 0)) #:busy-retry-limit 0))
(unless exists? (unless exists?
(call-with-transaction/retry (call-with-transaction/retry
'prepare-tables
db db
#f #f
(lambda () (lambda ()
@ -46,12 +49,20 @@
(define select-other-path-vq (define select-other-path-vq
(virtual-statement "SELECT atmain, path FROM other.pathids WHERE pathid=$1")) (virtual-statement "SELECT atmain, path FROM other.pathids WHERE pathid=$1"))
(define (call-with-database db-file proc (define (doc-db-init-pause)
0.01)
(define (doc-db-pause who pause)
(log-doc-db-info "database locked at ~a; now waiting ~a seconds"
who
pause)
(sleep pause)
(min 2 (* 2 pause)))
(define (call-with-database who db-file proc
#:fail [fail #f] #:fail [fail #f]
#:setup [setup void] #:setup [setup void]
#:teardown [teardown void]) #:teardown [teardown void])
(let loop ([pause 0.0]) (let loop ([pause (doc-db-init-pause)])
(unless (zero? pause) (sleep pause))
((let/ec esc ((let/ec esc
(define db (if (connection? db-file) (define db (if (connection? db-file)
db-file db-file
@ -59,6 +70,7 @@
(setup db) (setup db)
(begin0 (begin0
(call-with-transaction/retry (call-with-transaction/retry
who
db db
(if (connection? db-file) (if (connection? db-file)
(lambda () (esc fail)) (lambda () (esc fail))
@ -66,7 +78,7 @@
(esc (lambda () (esc (lambda ()
(disconnect db) (disconnect db)
(when fail (fail)) (when fail (fail))
(loop (max 0.01 (min 2 (* 2 pause)))))))) (loop (doc-db-pause who pause))))))
(lambda () (lambda ()
(define results (call-with-values (lambda () (proc db)) list)) (define results (call-with-values (lambda () (proc db)) list))
(lambda () (apply values results)))) (lambda () (apply values results))))
@ -78,6 +90,7 @@
#:fail [fail #f] #:fail [fail #f]
#:main-doc-relative-ok? [main-doc-relative-ok? #f]) #:main-doc-relative-ok? [main-doc-relative-ok? #f])
(call-with-database (call-with-database
'doc-db-key->path
db-file db-file
#:fail fail #:fail fail
(lambda (db) (lambda (db)
@ -89,8 +102,9 @@
(pathid->filename db pathid #f main-doc-relative-ok?))))) (pathid->filename db pathid #f main-doc-relative-ok?)))))
(define (add db-file elems filename callback) (define (add who db-file elems filename callback)
(call-with-database (call-with-database
who
db-file db-file
(lambda (db) (lambda (db)
(prepare-tables db) (prepare-tables db)
@ -99,8 +113,9 @@
(define stag (~s p)) (define stag (~s p))
(callback db stag pathid))))) (callback db stag pathid)))))
(define (clear db-file filename statement) (define (clear who db-file filename statement)
(call-with-database (call-with-database
who
db-file db-file
(lambda (db) (lambda (db)
(prepare-tables db) (prepare-tables db)
@ -109,7 +124,8 @@
pathid)))) pathid))))
(define (doc-db-add-provides db-file provides filename) (define (doc-db-add-provides db-file provides filename)
(add db-file provides filename (add 'doc-db-add-provides
db-file provides filename
(lambda (db stag pathid) (lambda (db stag pathid)
(query-exec db "INSERT INTO documented VALUES ($1, $2)" (query-exec db "INSERT INTO documented VALUES ($1, $2)"
stag stag
@ -117,11 +133,13 @@
(define (doc-db-clear-provides db-file filename) (define (doc-db-clear-provides db-file filename)
(clear db-file filename (clear 'doc-db-clear-provides
db-file filename
"DELETE FROM documented WHERE pathid=$1")) "DELETE FROM documented WHERE pathid=$1"))
(define (doc-db-add-dependencies db-file depends filename) (define (doc-db-add-dependencies db-file depends filename)
(add db-file depends filename (add 'doc-db-add-dependencies
db-file depends filename
(lambda (db stag pathid) (lambda (db stag pathid)
(query-exec db "INSERT INTO dependencies VALUES ($1, $2)" (query-exec db "INSERT INTO dependencies VALUES ($1, $2)"
pathid pathid
@ -129,11 +147,13 @@
(define (doc-db-clear-dependencies db-file filename) (define (doc-db-clear-dependencies db-file filename)
(clear db-file filename (clear 'doc-db-clear-dependencies
db-file filename
"DELETE FROM dependencies WHERE pathid=$1")) "DELETE FROM dependencies WHERE pathid=$1"))
(define (doc-db-add-searches db-file searches filename) (define (doc-db-add-searches db-file searches filename)
(call-with-database (call-with-database
'doc-db-add-searches
db-file db-file
(lambda (db) (lambda (db)
(prepare-tables db) (prepare-tables db)
@ -153,6 +173,7 @@
(define (doc-db-clear-searches db-file filename) (define (doc-db-clear-searches db-file filename)
(call-with-database (call-with-database
'doc-db-clear-searches
db-file db-file
(lambda (db) (lambda (db)
(prepare-tables db) (prepare-tables db)
@ -175,6 +196,7 @@
#:attach [attach-db-path #f] #:attach [attach-db-path #f]
#:main-doc-relative-ok? [main-doc-relative-ok? #f]) #:main-doc-relative-ok? [main-doc-relative-ok? #f])
(call-with-database (call-with-database
'doc-db-check-duplicates
db-file db-file
#:setup (maybe-attach attach-db-path) #:setup (maybe-attach attach-db-path)
#:teardown (maybe-detach attach-db-path) #:teardown (maybe-detach attach-db-path)
@ -217,6 +239,7 @@
(define (doc-db-check-unsatisfied filename db-file (define (doc-db-check-unsatisfied filename db-file
#:attach [attach-db-path #f]) #:attach [attach-db-path #f])
(call-with-database (call-with-database
'doc-db-check-unsatisfied
db-file db-file
#:setup (maybe-attach attach-db-path) #:setup (maybe-attach attach-db-path)
#:teardown (maybe-detach attach-db-path) #:teardown (maybe-detach attach-db-path)
@ -279,6 +302,7 @@
#:attach [attach-db-path #f] #:attach [attach-db-path #f]
#:main-doc-relative-ok? [main-doc-relative-ok? #f]) #:main-doc-relative-ok? [main-doc-relative-ok? #f])
(call-with-database (call-with-database
'doc-db-get-dependencies
db-file db-file
#:setup (maybe-attach attach-db-path) #:setup (maybe-attach attach-db-path)
#:teardown (maybe-detach attach-db-path) #:teardown (maybe-detach attach-db-path)
@ -307,6 +331,7 @@
(define (doc-db-clean-files db-file ok-files) (define (doc-db-clean-files db-file ok-files)
(call-with-database (call-with-database
'doc-db-clean-files
db-file db-file
(lambda (db) (lambda (db)
(prepare-tables db) (prepare-tables db)
@ -426,16 +451,15 @@
;; default, failure uses rollbacks, but `fast-abort' can be provided ;; default, failure uses rollbacks, but `fast-abort' can be provided
;; for a faster abort by dropping the connection. Don't try to use a ;; for a faster abort by dropping the connection. Don't try to use a
;; connection provided here in any other way on an abort. ;; connection provided here in any other way on an abort.
(define (call-with-transaction/retry db fast-abort thunk) (define (call-with-transaction/retry who db fast-abort thunk)
(let ([old-break-paramz (current-break-parameterization)] (let ([old-break-paramz (current-break-parameterization)]
[can-break? (break-enabled)]) [can-break? (break-enabled)])
(let loop ([pause 0.01]) (let loop ([pause (doc-db-init-pause)])
(define (call-with-lock-handler handler thunk) (define (call-with-lock-handler handler thunk)
(with-handlers* ([exn:fail:database-locked? (with-handlers* ([exn:fail:database-locked?
(lambda (exn) (lambda (exn)
;; Try again: ;; Try again:
(log-doc-db-info "database locked; now waiting ~a seconds" pause) (loop (doc-db-pause who pause)))])
(handler (min 10 (* pause 2))))])
(thunk))) (thunk)))
((let/ec esc ((let/ec esc
(define success? #f) (define success? #f)
@ -443,15 +467,13 @@
(lambda () (lambda ()
(call-with-lock-handler (call-with-lock-handler
(lambda (pause) (esc (lambda () (lambda (pause) (esc (lambda ()
(sleep pause) (loop (doc-db-pause `(start ,who) pause)))))
(loop pause))))
(lambda () (start-transaction db)))) (lambda () (start-transaction db))))
(lambda () (lambda ()
(call-with-lock-handler (call-with-lock-handler
(lambda (pause) (esc (lambda () (lambda (pause) (esc (lambda ()
(rollback db fast-abort 1) (rollback db fast-abort 1)
(sleep pause) (loop (doc-db-pause `(rollback ,who) pause)))))
(loop pause))))
(lambda () (lambda ()
(define l (call-with-values thunk list)) (define l (call-with-values thunk list))
(commit-transaction db) (commit-transaction db)
@ -464,7 +486,6 @@
(define (rollback db fast-abort count) (define (rollback db fast-abort count)
(when (in-transaction? db) (when (in-transaction? db)
(when fast-abort (when fast-abort
(log-doc-db-info "fast rollback abort")
(fast-abort)) (fast-abort))
(with-handlers* ([exn:fail:database-locked? (with-handlers* ([exn:fail:database-locked?
(lambda (exn) (lambda (exn)

50
collects/setup/xref.rkt
View File

@ -79,30 +79,32 @@
(cond (cond
[key [key
(define (try p) (define (try p)
(and p (let loop ([pause (doc-db-init-pause)])
(let* ([maybe-db (unbox (cdr p))] (and p
[db (let* ([maybe-db (unbox (cdr p))]
;; Use a cached connection, or... [db
(or (and (box-cas! (cdr p) maybe-db #f) ;; Use a cached connection, or...
maybe-db) (or (and (box-cas! (cdr p) maybe-db #f)
;; ... create a new one maybe-db)
(and (file-exists? (car p)) ;; ... create a new one
(doc-db-file->connection (car p))))]) (and (file-exists? (car p))
(and (doc-db-file->connection (car p))))])
db (and
((let/ec esc db
;; The db query: ((let/ec esc
(define result ;; The db query:
(doc-db-key->path db key (define result
#:fail (lambda () (doc-db-key->path db key
;; Rollback within a connection can be slow, #:fail (lambda ()
;; so abandon the connection and try again: ;; Rollback within a connection can be slow,
(doc-db-disconnect db) ;; so abandon the connection and try again:
(esc (lambda () (try p)))))) (doc-db-disconnect db)
;; cache the connection, if none is already cached: (esc (lambda ()
(or (box-cas! (cdr p) #f db) (loop (doc-db-pause 'xref-lookup pause)))))))
(doc-db-disconnect db)) ;; cache the connection, if none is already cached:
(lambda () result))))))) (or (box-cas! (cdr p) #f db)
(doc-db-disconnect db))
(lambda () result))))))))
(define dest (or (try main-db) (try user-db))) (define dest (or (try main-db) (try user-db)))
(and dest (and dest
((dest->source done-ht) dest))] ((dest->source done-ht) dest))]