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

db: updated to new error convention (mostly)

Browse Source
This commit is contained in:
Ryan Culpepper 2012-08-22 09:19:36 -04:00
parent 325293ceea
commit 7c395e9c7c
21 changed files with 268 additions and 183 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/db/private/generic/common.rkt
View File

@ -72,8 +72,7 @@
(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")))
(error function "could not find socket path")))
;; ----------------------------------------
@ -254,7 +253,7 @@
;; check-valid-tx-status : symbol -> void
(define/public (check-valid-tx-status fsym)
(when (eq? tx-status 'invalid)
(uerror fsym "current transaction is invalid")))
(error fsym "current transaction is invalid")))
;; ----
@ -300,7 +299,7 @@
(set! tx-stack (list (cons #f cwt?)))]
[else ;; in transaction
(unless (eq? isolation #f)
(error fsym "invalid isolation level for nested transaction: ~e" isolation))
(error/invalid-nested-isolation fsym isolation))
(let ([savepoint (start-transaction* fsym 'nested)])
(set! tx-stack (cons (cons savepoint cwt?) tx-stack)))])))
(void))
@ -384,13 +383,13 @@
- 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 "")))
(define (no! tx-state)
(error/tx-bad-stmt fsym
(or (statement-type->string stmt-type)
(case stmt-type
((implicit-commit) "statement with implicit commit")
(else #f)))
tx-state))
(case (transaction-nesting)
((#f)
@ -400,12 +399,12 @@
((top-level nested)
(case stmt-type
((start)
(no! " within transaction"))
(no! "within transaction"))
((commit rollback
savepoint prepare-transaction
release-savepoint rollback-savepoint
implicit-commit)
(no! " within managed transaction"))
(no! "within managed transaction"))
(else (void))))))
(super-new)))

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

@ -204,8 +204,7 @@
(send (get-connection #t) prepare fsym stmt close-on-exec?))
(define/public (free-statement stmt need-lock?)
(error 'free-statement
"internal error: virtual connection does not own statements"))))
(error/internal 'free-statement "virtual connection does not own statements"))))
;; ----
@ -287,7 +286,7 @@
(begin0 actual-counter
(set! actual-counter (add1 actual-counter)))])
(when (or (hash-ref proxy=>evt c #f) (memq c idle-list))
(uerror 'connection-pool "connect function did not produce a fresh connection"))
(error 'connection-pool "connect function did not produce a fresh connection"))
(hash-set! actual=>number c actual-number)
c))
@ -376,6 +375,5 @@
[else key])]
[result (sync/timeout 0.1 (send pool lease-evt key))])
(unless result
(uerror 'connection-pool-lease
"cannot obtain connection; connection pool limit reached"))
(error 'connection-pool-lease "connection pool limit reached"))
result))

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

@ -3,6 +3,7 @@
racket/vector
racket/class
racket/promise
unstable/error
"interfaces.rkt"
(only-in "sql-data.rkt" sql-null sql-null?))
(provide (all-defined-out))
@ -80,35 +81,31 @@
(define (query/rows c fsym sql want-columns)
(let [(result (query1 c fsym sql))]
(unless (rows-result? result)
(uerror fsym "query did not return rows: ~e" sql))
(error/want-rows fsym sql #t))
(let ([got-columns (length (rows-result-headers result))])
(when (and want-columns (not (= got-columns want-columns)))
(uerror fsym "query returned ~a ~a (expected ~a): ~e"
got-columns (if (= got-columns 1) "column" "columns") want-columns sql)))
(error/column-count fsym sql want-columns got-columns #t)))
result))
(define (query/cursor c fsym sql want-columns)
(let ([result (send c query fsym sql #t)])
(unless (cursor-result? result)
(uerror fsym "query did not return cursor: ~e" sql))
(error/want-cursor fsym sql))
(let ([got-columns (length (cursor-result-headers result))])
(when (and want-columns (not (= got-columns want-columns)))
(uerror fsym "query returned ~a ~a (expected ~a): ~e"
got-columns (if (= got-columns 1) "column" "columns")
want-columns sql)))
(error/column-count fsym sql want-columns got-columns #t)))
result))
(define (rows-result->row fsym rs sql maybe-row? one-column?)
(define rows (rows-result-rows rs))
(cond [(null? rows)
(cond [maybe-row? #f]
[else (uerror fsym "query returned zero rows (expected 1): ~e" sql)])]
[else (error/row-count fsym sql 1 0)])]
[(null? (cdr rows))
(let ([row (car rows)])
(cond [one-column? (vector-ref row 0)]
[else row]))]
[else
(uerror fsym "query returned multiple rows (expected 1): ~e" sql)]))
[else (error/row-count fsym sql 1 (length rows))]))
(define (compose-statement fsym c stmt args checktype)
(cond [(prop:statement? stmt)
@ -124,17 +121,12 @@
;; Ownership check done later, by query method.
stmt]
[(statement-binding? stmt)
(error fsym
(string-append
"cannot execute statement-binding with "
"additional inline arguments: ~e")
stmt)])])
(error/statement-binding-args fsym stmt args)])])
(send pst check-results fsym checktype stmt)
(send pst bind fsym args))]
[else ;; no args, and stmt is either string or statement-binding
stmt]))
;; Query API procedures
;; query-rows : connection Statement arg ... -> (listof (vectorof 'a))
@ -291,15 +283,12 @@
(define (call-with-transaction c proc #:isolation [isolation #f])
(send c start-transaction '|call-with-transaction (start)| isolation #t)
(with-handlers ([exn?
(lambda (e)
(lambda (e1)
(with-handlers ([exn?
(lambda (e2)
(error 'call-with-transaction
"error during rollback: ~a\ncaused by underlying error: ~a"
(exn-message e2)
(exn-message e)))])
(error/exn-in-rollback 'call-with-transaction e1 e2))])
(send c end-transaction '|call-with-transaction (rollback)| 'rollback #t))
(raise e))])
(raise e1))])
(begin0 (call-with-continuation-barrier proc)
(send c end-transaction '|call-with-transaction (commit)| 'commit #t))))
@ -358,11 +347,12 @@
[residual-length
(for/sum ([x (in-vector fields-used)]) (if x 0 1))])
(when (= residual-length 0)
(error fsym "cannot group by all fields"))
(raise-arguments-error fsym "cannot group by all fields"
"grouping field sets" key-fields-list))
(when (and (> residual-length 1) as-list?)
(error fsym
"expected exactly one residual field for #:group-mode 'list, got ~a"
residual-length))
(raise-arguments-error fsym "expected exactly one residual field when #:group-mode is 'list"
"grouping field sets" key-fields-list
"residual field count" residual-length))
(let* ([initial-projection
(for/vector #:length total-fields ([i (in-range total-fields)]) i)]
[headers
@ -401,20 +391,19 @@
[else key-field])])
(when (string? key-field)
(unless key-index
(error fsym "expected grouping field in ~s, got: ~e"
(sort (hash-keys name-map) string<?)
key-field)))
(raise-arguments-error fsym "bad grouping field"
"given" key-field
"available" (sort (hash-keys name-map) string<?))))
(when (exact-integer? key-field)
(unless (< key-index total-fields)
(error fsym "grouping index ~s out of range [0, ~a]"
key-index (sub1 total-fields))))
(raise-range-error fsym "fields" "grouping "
key-index
(sort (hash-keys name-map) string<?)
0 total-fields)))
(when fields-used
(when (vector-ref fields-used key-index)
(error fsym "grouping field ~s~a used multiple times"
key-field
(if (string? key-field)
(format " (index ~a)" key-index)
"")))
(raise-arguments-error fsym "grouping field used multiple times"
"field" key-field))
(vector-set! fields-used key-index #t))
key-index))
@ -532,8 +521,9 @@
(eq? (hash-ref table key not-given) not-given)
;; FIXME: okay to coalesce values if equal?
(equal? value old-value))
(error who "duplicate value for key: ~e; values are ~e and ~e"
key old-value value))
(raise-misc-error who "duplicate value for key"
'("key" value) key
'("values" multi value) (list old-value value)))
(if value-list?
(hash-set table key
(if (ok-value? value)

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

@ -1,6 +1,7 @@
#lang racket/base
(require racket/class
racket/serialize)
racket/serialize
unstable/error)
(provide connection<%>
dbsystem<%>
prepared-statement<%>
@ -165,8 +166,9 @@ producing plain old exn:fail.
;; raise-sql-error : symbol string string alist -> raises exn
(define (raise-sql-error who sqlstate message info)
(raise
(make-exn:fail:sql (format "~a: ~a (SQLSTATE ~a)" who message sqlstate)
(raise
(make-exn:fail:sql (compose-error-message who message
"SQLSTATE" sqlstate)
(current-continuation-marks)
sqlstate
info)))
@ -175,45 +177,55 @@ producing plain old exn:fail.
;; Common Errors
(provide uerror
error/internal
(provide error/internal
error/internal*
error/not-connected
error/no-support
error/need-password
error/comm
error/hopeless
error/unsupported-type
error/no-convert
error/invalid-nested-isolation
error/tx-bad-stmt
error/unbalanced-tx
error/unclosed-tx)
;;(define uerror raise-user-error)
(define uerror error)
error/unclosed-tx
error/exn-in-rollback
error/stmt-arity
error/stmt
error/want-rows
error/want-cursor
error/column-count
error/row-count
error/statement-binding-args)
(define (error/internal fsym fmt . args)
(apply error fsym (string-append "internal error: " fmt) args))
(raise-misc-error fsym "internal error"
#:continued (apply format fmt args)))
(define (error/not-connected fsym)
(uerror fsym "not connected"))
(define (error/need-password fsym)
(uerror fsym "password needed but not supplied"))
(define (error/internal* fsym msg . args)
(apply raise-misc-error fsym "internal error" #:continued msg args))
;; FIXME; clean up
(define (error/comm fsym [when-occurred #f])
(if when-occurred
(error/internal fsym "communication problem ~a" when-occurred)
(error/internal fsym "communication problem")))
(raise-misc-error fsym "communication failure"
"when" when-occurred))
(define (error/no-support fsym feature)
(raise-misc-error fsym "feature not supported"
"feature" feature))
(define (error/hopeless fsym)
(uerror fsym "connection is permanently locked due to a terminated thread"))
(error fsym "connection is permanently locked due to a terminated thread"))
(define (error/unsupported-type fsym typeid [type #f])
(if type
(uerror fsym "unsupported type: ~a (typeid ~a)" type typeid)
(uerror fsym "unsupported type: (typeid ~a)" typeid)))
(define (error/not-connected fsym)
(error fsym "not connected"))
(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/invalid-nested-isolation fsym isolation)
(raise-misc-error fsym "invalid isolation level for nested transaction"
'("isolation level" value) isolation))
(define (error/unbalanced-tx fsym mode saved-cwt?)
(error fsym "~a-transaction without matching start-transaction~a"
@ -222,3 +234,83 @@ producing plain old exn:fail.
(define (error/unclosed-tx fsym mode saved-cwt?)
(error fsym "unclosed nested transaction~a"
(if saved-cwt? " (within extent of call-with-transaction)" "")))
(define (error/tx-bad-stmt fsym stmt-type-string tx-state)
(raise-misc-error fsym "statement not allowed in current transaction state"
"statement type" stmt-type-string
"transaction state" tx-state))
(define (error/exn-in-rollback fsym e1 e2)
(raise-misc-error fsym "error during rollback"
#:continued "secondary error occurred during rollback triggered by primary error"
'("primary" value) (exn-message e1)
'("secondary" value) (exn-message e2)))
;; ----
(define (error/stmt-arity fsym expected given)
(raise-misc-error fsym "wrong number of parameters for query"
;; FIXME: add stmt, use error/stmt
"expected" expected
"given" given))
;; ----
(define (error/need-password fsym)
(error fsym "password needed but not supplied"))
;; ----
(define (error/unsupported-type fsym typeid [type #f])
(raise-misc-error fsym "unsupported type"
"type" type
"typeid" typeid))
(define (error/no-convert fsym sys type param [note #f])
(raise-misc-error fsym "cannot convert given value to SQL type"
'("given" value) param
"type" type
"dialect" sys
"note" note))
;; ----
(define (error/stmt fsym stmt message . args)
(apply raise-misc-error fsym message
'("statement" value) (or (let loop ([stmt stmt])
(cond [(string? stmt) stmt]
[(statement-binding? stmt) (loop (statement-binding-pst stmt))]
[(prepared-statement? stmt) (loop (send stmt get-stmt))]
[else #f]))
stmt)
;; FIXME: include params from statement-binding values?
;; must first change statement-binding to store raw params
args))
(define (error/want-rows fsym sql executed?)
(error/stmt fsym sql
(if executed?
"query did not return rows"
"query does not return rows")))
(define (error/want-cursor fsym sql)
(error/stmt fsym sql "query did not return cursor"))
(define (error/column-count fsym sql want-columns got-columns executed?)
(error/stmt fsym sql
(if executed?
"query returned wrong number of columns"
"query returns wrong number of columns")
"expected" want-columns
"got" got-columns))
(define (error/row-count fsym sql want-rows got-rows)
(error/stmt fsym sql "query returned wrong number of rows"
"expected" want-rows
"got" got-rows))
(define (error/statement-binding-args fsym stmt args)
(raise-misc-error fsym
"cannot execute statement-binding with additional inline arguments"
'("statement" value) stmt
'("arguments" value) args))

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

@ -54,22 +54,18 @@
(cond [(eq? checktype 'rows)
(unless (positive? (get-result-count))
(when close-on-exec? (finalize #t))
(error fsym "expected statement producing rows, got ~e" obj))]
(error/want-rows fsym obj #f))]
[(exact-positive-integer? checktype)
(unless (= (get-result-count) checktype)
(when close-on-exec? (finalize #t))
(error fsym
"expected statement producing rows with ~a ~a, got ~e"
checktype
(if (= checktype 1) "column" "columns")
obj))]
(error/column-count fsym obj checktype (get-result-count) #f))]
[else (void)]))
(define/public (check-owner fsym c obj)
(unless handle
(error fsym "prepared statement is closed"))
(unless (eq? c (weak-box-value owner))
(error fsym "prepared statement owned by another connection: ~e" obj)))
(error fsym "prepared statement owned by another connection")))
(define/public (bind fsym params)
(statement-binding this (apply-type-handlers fsym params param-handlers)))
@ -95,7 +91,7 @@
(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)))
(error/stmt-arity fsym expected-len given-len)))
(for/list ([handler (in-list param-handlers)]
[index (in-naturals)]
[param (in-list params)])

6
collects/db/private/generic/socket.rkt
View File

@ -9,7 +9,7 @@
;; Connects to the unix domain socket associated with the given path.
(define (unix-socket-connect path0)
(unless (path-string? path0)
(raise-type-error 'unix-socket-connect "path or string" path0))
(raise-argument-error 'unix-socket-connect "path-string?" path0))
(security-guard-check-file 'unix-socket-connect path0 '(read write))
(let* ([path* (cleanse-path (path->complete-path path0))]
[path-b (path->bytes path*)])
@ -51,9 +51,7 @@
(define (make-socket)
(unless (and AF_UNIX SOCK_STREAM)
(raise-user-error
'unix-socket-connect
"unix-domain sockets not supported on this platform"))
(error 'unix-socket-connect "unix-domain sockets not supported on this platform"))
(_socket AF_UNIX SOCK_STREAM 0))
(define _sockaddr_un_path_part

7
collects/db/private/generic/sql-convert.rkt
View File

@ -1,4 +1,5 @@
#lang racket/base
(require "interfaces.rkt")
;; ========================================
@ -16,7 +17,8 @@
(+ (string->number (cadr m))
(parse-exact-fraction (caddr m))))]
[else
(error 'parse-decimal "internal error: cannot parse ~s as decimal" s)]))
(error/internal* 'parse-decimal "cannot parse as decimal"
'("string" value) s)]))
(define (parse-exact-fraction s)
;; eg: (parse-exact-fraction "12") = 12/100
@ -97,5 +99,4 @@
;; marshal-error : string datum -> (raises error)
(define (marshal-error f i type datum)
(error f "cannot marshal as SQL type ~s: ~e"
type datum))
(error/no-convert f #f type datum))

6
collects/db/private/generic/sql-data.rkt
View File

@ -120,7 +120,7 @@
[else
(cond [(eq? default no-arg)
(error 'sql-day-time-interval->sql-time
"cannot convert interval to time: ~e" x)]
"cannot convert given interval to time: ~e" x)]
[(procedure? default) (default)]
[else default])])))
@ -155,9 +155,7 @@ byte. (Because that's PostgreSQL's binary format.) For example:
(define (check-index fsym b index)
(let ([len (sql-bits-length b)])
(unless (< index len)
(if (zero? len)
(error fsym "index ~e out of range for empty sql-bits" index)
(error fsym "index ~e out of range: [0, ~a]" index (+ len -1))))))
(raise-range-error fsym "sql-bits" "" index b 0 (sub1 len)))))
(define (sql-bits-ref b i)
(check-index 'sql-bits-ref b i)

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

@ -3,6 +3,7 @@
racket/match
openssl
openssl/sha1
unstable/error
"../generic/interfaces.rkt"
"../generic/common.rkt"
"../generic/prepared.rkt"
@ -184,12 +185,13 @@
[(struct handshake-packet (pver sver tid scramble capabilities charset status auth))
(check-required-flags capabilities)
(unless (member auth '("mysql_native_password" #f))
(uerror 'mysql-connect "unsupported authentication plugin: ~s" auth))
(raise-misc-error 'mysql-connect "back end requested unsupported authentication plugin"
'("plugin" value) auth))
(define do-ssl?
(and (case ssl ((yes optional) #t) ((no) #f))
(memq 'ssl capabilities)))
(when (and (eq? ssl 'yes) (not do-ssl?))
(uerror 'mysql-connect "server refused SSL connection"))
(error 'mysql-connect "back end refused SSL connection"))
(define wanted-capabilities (desired-capabilities capabilities do-ssl? dbname))
(when do-ssl?
(send-message (make-abbrev-client-auth-packet wanted-capabilities))
@ -215,9 +217,8 @@
[(equal? auth-plugin "mysql_old_password")
(send-message (auth (bytes-append (old-scramble-password scramble password)
(bytes 0))))]
[else (uerror 'mysql-connect
"server does not support authentication plugin: ~s"
auth-plugin)])
[else (raise-misc-error 'mysql-connect "back end does not support authentication plugin"
'("plugin" value) auth-plugin)])
(match (recv 'mysql-connect 'auth)
[(struct ok-packet (_ _ status warnings message))
(after-connect)]
@ -228,9 +229,8 @@
(define/private (check-required-flags capabilities)
(for-each (lambda (rf)
(unless (memq rf capabilities)
(uerror 'mysql-connect
"server does not support required capability: ~s"
rf)))
(raise-misc-error 'mysql-connect "server does not support required capability"
"capability" rf)))
REQUIRED-CAPABILITIES))
(define/private (desired-capabilities capabilities ssl? dbname)

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

@ -27,7 +27,7 @@
(+ (if (or server port) 1 0)
(if socket 1 0))])
(when (> connection-options 1)
(uerror 'mysql-connect "cannot give both server/port and socket arguments")))
(error 'mysql-connect "cannot give both server/port and socket arguments")))
(let* ([notice-handler
(cond [(procedure? notice-handler) notice-handler]
[else (make-print-notice notice-handler)])]

23
collects/db/private/mysql/message.rkt
View File

@ -403,8 +403,9 @@ computed string on the server can be. See also:
[inp (open-input-bytes bs)])
(let-values ([(msg-num msg) (parse-packet/1 num in inp expect len field-dvecs)])
(when (and (not (port-closed? inp)) (port-has-bytes? inp))
(error/internal 'parse-packet "bytes left over after parsing ~s; bytes were: ~s"
msg (io:read-bytes-to-eof inp)))
(error/internal* 'parse-packet "bytes left over after parsing packet"
'("packet" value) msg
'("leftover" value) (io:read-bytes-to-eof inp)))
(close-input-port inp)
(values num msg))))
@ -640,9 +641,8 @@ computed string on the server can be. See also:
sql-null
(read-binary-datum in* field-dvec))))
(when (port-has-bytes? in*)
(error/internal 'parse-binary-row-data-packet
"bytes left over; bytes were: ~s"
(io:read-bytes-to-eof in*)))
(error/internal* 'parse-binary-row-data-packet "bytes left over after parsing packet"
'("leftover" value) (io:read-bytes-to-eof in*)))
(close-input-port in*)
(values msg-num* (make-binary-row-data-packet field-v)))))
@ -738,11 +738,11 @@ computed string on the server can be. See also:
#:srid? #t))
((decimal)
(error/internal 'get-param "unimplemented decimal type: ~s" type))
(error/internal* 'get-result "unimplemented decimal type" "type" type))
((enum set)
(error/internal 'get-result "unimplemented type: ~s" type))
(error/internal 'get-result "unimplemented type" "type" type))
(else
(error/internal 'get-result "unknown type: ~s" type))))
(error/internal 'get-result "unknown type" "type" type))))
(define (supported-result-typeid? typeid)
(case typeid
@ -776,7 +776,8 @@ computed string on the server can be. See also:
[(geometry2d? param)
'geometry]
[else
(error/internal 'choose-param-type "bad parameter value: ~e" param)]))
(error/internal* 'choose-param-type "bad parameter value"
'("value" value) param)]))
(define (write-binary-datum out type param)
(case type
@ -836,7 +837,7 @@ computed string on the server can be. See also:
(let ([val (assq key table)])
(if val
(cdr val)
(error/internal function "not found: ~s" key))))
(error/internal* function "not found" '("key" value) key))))
(define (encode-flags flags table function)
(apply bitwise-ior
@ -986,7 +987,7 @@ computed string on the server can be. See also:
(define (encode-charset charset)
(case charset
((utf8-general-ci) 33)
(else (error/internal 'encode-charset "unknown charset: ~e" charset))))
(else (error/internal* 'encode-charset "unknown charset" "charset" charset))))
(define (decode-charset n)
(case n
((33) 'utf8-general-ci)

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

@ -4,6 +4,7 @@
racket/math
ffi/unsafe
ffi/unsafe/atomic
unstable/error
"../generic/interfaces.rkt"
"../generic/common.rkt"
"../generic/prepared.rkt"
@ -234,7 +235,9 @@
(integer->integer-bytes (sql-timestamp-nanosecond x) 4 #f)))))]
[(sql-null? param)
(bind SQL_C_CHAR SQL_VARCHAR #f)]
[else (error/internal fsym "cannot convert to typeid ~a: ~e" typeid param)]))
[else (error/internal* fsym "cannot convert given value to SQL type"
'("given" value) param
"typeid" typeid)]))
(define/private (fetch* fsym stmt result-typeids end-box limit)
;; scratchbuf: create a single buffer here to try to reduce garbage
@ -516,7 +519,8 @@
(define/override (start-transaction* fsym isolation)
(when (eq? isolation 'nested)
(uerror fsym "already in transaction (nested transactions not supported for ODBC)"))
(raise-misc-error fsym "already in transaction"
#:continued "nested transactions not supported for ODBC connections"))
(let* ([db (get-db fsym)]
[ok-levels
(let-values ([(status value)
@ -537,7 +541,8 @@
;; 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))
(raise-misc-error fsym "requested isolation level is not available"
'("isolation level" value) 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)])
@ -563,7 +568,7 @@
(define/public (list-tables fsym schema)
(define (no-search)
(uerror fsym "schema search path cannot be determined for this DBMS"))
(error fsym "schema search path cannot be determined for this DBMS"))
(let ([stmt
(cond
[(regexp-match? #rx"^DB2" dbms)
@ -591,7 +596,7 @@
"SELECT view_name AS name FROM sys.all_views "
"WHERE " schema-cond))]
[else
(uerror fsym "not supported for this DBMS")])])
(error fsym "not supported for this DBMS")])])
(let* ([result (query fsym stmt #f)]
[rows (rows-result-rows result)])
(for/list ([row (in-list rows)])
@ -664,7 +669,7 @@
s]
[(= s SQL_ERROR)
(when handle (diag-info who handle 'error #f))
(uerror who "unknown error (no diagnostic returned)")]
(error who "unknown error (no diagnostic returned)")]
[else s]))
(define (diag-info who handle mode on-notice)
@ -673,7 +678,7 @@
[(sqlhdbc? handle) SQL_HANDLE_DBC]
[(sqlhstmt? handle) SQL_HANDLE_STMT]
[else
(error/internal 'diag-info "unknown handle type: ~e" handle)])])
(error/internal* 'diag-info "unknown handle type" '("handle" value) handle)])])
(let-values ([(status sqlstate native-errcode message)
(SQLGetDiagRec handle-type handle 1)])
(case mode

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

@ -4,6 +4,7 @@
racket/vector
file/md5
openssl
unstable/error
"../generic/interfaces.rkt"
"../generic/common.rkt"
"../generic/sql-data.rkt"
@ -128,7 +129,7 @@
((transaction) #t)
((failed) 'invalid)))]
[(and or-eof? (eof-object? r)) (void)]
[else (error/comm fsym "expected ready")])))
[else (error/comm fsym "expecting ready-for-query")])))
;; == Asynchronous messages
@ -145,11 +146,8 @@
(cond [(equal? name "client_encoding")
(unless (equal? value "UTF8")
(disconnect* #f)
(uerror fsym
(string-append
"server attempted to change the client character encoding "
"from UTF8 to ~a, disconnecting")
value))]
(raise-misc-error fsym "client character encoding changed, disconnecting"
'("new encoding" value) value))]
[else (void)])]))
;; == Connection management
@ -209,20 +207,20 @@
(unless (string? password)
(error/need-password 'postgresql-connect))
(unless allow-cleartext-password?
(uerror 'postgresql-connect (nosupport "cleartext password")))
(error/no-support 'postgresql-connect "cleartext password"))
(send-message (make-PasswordMessage password))
(connect:expect-auth username password)]
[(struct AuthenticationCryptPassword (salt))
(uerror 'postgresql-connect (nosupport "crypt()-encrypted password"))]
(error/no-support 'postgresql-connect "crypt()-encrypted password")]
[(struct AuthenticationMD5Password (salt))
(unless password
(error/need-password 'postgresql-connect))
(send-message (make-PasswordMessage (md5-password username password salt)))
(connect:expect-auth username password)]
[(struct AuthenticationKerberosV5 ())
(uerror 'postgresql-connect (nosupport "KerberosV5 authentication"))]
(error/no-support 'postgresql-connect "KerberosV5 authentication")]
[(struct AuthenticationSCMCredential ())
(uerror 'postgresql-connect (nosupport "SCM authentication"))]
(error/no-support 'postgresql-connect "SCM authentication")]
;; ErrorResponse handled by recv-message
[_ (error/comm 'postgresql-connect "during authentication")])))
@ -294,7 +292,8 @@
[pst-name (send pst get-handle)]
[params (statement-binding-params stmt)])
(unless pst-name
(error/internal 'query1:enqueue "statement was deleted: ~s" (send pst get-stmt)))
(error/internal* 'query1:enqueue "statement was deleted"
"statement" (send pst get-stmt)))
(buffer-message (make-Bind portal pst-name
(map typeid->format (send pst get-param-typeids))
params
@ -365,10 +364,11 @@
(define/private (query1:error fsym r)
(match r
[(struct CopyInResponse (format column-formats))
(uerror fsym (nosupport "COPY IN statements"))]
(error/no-support fsym "COPY IN statements")]
[(struct CopyOutResponse (format column-formats))
(uerror fsym (nosupport "COPY OUT statements"))]
[_ (error/comm fsym (format "got: ~e" r))]))
(error/no-support fsym "COPY OUT statements")]
[_ (error/internal* fsym "unexpected message from back end"
'("message" value) r)]))
(define/private (get-convert-row! fsym field-dvecs)
(let* ([type-reader-v

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

@ -387,7 +387,7 @@ record = cols:int4 (typeoid:int4 len/-1:int4 data:byte^len)^cols
(case (bytes-ref x 0)
((0) #f)
((1) #t)
(else (error/internal 'recv-boolean "bad value: ~e" x))))
(else (error/internal* 'recv-boolean "bad value" '("value" value) x))))
(define (recv-char1 x)
(integer->char (bytes-ref x 0)))

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

@ -38,7 +38,7 @@
(postgresql-guess-socket-path)
socket)])
(when (> connection-options 1)
(uerror 'postgresql-connect "cannot give both server/port and socket arguments"))
(error 'postgresql-connect "cannot give both server/port and socket arguments"))
(let ([c (new connection%
(notice-handler notice-handler)
(notification-handler notification-handler)

16
collects/db/private/postgresql/message.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require (for-syntax racket/base)
racket/match
unstable/error
"../generic/interfaces.rkt"
"../generic/sql-data.rkt")
(provide write-message
@ -54,8 +55,9 @@
(define (subport in len)
(let ([bytes (io:read-bytes-as-bytes in len)])
(unless (and (bytes? bytes) (= (bytes-length bytes) len))
(error/internal 'subport "truncated input; expected ~s bytes, got ~s"
len (if (bytes? bytes) (bytes-length bytes) 0)))
(error/internal* 'subport "truncated input; got fewer bytes than expected"
"expected" len
"got" (if (bytes? bytes) (bytes-length bytes) 0)))
(open-input-bytes bytes)))
@ -161,8 +163,8 @@
(make-AuthenticationMD5Password salt)))
((6) (make-AuthenticationSCMCredential))
(else
(error/internal 'authentication
"unknown authentication method requested (~s)" tag))))))
(error/internal* 'authentication "back end requested unknown authentication method"
"method code" tag))))))
(define-struct StartupMessage (parameters) #:transparent)
(define (write:StartupMessage p v)
@ -430,7 +432,8 @@
(string->symbol (format "write:~a" (syntax-e type))))))])
#'(cond [(pred msg) (write port msg)] ...
[else
(error/internal 'write-message "unknown message type: ~e" msg)]))]))
(error/internal* 'write-message "unknown message type"
'("message" value) msg)]))]))
(gen-cond Sync
Parse
Describe
@ -470,7 +473,8 @@
(else
(if (eof-object? c)
c
(error/internal 'parse-server-message "unknown message header byte: ~e" c))))))
(error/internal* 'parse-server-message "unknown message header"
'("header" value) c))))))
;; ========================================
;; Helpers

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

@ -2,6 +2,7 @@
(require racket/class
ffi/unsafe
ffi/unsafe/atomic
unstable/error
"../generic/interfaces.rkt"
"../generic/common.rkt"
"../generic/prepared.rkt"
@ -120,7 +121,7 @@
[(sql-null? param)
(sqlite3_bind_null stmt i)]
[else
(error/internal fsym "bad parameter: ~e" param)])))
(error/internal* fsym "bad parameter value" '("value" value) param)])))
(define/private (step* fsym db stmt end-box fetch-limit)
(if (zero? fetch-limit)
@ -154,8 +155,8 @@
[(= type SQLITE_BLOB)
(sqlite3_column_blob stmt i)]
[else
(error/internal
fsym "unknown column type: ~e" type)]))))
(error/internal* fsym "unknown column type"
"type" type)]))))
vec)])))
(define/override (classify-stmt sql) (classify-sl-sql sql))
@ -170,11 +171,12 @@
(sqlite3_prepare_v2 db sql)])
(when tail?
(when stmt (sqlite3_finalize stmt))
(uerror fsym "multiple SQL statements given: ~e" sql))
(raise-misc-error fsym "multiple statements given"
'("given" value) sql))
(values prep-status stmt)))])
(when DEBUG?
(dprintf " << prepared statement #x~x\n" (cast stmt _pointer _uintptr)))
(unless stmt (uerror fsym "SQL syntax error in ~e" sql))
(unless stmt (raise-misc-error fsym "SQL syntax error" '("given" value) sql))
(let* ([param-typeids
(for/list ([i (in-range (sqlite3_bind_parameter_count stmt))])
'any)]
@ -326,7 +328,7 @@
(= s SQLITE_ROW)
(= s SQLITE_DONE))
s
(uerror who "~a" (lookup-status-message s db))))
(error who "~a" (lookup-status-message s db))))
(define error-table
`([,SQLITE_ERROR . "unknown error"]

15
collects/db/scribblings/example-log.rktd
View File

@ -120,7 +120,7 @@
(c
exn
c
"query-value: query returned zero rows (expected 1): \"select d from the_numbers where n = 5\""))
"query-value: query returned wrong number of rows\n statement: \"select d from the_numbers where n = 5\"\n expected: 1\n got: 0"))
#""
#"")
((query-maybe-value pgc "select d from the_numbers where n = 5")
@ -146,7 +146,7 @@
(query-value pgc "select NoSuchField from NoSuchTable"))
(query-value pgc "select 'okay to proceed!'"))
((3) 0 () 0 () () (c values c (u . "okay to proceed!")))
#"query-value: relation \"nosuchtable\" does not exist (SQLSTATE 42P01)\n"
#"query-value: relation \"nosuchtable\" does not exist\n SQLSTATE: 42P01\n"
#"")
((query-value pgc "select d from the_numbers where n = $1" 2)
((3) 0 () 0 () () (c values c (u . "company")))
@ -300,7 +300,7 @@
(c
exn
c
"query-value: query returned zero rows (expected 1): #<statement-binding>"))
"query-value: query returned wrong number of rows\n statement: \"select d from the_numbers where n = $1\"\n expected: 1\n got: 0"))
#""
#"")
((query-value c "select count(*) from the_numbers")
@ -331,7 +331,7 @@
(c
exn
c
"in-query: query returned 2 columns (expected 1): \"select * from the_numbers\""))
"in-query: query returned wrong number of columns\n statement: \"select * from the_numbers\"\n expected: 1\n got: 2"))
#""
#"")
((define vehicles-result
@ -518,7 +518,7 @@
0
()
()
(c exn c "query-value: unsupported type: inet (typeid 869)"))
(c exn c "query-value: unsupported type\n type: inet\n typeid: 869"))
#""
#"")
((query-value pgc "select cast(inet '127.0.0.1' as varchar)")
@ -559,7 +559,10 @@
0
()
()
(c exn c "query-value: cannot convert to PostgreSQL string type: 1"))
(c
exn
c
"query-value: cannot convert given value to SQL type\n given: 1\n type: string\n dialect: PostgreSQL"))
#""
#"")
((query-value c "select NULL")

6
collects/db/util/datetime.rkt
View File

@ -11,11 +11,7 @@
[(struct sql-time (hour minute second nanosecond tz))
(srfi:make-date nanosecond second minute hour 0 0 0 (or tz 0))]
[(struct sql-timestamp (year month day hour minute second nanosecond tz))
(srfi:make-date nanosecond second minute hour day month year (or tz 0))]
[else
(raise-type-error 'sql-datetime->srfi-date
"sql-date, sql-time, or sql-timestamp"
datetime)]))
(srfi:make-date nanosecond second minute hour day month year (or tz 0))]))
(define (srfi-date->sql-date date)
(make-sql-date (srfi:date-year date)

28
collects/db/util/postgresql.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require racket/contract/base
racket/string
unstable/error
"geometry.rkt")
#|
@ -41,13 +42,13 @@ polygon = #points:int4 (x y : float8)*
#:transparent
#:guard (lambda (ndim counts lbounds vals _n)
(unless (= (length counts) ndim)
(error 'pg-array
"expected list of ~s integers for dimension-lengths, got: ~e"
ndim counts))
(raise-misc-error 'pg-array "list for dimension lengths has wrong length"
"expected length" ndim
'("got" value) counts))
(unless (= (length lbounds) ndim)
(error 'pg-array
"expected list of ~s integers for dimension-lower-bounds, got: ~e"
ndim lbounds))
(raise-misc-error 'pg-array "list for dimension lower bounds has wrong length"
"expected length" ndim
'("got" value) lbounds))
(let loop ([counts* counts] [vals* vals])
(when (pair? counts*)
(unless (and (vector? vals*)
@ -59,18 +60,19 @@ polygon = #points:int4 (x y : float8)*
(define (pg-array-ref arr . indexes)
(unless (= (pg-array-dimensions arr) (length indexes))
(error 'pg-array-ref "expected ~s indexes, got: ~e" indexes))
(raise-misc-error 'pg-array-ref "wrong number of indexes"
"expected number" (pg-array-dimensions arr)
'("got" value) indexes))
(let* ([counts (pg-array-dimension-lengths arr)]
[lbounds (pg-array-dimension-lower-bounds arr)]
[ubounds (map (lambda (c lb) (+ c lb -1)) counts lbounds)])
(unless (for/and ([index indexes] [lbound lbounds] [ubound ubounds])
(<= lbound index ubound))
(error 'pg-array-ref
"index ~s of of range (~a)"
indexes
(string-join (for/list ([lbound lbounds] [ubound ubounds])
(format "[~a,~a]" lbound ubound))
", ")))
(raise-misc-error 'pg-array-ref "index out of range"
'("index" value) indexes
"valid range" (string-join (for/list ([lbound lbounds] [ubound ubounds])
(format "[~a,~a]" lbound ubound))
", ")))
(let loop ([indexes (map - indexes lbounds)]
[vals (pg-array-contents arr)])
(cond [(pair? indexes)

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

@ -317,7 +317,7 @@
(test-case "error on managed st, unmanaged end"
(with-connection c
(start-transaction c)
(check-exn #rx"ROLLBACK not allowed within managed transaction"
(check-exn #rx"statement not allowed in current transaction state.*statement type: ROLLBACK"
(lambda () (query-exec c "ROLLBACK")))
(check-equal? (in-transaction? c) #t)
;; SQLite-ODBC is unhappy with open tx on disconnect
@ -332,7 +332,7 @@
(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"
(check-exn #rx"statement not allowed in current transaction state.*statement type: ROLLBACK"
(lambda ()
(call-with-transaction c
(lambda () (query-exec c "ROLLBACK")))))
@ -352,7 +352,7 @@
(test-case "error on implicit-commit stmt"
(with-connection c
(start-transaction c)
(check-exn #rx"statement with implicit commit not allowed"
(check-exn #rx"statement not allowed.*statement type: statement with implicit commit"
(lambda () (query-exec c "create table foo (n integer)")))
;; SQLite-ODBC is unhappy with open tx on disconnect
(rollback-transaction c))))