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

db: added nested transactions

Browse Source
This commit is contained in:
Ryan Culpepper 2011-12-31 01:47:03 -07:00
parent 62e117bfe6
commit dba35c3116
20 changed files with 974 additions and 355 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
collects/db/TODO
View File

@ -78,3 +78,30 @@ Misc
- sqlite3: sqlite3_last_insert_rowid(), use sqlite3_changes() to see if insert succeeded,
but still need to tell if stmt was even insert (parse sql?)
- odbc: ???
- add recursive locking?
- cons: - considered by experts to be bad design, sloppy
- pros: - would simplify cleanup for one-shot pstmts
- would enable simple impl of user-level 'call-with-lock' for grouping
multiple operations together
(but this could also be done by two locks: outer "ownership" lock
and inner "invariant-protecting" lock)
- audit code for break-safety, disable breaks as needed
- dialect info for ODBC
- can get some tx data from ODBC...
- on the other hand, not supposed to do tx-SQL in ODBC anyway, so low-priority
- postgresql query path optimizations
- once all types have binary readers...
- can eliminate prepare step when args given (use unnamed statement)
- then, can remember what SQL in unnamed statement, avoid re-parse
- mysql, sqlite3, odbc query path optimization
- can do something similar, but messier because no unnamed statement
- might make close-on-exec? obsolete
- add sql field to pstmt%, add sql=>pstmt hash in connection (update on pstmt finalize)
- use as stmt cache, avoid re-prepare
- sql field would be good for eventually implementing cursors, too
- PROBLEM: if schema changes, may invalidate pstmt, change types, etc

12
collects/db/private/generic/connect-util.rkt
View File

@ -67,8 +67,8 @@
(get-base)
(free-statement stmt)
(transaction-status fsym)
(start-transaction fsym isolation)
(end-transaction fsym mode)
(start-transaction fsym isolation cwt?)
(end-transaction fsym mode cwt?)
(list-tables fsym schema))
(super-new)))
@ -177,8 +177,8 @@
(#f #f (connected?))
(#t '_ (get-dbsystem))
(#t '_ (query fsym stmt))
(#t '_ (start-transaction fsym isolation))
(#f (void) (end-transaction fsym mode))
(#t '_ (start-transaction fsym isolation cwt?))
(#f (void) (end-transaction fsym mode cwt?))
(#f #f (transaction-status fsym))
(#t '_ (list-tables fsym schema)))
@ -340,8 +340,8 @@
(get-base)
(free-statement stmt)
(transaction-status fsym)
(start-transaction fsym isolation)
(end-transaction fsym mode)
(start-transaction fsym isolation cwt?)
(end-transaction fsym mode cwt?)
(list-tables fsym schema))
;; (define-forward define/override (connected?))

24
collects/db/private/generic/functions.rkt
View File

@ -253,13 +253,22 @@
;; ========================================
(define (start-transaction c #:isolation [isolation #f])
(send c start-transaction 'start-transaction isolation))
(send c start-transaction 'start-transaction isolation #f))
(define (commit-transaction c)
(send c end-transaction 'commit-transaction 'commit))
(send c end-transaction 'commit-transaction 'commit #f))
(define (rollback-transaction c)
(send c end-transaction 'rollback-transaction 'rollback))
(send c end-transaction 'rollback-transaction 'rollback #f))
(define (call-with-transaction c proc #:isolation [isolation #f])
(send c start-transaction '|call-with-transaction (start)| isolation #t)
(with-handlers ([(lambda (e) #t)
(lambda (e)
(send c end-transaction '|call-with-transaction (rollback)| 'rollback #t)
(raise e))])
(begin0 (call-with-continuation-barrier proc)
(send c end-transaction '|call-with-transaction (commit)| 'commit #t))))
(define (in-transaction? c)
(and (send c transaction-status 'in-transaction?) #t))
@ -267,15 +276,6 @@
(define (needs-rollback? c)
(eq? (send c transaction-status 'needs-rollback?) 'invalid))
(define (call-with-transaction c proc #:isolation [isolation #f])
(send c start-transaction 'call-with-transaction isolation)
(begin0 (with-handlers ([(lambda (e) #t)
(lambda (e)
(send c end-transaction 'call-with-transaction 'rollback)
(raise e))])
(proc))
(send c end-transaction 'call-with-transaction 'commit)))
;; ========================================
;; list-tables : ... -> (listof string)

240
collects/db/private/generic/interfaces.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require racket/class
racket/string
ffi/unsafe/atomic)
(provide connection<%>
dbsystem<%>
@ -18,6 +19,8 @@
transactions%
isolation-symbol->string
make-sql-classifier
sql-skip-comments
hex-string->bytes
@ -42,8 +45,11 @@
prepare ;; symbol preparable boolean -> prepared-statement<%>
get-base ;; -> connection<%> or #f (#f means base isn't fixed)
list-tables ;; symbol symbol -> (listof string)
start-transaction ;; symbol (U 'serializable ...) -> void
end-transaction ;; symbol (U 'commit 'rollback) -> void
;; in start-tx and end-tx, the final boolean arg indicates whether the
;; transaction is managed manually (#f) or by call-with-tx (#t)
start-transaction ;; symbol (U 'serializable ...) boolean -> void
end-transaction ;; symbol (U 'commit 'rollback) boolean -> void
transaction-status ;; symbol -> (U boolean 'invalid)
free-statement)) ;; prepared-statement<%> -> void
@ -279,13 +285,178 @@
(define transactions%
(class locking%
(inherit call-with-lock)
#|
A transaction created via SQL is "unmanaged".
A transaction created via start-tx, call-with-tx is "managed".
FIXME: eliminate distinction, if possible.
- currently: tx-stack != null means tx-status != #f
- would also like: tx-stack = null iff tx-status = #f
|#
;; tx-status : #f, #t, 'invalid
(field [tx-status #f])
;; tx-stack : (list (cons string boolean) ... (cons #f boolean)
;; Represents the "managed" transaction stack.
(field [tx-stack null])
;; check-valid-tx-status : symbol -> void
(define/public (check-valid-tx-status fsym)
(when (eq? tx-status 'invalid)
(uerror fsym "current transaction is invalid and must be explicitly rolled back")))
(uerror fsym "current transaction is invalid")))
;; ----
(define/public (transaction-status fsym)
(call-with-lock fsym (lambda () tx-status)))
;; transaction-nesting : -> (U #f 'unmanaged 'top-level 'nested)
(define/public (transaction-nesting)
(cond [(eq? tx-status #f) #f]
[(null? tx-stack) 'unmanaged]
[(null? (cdr tx-stack)) 'top-level]
[else 'nested]))
(define/public (tx-state->string)
(string-append (case (transaction-nesting)
((#f) "not in transaction")
((unmanaged) "in unmanaged transaction")
((top-level nested) "in managed transaction"))
(let ([savepoints (filter string? (map car tx-stack))])
(if (pair? savepoints)
(string-append "; savepoints: "
(string-join savepoints ", "))
""))))
;; ----
(define/public (start-transaction fsym isolation cwt?)
(call-with-lock fsym
(lambda ()
(check-valid-tx-status fsym)
(cond [(not tx-status)
(start-transaction* fsym isolation)
(set! tx-stack (list (cons #f cwt?)))]
[else ;; in transaction
(unless (eq? isolation #f)
(error fsym "invalid isolation level for nested transaction: ~e" isolation))
(let ([savepoint (start-transaction* fsym 'nested)])
(set! tx-stack (cons (cons savepoint cwt?) tx-stack)))])))
(void))
(define/public (start-transaction* fsym isolation)
;; returns string (savepoint name) if isolation = 'nested, #f otherwise
(error/internal fsym "not implemented"))
(define/public (end-transaction fsym mode cwt?)
(call-with-lock fsym
(lambda ()
(unless (eq? mode 'rollback)
;; PostgreSQL: otherwise COMMIT statement would cause silent ROLLBACK!
(check-valid-tx-status fsym))
(define tx-stack*
(cond [(and (eq? mode 'rollback) cwt?)
;; Need to rollback any open start-tx transactions within call-with-tx.
;; No need to complain, because cwt/rollback means exn already raised,
;; either by thunk or commit attempt.
(let loop ([tx-stack* tx-stack])
(cond [(pair? tx-stack*)
(if (cdar tx-stack*)
tx-stack*
(loop (cdr tx-stack*)))]
[else
(error/internal "unmatched end of call-with-transaction")]))]
[else tx-stack]))
(cond [(pair? tx-stack*)
(let ([savepoint (caar tx-stack*)]
[saved-cwt? (cdar tx-stack*)])
(unless (eq? saved-cwt? cwt?)
(case saved-cwt?
((#f) ;; saved-cwt = #f, cwt = #t
(error/unclosed-tx fsym mode #t))
((#t) ;; saved-cwt = #t, cwt = #f: possible
(error/unbalanced-tx fsym mode #t))))
(end-transaction* fsym mode savepoint)
(set! tx-stack (cdr tx-stack*)))]
[else ;; not in managed transaction
(when #f ;; DISABLED!
#|
FIXME: Unmatched {commit,rollback}-transaction should
probably be illegal outside of transaction for consistency
with requirements within call-with-tx. But that would break
backwards compatibility, so disabled.
|#
(error/unbalanced-tx fsym mode #f))
(when tx-status
;; Allow closing unmanaged transaction
(end-transaction* fsym mode #f))])
(void))))
(define/public (end-transaction* fsym mode savepoint)
(error/internal fsym "not implemented"))
;; check-statement/tx-status : symbol symbol/#f -> void
;; Used to check whether SQL command is allowed given managed tx status.
(define/public (check-statement/tx fsym stmt-type)
#|
Nested transaction safety
For simplicity, we put rules for all statement types here, including
non-standard statements. FIXME: need to decouple eventually.
if in "unmanaged" top-level transaction
- allow all SQL commands (but restrict tx functions)
- yes, even implicit-commit
if in "managed" top-level transaction (no "managed" savepoints):
- START not allowed
- COMMIT, ROLLBACK not allowed (for now!)
- SAVEPOINT allowed
- RELEASE TO, ROLLBACK TO allowed
- implicit-commit not allowed
if in nested "managed" transaction (impl as "managed" savepoint):
- START not allowed
- COMMIT, ROLLBACK not allowed
- SAVEPOINT not allowed -- because it could not be used; see next
- RELEASE TO, ROLLBACK TO not allowed -- because it may cross nesting levels
- implicit-commit now allowed
|#
(define (no! why)
(error fsym "~a not allowed~a"
(or (statement-type->string stmt-type)
(case stmt-type
((implicit-commit) "statement with implicit commit")
(else "unknown")))
(or why "")))
(case (transaction-nesting)
((#f)
(void))
((unmanaged)
(void))
((top-level)
(case stmt-type
((start)
(no! " within transaction"))
((commit rollback
implicit-commit)
(no! " within managed transaction"))
(else (void))))
((nested)
(case stmt-type
((start)
(no! " within transaction"))
((commit rollback
savepoint prepare-transaction
release-savepoint rollback-savepoint
implicit-commit)
(no! " in managed transaction"))
(else (void))))))
(super-new)))
@ -303,6 +474,57 @@
;; ----------------------------------------
;; Simple SQL "parsing" (just classification)
(define (make-sql-classifier table-spec
#:hash-comments? [hash-comments? #f])
(define (make-sql-regexp stmt-str)
;; eg, turns "alter table" into #px"^[[:space:]]*(?i:alter)[[:space:]](?i:table)"
;; FIXME/TODO: comments (need real tokenizer; keep regexps as fast path?)
(pregexp
(apply string-append
"^"
(for/list ([piece (in-list (regexp-split #rx" " stmt-str))])
(format "[[:space:]]*(?i:~a)(?i:[[:space:]]|$)" piece)))))
(define classifier-table
(for/list ([rule-spec (in-list table-spec)])
(cons (make-sql-regexp (car rule-spec)) (cadr rule-spec))))
(lambda (str [start 0])
(let ([start (sql-skip-comments str start #:hash-comments? hash-comments?)])
(for/first ([rule (in-list classifier-table)]
#:when (regexp-match? (car rule) str start))
(cdr rule)))))
;; sql-skip-comments : string nat -> nat
(define (sql-skip-comments str start #:hash-comments? [hash-comments? #f])
(define dash-rx #px"^[[:space:]]*-- [^\n\r]*(?:[\n\r]|$)")
(define sh-like-rx #px"^[[:space:]]*#[^\n\r]*(?:[\n\r]|$)")
(define c-like-rx #px"^[[:space:]]*/\\*(?:[^\\*]|\\*[^/])*\\*/")
(let loop ([start start])
(cond [(or (regexp-match-positions dash-rx str start)
(regexp-match-positions c-like-rx str start)
(and hash-comments?
(regexp-match-positions sh-like-rx str start)))
=> (lambda (pl) (loop (cdar pl)))]
[else start])))
;; statement-type->string : symbol -> string/#f
(define (statement-type->string stmt-type)
(case stmt-type
;; standard
((start) "START TRANSACTION")
((commit) "COMMIT")
((rollback) "ROLLBACK")
((savepoint) "SAVEPOINT")
((release-savepoint) "RELEASE SAVEPOINT")
((rollback-savepoint) "ROLLBACK TO SAVEPOINT")
;; postgresql extensions
((prepare-transaction) "PREPARE TRANSACTION")
;; unknown
(else #f)))
;; ----------------------------------------
;; Passwords
#|
@ -382,7 +604,6 @@ producing plain old exn:fail.
error/comm
error/hopeless
error/unsupported-type
error/already-in-tx
error/no-convert)
;;(define uerror raise-user-error)
@ -410,9 +631,14 @@ producing plain old exn:fail.
(uerror fsym "unsupported type: ~a (typeid ~a)" type typeid)
(uerror fsym "unsupported type: (typeid ~a)" typeid)))
(define (error/already-in-tx fsym)
(uerror fsym "already in transaction"))
(define (error/no-convert fsym sys type param [note #f])
(uerror fsym "cannot convert to ~a ~a type~a~a: ~e"
sys type (if note " " "") (or note "") param))
(define (error/unbalanced-tx fsym mode saved-cwt?)
(error fsym "~a-transaction without matching start-transaction~a"
mode (if saved-cwt? " (within the extent of call-with-transaction)" "")))
(define (error/unclosed-tx fsym mode saved-cwt?)
(error fsym "unclosed nested transaction~a"
(if saved-cwt? " (within extent of call-with-transaction)" "")))

8
collects/db/private/generic/place-client.rkt
View File

@ -74,10 +74,10 @@
(call 'prepare fsym stmt close-on-exec?))
(define/public (transaction-status fsym)
(call 'transaction-status fsym))
(define/public (start-transaction fsym iso)
(call 'start-transaction fsym iso))
(define/public (end-transaction fsym mode)
(call 'end-transaction fsym mode))
(define/public (start-transaction fsym iso cwt?)
(call 'start-transaction fsym iso cwt?))
(define/public (end-transaction fsym mode cwt?)
(call 'end-transaction fsym mode cwt?))
(define/public (list-tables fsym schema)
(call 'list-tables fsym schema))

4
collects/db/private/generic/place-server.rkt
View File

@ -109,8 +109,8 @@ server -> client: (or (list 'values result ...)
(forward-methods (connected?)
(prepare w s m)
(list-tables w s)
(start-transaction w m)
(end-transaction w m)
(start-transaction w m c)
(end-transaction w m c)
(transaction-status w))]))
(lambda results
(let ([results (for/list ([result (in-list results)]) (result->sexpr result))])

7
collects/db/private/generic/prepared.rkt
View File

@ -8,11 +8,12 @@
;; prepared-statement%
(define prepared-statement%
(class* object% (prepared-statement<%>)
(init ([-owner owner]))
(init-field handle ;; handle, determined by database system, #f means closed
close-on-exec? ;; boolean
param-typeids ;; (listof typeid)
result-dvecs) ;; (listof vector), layout depends on dbsys
(init ([-owner owner]))
result-dvecs ;; (listof vector), layout depends on dbsys
[stmt-type #f]) ;; usually symbol or #f (see classify-*-sql)
(define owner (make-weak-box -owner))
(define dbsystem (send -owner get-dbsystem))
@ -39,6 +40,8 @@
(define/public (get-result-types)
(send dbsystem describe-typeids result-typeids))
(define/public (get-stmt-type) stmt-type)
;; checktype is either #f, 'rows, or exact-positive-integer
(define/public (check-results fsym checktype obj)
(cond [(eq? checktype 'rows)

126
collects/db/private/mysql/connection.rkt
View File

@ -24,7 +24,8 @@
(inherit call-with-lock
call-with-lock*
add-delayed-call!
check-valid-tx-status)
check-valid-tx-status
check-statement/tx)
(inherit-field tx-status)
(super-new)
@ -38,12 +39,10 @@
;; == Debugging
(define DEBUG-RESPONSES #f)
(define DEBUG-SENT-MESSAGES #f)
(define DEBUG? #f)
(define/public (debug incoming? [outgoing? incoming?])
(set! DEBUG-RESPONSES incoming?)
(set! DEBUG-SENT-MESSAGES outgoing?))
(define/public (debug debug?)
(set! DEBUG? debug?))
;; ========================================
@ -62,7 +61,7 @@
;; buffer-message : message -> void
(define/private (buffer-message msg)
(when DEBUG-SENT-MESSAGES
(when DEBUG?
(fprintf (current-error-port) " >> ~s\n" msg))
(with-disconnect-on-error
(write-packet outport msg next-msg-num)
@ -93,7 +92,7 @@
(error/comm fsym))
(let-values ([(msg-num next) (parse-packet inport expectation field-dvecs)])
(set! next-msg-num (add1 msg-num))
(when DEBUG-RESPONSES
(when DEBUG?
(eprintf " << ~s\n" next))
;; Update transaction status (see Transactions below)
(when (ok-packet? next)
@ -145,7 +144,7 @@
(define/private (disconnect* lock-not-held?)
(define (go politely?)
(when DEBUG-SENT-MESSAGES
(when DEBUG?
(eprintf " ** Disconnecting\n"))
(let ([outport* outport]
[inport* inport])
@ -258,18 +257,22 @@
;; == Query
;; name-counter : number
(define name-counter 0)
;; query : symbol Statement -> QueryResult
(define/public (query fsym stmt)
(check-valid-tx-status fsym)
(let*-values ([(stmt result)
(call-with-lock fsym
(lambda ()
(let ([stmt (check-statement fsym stmt)])
(let* ([stmt (check-statement fsym stmt)]
[stmt-type
(cond [(statement-binding? stmt)
(send (statement-binding-pst stmt) get-stmt-type)]
[(string? stmt)
(classify-my-sql stmt)])])
(check-statement/tx fsym stmt-type)
(values stmt (query1 fsym stmt #t)))))])
;; For some reason, *really* slow: (statement:after-exec stmt)
(when #f ;; DISABLED---for some reason, *really* slow
(statement:after-exec stmt))
(query1:process-result fsym result)))
;; query1 : symbol Statement -> QueryResult
@ -373,6 +376,7 @@
(close-on-exec? close-on-exec?)
(param-typeids (map field-dvec->typeid param-dvecs))
(result-dvecs field-dvecs)
(stmt-type (classify-my-sql stmt))
(owner this)))])))
(define/private (prepare1:get-field-descriptions fsym)
@ -425,33 +429,41 @@
;; - transaction deadlock = 1213 (ER_LOCK_DEADLOCK)
;; - lock wait timeout (depends on config) = 1205 (ER_LOCK_WAIT_TIMEOUT)
(define/public (transaction-status fsym)
(call-with-lock fsym (lambda () tx-status)))
(define/override (start-transaction* fsym isolation)
(cond [(eq? isolation 'nested)
(let ([savepoint (generate-name)])
(query1 fsym (format "SAVEPOINT ~a" savepoint) #t)
savepoint)]
[else
(let ([isolation-level (isolation-symbol->string isolation)])
(when isolation-level
(query1 fsym (format "SET TRANSACTION ISOLATION LEVEL ~a" isolation-level) #t))
(query1 fsym "START TRANSACTION" #t)
#f)]))
(define/public (start-transaction fsym isolation)
(call-with-lock fsym
(lambda ()
(when tx-status
(error/already-in-tx fsym))
;; SET TRANSACTION ISOLATION LEVEL sets mode for *next* transaction
;; so need lock around both statements
(let* ([isolation-level (isolation-symbol->string isolation)]
[set-stmt "SET TRANSACTION ISOLATION LEVEL "])
(when isolation-level
(query1 fsym (string-append set-stmt isolation-level) #t)))
(query1 fsym "START TRANSACTION" #t)
(void))))
(define/override (end-transaction* fsym mode savepoint)
(case mode
((commit)
(cond [savepoint
(query1 fsym (format "RELEASE SAVEPOINT ~a" savepoint) #t)]
[else
(query1 fsym "COMMIT" #t)]))
((rollback)
(cond [savepoint
(query1 fsym (format "ROLLBACK TO SAVEPOINT ~a" savepoint) #t)
(query1 fsym (format "RELEASE SAVEPOINT ~a" savepoint) #t)]
[else
(query1 fsym "ROLLBACK" #t)])))
(void))
(define/public (end-transaction fsym mode)
(call-with-lock fsym
(lambda ()
(unless (eq? mode 'rollback)
(check-valid-tx-status fsym))
(let ([stmt (case mode
((commit) "COMMIT")
((rollback) "ROLLBACK"))])
(query1 fsym stmt #t)
(void)))))
;; name-counter : number
(define name-counter 0)
;; generate-name : -> string
(define/private (generate-name)
(let ([n name-counter])
(set! name-counter (add1 name-counter))
(format "λmz_~a" n)))
;; Reflection
@ -461,11 +473,7 @@
(string-append "SELECT table_name FROM information_schema.tables "
"WHERE table_schema = schema()")]
[rows
(vector-ref
(call-with-lock fsym
(lambda ()
(query1 fsym stmt #t)))
2)])
(vector-ref (call-with-lock fsym (lambda () (query1 fsym stmt #t))) 2)])
(for/list ([row (in-list rows)])
(vector-ref row 0))))
@ -598,34 +606,8 @@ On the other hand, we want to force all rows-returning statements
through the prepared-statement path to use the binary data
protocol. That would seem to be the following:
CALL (?) and SELECT
The following bit of heinously offensive code determines the kind of
SQL statement is contained in a string.
----
3 kinds of comments in mysql SQL:
- "#" to end of line
- "-- " to end of line
- "/*" to next "*/" (not nested), except some weird conditional-inclusion stuff
I'll ignore the third kind.
SELECT and SHOW
|#
(define (force-prepare-sql? fsym stmt)
(let ([kw (get-sql-keyword stmt)])
(cond [(not kw)
;; better to have unpreparable stmt rejected than
;; to have SELECT return unconvered types
#t]
[(string-ci=? kw "select") #t]
[(string-ci=? kw "call") #t]
[else #f])))
(define sql-statement-rx
#rx"^(?:(?:#[^\n\r]*[\n\r])|(?:-- [^\n\r]*[\n\r])|[ \t\n\r])*([A-Za-z]+)")
(define (get-sql-keyword stmt)
(let ([m (regexp-match sql-statement-rx stmt)])
(and m (cadr m))))
(memq (classify-my-sql stmt) '(select show)))

41
collects/db/private/mysql/dbsystem.rkt
View File

@ -4,7 +4,8 @@
"../generic/sql-data.rkt"
"../../util/private/geometry.rkt"
(only-in "message.rkt" field-dvec->typeid))
(provide dbsystem)
(provide dbsystem
classify-my-sql)
(define mysql-dbsystem%
(class* object% (dbsystem<%>)
@ -55,6 +56,44 @@
;; ========================================
;; SQL "parsing"
;; We care about:
;; - determining whether commands must be prepared (to use binary data)
;; see http://dev.mysql.com/doc/refman/5.0/en/c-api-prepared-statements.html
;; - detecting commands that affect transaction status (maybe implicitly)
;; see http://dev.mysql.com/doc/refman/5.0/en/implicit-commit.html
;; classify-my-sql : string [nat] -> symbol/#f
(define classify-my-sql
(make-sql-classifier #:hash-comments? #t
'(;; Must be prepared
("SELECT" select)
("SHOW" show)
;; Explicit transaction commands
("ROLLBACK WORK TO" rollback-savepoint)
("ROLLBACK TO" rollback-savepoint)
("RELEASE SAVEPOINT" release-savepoint)
("SAVEPOINT" savepoint)
("START TRANSACTION" start)
("BEGIN" start)
("COMMIT" commit)
("ROLLBACK" rollback) ;; Note: after ROLLBACK TO, etc
("SET autocommit" set-autocommit) ;; trouble
;; Note: commit/rollback may immediately start new transaction
;; Implicit commit
("ALTER" implicit-commit)
("CREATE" implicit-commit)
("DROP" implicit-commit)
("RENAME" implicit-commit)
("TRUNCATE" implicit-commit)
("LOAD" implicit-commit)
("LOCK TABLES" implicit-commit)
("UNLOCK TABLES" implicit-commit))))
;; ========================================
(define-type-table (supported-types
type-alias->type
typeid->type

110
collects/db/private/odbc/connection.rkt
View File

@ -42,7 +42,8 @@
(inherit call-with-lock
call-with-lock*
add-delayed-call!
check-valid-tx-status)
check-valid-tx-status
check-statement/tx)
(inherit-field tx-status)
(define/public (get-db fsym)
@ -58,12 +59,12 @@
(call-with-lock fsym
(lambda ()
(check-valid-tx-status fsym)
(query1 fsym stmt)))])
(query1 fsym stmt #t)))])
(statement:after-exec stmt*)
(cond [(pair? dvecs) (rows-result (map field-dvec->field-info dvecs) rows)]
[else (simple-result '())])))
(define/private (query1 fsym stmt)
(define/private (query1 fsym stmt check-tx?)
(let* ([stmt (cond [(string? stmt)
(let* ([pst (prepare1 fsym stmt #t)])
(send pst bind fsym null))]
@ -72,6 +73,7 @@
[pst (statement-binding-pst stmt)]
[params (statement-binding-params stmt)])
(send pst check-owner fsym this stmt)
(when check-tx? (check-statement/tx fsym (send pst get-stmt-type)))
(let ([result-dvecs (send pst get-result-dvecs)])
(for ([dvec (in-list result-dvecs)])
(let ([typeid (field-dvec->typeid dvec)])
@ -409,9 +411,10 @@
(let ([pst (new prepared-statement%
(handle stmt)
(close-on-exec? close-on-exec?)
(owner this)
(param-typeids param-typeids)
(result-dvecs result-dvecs))])
(result-dvecs result-dvecs)
(stmt-type (classify-odbc-sql sql))
(owner this))])
(hash-set! statement-table pst #t)
pst)))
@ -473,59 +476,50 @@
;; Transactions
(define/public (transaction-status fsym)
(call-with-lock fsym
(lambda () (let ([db (get-db fsym)]) tx-status))))
(define/override (start-transaction* fsym isolation)
(when (eq? isolation 'nested)
(uerror fsym "already in transaction (nested transactions not supported for ODBC)"))
(let* ([db (get-db fsym)]
[ok-levels
(let-values ([(status value)
(SQLGetInfo db SQL_TXN_ISOLATION_OPTION)])
(begin0 value (handle-status fsym status db)))]
[default-level
(let-values ([(status value)
(SQLGetInfo db SQL_DEFAULT_TXN_ISOLATION)])
(begin0 value (handle-status fsym status db)))]
[requested-level
(case isolation
((serializable) SQL_TXN_SERIALIZABLE)
((repeatable-read) SQL_TXN_REPEATABLE_READ)
((read-committed) SQL_TXN_READ_COMMITTED)
((read-uncommitted) SQL_TXN_READ_UNCOMMITTED)
(else
;; MySQL ODBC returns 0 for default level, seems no good.
;; So if 0, use serializable.
(if (zero? default-level) SQL_TXN_SERIALIZABLE default-level)))])
(when (zero? (bitwise-and requested-level ok-levels))
(uerror fsym "requested isolation level ~a is not available" isolation))
(let ([status (SQLSetConnectAttr db SQL_ATTR_TXN_ISOLATION requested-level)])
(handle-status fsym status db)))
(let ([status (SQLSetConnectAttr db SQL_ATTR_AUTOCOMMIT SQL_AUTOCOMMIT_OFF)])
(handle-status fsym status db)
(set! tx-status #t)
(void)))
(define/public (start-transaction fsym isolation)
(call-with-lock fsym
(lambda ()
(let* ([db (get-db fsym)])
(when tx-status
(error/already-in-tx fsym))
(let* ([ok-levels
(let-values ([(status value)
(SQLGetInfo db SQL_TXN_ISOLATION_OPTION)])
(begin0 value (handle-status fsym status db)))]
[default-level
(let-values ([(status value)
(SQLGetInfo db SQL_DEFAULT_TXN_ISOLATION)])
(begin0 value (handle-status fsym status db)))]
[requested-level
(case isolation
((serializable) SQL_TXN_SERIALIZABLE)
((repeatable-read) SQL_TXN_REPEATABLE_READ)
((read-committed) SQL_TXN_READ_COMMITTED)
((read-uncommitted) SQL_TXN_READ_UNCOMMITTED)
(else
;; MySQL ODBC returns 0 for default level, seems no good.
;; So if 0, use serializable.
(if (zero? default-level) SQL_TXN_SERIALIZABLE default-level)))])
(when (zero? (bitwise-and requested-level ok-levels))
(uerror fsym "requested isolation level ~a is not available" isolation))
(let ([status (SQLSetConnectAttr db SQL_ATTR_TXN_ISOLATION requested-level)])
(handle-status fsym status db)))
(let ([status (SQLSetConnectAttr db SQL_ATTR_AUTOCOMMIT SQL_AUTOCOMMIT_OFF)])
(handle-status fsym status db)
(set! tx-status #t)
(void))))))
(define/public (end-transaction fsym mode)
(call-with-lock fsym
(lambda ()
(unless (eq? mode 'rollback)
(check-valid-tx-status fsym))
(let ([db (get-db fsym)]
[completion-type
(case mode
((commit) SQL_COMMIT)
((rollback) SQL_ROLLBACK))])
(handle-status fsym (SQLEndTran db completion-type) db)
(let ([status (SQLSetConnectAttr db SQL_ATTR_AUTOCOMMIT SQL_AUTOCOMMIT_ON)])
(handle-status fsym status db)
;; commit/rollback can fail; don't change status until possible error handled
(set! tx-status #f)
(void))))))
(define/override (end-transaction* fsym mode _savepoint)
;; _savepoint = #f, because nested transactions not supported on ODBC
(let ([db (get-db fsym)]
[completion-type
(case mode
((commit) SQL_COMMIT)
((rollback) SQL_ROLLBACK))])
(handle-status fsym (SQLEndTran db completion-type) db)
(let ([status (SQLSetConnectAttr db SQL_ATTR_AUTOCOMMIT SQL_AUTOCOMMIT_ON)])
(handle-status fsym status db)
;; commit/rollback can fail; don't change status until possible error handled
(set! tx-status #f)
(void))))
;; GetTables
@ -669,7 +663,7 @@ all Racket threads for a long time.
1) The postgresql, mysql, and oracle drivers don't even support async
execution. Only DB2 (and probably SQL Server, but I didn't try it).
2) Tests using the DB2 driver gave bafflind HY010 (function sequence
2) Tests using the DB2 driver gave baffling HY010 (function sequence
error). My best theory so far is that DB2 (or maybe unixodbc) requires
poll call arguments to be identical to original call arguments, which
means that I would have to replace all uses of (_ptr o X) with

34
collects/db/private/odbc/dbsystem.rkt
View File

@ -4,7 +4,8 @@
"../generic/sql-data.rkt"
"../generic/sql-convert.rkt")
(provide dbsystem
supported-typeid?)
supported-typeid?
classify-odbc-sql)
(define odbc-dbsystem%
(class* object% (dbsystem<%>)
@ -28,6 +29,37 @@
;; ----
;; SQL "parsing"
;; We just care about detecting commands that affect transaction status.
;; Since we have no idea what the actual database system is, just cover
;; standard commands and assume DDL is not transactional.
;; classify-odbc-sql : string [nat] -> symbol/#f
(define classify-odbc-sql
(make-sql-classifier #:hash-comments? #t
'(;; Explicit transaction commands
("ROLLBACK TRANSACTION TO" rollback-savepoint)
("ROLLBACK WORK TO" rollback-savepoint)
("ROLLBACK TO" rollback-savepoint)
("RELEASE" release-savepoint)
("SAVEPOINT" savepoint)
("START" start)
("BEGIN" start)
("COMMIT" commit)
("END" commit)
("ROLLBACK" rollback) ;; Note: after ROLLBACK TO, etc
;; Implicit commit
("ALTER" implicit-commit)
("CREATE" implicit-commit)
("DROP" implicit-commit)
("GRANT" implicit-commit)
("RENAME" implicit-commit)
("TRUNCATE" implicit-commit))))
;; ----
(define-syntax-rule
(defchecks get-check [(typeid name pred ...) ...] [(*typeid *name *fun) ...])
(define get-check

155
collects/db/private/postgresql/connection.rkt
View File

@ -33,7 +33,10 @@
(inherit call-with-lock
call-with-lock*
add-delayed-call!
check-valid-tx-status)
check-valid-tx-status
check-statement/tx
transaction-nesting
tx-state->string)
(inherit-field tx-status)
(super-new)
@ -48,12 +51,10 @@
;; == Debugging
;; Debugging
(define DEBUG-RESPONSES #f)
(define DEBUG-SENT-MESSAGES #f)
(define DEBUG? #f)
(define/public (debug incoming? [outgoing? incoming?])
(set! DEBUG-RESPONSES incoming?)
(set! DEBUG-SENT-MESSAGES outgoing?))
(define/public (debug debug?)
(set! DEBUG? debug?))
;; ========================================
@ -64,7 +65,7 @@
(define/private (raw-recv)
(with-disconnect-on-error
(let ([r (parse-server-message inport)])
(when DEBUG-RESPONSES
(when DEBUG?
(fprintf (current-error-port) " << ~s\n" r))
r)))
@ -88,7 +89,7 @@
;; buffer-message : message -> void
(define/private (buffer-message msg)
(when DEBUG-SENT-MESSAGES
(when DEBUG?
(fprintf (current-error-port) " >> ~s\n" msg))
(with-disconnect-on-error
(write-message msg outport)))
@ -141,7 +142,7 @@
;; disconnect* : boolean -> void
(define/private (disconnect* no-lock-held?)
(define (go politely?)
(when DEBUG-SENT-MESSAGES
(when DEBUG?
(fprintf (current-error-port) " ** Disconnecting\n"))
(let ([outport* outport]
[inport* inport])
@ -243,43 +244,55 @@
(call-with-lock fsym
(lambda ()
(check-valid-tx-status fsym)
(query1 fsym stmt0)))])
(let* ([stmt (check-statement fsym stmt0)]
[stmt-type (send (statement-binding-pst stmt) get-stmt-type)])
(check-statement/tx fsym stmt-type)
(values stmt (query1 fsym stmt #f)))))])
(statement:after-exec stmt)
(query1:process-result fsym result)))
(define/private (query1 fsym stmt)
(let ([stmt (check-statement fsym stmt)])
(query1:enqueue stmt)
(send-message (make-Sync))
(begin0 (values stmt (query1:collect fsym stmt))
(check-ready-for-query fsym #f))))
(define/private (query1 fsym stmt simple?)
;; if simple?: stmt must be string, no params, & results must be binary-readable
(query1:enqueue stmt)
(send-message (make-Sync))
(begin0 (query1:collect fsym simple?)
(check-ready-for-query fsym #f)
(when DEBUG?
(fprintf (current-error-port) " ** ~a\n" (tx-state->string)))))
;; check-statement : symbol statement -> statement-binding
;; Always prepare, so we can have type information to choose result formats.
;; Convert to statement-binding; need to prepare to get type information, used to
;; choose result formats.
;; FIXME: if text format eliminated, can skip prepare
;; FIXME: can use classify-pg-sql to avoid preparing stmts with no results
(define/private (check-statement fsym stmt)
(cond [(statement-binding? stmt)
(let ([pst (statement-binding-pst stmt)])
(send pst check-owner fsym this stmt))
stmt]
(send pst check-owner fsym this stmt)
stmt)]
[(string? stmt)
(let ([pst (prepare1 fsym stmt #t)])
(send pst bind fsym null))]))
;; query1:enqueue : Statement -> void
(define/private (query1:enqueue stmt)
(let* ([pst (statement-binding-pst stmt)]
[pst-name (send pst get-handle)]
[params (statement-binding-params stmt)])
(buffer-message (make-Bind "" pst-name
(map typeid->format (send pst get-param-typeids))
params
(map typeid->format (send pst get-result-typeids)))))
(cond [(statement-binding? stmt)
(let* ([pst (statement-binding-pst stmt)]
[pst-name (send pst get-handle)]
[params (statement-binding-params stmt)])
(buffer-message (make-Bind "" pst-name
(map typeid->format (send pst get-param-typeids))
params
(map typeid->format (send pst get-result-typeids)))))]
[(string? stmt)
(buffer-message (make-Parse "" stmt '()))
(buffer-message (make-Bind "" "" '() '() '(1)))])
(buffer-message (make-Describe 'portal ""))
(buffer-message (make-Execute "" 0))
(buffer-message (make-Close 'portal "")))
(define/private (query1:collect fsym stmt)
(when (string? stmt)
(define/private (query1:collect fsym simple?)
(when simple?
(match (recv-message fsym)
[(struct ParseComplete ()) (void)]
[other-r (query1:error fsym other-r)]))
@ -360,14 +373,14 @@
(let ([name (generate-name)])
(prepare1:enqueue name stmt)
(send-message (make-Sync))
(begin0 (prepare1:collect fsym name close-on-exec?)
(begin0 (prepare1:collect fsym name close-on-exec? (classify-pg-sql stmt))
(check-ready-for-query fsym #f))))
(define/private (prepare1:enqueue name stmt)
(buffer-message (make-Parse name stmt null))
(buffer-message (make-Describe 'statement name)))
(define/private (prepare1:collect fsym name close-on-exec?)
(define/private (prepare1:collect fsym name close-on-exec? stmt-type)
(match (recv-message fsym)
[(struct ParseComplete ()) (void)]
[other-r (prepare1:error fsym other-r)])
@ -378,6 +391,7 @@
(close-on-exec? close-on-exec?)
(param-typeids param-typeids)
(result-dvecs field-dvecs)
(stmt-type stmt-type)
(owner this))))
(define/private (prepare1:describe-params fsym)
@ -423,57 +437,52 @@
;; == Transactions
(define/public (transaction-status fsym)
(call-with-lock fsym (lambda () tx-status)))
(define/override (start-transaction* fsym isolation)
(cond [(eq? isolation 'nested)
(let ([savepoint (generate-name)])
(query1 fsym (format "SAVEPOINT ~a" savepoint) #t)
savepoint)]
[else
(let* ([isolation-level (isolation-symbol->string isolation)]
[stmt (if isolation-level
(string-append "BEGIN WORK ISOLATION LEVEL " isolation-level)
"BEGIN WORK")])
;; FIXME: also support
;; 'read-only => "READ ONLY"
;; 'read-write => "READ WRITE"
(query1 fsym stmt #t)
#f)]))
(define/public (start-transaction fsym isolation)
(internal-query fsym
(lambda ()
(when tx-status
(error/already-in-tx fsym)))
(let ([isolation-level (isolation-symbol->string isolation)])
;; 'read-only => "READ ONLY"
;; 'read-write => "READ WRITE"
(if isolation-level
(string-append "BEGIN WORK ISOLATION LEVEL " isolation-level)
"BEGIN WORK")))
(void))
(define/public (end-transaction fsym mode)
(internal-query fsym
(lambda ()
(unless (eq? mode 'rollback)
;; otherwise, COMMIT statement would cause silent ROLLBACK !!!
(check-valid-tx-status fsym)))
(case mode
((commit) "COMMIT WORK")
((rollback) "ROLLBACK WORK")))
(define/override (end-transaction* fsym mode savepoint)
(case mode
((commit)
(cond [savepoint
(query1 fsym (format "RELEASE SAVEPOINT ~a" savepoint) #t)]
[else
(query1 fsym "COMMIT WORK" #t)]))
((rollback)
(cond [savepoint
(query1 fsym (format "ROLLBACK TO SAVEPOINT ~a" savepoint) #t)
(query1 fsym (format "RELEASE SAVEPOINT ~a" savepoint) #t)]
[else
(query1 fsym "ROLLBACK WORK" #t)])))
(void))
;; == Reflection
(define/public (list-tables fsym schema)
(let* ([where-cond
(case schema
((search search-or-current)
"table_schema = SOME (current_schemas(false))")
((current)
"table_schema = current_schema"))]
[stmt
(string-append "SELECT table_name FROM information_schema.tables WHERE "
where-cond)]
[rows (vector-ref (internal-query fsym void stmt) 2)])
(let* ([stmt
(string-append
"SELECT table_name FROM information_schema.tables WHERE "
(case schema
((search search-or-current)
"table_schema = SOME (current_schemas(false))")
((current)
"table_schema = current_schema")))]
[result (call-with-lock fsym (lambda () (query1 fsym stmt #t)))]
[rows (vector-ref result 2)])
(for/list ([row (in-list rows)])
(bytes->string/utf-8 (vector-ref row 0)))))
(define/private (internal-query fsym pre-thunk stmt)
(let-values ([(stmt result)
(call-with-lock fsym
(lambda ()
(pre-thunk)
(query1 fsym stmt)))])
(statement:after-exec stmt)
result))
))
;; ========================================

35
collects/db/private/postgresql/dbsystem.rkt
View File

@ -13,7 +13,8 @@
(only-in "message.rkt" field-dvec->typeid))
(provide dbsystem
typeid->type-reader
typeid->format)
typeid->format
classify-pg-sql)
(define postgresql-dbsystem%
(class* object% (dbsystem<%>)
@ -45,6 +46,38 @@
;; ========================================
;; SQL "parsing"
;; We just care about detecting commands that affect transaction status.
;; classify-pg-sql : string [nat] -> symbol/#f
(define classify-pg-sql
;; Source: http://www.postgresql.org/docs/current/static/sql-commands.html
(make-sql-classifier
`(("ABORT" rollback)
("BEGIN" start)
;; COMMIT PREPARED itself is harmless.
("COMMIT PREPARED" #f) ;; Note: before COMMIT
("COMMIT" commit)
("DO" *do) ;; can do anything
("END" commit)
("EXECUTE" *execute) ;; can do anything
;; PREPARE TRANSACTION is like shift: it saves and aborts current transaction.
;; Perhaps all we care about is that it ends transaction, treat like commit/rollback.
("PREPARE TRANSACTION" prepare-transaction) ;; Note: before PREPARE
("RELEASE SAVEPOINT" release-savepoint)
;; For ROLLBACK variants, ordered carefully and expanded optional words
;; ROLLBACK PREPARED just deletes saved transaction
("ROLLBACK PREPARED" #f)
("ROLLBACK WORK TO" rollback-savepoint)
("ROLLBACK TRANSACTION TO" rollback-savepoint)
("ROLLBACK TO" rollback-savepoint)
("ROLLBACK" rollback)
("SAVEPOINT" savepoint)
("START TRANSACTION" start)
)))
;; ========================================
;; Derived from
;; http://www.us.postgresql.org/users-lounge/docs/7.2/postgres/datatype.html
;; and

101
collects/db/private/sqlite3/connection.rkt
View File

@ -24,11 +24,12 @@
(inherit call-with-lock*
add-delayed-call!
check-valid-tx-status)
(inherit-field tx-status) ;; only #f or 'invalid for compat w/ check-valid-tx-status
check-valid-tx-status
check-statement/tx)
(inherit-field tx-status)
(define/override (call-with-lock fsym proc)
(call-with-lock* fsym (lambda () (set! saved-tx-status (get-tx-status)) (proc)) #f #t))
(call-with-lock* fsym (lambda () (set! saved-tx-status tx-status) (proc)) #f #t))
(define/private (get-db fsym)
(or -db (error/not-connected fsym)))
@ -41,11 +42,11 @@
(call-with-lock fsym
(lambda ()
(check-valid-tx-status fsym)
(query1 fsym stmt)))])
(query1 fsym stmt #t)))])
(statement:after-exec stmt)
result))
(define/private (query1 fsym stmt)
(define/private (query1 fsym stmt check-tx?)
(let* ([stmt (cond [(string? stmt)
(let* ([pst (prepare1 fsym stmt #t)])
(send pst bind fsym null))]
@ -54,6 +55,7 @@
[pst (statement-binding-pst stmt)]
[params (statement-binding-params stmt)])
(send pst check-owner fsym this stmt)
(when check-tx? (check-statement/tx fsym (send pst get-stmt-type)))
(let ([db (get-db fsym)]
[stmt (send pst get-handle)])
(HANDLE fsym (sqlite3_reset stmt))
@ -68,18 +70,13 @@
[rows (step* fsym db stmt)])
(HANDLE fsym (sqlite3_reset stmt))
(HANDLE fsym (sqlite3_clear_bindings stmt))
(unless (eq? tx-status 'invalid)
(set! tx-status (get-tx-status)))
(values stmt
(cond [(pair? info)
(rows-result info rows)]
[else
(let ([changes (sqlite3_changes db)])
(cond [(and (positive? changes)
#f ;; Note: currently disabled
#| FIXME: statement was INSERT stmt |#)
(simple-result
(list (cons 'last-insert-rowid
(sqlite3_last_insert_rowid db))))]
[else (simple-result '())]))]))))))
(simple-result '())]))))))
(define/private (load-param fsym db stmt i param)
(HANDLE fsym
@ -155,6 +152,7 @@
(close-on-exec? close-on-exec?)
(param-typeids param-typeids)
(result-dvecs result-dvecs)
(stmt-type (classify-sl-sql sql))
(owner this))])
(hash-set! statement-table pst #t)
pst)))
@ -194,49 +192,46 @@
;; http://www.sqlite.org/lang_transaction.html
(define/public (transaction-status fsym)
(call-with-lock fsym
(lambda ()
(let ([db (get-db fsym)])
(or tx-status (get-tx-status db))))))
(define/private (get-tx-status)
(not (sqlite3_get_autocommit -db)))
(define/private (get-tx-status [db -db])
(and db (not (sqlite3_get_autocommit db))))
(define/public (start-transaction fsym isolation)
(define/override (start-transaction* fsym isolation)
;; Isolation level can be set to READ UNCOMMITTED via pragma, but
;; ignored in all but a few cases, don't bother.
;; FIXME: modes are DEFERRED | IMMEDIATE | EXCLUSIVE
(let ([stmt
(call-with-lock fsym
(lambda ()
(let ([db (get-db fsym)])
(when (get-tx-status db)
(error/already-in-tx fsym))
(let-values ([(stmt* _result)
(query1 fsym "BEGIN TRANSACTION")])
stmt*))))])
(statement:after-exec stmt)
(void)))
(cond [(eq? isolation 'nested)
(let ([savepoint (generate-name)])
(query1 fsym (format "SAVEPOINT ~a" savepoint) #f)
savepoint)]
[else
(query1 fsym "BEGIN TRANSACTION" #f)
#f]))
(define/public (end-transaction fsym mode)
(let ([stmt
(call-with-lock fsym
(lambda ()
(let ([db (get-db fsym)])
(unless (eq? mode 'rollback)
(check-valid-tx-status fsym))
(when (get-tx-status db)
(let-values ([(stmt* _result)
(case mode
((commit)
(query1 fsym "COMMIT TRANSACTION"))
((rollback)
(query1 fsym "ROLLBACK TRANSACTION")))])
(set! tx-status #f)
stmt*)))))])
(statement:after-exec stmt)
(void)))
(define/override (end-transaction* fsym mode savepoint)
(case mode
((commit)
(cond [savepoint
(query1 fsym (format "RELEASE SAVEPOINT ~a" savepoint) #f)]
[else
(query1 fsym "COMMIT TRANSACTION" #f)]))
((rollback)
(cond [savepoint
(query1 fsym (format "ROLLBACK TO SAVEPOINT ~a" savepoint) #f)
(query1 fsym (format "RELEASE SAVEPOINT ~a" savepoint) #f)]
[else
(query1 fsym "ROLLBACK TRANSACTION" #f)])
;; remove 'invalid status, if necessary
(set! tx-status (get-tx-status))))
(void))
;; name-counter : number
(define name-counter 0)
;; generate-name : -> string
(define/private (generate-name)
(let ([n name-counter])
(set! name-counter (add1 name-counter))
(format "λmz_~a" n)))
;; Reflection
@ -247,7 +242,7 @@
"WHERE type = 'table' or type = 'view'")])
(let-values ([(stmt result)
(call-with-lock fsym
(lambda () (query1 fsym stmt)))])
(lambda () (query1 fsym stmt #f)))])
(statement:after-exec stmt)
(for/list ([row (in-list (rows-result-rows result))])
(vector-ref row 0)))))
@ -272,7 +267,7 @@
;; Can't figure out how to test...
(define/private (handle-status who s)
(when (memv s maybe-rollback-status-list)
(when (and saved-tx-status -db (not (get-tx-status -db))) ;; was in trans, now not
(when (and saved-tx-status -db (not (get-tx-status))) ;; was in trans, now not
(set! tx-status 'invalid)))
(handle-status* who s -db))

25
collects/db/private/sqlite3/dbsystem.rkt
View File

@ -1,7 +1,8 @@
#lang racket/base
(require racket/class
"../generic/interfaces.rkt")
(provide dbsystem)
(provide dbsystem
classify-sl-sql)
(define sqlite3-dbsystem%
(class* object% (dbsystem<%>)
@ -34,3 +35,25 @@
(bytes? param))
(error/no-convert fsym "SQLite" "parameter" param))
param)
;; ========================================
;; SQL "parsing"
;; We just care about detecting commands that affect transaction status.
;; classify-sl-sql : string [nat] -> symbol/#f
(define classify-sl-sql
(make-sql-classifier
'(;; Explicit transaction commands
("ROLLBACK TRANSACTION TO" rollback-savepoint)
("ROLLBACK TO" rollback-savepoint)
("RELEASE" release-savepoint)
("SAVEPOINT" savepoint)
;; Note: SAVEPOINT allowed outside of transaction! (but that's okay)
("BEGIN" start)
("COMMIT" commit)
("END" commit)
("ROLLBACK" rollback) ;; Note: after ROLLBACK TO, etc
)))

24
collects/db/scribblings/connect.scrbl
View File

@ -22,15 +22,15 @@ connections}. PostgreSQL and MySQL connections are wire-based, and
SQLite and ODBC connections are FFI-based.
Wire-based connections communicate using @tech/reference{ports}, which
do not cause other Racket threads to block. In contrast, all Racket
threads are blocked during an FFI call, so FFI-based connections can
seriously degrade the interactivity of a Racket program, particularly
if long-running queries are performed using the connection. This
problem can be avoided by creating the FFI-based connection in a
separate @tech/reference{place} using the @racket[#:use-place]
keyword argument. Such a connection will not block all Racket threads
during queries; the disadvantage is the cost of creating and
communicating with a separate @tech/reference{place}.
do not cause other Racket threads to block. In contrast, an FFI call
causes all Racket threads to block until it completes, so FFI-based
connections can degrade the interactivity of a Racket program,
particularly if long-running queries are performed using the
connection. This problem can be avoided by creating the FFI-based
connection in a separate @tech/reference{place} using the
@racket[#:use-place] keyword argument. Such a connection will not
block all Racket threads during queries; the disadvantage is the cost
of creating and communicating with a separate @tech/reference{place}.
Base connections are made using the following functions.
@ -567,14 +567,14 @@ ODBC's DSNs.
@racket[data-source], then @racket[dsn-file] is ignored.
@examples/results[
[(put-dsn 'mydb
[(put-dsn 'pg
(postgresql-data-source #:user "me"
#:database "mydb"
#:password "icecream"))
(void)]
[(dsn-connect 'mydb)
[(dsn-connect 'pg)
(new connection%)]
[(dsn-connect 'mydb #:notice-handler (lambda (code msg) ....))
[(dsn-connect 'pg #:notice-handler (lambda (code msg) ....))
(new connection%)]
]
}

139
collects/db/scribblings/query.scrbl
View File

@ -492,19 +492,34 @@ closed.
The functions described in this section provide a consistent interface
to transactions.
ODBC connections should use these functions exclusively instead of
transaction-changing SQL statements such as @tt{START TRANSACTION} and
@tt{COMMIT}. Using transaction-changing SQL may cause these functions
to behave incorrectly and may cause additional problems in the ODBC
driver.
A @deftech{managed transaction} is one created via either
@racket[start-transaction] or @racket[call-with-transaction]. In
contrast, an @deftech{unmanaged transaction} is one created by
evaluating a SQL statement such as @tt{START TRANSACTION}. A
@deftech{nested transaction} is a transaction created within the
extent of an existing transaction. If a nested transaction is
committed, its changes are promoted to the enclosing transaction,
which may itself be committed or rolled back. If a nested transaction
is rolled back, its changes are discarded, but the enclosing
transaction remains open. Nested transactions are implemented via SQL
@tt{SAVEPOINT}, @tt{RELEASE SAVEPOINT}, and @tt{ROLLBACK TO
SAVEPOINT}.
PostgreSQL, MySQL, and SQLite connections are discouraged from using
transaction-changing SQL statements, but the consequences are less
dire. The functions below will behave correctly, but the syntax and
behavior of the SQL statements is idiosyncratic. For example, in MySQL
@tt{START TRANSACTION} commits the current transaction, if one is
active; in PostgreSQL @tt{COMMIT} silently rolls back the current
transaction if an error occurred in a previous statement.
ODBC connections must use @tech{managed transactions} exclusively;
using transaction-changing SQL may cause these functions to behave
incorrectly and may cause additional problems in the ODBC driver. ODBC
connections do not support @tech{nested transactions}.
PostgreSQL, MySQL, and SQLite connections must not mix @tech[#:key
"managed transaction"]{managed} and @tech[#:key "unmanaged
transaction"]{unmanaged} transactions. For example, calling
@racket[start-transaction] and then executing a @tt{ROLLBACK}
statement is not allowed. Note that in MySQL, some SQL statements have
@hyperlink["http://dev.mysql.com/doc/refman/5.0/en/implicit-commit.html"]{implicit
transaction effects}. For example, in MySQL a @tt{CREATE TABLE}
statement implicitly commits the current transaction. These statements
also must not be used within @tech{managed transactions}. (In
contrast, PostgreSQL and SQLite both support transactional DDL.)
@bold{Errors} Query errors may affect an open transaction in one of
three ways:
@ -512,8 +527,7 @@ three ways:
@item{the transaction remains open and unchanged}
@item{the transaction is automatically rolled back}
@item{the transaction becomes an @deftech{invalid transaction}; all
subsequent queries will fail until the transaction is explicitly
rolled back}
subsequent queries will fail until the transaction is rolled back}
]
To avoid the silent loss of information, this library attempts to
avoid behavior (2) completely by marking transactions as invalid
@ -525,31 +539,37 @@ to what errors cause which behaviors:
parameter arity and type errors, leave the transaction open and
unchanged (1).}
@item{All errors originating from PostgreSQL cause the transaction to
become invalid (3).}
become @tech[#:key "invalid transaction"]{invalid} (3).}
@item{Most errors originating from MySQL leave the transaction open
and unchanged (1), but a few cause the transaction to become invalid
(3). In the latter cases, the underlying behavior
of MySQL is to roll back the transaction but @emph{leave it open}
(see @hyperlink["http://dev.mysql.com/doc/refman/5.1/en/innodb-error-handling.html"]{the
and unchanged (1), but a few cause the transaction to become
@tech[#:key "invalid transaction"]{invalid} (3). In the latter
cases, the underlying behavior of MySQL is to roll back the
transaction but @emph{leave it open} (see
@hyperlink["http://dev.mysql.com/doc/refman/5.1/en/innodb-error-handling.html"]{the
MySQL documentation}). This library detects those cases and marks
the transaction invalid instead.}
the transaction @tech[#:key "invalid transaction"]{invalid}
instead.}
@item{Most errors originating from SQLite leave the transaction open
and unchanged (1), but a few cause the transaction to become
invalid (3). In the latter cases, the underlying behavior of SQLite
is to roll back the transaction (see
@tech[#:key "invalid transaction"]{invalid} (3). In the latter
cases, the underlying behavior of SQLite is to roll back the
transaction (see
@hyperlink["http://www.sqlite.org/lang_transaction.html"]{the SQLite
documentation}). This library detects those cases and marks the
transaction invalid instead.}
transaction @tech[#:key "invalid transaction"]{invalid} instead.}
@item{All errors originating from an ODBC driver cause the transaction
to become invalid (3). The underlying behavior of ODBC drivers
varies widely, and ODBC provides no mechanism to detect when an
existing transaction has been rolled back, so this library
intercepts all errors and marks the transaction invalid instead.}
to become @tech[#:key "invalid transaction"]{invalid} (3). The
underlying behavior of ODBC drivers varies widely, and ODBC provides
no mechanism to detect when an existing transaction has been rolled
back, so this library intercepts all errors and marks the
transaction @tech[#:key "invalid transaction"]{invalid} instead.}
]
Future versions of this library may refine the set of errors that
invalidate a transaction (for example, by identifying innocuous ODBC
errors by SQLSTATE) and may provide an option to automatically
rollback invalid transactions.
If a nested transaction marked @tech[#:key "invalid
transaction"]{invalid} is rolled back, the enclosing transaction is
typically still valid.
If a transaction is open when a connection is disconnected, it is
implicitly rolled back.
@defproc[(start-transaction [c connection?]
[#:isolation isolation-level
@ -566,37 +586,50 @@ rollback invalid transactions.
database-dependent; it may be a default isolation level or it may be
the isolation level of the previous transaction.
If @racket[c] is already in a transaction, an exception is raised.
If @racket[c] is already in a transaction, @racket[isolation-level]
must be @racket[#f], and a @tech{nested transaction} is opened.
}
@defproc[(commit-transaction [c connection?]) void?]{
Attempts to commit the current transaction, if one is active. If the
transaction cannot be commited, an exception is raised.
Attempts to commit the current transaction, if one is open. If the
transaction cannot be commited (for example, if it is @tech[#:key
"invalid transaction"]{invalid}), an exception is raised.
If no transaction is active, this function has no effect.
If the current transaction is a @tech{nested transaction}, the
nested transaction is closed, its changes are incorporated into the
enclosing transaction, and the enclosing transaction is resumed.
If no transaction is open, this function has no effect.
}
@defproc[(rollback-transaction [c connection?]) void?]{
Rolls back the current transaction, if one is active.
Rolls back the current transaction, if one is open.
If no transaction is active, this function has no effect.
If the current transaction is a @tech{nested transaction}, the
nested transaction is closed, its changes are abandoned, and the
enclosing transaction is resumed.
If no transaction is open, this function has no effect.
}
@defproc[(in-transaction? [c connection?])
boolean?]{
Returns @racket[#t] if @racket[c] has a transaction is active,
@racket[#f] otherwise.
Returns @racket[#t] if @racket[c] has an open transaction
(@tech[#:key "managed transaction"]{managed} or @tech[#:key
"unmanaged transaction"]{unmanaged}), @racket[#f] otherwise.
}
@defproc[(needs-rollback? [c connection?]) boolean?]{
Returns @racket[#t] if @racket[c] is in an @tech{invalid
transaction}. All queries executed using @racket[c] will fail until
the transaction is explicitly rolled back using
@racket[rollback-transaction].
the transaction is rolled back (either using
@racket[rollback-transaction], if the transaction was created with
@racket[start-transaction], or when the procedure passed to
@racket[call-with-transaction] returns).
}
@defproc[(call-with-transaction [c connection?]
@ -613,8 +646,26 @@ rollback invalid transactions.
Calls @racket[proc] in the context of a new transaction with
isolation level @racket[isolation-level]. If @racket[proc] completes
normally, the transaction is committed and @racket[proc]'s results
are returned. If @racket[proc] raises an exception, the transaction
is rolled back.
are returned. If @racket[proc] raises an exception (or if the
implicit commit at the end raises an exception), the transaction is
rolled back and the exception is re-raised.
If @racket[call-with-transaction] is called within a transaction,
@racket[isolation-level] must be @racket[#f], and it creates a
@tech{nested transaction}. Within the extent of a call to
@racket[call-with-transaction], transactions must be properly
nested. In particular:
@itemlist[
@item{Calling either @racket[commit-transaction] or
@racket[rollback-transaction] when the open transaction was
created by @racket[call-with-transaction] causes an exception to be
raised.}
@item{If a further nested transaction is open when @racket[proc]
completes (that is, created by an unmatched
@racket[start-transaction] call), an exception is raised and the
nested transaction created by @racket[call-with-transaction] is
rolled back.}
]
}
@section{SQL Errors}
@ -651,7 +702,7 @@ type.
provide SQLSTATE error codes.
}
@section{Database Information}
@section{Database Catalog Information}
@defproc[(list-tables [c connection?]
[#:schema schema

6
collects/tests/db/all-tests.rkt
View File

@ -13,7 +13,8 @@
"db/sql-types.rkt"
"db/concurrent.rkt"))
(prefix-in gen-
(combine-in "gen/sql-types.rkt"
(combine-in "gen/misc.rkt"
"gen/sql-types.rkt"
"gen/query.rkt")))
(provide (all-defined-out))
@ -193,7 +194,8 @@ Testing profiles are flattened, not hierarchical.
(define generic-test
(make-test-suite "Generic tests (no db)"
(list gen-sql-types:test
(list gen-misc:test
gen-sql-types:test
gen-query:test)))
;; ----

192
collects/tests/db/db/query.rkt
View File

@ -266,12 +266,196 @@
(check-equal? (in-transaction? c) #t)
(check-pred void? (rollback-transaction c))
(check-equal? (in-transaction? c) #f)))
(test-case "error on repeated start"
(test-case "error on managed st, unmanaged end"
(with-connection c
(start-transaction c)
(check-exn #rx"already in transaction"
(lambda () (start-transaction c)))))
(test-case "call-with-tx"
(check-exn #rx"ROLLBACK not allowed within managed transaction"
(lambda () (query-exec c "ROLLBACK")))
(check-equal? (in-transaction? c) #t)
;; SQLite-ODBC is unhappy with open tx on disconnect
(rollback-transaction c)))
(unless (ANYFLAGS 'odbc)
(test-case "unmanaged st, managed end ok"
(with-connection c
(query-exec c (cond [(ANYFLAGS 'ispg 'ismy) "START TRANSACTION"]
[(ANYFLAGS 'issl) "BEGIN TRANSACTION"]))
(check-equal? (in-transaction? c) #t)
(rollback-transaction c)
(check-equal? (in-transaction? c) #f))))
(test-case "error on cwt, unmanaged end"
(with-connection c
(check-exn #rx"ROLLBACK not allowed within managed transaction"
(lambda ()
(call-with-transaction c
(lambda () (query-exec c "ROLLBACK")))))
(check-equal? (in-transaction? c) #f)))
(when (and (ANYFLAGS 'ispg 'issl) (not (ANYFLAGS 'odbc)))
(test-case "transactional ddl"
(with-connection c
(start-transaction c)
(query-exec c "create table foo (n integer)")
(define exists1 (table-exists? c "foo"))
(rollback-transaction c)
(define exists2 (table-exists? c "foo"))
(when exists2 (query-exec c "drop table foo")) ;; shouldn't happen
(check-equal? exists1 #t)
(check-equal? exists2 #f))))
(when (ANYFLAGS 'ismy 'odbc)
(test-case "error on implicit-commit stmt"
(with-connection c
(start-transaction c)
(check-exn #rx"statement with implicit commit not allowed"
(lambda () (query-exec c "create table foo (n integer)")))
;; SQLite-ODBC is unhappy with open tx on disconnect
(rollback-transaction c))))
(when (ANYFLAGS 'odbc)
(test-case "error on repeated start"
(with-connection c
(start-transaction c)
(check-exn #rx"already in transaction"
(lambda () (start-transaction c))))))
(unless (ANYFLAGS 'odbc)
(test-case "start, start"
(with-connection c
(check-pred void? (start-transaction c))
(check-pred void? (start-transaction c))
(check-equal? (in-transaction? c) #t)
(check-pred void? (commit-transaction c))
(check-equal? (in-transaction? c) #t)
(check-pred void? (commit-transaction c))
(check-equal? (in-transaction? c) #f))))
(when (ANYFLAGS 'odbc)
(test-case "start, start fails"
(with-connection c
(start-transaction c)
(check-exn #rx"already in transaction"
(lambda () (start-transaction c)))))
(test-case "cwt, start fails"
(with-connection c
(start-transaction c)
(check-exn #rx"already in transaction"
(lambda () (call-with-transaction c void))))))
(test-case "commit w/o start is no-op"
(with-connection c
(check-pred void? (commit-transaction c))))
(test-case "rollback w/o start is no-op"
(with-connection c
(check-pred void? (rollback-transaction c))))
(test-case "cwt normal"
(with-connection c
(check-equal? (call-with-transaction c
(lambda () (query-value c (select-val "'abc'"))))
"abc")))
(test-case "cwt w/ error"
(with-connection c
(check-exn exn:fail?
(lambda ()
(call-with-transaction c
(lambda () (query-value c (select-val "foo"))))))
(check-equal? (in-transaction? c) #f)))
(test-case "cwt w/ caught error"
(with-connection c
(define (check-pg-exn proc)
(if (ANYFLAGS 'ispg 'odbc) (check-exn exn:fail? proc) (proc)))
(let ([ok? #f])
(check-pg-exn
(lambda ()
(call-with-transaction c
(lambda ()
(with-handlers ([exn:fail? void?])
(query-value c (select-val "foo")))
(set! ok? (in-transaction? c))))))
(check-equal? ok? #t "still in tx after caught error")
(check-equal? (in-transaction? c) #f))))
(unless (ANYFLAGS 'odbc)
(test-case "cwt w/ unclosed tx"
(with-connection c
(check-exn #rx"unclosed nested tr.* .within .* call-with-transaction"
(lambda ()
(call-with-transaction c
(lambda ()
(start-transaction c)
(query-value c (select-val "17"))))))
(check-equal? (in-transaction? c) #f)))
(test-case "cwt w/ unbalanced commit"
(with-connection c
(check-exn #rx"commit-tr.* start-tr.* .within .* call-with-transaction"
(lambda ()
(call-with-transaction c
(lambda ()
(commit-transaction c)))))
(check-equal? (in-transaction? c) #f)))
(test-case "cwt w/ unbalanced rollback"
(with-connection c
(check-exn #rx"rollback-tr.* start-tr.* .within .* call-with-transaction"
(lambda ()
(call-with-transaction c
(lambda ()
(rollback-transaction c)))))
(check-equal? (in-transaction? c) #f)))
;; start-tx, then call-with-tx
(test-case "st, cwt normal"
(with-connection c
(start-transaction c)
(check-equal? (call-with-transaction c
(lambda () (query-value c (select-val "17"))))
17)
(check-equal? (in-transaction? c) #t)))
(test-case "st, cwt w/ error"
(with-connection c
(start-transaction c)
(check-exn exn:fail?
(lambda ()
(call-with-transaction c
(lambda () (query-value c (select-val "foo"))))))
(check-equal? (in-transaction? c) #t)))
(test-case "st, cwt w/ caught error"
(with-connection c
(define (check-pg-exn proc)
(if (ANYFLAGS 'ispg) (check-exn exn:fail? proc) (proc)))
(let ([ok? #f])
(start-transaction c)
(check-pg-exn
(lambda ()
(call-with-transaction c
(lambda ()
(with-handlers ([exn:fail? void?])
(query-value c (select-val "foo")))
(set! ok? (in-transaction? c))))))
(check-equal? ok? #t "still in tx after caught error")
(check-equal? (in-transaction? c) #t))))
(test-case "st, cwt w/ unclosed tx"
(with-connection c
(start-transaction c)
(check-exn #rx"unclosed nested tr.* .within .* call-with-transaction"
(lambda ()
(call-with-transaction c
(lambda ()
(start-transaction c)
(query-value c (select-val "17"))))))
(check-equal? (in-transaction? c) #t)))
(test-case "st, cwt w/ unbalanced commit"
(with-connection c
(start-transaction c)
(check-exn #rx"commit-tr.* start-tr.* .within .* call-with-transaction"
(lambda ()
(call-with-transaction c
(lambda ()
(commit-transaction c)))))
(check-equal? (in-transaction? c) #t)))
(test-case "cwt w/ unbalanced rollback"
(with-connection c
(start-transaction c)
(check-exn #rx"rollback-tr.* start-tr.* .within .* call-with-transaction"
(lambda ()
(call-with-transaction c
(lambda ()
(rollback-transaction c)))))
(check-equal? (in-transaction? c) #t))))
(test-case "cwt misc"
(with-connection c
(check-equal? (call-with-transaction c
(lambda ()

19
collects/tests/db/gen/misc.rkt Normal file
View File

@ -0,0 +1,19 @@
#lang racket/base
(require rackunit
racket/class
"../config.rkt")
(provide misc:test)
(require db/private/generic/interfaces)
(define misc:test
(test-suite "Misc internal function tests"
(test-case "sql-skip-comments"
(define (eat s [hash? #f]) (substring s (sql-skip-comments s 0 #:hash-comments? hash?)))
(check-equal? (eat "/* blah ** blah */ insert")
" insert")
(check-equal? (eat "-- blah\n -- /* \nok")
"ok")
(check-equal? (eat "#a\n# b c d\nok" #t)
"ok"))))