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

db: clean up and reogranize common impl code

Browse Source
This commit is contained in:
Ryan Culpepper 2012-01-07 01:45:12 -07:00
parent 5a27a8538c
commit 4c817d0f7f
20 changed files with 498 additions and 501 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

406
collects/db/private/generic/common.rkt Normal file
View File

@ -0,0 +1,406 @@
#lang racket/base
(require racket/class
racket/string
ffi/unsafe/atomic
"interfaces.rkt")
(provide define-type-table
locking%
transactions%
isolation-symbol->string
make-sql-classifier
sql-skip-comments
make-handler
guess-socket-path/paths)
;; Common connection-implementation code
;; ----------------------------------------
;; Defining type tables
(define-syntax-rule (define-type-table (supported-types
type-alias->type
typeid->type
type->typeid
describe-typeid)
(typeid type (alias ...) supported?) ...)
(begin
(define all-types '((type supported?) ...))
(define supported-types
(sort (map car (filter cadr all-types))
string<?
#:key symbol->string
#:cache-keys? #t))
(define (type-alias->type x)
(case x
((alias ...) 'type) ...
(else x)))
(define (typeid->type x)
(case x
((typeid) 'type) ...
(else #f)))
(define (type->typeid x)
(case x
((type) 'typeid) ...
(else #f)))
(define (describe-typeid x)
(let ([t (typeid->type x)]
[ok? (case x ((typeid) supported?) ... (else #f))])
(list ok? t x)))))
;; ----------------------------------------
;; Notice/notification handler maker
;; make-handler : output-port/symbol string -> string string -> void
(define (make-handler out header)
(if (procedure? out)
out
(lambda (code message)
(fprintf (case out
((output) (current-output-port))
((error) (current-error-port))
(else out))
"~a: ~a (SQLSTATE ~a)\n" header message code))))
;; ----------------------------------------
;; Socket paths
(define (guess-socket-path/paths function paths)
(or (for/or ([path (in-list paths)])
(and (file-exists? path) path))
(error function
"could not find socket path")))
;; ----------------------------------------
;; Connection base class (locking)
(define locking%
(class object%
;; == Communication locking
;; Goal: we would like to be able to detect if a thread has
;; acquired the lock and then died, leaving the connection
;; permanently locked.
;;
;; lock-holder=(thread-dead-evt thd) iff thd has acquired inner-lock
;; - lock-holder, inner-lock always modified together within
;; atomic block
;;
;; Thus if (thread-dead-evt thd) is ready, thd died holding
;; inner-lock, so hopelessly locked.
;;
;; outer-sema = inner-lock
;; - outer-sema, inner-lock always modified together within atomic
;;
;; The outer-lock just prevents threads from spinning polling
;; inner-lock. If a thread gets past outer-lock and dies before
;; acquiring inner-lock, ok, because outer-lock still open at that
;; point, so other threads can enter outer-lock and acquire inner-lock.
(define outer-sema (make-semaphore 1))
(define outer-lock (semaphore-peek-evt outer-sema))
(define inner-lock (make-semaphore 1))
(define lock-holder never-evt)
;; Delay async calls (eg, notice handler) until unlock
(define delayed-async-calls null)
;; ----
(define/public (call-with-lock who proc)
(call-with-lock* who proc #f #t))
(define/public-final (call-with-lock* who proc hopeless require-connected?)
(let ([me (thread-dead-evt (current-thread))]
[result (sync outer-lock lock-holder)])
(cond [(eq? result outer-lock)
;; Got past outer stage
(let ([proceed?
(begin (start-atomic)
(let ([proceed? (semaphore-try-wait? inner-lock)])
(when proceed?
(set! lock-holder me)
(semaphore-wait outer-sema))
(end-atomic)
proceed?))])
(cond [proceed?
;; Acquired lock
;; - lock-holder = me, and outer-lock is closed again
(when (and require-connected? (not (connected?)))
(unlock)
(error/not-connected who))
(with-handlers ([values (lambda (e) (unlock) (raise e))])
(begin0 (proc) (unlock)))]
[else
;; Didn't acquire lock; retry
(call-with-lock* who proc hopeless require-connected?)]))]
[(eq? result lock-holder)
;; Thread holding lock is dead
(if hopeless (hopeless) (error/hopeless who))]
[else
;; lock-holder was stale; retry
(call-with-lock* who proc hopeless require-connected?)])))
(define/private (unlock)
(let ([async-calls (reverse delayed-async-calls)])
(set! delayed-async-calls null)
(start-atomic)
(set! lock-holder never-evt)
(semaphore-post inner-lock)
(semaphore-post outer-sema)
(end-atomic)
(for-each call-with-continuation-barrier async-calls)))
;; needs overriding
(define/public (connected?) #f)
(define/public-final (add-delayed-call! proc)
(set! delayed-async-calls (cons proc delayed-async-calls)))
(super-new)))
;; ----------------------------------------
(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")))
;; ----
(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)))
;; ----------------------------------------
;; Isolation levels
(define (isolation-symbol->string isolation)
(case isolation
((serializable) "SERIALIZABLE")
((repeatable-read) "REPEATABLE READ")
((read-committed) "READ COMMITTED")
((read-uncommitted) "READ UNCOMMITTED")
(else #f)))
;; ----------------------------------------
;; 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)))

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

@ -1,6 +1,7 @@
#lang racket/base
(require racket/class
"interfaces.rkt")
"interfaces.rkt"
"common.rkt")
(provide kill-safe-connection
virtual-connection
connection-pool

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

@ -8,9 +8,6 @@
;; == Administrative procedures
(define (connection? x)
(is-a? x connection<%>))
(define (connected? x)
(send x connected?))
@ -20,9 +17,6 @@
(define (connection-dbsystem x)
(send x get-dbsystem))
(define (dbsystem? x)
(is-a? x dbsystem<%>))
(define (dbsystem-name x)
(send x get-short-name))
@ -44,9 +38,6 @@
(define (bind-prepared-statement pst params)
(send pst bind 'bind-prepared-statement params))
(define (prepared-statement? x)
(is-a? x prepared-statement<%>))
(define (prepared-statement-parameter-types pst)
(send pst get-param-types))
(define (prepared-statement-result-types pst)

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

@ -1,39 +1,29 @@
#lang racket/base
(require racket/class
racket/string
ffi/unsafe/atomic)
(require racket/class)
(provide connection<%>
dbsystem<%>
prepared-statement<%>
(struct-out simple-result)
(struct-out rows-result)
connection?
dbsystem?
prepared-statement?
(struct-out statement-binding)
(struct-out simple-result)
(struct-out rows-result)
init-private
define-type-table
locking%
transactions%
isolation-symbol->string
make-sql-classifier
sql-skip-comments
hex-string->bytes
make-handler
guess-socket-path/paths
dblogger
dbdebug
(struct-out exn:fail:sql)
raise-sql-error)
;; ==== Connection
;; ----------------------------------------
;; Interfaces
;; connection<%>
(define connection<%>
@ -53,8 +43,6 @@
transaction-status ;; symbol -> (U boolean 'invalid)
free-statement)) ;; prepared-statement<%> -> void
;; ==== DBSystem
;; dbsystem<%>
;; Represents brand of database system, SQL dialect, etc
(define dbsystem<%>
@ -68,15 +56,12 @@
get-known-types ;; -> (listof symbol)
describe-typeids)) ;; (listof typeid) -> (listof TypeDesc)
;; ParameterHandler = (fsym index datum -> ???)
;; Each system gets to choose its checked-param representation.
;; Maybe check and convert to string. Maybe just check, do binary conversion later.
;; TypeDesc = (list boolean symbol/#f typeid)
;; ==== Prepared
;; prepared-statement<%>
(define prepared-statement<%>
(interface ()
@ -103,16 +88,22 @@
get-result-types ;; -> (listof TypeDesc)
))
(define (connection? x)
(is-a? x connection<%>))
;; ==== Auxiliary structures
(define (dbsystem? x)
(is-a? x dbsystem<%>))
(define (prepared-statement? x)
(is-a? x prepared-statement<%>))
;; ----------------------------------------
;; Auxiliary structures
;; A statement-binding is:
;; - (statement-binding prepared-statement ??? (listof ???))
;; meta might include information such as text vs binary format
(struct statement-binding (pst meta params))
;; A YesNoOptional is one of 'yes, 'no, 'optional
;; An SSLMode is one of 'sslv2-or-v3, 'sslv2, 'sslv3, 'tls
;; - (statement-binding prepared-statement (listof ???))
(struct statement-binding (pst params))
;; An query-result is one of:
;; - (simple-result alist)
@ -124,8 +115,9 @@
;; A Header is (listof FieldInfo)
;; A FieldInfo is an alist, contents dbsys-dependent
;; ----------------------------------------
;; === Class utilities
;; Class utilities
;; Here just because ...
@ -136,431 +128,6 @@
(begin (init ([private-iid iid]))
(define iid private-iid)))
;; === Util for defining type tables
(define-syntax-rule (define-type-table (supported-types
type-alias->type
typeid->type
type->typeid
describe-typeid)
(typeid type (alias ...) supported?) ...)
(begin
(define all-types '((type supported?) ...))
(define supported-types
(sort (map car (filter cadr all-types))
string<?
#:key symbol->string
#:cache-keys? #t))
(define (type-alias->type x)
(case x
((alias ...) 'type) ...
(else x)))
(define (typeid->type x)
(case x
((typeid) 'type) ...
(else #f)))
(define (type->typeid x)
(case x
((type) 'typeid) ...
(else #f)))
(define (describe-typeid x)
(let ([t (typeid->type x)]
[ok? (case x ((typeid) supported?) ... (else #f))])
(list ok? t x)))))
;; == Notice/notification handler maker
;; make-handler : output-port/symbol string -> string string -> void
(define (make-handler out header)
(if (procedure? out)
out
(lambda (code message)
(fprintf (case out
((output) (current-output-port))
((error) (current-error-port))
(else out))
"~a: ~a (SQLSTATE ~a)\n" header message code))))
;; == Socket paths
(define (guess-socket-path/paths function paths)
(or (for/or ([path (in-list paths)])
(and (file-exists? path) path))
(error function
"could not find socket path")))
;; ----------------------------------------
;; Connection base class (locking)
(define locking%
(class object%
;; == Communication locking
;; Goal: we would like to be able to detect if a thread has
;; acquired the lock and then died, leaving the connection
;; permanently locked.
;;
;; lock-holder=(thread-dead-evt thd) iff thd has acquired inner-lock
;; - lock-holder, inner-lock always modified together within
;; atomic block
;;
;; Thus if (thread-dead-evt thd) is ready, thd died holding
;; inner-lock, so hopelessly locked.
;;
;; outer-sema = inner-lock
;; - outer-sema, inner-lock always modified together within atomic
;;
;; The outer-lock just prevents threads from spinning polling
;; inner-lock. If a thread gets past outer-lock and dies before
;; acquiring inner-lock, ok, because outer-lock still open at that
;; point, so other threads can enter outer-lock and acquire inner-lock.
(define outer-sema (make-semaphore 1))
(define outer-lock (semaphore-peek-evt outer-sema))
(define inner-lock (make-semaphore 1))
(define lock-holder never-evt)
;; Delay async calls (eg, notice handler) until unlock
(define delayed-async-calls null)
;; ----
(define/public (call-with-lock who proc)
(call-with-lock* who proc #f #t))
(define/public-final (call-with-lock* who proc hopeless require-connected?)
(let ([me (thread-dead-evt (current-thread))]
[result (sync outer-lock lock-holder)])
(cond [(eq? result outer-lock)
;; Got past outer stage
(let ([proceed?
(begin (start-atomic)
(let ([proceed? (semaphore-try-wait? inner-lock)])
(when proceed?
(set! lock-holder me)
(semaphore-wait outer-sema))
(end-atomic)
proceed?))])
(cond [proceed?
;; Acquired lock
;; - lock-holder = me, and outer-lock is closed again
(when (and require-connected? (not (connected?)))
(unlock)
(error/not-connected who))
(with-handlers ([values (lambda (e) (unlock) (raise e))])
(begin0 (proc) (unlock)))]
[else
;; Didn't acquire lock; retry
(call-with-lock* who proc hopeless require-connected?)]))]
[(eq? result lock-holder)
;; Thread holding lock is dead
(if hopeless (hopeless) (error/hopeless who))]
[else
;; lock-holder was stale; retry
(call-with-lock* who proc hopeless require-connected?)])))
(define/private (unlock)
(let ([async-calls (reverse delayed-async-calls)])
(set! delayed-async-calls null)
(start-atomic)
(set! lock-holder never-evt)
(semaphore-post inner-lock)
(semaphore-post outer-sema)
(end-atomic)
(for-each call-with-continuation-barrier async-calls)))
;; needs overriding
(define/public (connected?) #f)
(define/public-final (add-delayed-call! proc)
(set! delayed-async-calls (cons proc delayed-async-calls)))
(super-new)))
;; ----------------------------------------
(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")))
;; ----
(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)))
;; ----------------------------------------
;; Isolation levels
(define (isolation-symbol->string isolation)
(case isolation
((serializable) "SERIALIZABLE")
((repeatable-read) "REPEATABLE READ")
((read-committed) "READ COMMITTED")
((read-uncommitted) "READ UNCOMMITTED")
(else #f)))
;; ----------------------------------------
;; 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
#|
;; Also in file/sha1
(define (bytes->hex-string b)
(define (int->hex-digit n)
(string-ref "0123456789abcdef" n))
(let* ([c (bytes-length b)]
[s (make-string (* 2 c))])
(for ([i (in-range c)])
(string-set! s (+ i i 0) (int->hex-digit (arithmetic-shift (bytes-ref b i) -4)))
(string-set! s (+ i i 1) (int->hex-digit (bitwise-and (bytes-ref b) #xFF))))
s))
|#
(define (hex-string->bytes s)
(define (hex-digit->int c)
(let ([c (char->integer c)])
(cond [(<= (char->integer #\0) c (char->integer #\9))
(- c (char->integer #\0))]
[(<= (char->integer #\a) c (char->integer #\f))
(- c (char->integer #\a))]
[(<= (char->integer #\A) c (char->integer #\F))
(- c (char->integer #\A))])))
(unless (and (string? s) (even? (string-length s))
(regexp-match? #rx"[0-9a-zA-Z]*" s))
(raise-type-error 'hex-string->bytes
"string containing an even number of hexadecimal digits" s))
(let* ([c (quotient (string-length s) 2)]
[b (make-bytes c)])
(for ([i (in-range c)])
(let ([high (hex-digit->int (string-ref s (+ i i)))]
[low (hex-digit->int (string-ref s (+ i i 1)))])
(bytes-set! b i (+ (arithmetic-shift high 4) low))))
b))
;; ----------------------------------------
;; Logging
@ -572,9 +139,9 @@
;; ----------------------------------------
#|
Exceptions
;; Exceptions
#|
Only errors with an associated SQLSTATE are represented by
exn:fail:sql, specifically only errors originating from a database
backend or library. Other errors are typically raised using 'error',
@ -604,7 +171,9 @@ producing plain old exn:fail.
error/comm
error/hopeless
error/unsupported-type
error/no-convert)
error/no-convert
error/unbalanced-tx
error/unclosed-tx)
;;(define uerror raise-user-error)
(define uerror error)

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

@ -8,6 +8,7 @@
(for-syntax (only-in racket/base quote))
ffi/unsafe/atomic
"interfaces.rkt"
"common.rkt"
"prepared.rkt")
(provide place-connect
place-proxy-connection%)
@ -73,8 +74,8 @@
(call 'query fsym
(match stmt
[(? string?) (list 'string stmt)]
[(statement-binding pst meta params)
(list 'statement-binding (send pst get-handle) meta params)])))
[(statement-binding pst params)
(list 'statement-binding (send pst get-handle) params)])))
(define/public (prepare fsym stmt close-on-exec?)
(call 'prepare fsym stmt close-on-exec?))
(define/public (transaction-status fsym)

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

@ -119,8 +119,8 @@ server -> client: (or (list 'values result ...)
(define/private (sexpr->statement x)
(match x
[(list 'string s) s]
[(list 'statement-binding pstmt-index meta args)
(statement-binding (hash-ref pstmt-table pstmt-index) meta args)]))
[(list 'statement-binding pstmt-index args)
(statement-binding (hash-ref pstmt-table pstmt-index) args)]))
(define/private (result->sexpr x)
(match x

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

@ -3,7 +3,8 @@
"interfaces.rkt"
"sql-data.rkt")
(provide prepared-statement%
statement:after-exec)
statement:after-exec
apply-type-handlers)
;; prepared-statement%
(define prepared-statement%
@ -63,20 +64,7 @@
(error fsym "prepared statement owned by another connection: ~e" obj)))
(define/public (bind fsym params)
(check-param-count fsym params param-typeids)
(let* ([params
(for/list ([handler (in-list param-handlers)]
[index (in-naturals)]
[param (in-list params)])
(cond [(sql-null? param) sql-null]
[else (handler fsym index param)]))])
(statement-binding this #f params)))
(define/private (check-param-count fsym params param-typeids)
(define len (length params))
(define tlen (length param-typeids))
(when (not (= len tlen))
(error fsym "prepared statement requires ~s parameters, given ~s" tlen len)))
(statement-binding this (apply-type-handlers fsym params param-handlers)))
(define/public (finalize)
(let ([owner (weak-box-value owner)])
@ -94,6 +82,17 @@
(when (statement-binding? stmt)
(send (statement-binding-pst stmt) after-exec)))
(define (apply-type-handlers fsym params param-handlers)
(let ([given-len (length params)]
[expected-len (length param-handlers)])
(when (not (= given-len expected-len))
(uerror fsym "statement requires ~s parameters, given ~s" expected-len given-len)))
(for/list ([handler (in-list param-handlers)]
[index (in-naturals)]
[param (in-list params)])
(cond [(sql-null? param) sql-null]
[else (handler fsym index param)])))
;; ----
(define will-executor (make-will-executor))

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

@ -4,12 +4,13 @@
openssl
openssl/sha1
"../generic/interfaces.rkt"
"../generic/common.rkt"
"../generic/prepared.rkt"
"../generic/sql-data.rkt"
"message.rkt"
"dbsystem.rkt")
(provide connection%
password-hash)
mysql-password-hash)
(define MAX-PACKET-LENGTH #x1000000)
@ -481,12 +482,15 @@
;; ========================================
;; mysql-password-hash : string -> string
(define (mysql-password-hash password)
(bytes->hex-string (password-hash password)))
;; scramble-password : bytes string -> bytes
(define (scramble-password scramble password)
(and scramble password
(let* ([stage1 (cond [(string? password) (password-hash password)]
[(pair? password)
(hex-string->bytes (cadr password))])]
[(pair? password) (hex-string->bytes (cadr password))])]
[stage2 (sha1-bytes (open-input-bytes stage1))]
[stage3 (sha1-bytes (open-input-bytes (bytes-append scramble stage2)))]
[reply (bytes-xor stage1 stage3)])
@ -509,6 +513,27 @@
(loop (add1 i))))
c))
(define (hex-string->bytes s)
(define (hex-digit->int c)
(let ([c (char->integer c)])
(cond [(<= (char->integer #\0) c (char->integer #\9))
(- c (char->integer #\0))]
[(<= (char->integer #\a) c (char->integer #\f))
(- c (char->integer #\a))]
[(<= (char->integer #\A) c (char->integer #\F))
(- c (char->integer #\A))])))
(unless (and (string? s) (even? (string-length s))
(regexp-match? #rx"[0-9a-zA-Z]*" s))
(raise-type-error 'hex-string->bytes
"string containing an even number of hexadecimal digits" s))
(let* ([c (quotient (string-length s) 2)]
[b (make-bytes c)])
(for ([i (in-range c)])
(let ([high (hex-digit->int (string-ref s (+ i i)))]
[low (hex-digit->int (string-ref s (+ i i 1)))])
(bytes-set! b i (+ (arithmetic-shift high 4) low))))
b))
;; =======================================
(provide old-scramble-password

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

@ -1,6 +1,7 @@
#lang racket/base
(require racket/class
"../generic/interfaces.rkt"
"../generic/common.rkt"
"../generic/sql-data.rkt"
"../../util/private/geometry.rkt"
(only-in "message.rkt" field-dvec->typeid))

5
collects/db/private/mysql/main.rkt
View File

@ -2,8 +2,8 @@
(require racket/class
racket/tcp
openssl
file/sha1
"../generic/interfaces.rkt"
"../generic/common.rkt"
"../generic/socket.rkt"
"connection.rkt")
(provide mysql-connect
@ -62,6 +62,3 @@
(define (mysql-guess-socket-path)
(guess-socket-path/paths 'mysql-guess-socket-path socket-paths))
(define (mysql-password-hash password)
(bytes->hex-string (password-hash password)))

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

@ -5,6 +5,7 @@
ffi/unsafe
ffi/unsafe/atomic
"../generic/interfaces.rkt"
"../generic/common.rkt"
"../generic/prepared.rkt"
"../generic/sql-data.rkt"
"../generic/sql-convert.rkt"

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

@ -1,6 +1,7 @@
#lang racket/base
(require racket/class
"../generic/interfaces.rkt"
"../generic/common.rkt"
"../generic/sql-data.rkt"
"../generic/sql-convert.rkt")
(provide dbsystem

1
collects/db/private/odbc/main.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require racket/class
"../generic/interfaces.rkt"
"../generic/common.rkt"
"../generic/place-client.rkt"
"connection.rkt"
"dbsystem.rkt"

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

@ -5,6 +5,7 @@
file/md5
openssl
"../generic/interfaces.rkt"
"../generic/common.rkt"
"../generic/sql-data.rkt"
"../generic/prepared.rkt"
"message.rkt"

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

@ -5,6 +5,7 @@
racket/match
(prefix-in srfi: srfi/19)
"../generic/interfaces.rkt"
"../generic/common.rkt"
"../generic/sql-data.rkt"
"../generic/sql-convert.rkt"
"../../util/datetime.rkt"

1
collects/db/private/postgresql/main.rkt
View File

@ -3,6 +3,7 @@
racket/tcp
openssl
"../generic/interfaces.rkt"
"../generic/common.rkt"
"../generic/socket.rkt"
"connection.rkt")
(provide postgresql-connect

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

@ -3,6 +3,7 @@
ffi/unsafe
ffi/unsafe/atomic
"../generic/interfaces.rkt"
"../generic/common.rkt"
"../generic/prepared.rkt"
"../generic/sql-data.rkt"
"ffi.rkt"

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

@ -1,6 +1,7 @@
#lang racket/base
(require racket/class
"../generic/interfaces.rkt")
"../generic/interfaces.rkt"
"../generic/common.rkt")
(provide dbsystem
classify-sl-sql)
@ -38,7 +39,6 @@
;; ========================================
;; SQL "parsing"
;; We just care about detecting commands that affect transaction status.

2
collects/tests/db/db/connection.rkt
View File

@ -4,7 +4,7 @@
rackunit
"../config.rkt"
db/base
(only-in db/private/generic/interfaces locking%))
(only-in db/private/generic/common locking%))
(import config^ database^)
(export test^)

2
collects/tests/db/gen/misc.rkt
View File

@ -5,7 +5,7 @@
(provide misc:test)
(require db/private/generic/interfaces)
(require db/private/generic/common)
(define misc:test
(test-suite "Misc internal function tests"