From 7c395e9c7cfb883374f2651b9d5d67153756facb Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 22 Aug 2012 09:19:36 -0400 Subject: [PATCH] db: updated to new error convention (mostly) --- collects/db/private/generic/common.rkt | 25 ++- collects/db/private/generic/connect-util.rkt | 8 +- collects/db/private/generic/functions.rkt | 66 ++++---- collects/db/private/generic/interfaces.rkt | 144 ++++++++++++++---- collects/db/private/generic/prepared.rkt | 12 +- collects/db/private/generic/socket.rkt | 6 +- collects/db/private/generic/sql-convert.rkt | 7 +- collects/db/private/generic/sql-data.rkt | 6 +- collects/db/private/mysql/connection.rkt | 16 +- collects/db/private/mysql/main.rkt | 2 +- collects/db/private/mysql/message.rkt | 23 +-- collects/db/private/odbc/connection.rkt | 19 ++- collects/db/private/postgresql/connection.rkt | 28 ++-- collects/db/private/postgresql/dbsystem.rkt | 2 +- collects/db/private/postgresql/main.rkt | 2 +- collects/db/private/postgresql/message.rkt | 16 +- collects/db/private/sqlite3/connection.rkt | 14 +- collects/db/scribblings/example-log.rktd | 15 +- collects/db/util/datetime.rkt | 6 +- collects/db/util/postgresql.rkt | 28 ++-- collects/tests/db/db/query.rkt | 6 +- 21 files changed, 268 insertions(+), 183 deletions(-) diff --git a/collects/db/private/generic/common.rkt b/collects/db/private/generic/common.rkt index ae4a625327..5775ca7b6a 100644 --- a/collects/db/private/generic/common.rkt +++ b/collects/db/private/generic/common.rkt @@ -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))) diff --git a/collects/db/private/generic/connect-util.rkt b/collects/db/private/generic/connect-util.rkt index 660213c22a..f9212d35e0 100644 --- a/collects/db/private/generic/connect-util.rkt +++ b/collects/db/private/generic/connect-util.rkt @@ -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)) diff --git a/collects/db/private/generic/functions.rkt b/collects/db/private/generic/functions.rkt index 9e0c50d65b..46cba5c88e 100644 --- a/collects/db/private/generic/functions.rkt +++ b/collects/db/private/generic/functions.rkt @@ -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 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)) diff --git a/collects/db/private/generic/prepared.rkt b/collects/db/private/generic/prepared.rkt index e8edc47f33..6a8519cf87 100644 --- a/collects/db/private/generic/prepared.rkt +++ b/collects/db/private/generic/prepared.rkt @@ -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)]) diff --git a/collects/db/private/generic/socket.rkt b/collects/db/private/generic/socket.rkt index 2745bdc4e8..7ac4988991 100644 --- a/collects/db/private/generic/socket.rkt +++ b/collects/db/private/generic/socket.rkt @@ -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 diff --git a/collects/db/private/generic/sql-convert.rkt b/collects/db/private/generic/sql-convert.rkt index 897a7e1742..0953b8b993 100644 --- a/collects/db/private/generic/sql-convert.rkt +++ b/collects/db/private/generic/sql-convert.rkt @@ -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)) diff --git a/collects/db/private/generic/sql-data.rkt b/collects/db/private/generic/sql-data.rkt index 732972fd64..569a5bcfdd 100644 --- a/collects/db/private/generic/sql-data.rkt +++ b/collects/db/private/generic/sql-data.rkt @@ -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) diff --git a/collects/db/private/mysql/connection.rkt b/collects/db/private/mysql/connection.rkt index 060e1057ce..1f0acb48a3 100644 --- a/collects/db/private/mysql/connection.rkt +++ b/collects/db/private/mysql/connection.rkt @@ -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) diff --git a/collects/db/private/mysql/main.rkt b/collects/db/private/mysql/main.rkt index b3b936cb4d..b70ba1ac8f 100644 --- a/collects/db/private/mysql/main.rkt +++ b/collects/db/private/mysql/main.rkt @@ -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)])] diff --git a/collects/db/private/mysql/message.rkt b/collects/db/private/mysql/message.rkt index 3db25afe55..99ec802501 100644 --- a/collects/db/private/mysql/message.rkt +++ b/collects/db/private/mysql/message.rkt @@ -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) diff --git a/collects/db/private/odbc/connection.rkt b/collects/db/private/odbc/connection.rkt index 50d1bf46b6..a607f18bf5 100644 --- a/collects/db/private/odbc/connection.rkt +++ b/collects/db/private/odbc/connection.rkt @@ -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 diff --git a/collects/db/private/postgresql/connection.rkt b/collects/db/private/postgresql/connection.rkt index 80cad09c0b..83b4c2eab0 100644 --- a/collects/db/private/postgresql/connection.rkt +++ b/collects/db/private/postgresql/connection.rkt @@ -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 diff --git a/collects/db/private/postgresql/dbsystem.rkt b/collects/db/private/postgresql/dbsystem.rkt index 3953254f17..e26ad1c714 100644 --- a/collects/db/private/postgresql/dbsystem.rkt +++ b/collects/db/private/postgresql/dbsystem.rkt @@ -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))) diff --git a/collects/db/private/postgresql/main.rkt b/collects/db/private/postgresql/main.rkt index ef57a353ba..9a986f8686 100644 --- a/collects/db/private/postgresql/main.rkt +++ b/collects/db/private/postgresql/main.rkt @@ -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) diff --git a/collects/db/private/postgresql/message.rkt b/collects/db/private/postgresql/message.rkt index 744dc7628a..e644a76909 100644 --- a/collects/db/private/postgresql/message.rkt +++ b/collects/db/private/postgresql/message.rkt @@ -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 diff --git a/collects/db/private/sqlite3/connection.rkt b/collects/db/private/sqlite3/connection.rkt index c09861b053..5a716249cc 100644 --- a/collects/db/private/sqlite3/connection.rkt +++ b/collects/db/private/sqlite3/connection.rkt @@ -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"] diff --git a/collects/db/scribblings/example-log.rktd b/collects/db/scribblings/example-log.rktd index 81824e02ba..905c977c34 100644 --- a/collects/db/scribblings/example-log.rktd +++ b/collects/db/scribblings/example-log.rktd @@ -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): #")) + "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") diff --git a/collects/db/util/datetime.rkt b/collects/db/util/datetime.rkt index 961fbdcb4f..8b621f8f77 100644 --- a/collects/db/util/datetime.rkt +++ b/collects/db/util/datetime.rkt @@ -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) diff --git a/collects/db/util/postgresql.rkt b/collects/db/util/postgresql.rkt index db4e783fda..dae5765f0e 100644 --- a/collects/db/util/postgresql.rkt +++ b/collects/db/util/postgresql.rkt @@ -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) diff --git a/collects/tests/db/db/query.rkt b/collects/tests/db/db/query.rkt index 407c60cb1d..1d7c04e16a 100644 --- a/collects/tests/db/db/query.rkt +++ b/collects/tests/db/db/query.rkt @@ -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))))