/cl-postgres/errors.lisp
Lisp | 184 lines | 163 code | 13 blank | 8 comment | 3 complexity | 08c7034d299932648172d2ef6f9d8758 MD5 | raw file
- ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES; -*-
- (in-package :cl-postgres)
- (defparameter *current-query* nil)
- (defparameter *query-log* nil)
- (defparameter *query-callback* 'log-query)
- (defun log-query (query time-units)
- (when *query-log*
- (format *query-log* "CL-POSTGRES query (~ams): ~a~%"
- (round (/ (* 1000 time-units)
- internal-time-units-per-second))
- query)))
- (defmacro with-query ((query) &body body)
- (let ((time-name (gensym)))
- `(let ((*current-query* ,query)
- (,time-name (if *query-callback* (get-internal-real-time) 0)))
- (multiple-value-prog1 (progn ,@body)
- (when *query-callback*
- (funcall *query-callback*
- *current-query*
- (- (get-internal-real-time) ,time-name)))))))
- ;;
- ;; See http://www.postgresql.org/docs/current/protocol-error-fields.html
- ;; and https://www.postgresql.org/docs/current/errcodes-appendix.html
- ;; for details, including documentation strings.
- ;;
- (define-condition database-error (error)
- ((error-code :initarg :code :initform nil :reader database-error-code
- :documentation "Code: the SQLSTATE code for the error (see Appendix A). Not localizable. Always present.")
- (message :initarg :message :accessor database-error-message
- :documentation "Message: the primary human-readable error message. This should be accurate but terse (typically one line). Always present.")
- (detail :initarg :detail :initform nil :reader database-error-detail
- :documentation "Detail: an optional secondary error message carrying more detail about the problem. Might run to multiple lines.")
- (hint :initarg :hint :initform nil :reader database-error-hint
- :documentation "Hint: an optional suggestion what to do about the problem.")
- (context :initarg :context :initform nil :reader database-error-context
- :documentation "Where: an indication of the context in which the error occurred. Presently this includes a call stack traceback of active procedural language functions and internally-generated queries. The trace is one entry per line, most recent first."
- )
- (query :initform *current-query* :reader database-error-query
- :documentation "Query that led to the error, if any.")
- (position :initarg :position :initform nil :reader database-error-position
- :documentation "Position: the field value is a decimal ASCII integer, indicating an error cursor position as an index into the original query string. The first character has index 1, and positions are measured in characters not bytes.")
- (cause :initarg :cause :initform nil :reader database-error-cause))
- (:report (lambda (err stream)
- (format stream "Database error~@[ ~A~]: ~A~@[~&DETAIL: ~A~]~@[~&HINT: ~A~]~@[~&CONTEXT: ~A~]~@[~&QUERY: ~A~]~@[~VT^~]"
- (database-error-code err)
- (database-error-message err)
- (database-error-detail err)
- (database-error-hint err)
- (database-error-context err)
- (database-error-query err)
- (database-error-position err))))
- (:documentation "This is the condition type that will be used to
- signal virtually all database-related errors \(though in some cases
- socket errors may be raised when a connection fails on the IP
- level)."))
- (defun database-error-constraint-name (err)
- "Given a database-error for an integrity violation, will attempt to
- extract the constraint name."
- (labels ((extract-quoted-part (string n)
- "Extracts the Nth quoted substring from STRING."
- (let* ((start-quote-inst (* 2 n))
- (start-quote-pos (position-nth #\" string start-quote-inst))
- (end-quote-pos (position #\" string :start (1+ start-quote-pos))))
- (subseq string (1+ start-quote-pos) end-quote-pos)))
- (position-nth (item seq n)
- "Finds the position of the zero-indexed Nth ITEM in SEQ."
- (loop :with pos = -1 :repeat (1+ n)
- :do (setf pos (position item seq :start (1+ pos)))
- :finally (return pos))))
- (let ((message (database-error-message err)))
- (typecase err
- (cl-postgres-error:not-null-violation (extract-quoted-part message 0))
- (cl-postgres-error:unique-violation (extract-quoted-part message 0))
- (cl-postgres-error:foreign-key-violation (extract-quoted-part message 1))
- (cl-postgres-error:check-violation (extract-quoted-part message 1))))))
- (defun database-error-extract-name (err)
- "Given a database-error, will extract the critical name from the error message."
- (labels ((extract-quoted-part (string n)
- "Extracts the Nth quoted substring from STRING."
- (let* ((start-quote-inst (* 2 n))
- (start-quote-pos (position-nth #\" string start-quote-inst))
- (end-quote-pos (position #\" string :start (1+ start-quote-pos))))
- (subseq string (1+ start-quote-pos) end-quote-pos)))
- (position-nth (item seq n)
- "Finds the position of the zero-indexed Nth ITEM in SEQ."
- (loop :with pos = -1 :repeat (1+ n)
- :do (setf pos (position item seq :start (1+ pos)))
- :finally (return pos))))
- (let* ((message (database-error-message err)))
- (typecase err
- (cl-postgres-error:invalid-sql-statement-name
- (extract-quoted-part message 0))
- (cl-postgres-error:duplicate-prepared-statement
- (extract-quoted-part message 0))))))
- (define-condition database-connection-error (database-error) ()
- (:documentation "Conditions of this type are signalled when an error
- occurs that breaks the connection socket. They offer a :reconnect
- restart."))
- (define-condition database-connection-lost (database-connection-error) ()
- (:documentation "Raised when a query is initiated on a disconnected
- connection object."))
- (define-condition database-socket-error (database-connection-error) ()
- (:documentation "Used to wrap stream-errors and socket-errors,
- giving them a database-connection-error superclass."))
- (defun wrap-socket-error (err)
- (make-instance 'database-socket-error
- :message (princ-to-string err)
- :cause err))
- (in-package :cl-postgres-error)
- (defparameter *error-table* (make-hash-table :test 'equal))
- (defmacro deferror (code typename &optional (superclass 'database-error))
- `(progn (define-condition ,typename (,superclass) ())
- (setf (gethash ,code *error-table*) ',typename)))
- ;; Connection Exceptions
- ;; https://www.postgresql.org/docs/current/errcodes-appendix.html
- (deferror "08000" connection-exception)
- (deferror "08003" connection-does-not-exist)
- (deferror "08006" connection-failure)
- (deferror "08001" sqlclient-unable-to-establish-sqlconnection)
- (deferror "08004" sqlserver-rejected-establishment-of-sqlconnection)
- (deferror "08007" transaction-resolution-unknown)
- (deferror "08P01" protocol-violation)
- (deferror "0A" feature-not-supported)
- (deferror "22" data-exception)
- (deferror "22012" db-division-by-zero data-exception)
- (deferror "22007" invalid-datetime-format data-exception)
- (deferror "22003" numeric-value-out-of-range data-exception)
- (deferror "22P01" floating-point-exception data-exception)
- (deferror "23" integrity-violation)
- (deferror "23001" restrict-violation integrity-violation)
- (deferror "23502" not-null-violation integrity-violation)
- (deferror "23503" foreign-key-violation integrity-violation)
- (deferror "23505" unique-violation integrity-violation)
- (deferror "23514" check-violation integrity-violation)
- (deferror "26000" invalid-sql-statement-name)
- (deferror "42" syntax-error-or-access-violation)
- (deferror "42501" insufficient-privilege syntax-error-or-access-violation)
- (deferror "40" transaction-rollback)
- (deferror "40001" serialization-failure transaction-rollback)
- (deferror "40002" transaction-integrity-constraint-violation transaction-rollback)
- (deferror "40003" statement-completion-unknown transaction-rollback)
- (deferror "40P01" deadlock-detected transaction-rollback)
- (deferror "42P01" undefined-table syntax-error-or-access-violation)
- (deferror "42601" columns-error syntax-error-or-access-violation)
- (deferror "42703" undefined-column syntax-error-or-access-violation)
- (deferror "42701" duplicate-column syntax-error-or-access-violation)
- (deferror "42P03" duplicate-cursor syntax-error-or-access-violation)
- (deferror "42P04" duplicate-database syntax-error-or-access-violation)
- (deferror "42723" duplicate-function syntax-error-or-access-violation)
- (deferror "42P05" duplicate-prepared-statement syntax-error-or-access-violation)
- (deferror "42P06" duplicate-schema syntax-error-or-access-violation)
- (deferror "42P07" duplicate-table syntax-error-or-access-violation)
- (deferror "42712" duplicate-alias syntax-error-or-access-violation)
- (deferror "42710" duplicate-object syntax-error-or-access-violation)
- (deferror "53" insufficient-resources)
- (deferror "54" program-limit-exceeded)
- (deferror "55" object-state-error)
- (deferror "55006" object-in-use object-state-error)
- (deferror "55P03" lock-not-available object-state-error)
- (deferror "57" operator-intervention)
- (deferror "57014" query-canceled operator-intervention)
- (define-condition server-shutdown (operator-intervention database-connection-error) ())
- (deferror "57P01" admin-shutdown server-shutdown)
- (deferror "57P02" crash-shutdown server-shutdown)
- (deferror "57P03" cannot-connect-now operator-intervention)
- (deferror "58" system-error)
- (deferror "XX" internal-error)
- (defun get-error-type (code)
- (or (gethash code *error-table*)
- (and code (gethash (subseq code 0 2) *error-table*))
- 'database-error))