diff --git a/collects/db/private/generic/common.rkt b/collects/db/private/generic/common.rkt new file mode 100644 index 0000000000..02e575cb63 --- /dev/null +++ b/collects/db/private/generic/common.rkt @@ -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)) + stringstring + #: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))) diff --git a/collects/db/private/generic/connect-util.rkt b/collects/db/private/generic/connect-util.rkt index 6907ae3d2b..70ffd91746 100644 --- a/collects/db/private/generic/connect-util.rkt +++ b/collects/db/private/generic/connect-util.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/class - "interfaces.rkt") + "interfaces.rkt" + "common.rkt") (provide kill-safe-connection virtual-connection connection-pool diff --git a/collects/db/private/generic/functions.rkt b/collects/db/private/generic/functions.rkt index e8b448ea10..6d70b4f304 100644 --- a/collects/db/private/generic/functions.rkt +++ b/collects/db/private/generic/functions.rkt @@ -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) diff --git a/collects/db/private/generic/interfaces.rkt b/collects/db/private/generic/interfaces.rkt index ec6e534b65..6597063a96 100644 --- a/collects/db/private/generic/interfaces.rkt +++ b/collects/db/private/generic/interfaces.rkt @@ -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)) - stringstring - #: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) diff --git a/collects/db/private/generic/place-client.rkt b/collects/db/private/generic/place-client.rkt index d4fccad936..6da95ca836 100644 --- a/collects/db/private/generic/place-client.rkt +++ b/collects/db/private/generic/place-client.rkt @@ -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) diff --git a/collects/db/private/generic/place-server.rkt b/collects/db/private/generic/place-server.rkt index dc41571bce..98a346750f 100644 --- a/collects/db/private/generic/place-server.rkt +++ b/collects/db/private/generic/place-server.rkt @@ -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 diff --git a/collects/db/private/generic/prepared.rkt b/collects/db/private/generic/prepared.rkt index f965a73e97..c3975f2068 100644 --- a/collects/db/private/generic/prepared.rkt +++ b/collects/db/private/generic/prepared.rkt @@ -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)) diff --git a/collects/db/private/mysql/connection.rkt b/collects/db/private/mysql/connection.rkt index 0c7e7d1180..251d3698a6 100644 --- a/collects/db/private/mysql/connection.rkt +++ b/collects/db/private/mysql/connection.rkt @@ -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 diff --git a/collects/db/private/mysql/dbsystem.rkt b/collects/db/private/mysql/dbsystem.rkt index de7aeac1ab..32e1e2eb7d 100644 --- a/collects/db/private/mysql/dbsystem.rkt +++ b/collects/db/private/mysql/dbsystem.rkt @@ -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)) diff --git a/collects/db/private/mysql/main.rkt b/collects/db/private/mysql/main.rkt index 9c9fd062b0..b3b936cb4d 100644 --- a/collects/db/private/mysql/main.rkt +++ b/collects/db/private/mysql/main.rkt @@ -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))) diff --git a/collects/db/private/odbc/connection.rkt b/collects/db/private/odbc/connection.rkt index 7e53cff2a7..40cc6873eb 100644 --- a/collects/db/private/odbc/connection.rkt +++ b/collects/db/private/odbc/connection.rkt @@ -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" diff --git a/collects/db/private/odbc/dbsystem.rkt b/collects/db/private/odbc/dbsystem.rkt index 55cef323f4..0a805bba20 100644 --- a/collects/db/private/odbc/dbsystem.rkt +++ b/collects/db/private/odbc/dbsystem.rkt @@ -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 diff --git a/collects/db/private/odbc/main.rkt b/collects/db/private/odbc/main.rkt index b5a63c6f70..218259fb27 100644 --- a/collects/db/private/odbc/main.rkt +++ b/collects/db/private/odbc/main.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/class "../generic/interfaces.rkt" + "../generic/common.rkt" "../generic/place-client.rkt" "connection.rkt" "dbsystem.rkt" diff --git a/collects/db/private/postgresql/connection.rkt b/collects/db/private/postgresql/connection.rkt index c3877cc908..bed08f50cb 100644 --- a/collects/db/private/postgresql/connection.rkt +++ b/collects/db/private/postgresql/connection.rkt @@ -5,6 +5,7 @@ file/md5 openssl "../generic/interfaces.rkt" + "../generic/common.rkt" "../generic/sql-data.rkt" "../generic/prepared.rkt" "message.rkt" diff --git a/collects/db/private/postgresql/dbsystem.rkt b/collects/db/private/postgresql/dbsystem.rkt index 34015ed5d9..11475c314e 100644 --- a/collects/db/private/postgresql/dbsystem.rkt +++ b/collects/db/private/postgresql/dbsystem.rkt @@ -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" diff --git a/collects/db/private/postgresql/main.rkt b/collects/db/private/postgresql/main.rkt index 1c3a8a9c40..ef57a353ba 100644 --- a/collects/db/private/postgresql/main.rkt +++ b/collects/db/private/postgresql/main.rkt @@ -3,6 +3,7 @@ racket/tcp openssl "../generic/interfaces.rkt" + "../generic/common.rkt" "../generic/socket.rkt" "connection.rkt") (provide postgresql-connect diff --git a/collects/db/private/sqlite3/connection.rkt b/collects/db/private/sqlite3/connection.rkt index 007ddc1300..09b8105b82 100644 --- a/collects/db/private/sqlite3/connection.rkt +++ b/collects/db/private/sqlite3/connection.rkt @@ -3,6 +3,7 @@ ffi/unsafe ffi/unsafe/atomic "../generic/interfaces.rkt" + "../generic/common.rkt" "../generic/prepared.rkt" "../generic/sql-data.rkt" "ffi.rkt" diff --git a/collects/db/private/sqlite3/dbsystem.rkt b/collects/db/private/sqlite3/dbsystem.rkt index 0fec4f6209..4c560a939d 100644 --- a/collects/db/private/sqlite3/dbsystem.rkt +++ b/collects/db/private/sqlite3/dbsystem.rkt @@ -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. diff --git a/collects/tests/db/db/connection.rkt b/collects/tests/db/db/connection.rkt index 77ba036012..b77fd31c6f 100644 --- a/collects/tests/db/db/connection.rkt +++ b/collects/tests/db/db/connection.rkt @@ -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^) diff --git a/collects/tests/db/gen/misc.rkt b/collects/tests/db/gen/misc.rkt index 36ef881989..ca1747e2bb 100644 --- a/collects/tests/db/gen/misc.rkt +++ b/collects/tests/db/gen/misc.rkt @@ -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"