cl-postgres/errors.lisp

   1 (in-package :cl-postgres)
   2
   3 (defparameter *current-query* nil)
   4 (defparameter *query-log* nil)
   5 (defparameter *query-callback* 'log-query)
   6
   7 (defun log-query (query time-units)
   8   (when *query-log*
   9     (format *query-log* "CL-POSTGRES query (~ams): ~a~%"
  10             (round (/ (* 1000 time-units)
  11                       internal-time-units-per-second))
  12             query)))
  13
  14 (defmacro with-query ((query) &body body)
  15   (let ((time-name (gensym)))
  16     `(let ((*current-query* ,query)
  17            (,time-name (if *query-callback* (get-internal-real-time) 0)))
  18        (multiple-value-prog1 (progn ,@body)
  19          (when *query-callback*
  20            (funcall *query-callback*
  21                     *current-query*
  22                     (- (get-internal-real-time) ,time-name)))))))
  23
  24 ;;
  25 ;; See http://www.postgresql.org/docs/9.3/static/protocol-error-fields.html
  26 ;; for details, including documentation strings.
  27 ;;
  28 (define-condition database-error (error)
  29   ((error-code :initarg :code :initform nil :reader database-error-code
  30                :documentation "Code: the SQLSTATE code for the error (see Appendix A). Not localizable. Always present.")
  31    (message :initarg :message :accessor database-error-message
  32             :documentation "Message: the primary human-readable error message. This should be accurate but terse (typically one line). Always present.")
  33    (detail :initarg :detail :initform nil :reader database-error-detail
  34            :documentation "Detail: an optional secondary error message carrying more detail about the problem. Might run to multiple lines.")
  35    (hint :initarg :hint :initform nil :reader database-error-hint
  36          :documentation "Hint: an optional suggestion what to do about the problem.")
  37    (context :initarg :context :initform nil :reader database-error-context
  38             :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."
  39 )
  40    (query :initform *current-query* :reader database-error-query
  41           :documentation "Query that led to the error, if any.")
  42    (position :initarg :position :initform nil :reader database-error-position
  43              :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.")
  44    (cause :initarg :cause :initform nil :reader database-error-cause))
  45   (:report (lambda (err stream)
  46              (format stream "Database error~@[ ~A~]: ~A~@[~&DETAIL: ~A~]~@[~&HINT: ~A~]~@[~&CONTEXT: ~A~]~@[~&QUERY: ~A~]~@[~VT^~]"
  47                      (database-error-code err)
  48                      (database-error-message err)
  49                      (database-error-detail err)
  50                      (database-error-hint err)
  51                      (database-error-context err)
  52                      (database-error-query err)
  53                      (database-error-position err))))
  54   (:documentation "This is the condition type that will be used to
  55 signal virtually all database-related errors \(though in some cases
  56 socket errors may be raised when a connection fails on the IP
  57 level)."))
  58
  59 (defun database-error-constraint-name (err)
  60   "Given a database-error for an integrity violation, will attempt to
  61 extract the constraint name."
  62   (labels ((extract-quoted-part (string n)
  63              "Extracts the Nth quoted substring from STRING."
  64              (let* ((start-quote-inst (* 2 n))
  65                     (start-quote-pos (position-nth #\" string start-quote-inst))
  66                     (end-quote-pos (position #\" string :start (1+ start-quote-pos))))
  67                (subseq string (1+ start-quote-pos) end-quote-pos)))
  68            (position-nth (item seq n)
  69              "Finds the position of the zero-indexed Nth ITEM in SEQ."
  70              (loop :with pos = -1 :repeat (1+ n)
  71                    :do (setf pos (position item seq :start (1+ pos)))
  72                    :finally (return pos))))
  73     (let ((message (database-error-message err)))
  74       (typecase err
  75         (cl-postgres-error:not-null-violation (extract-quoted-part message 0))
  76         (cl-postgres-error:unique-violation (extract-quoted-part message 0))
  77         (cl-postgres-error:foreign-key-violation (extract-quoted-part message 1))
  78         (cl-postgres-error:check-violation (extract-quoted-part message 1))))))
  79
  80 (define-condition database-connection-error (database-error) ()
  81   (:documentation "Conditions of this type are signalled when an error
  82 occurs that breaks the connection socket. They offer a :reconnect
  83 restart."))
  84 (define-condition database-connection-lost (database-connection-error) ()
  85   (:documentation "Raised when a query is initiated on a disconnected
  86 connection object."))
  87 (define-condition database-socket-error (database-connection-error) ()
  88   (:documentation "Used to wrap stream-errors and socket-errors,
  89 giving them a database-connection-error superclass."))
  90
  91 (defun wrap-socket-error (err)
  92   (make-instance 'database-socket-error
  93                  :message (princ-to-string err)
  94                  :cause err))
  95
  96 (in-package :cl-postgres-error)
  97
  98 (defparameter *error-table* (make-hash-table :test 'equal))
  99 (defmacro deferror (code typename &optional (superclass 'database-error))
 100   `(progn (define-condition ,typename (,superclass) ())
 101           (setf (gethash ,code *error-table*) ',typename)))
 102
 103 (deferror "0A" feature-not-supported)
 104 (deferror "22" data-exception)
 105 (deferror "22012" db-division-by-zero data-exception)
 106 (deferror "22007" invalid-datetime-format data-exception)
 107 (deferror "22003" numeric-value-out-of-range data-exception)
 108 (deferror "22P01" floating-point-exception data-exception)
 109 (deferror "23" integrity-violation)
 110 (deferror "23001" restrict-violation integrity-violation)
 111 (deferror "23502" not-null-violation integrity-violation)
 112 (deferror "23503" foreign-key-violation integrity-violation)
 113 (deferror "23505" unique-violation integrity-violation)
 114 (deferror "23514" check-violation integrity-violation)
 115 (deferror "42" syntax-error-or-access-violation)
 116 (deferror "42501" insufficient-privilege syntax-error-or-access-violation)
 117 (deferror "40" transaction-rollback)
 118 (deferror "40001" serialization-failure transaction-rollback)
 119 (deferror "40002" transaction-integrity-constraint-violation transaction-rollback)
 120 (deferror "40003" statement-completion-unknown transaction-rollback)
 121 (deferror "40P01" deadlock-detected transaction-rollback)
 122 (deferror "53" insufficient-resources)
 123 (deferror "54" program-limit-exceeded)
 124 (deferror "55" object-state-error)
 125 (deferror "55006" object-in-use object-state-error)
 126 (deferror "55P03" lock-not-available object-state-error)
 127 (deferror "57" operator-intervention)
 128 (deferror "57014" query-canceled operator-intervention)
 129 (define-condition server-shutdown (operator-intervention database-connection-error) ())
 130 (deferror "57P01" admin-shutdown server-shutdown)
 131 (deferror "57P02" crash-shutdown server-shutdown)
 132 (deferror "57P03" cannot-connect-now operator-intervention)
 133 (deferror "58" system-error)
 134 (deferror "XX" internal-error)
 135
 136 (defun get-error-type (code)
 137   (or (gethash code *error-table*)
 138       (and code (gethash (subseq code 0 2) *error-table*))
 139       'database-error))