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

105
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,12 +66,9 @@
(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)])
((let/ec esc
(define db (if (connection? db-file) (define db (if (connection? db-file)
db-file db-file
(doc-db-file->connection db-file))) (doc-db-file->connection db-file)))
@ -83,36 +77,17 @@
(call-with-retry/transaction (call-with-retry/transaction
who who
db db
(if (connection? db-file) write?
(and fail (lambda () (proc db)))
(lambda (should-retry?)
(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) (teardown db)
(unless (connection? db-file) (unless (connection? db-file)
(disconnect db))))))) (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
(fast-abort should-retry?)
(when (in-transaction? db) (when (in-transaction? db)
(with-handlers* ([exn:fail:database-locked? (with-handlers* ([exn:fail:retry?
(lambda (exn) (lambda (exn)
(when (zero? (modulo count 100))
(when (= count 10000) (error "fail"))
(log-doc-db-info "database locked on rollback; tried ~a times so far" (log-doc-db-info "database locked on rollback; tried ~a times so far"
count)) count)
(rollback db #f should-retry? (add1 count)))]) (rollback db (add1 count)))])
(rollback-transaction db))))) (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 () (esc (lambda () (lambda () (loop (doc-db-pause `(query ,who) pause)))
(if (and fast-abort thunk)))
(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))))))))

24
collects/setup/xref.rkt
View File

@ -85,18 +85,11 @@
(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)])
(cond
[(pause . >= . pause-limit)
(log-doc-db-info "too much contention on database; falling back to full index")
#t]
[else
(and p (and p
(let* ([maybe-db (unbox (cdr p))] (let* ([maybe-db (unbox (cdr p))]
[db [db
@ -108,22 +101,13 @@
(doc-db-file->connection (car p))))]) (doc-db-file->connection (car p))))])
(and (and
db db
((let/ec esc (let ()
;; The db query: ;; The db query:
(define result (begin0
(doc-db-key->path db key (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: ;; cache the connection, if none is already cached:
(or (box-cas! (cdr p) #f db) (or (box-cas! (cdr p) #f db)
(doc-db-disconnect 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)