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

setup/xref: simplify db interaction

Browse Source 
Relies on improvements to SQLite retry support.
This commit is contained in:
Matthew Flatt 2012-12-03 18:55:52 -07:00
parent adee7494b4
commit cd257fe65b
2 changed files with 66 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -35,16 +35,13 @@
(call-with-retry/transaction (call-with-retry/transaction
'prepare-tables 'prepare-tables
db db
#f #t
+inf.0
(lambda () (lambda ()
(prepare-tables db)))) (prepare-tables db))))
;; we don't need to survive a catastrophic failure: ;; we don't need to survive a catastrophic failure:
(call-with-retry (call-with-retry
'synchronous-off 'synchronous-off
db db
#f
+inf.0
(lambda () (lambda ()
(query-exec db "pragma synchronous = off"))) (query-exec db "pragma synchronous = off")))
db) db)
@ -69,50 +66,28 @@
(min 2 (* 2 pause))) (min 2 (* 2 pause)))
(define (call-with-database who db-file proc (define (call-with-database who db-file proc
#:fail [fail #f] #:write? [write? #f]
#:delay-limit [pause-limit +inf.0]
#:setup [setup void] #:setup [setup void]
#:teardown [teardown void]) #:teardown [teardown void])
(let loop ([pause (doc-db-init-pause)]) (define db (if (connection? db-file)
((let/ec esc db-file
(define db (if (connection? db-file) (doc-db-file->connection db-file)))
db-file (setup db)
(doc-db-file->connection db-file))) (begin0
(setup db) (call-with-retry/transaction
(begin0 who
(call-with-retry/transaction db
who write?
db (lambda () (proc db)))
(if (connection? db-file) (teardown db)
(and fail (unless (connection? db-file)
(lambda (should-retry?) (disconnect db))))
(if should-retry?
(esc (lambda () (fail #t)))
(fail #f))))
(lambda (should-retry?)
(if should-retry?
(esc (lambda ()
(disconnect db)
(when fail (fail))
(loop (doc-db-pause who pause))))
(disconnect db))))
pause-limit
(lambda ()
(define results (call-with-values (lambda () (proc db)) list))
(lambda () (apply values results))))
(teardown db)
(unless (connection? db-file)
(disconnect db)))))))
(define (doc-db-key->path db-file key (define (doc-db-key->path db-file key
#:fail [fail #f]
#:delay-limit [pause-limit +inf.0]
#: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 'doc-db-key->path
db-file db-file
#:fail fail
#:delay-limit pause-limit
(lambda (db) (lambda (db)
(define row (query-maybe-row db select-pathid-vq (define row (query-maybe-row db select-pathid-vq
(~s key))) (~s key)))
@ -126,6 +101,7 @@
(call-with-database (call-with-database
who who
db-file db-file
#:write? #t
(lambda (db) (lambda (db)
(prepare-tables db) (prepare-tables db)
(define pathid (filename->pathid db filename)) (define pathid (filename->pathid db filename))
@ -137,6 +113,7 @@
(call-with-database (call-with-database
who who
db-file db-file
#:write? #t
(lambda (db) (lambda (db)
(prepare-tables db) (prepare-tables db)
(define pathid (filename->pathid db filename)) (define pathid (filename->pathid db filename))
@ -175,6 +152,7 @@
(call-with-database (call-with-database
'doc-db-add-searches 'doc-db-add-searches
db-file db-file
#:write? #t
(lambda (db) (lambda (db)
(prepare-tables db) (prepare-tables db)
(define pathid (filename->pathid db filename)) (define pathid (filename->pathid db filename))
@ -195,6 +173,7 @@
(call-with-database (call-with-database
'doc-db-clear-searches 'doc-db-clear-searches
db-file db-file
#:write? #t
(lambda (db) (lambda (db)
(prepare-tables db) (prepare-tables db)
(define pathid (filename->pathid db filename)) (define pathid (filename->pathid db filename))
@ -353,6 +332,7 @@
(call-with-database (call-with-database
'doc-db-clean-files 'doc-db-clean-files
db-file db-file
#:write? #t
(lambda (db) (lambda (db)
(prepare-tables db) (prepare-tables db)
(define rows (query-rows db "SELECT atmain, path, pathid FROM pathids")) (define rows (query-rows db "SELECT atmain, path, pathid FROM pathids"))
@ -462,72 +442,55 @@
(query-exec db (~a "CREATE INDEX searchesPathId " (query-exec db (~a "CREATE INDEX searchesPathId "
"on searches (pathid, setid)")))) "on searches (pathid, setid)"))))
(define (exn:fail:database-locked? v) (define (exn:fail:retry? v)
(and (exn:fail? v) (and (exn:fail:sql? v)
(regexp-match #rx"the database file is locked$" (let ([s (exn:fail:sql-sqlstate v)])
(exn-message v)))) (or (eq? s 'busy)
(and (string? s) (regexp-match? s #rx"^40...$"))))))
(define (call-with-lock-handler handler thunk) (define (call-with-lock-handler handler thunk)
(with-handlers* ([exn:fail:database-locked? (with-handlers* ([exn:fail:retry?
(lambda (exn) (handler))]) (lambda (exn) (handler))])
(thunk))) (thunk)))
(define (fast-abort-on-limit fast-abort should-retry?)
(log-doc-db-info "database lock delay exceeded limit")
(fast-abort should-retry?))
;; By default, failure uses rollbacks, but `fast-abort' can be (define (call-with-retry/transaction who db write? thunk)
;; provided for a faster abort by dropping the connection. Don't try
;; to use a connection provided here in any other way on an abort. The
;; argument to `fast-abort' is `should-retry?': on #t, perhaps escape
;; to retry, but on #f, just clean up without escaping.
(define (call-with-retry/transaction who db fast-abort pause-limit thunk)
(let loop ([pause (doc-db-init-pause)]) (let loop ([pause (doc-db-init-pause)])
((let/ec esc ((let/ec esc
(define at-commit? #f)
(define success? #f) (define success? #f)
(dynamic-wind (dynamic-wind
(lambda () (lambda ()
(call-with-lock-handler (call-with-lock-handler
(lambda () (esc (lambda () (lambda () (esc (lambda ()
(if (and fast-abort (loop (doc-db-pause `(start ,who) pause)))))
(pause . > . pause-limit)) (lambda () (start-transaction db #:option (if write? 'immediate #f)))))
(fast-abort-on-limit fast-abort #t)
(loop (doc-db-pause `(start ,who) pause))))))
(lambda () (start-transaction db))))
(lambda () (lambda ()
(call-with-lock-handler (call-with-lock-handler
(lambda () (esc (lambda () (lambda () (esc (lambda ()
(rollback db fast-abort #t 1) (loop (doc-db-pause `(,(if at-commit? 'commit 'query)
(loop (doc-db-pause `(rollback ,who) pause))))) ,who)
pause)))))
(lambda () (lambda ()
(define l (call-with-values thunk list)) (define l (call-with-values thunk list))
(set! at-commit? #t)
(commit-transaction db) (commit-transaction db)
(set! success? #t) (set! success? #t)
(lambda () (apply values l))))) (lambda () (apply values l)))))
(lambda () (lambda ()
(unless success? (unless success?
(rollback db fast-abort #f 1)))))))) (rollback db 1))))))))
(define (rollback db fast-abort should-retry? count) (define (rollback db count)
(if fast-abort (when (in-transaction? db)
(fast-abort should-retry?) (with-handlers* ([exn:fail:retry?
(when (in-transaction? db) (lambda (exn)
(with-handlers* ([exn:fail:database-locked? (log-doc-db-info "database locked on rollback; tried ~a times so far"
(lambda (exn) count)
(when (zero? (modulo count 100)) (rollback db (add1 count)))])
(when (= count 10000) (error "fail")) (rollback-transaction db))))
(log-doc-db-info "database locked on rollback; tried ~a times so far"
count))
(rollback db #f should-retry? (add1 count)))])
(rollback-transaction db)))))
(define (call-with-retry who db fast-abort pause-limit thunk) (define (call-with-retry who db thunk)
(let loop ([pause (doc-db-init-pause)]) (let loop ([pause (doc-db-init-pause)])
((let/ec esc (call-with-lock-handler
(call-with-lock-handler (lambda () (loop (doc-db-pause `(query ,who) pause)))
(lambda () (esc (lambda () thunk)))
(if (and fast-abort
(pause . > . pause-limit))
(fast-abort-on-limit fast-abort #t)
(loop (doc-db-pause `(retry ,who) pause))))))
(lambda ()
(define l (call-with-values thunk list))
(lambda () (apply values l))))))))

52
collects/setup/xref.rkt
View File

@ -85,45 +85,29 @@
(lambda () (lambda ()
(for/list ([thunk (in-list thunks)]) (for/list ([thunk (in-list thunks)])
(thunk))))) (thunk)))))
(define pause-limit 1.0)
(lambda (key) (lambda (key)
(cond (cond
[forced-all? #f] [forced-all? #f]
[key [key
(define (try p) (define (try p)
(let loop ([pause (doc-db-init-pause)]) (and p
(cond (let* ([maybe-db (unbox (cdr p))]
[(pause . >= . pause-limit) [db
(log-doc-db-info "too much contention on database; falling back to full index") ;; Use a cached connection, or...
#t] (or (and (box-cas! (cdr p) maybe-db #f)
[else maybe-db)
(and p ;; ... create a new one
(let* ([maybe-db (unbox (cdr p))] (and (file-exists? (car p))
[db (doc-db-file->connection (car p))))])
;; Use a cached connection, or... (and
(or (and (box-cas! (cdr p) maybe-db #f) db
maybe-db) (let ()
;; ... create a new one ;; The db query:
(and (file-exists? (car p)) (begin0
(doc-db-file->connection (car p))))]) (doc-db-key->path db key)
(and ;; cache the connection, if none is already cached:
db (or (box-cas! (cdr p) #f db)
((let/ec esc (doc-db-disconnect db))))))))
;; The db query:
(define result
(doc-db-key->path db key
#:delay-limit pause-limit
#:fail (lambda (should-retry?)
;; Rollback within a connection can be slow,
;; so abandon the connection and try again:
(doc-db-disconnect db)
(when should-retry?
(esc (lambda ()
(loop (doc-db-pause 'xref-lookup pause))))))))
;; cache the connection, if none is already cached:
(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
(if (eq? dest #t) (if (eq? dest #t)