;;; v3-protocol.lisp -- frontend/backend protocol from PostgreSQL v7.4
;;;
;;; Author: Peter Van Eynde <pvaneynd@debian.org>

(in-package :postgresql)

(defclass pgcon-v3 (pgcon)
  ((parameters  :accessor pgcon-parameters
                :initform (list))
   (encoding    :accessor pgcon-encoding
                :initform nil)
   (sql-stream  :initform nil
		:accessor pgcon-sql-stream
		:type (or null stream))))


(define-condition error-response (postgresql-error)
  ((severity :initarg :severity
             :reader error-response-severity)
  (code     :initarg :code
             :reader error-response-code)
  (message     :initarg :message
                :reader error-response-message)
  (detail     :initarg :detail
               :reader error-response-detail)
  (hint     :initarg :hint
             :reader error-response-hint)
  (position     :initarg :position
                 :reader error-response-position)
  (where     :initarg :where
              :reader error-response-where)
  (file     :initarg :file
             :reader error-response-file)
  (line     :initarg :line
             :reader error-response-line)
  (routine     :initarg :routine
                :reader error-response-routine))
  (:report
    (lambda (exc stream)
       (format stream "PostgreSQL ~A: (~A) ~A, ~A. Hint: ~A File: ~A, line ~A/~A ~A -> ~A"
               (ignore-errors
                   (error-response-severity exc))
               (ignore-errors
                   (error-response-code exc))
               (ignore-errors
                   (error-response-message exc))
               (ignore-errors
                   (error-response-detail exc))
               (ignore-errors
                   (error-response-hint exc))
               (ignore-errors
                   (error-response-file exc))
               (ignore-errors
                   (error-response-line exc))
               (ignore-errors
                   (error-response-position exc))
               (ignore-errors
                   (error-response-routine exc))
               (ignore-errors
                   (error-response-where exc))))))


;; packets send/received are always:
;;
;; - a byte indicating a character code
;; - 4 bytes -> an integer  giving the length
;;     of the packet
;; - data
;;
;; So we create specialized data structures for this

(defclass pg-packet ()
  ((type :initarg :type
         :type base-char
         :reader pg-packet-type)
   (length :initarg :length
           :type (unsigned-byte 32)
	   :reader pg-packet-length)
   (data :initarg :data
         :type (array (unsigned-byte 8) *))
   (position :initform 0
             :type integer)
   (connection  :initarg :connection
                :type pgcon-v3)))

(defmethod print-object ((object pg-packet) stream)
    (print-unreadable-object (object stream :type t :identity t)
      (format stream "type: ~A length: ~A position: ~A"
              (and (slot-boundp object 'type)
                   (slot-value object 'type))
              (and (slot-boundp object 'length)
                   (slot-value object 'length))
              (and (slot-boundp object 'position)
                   (slot-value object 'position)))))


;; the error and notice functions:

;; FIXME remove the duplication between this an HANDLE-NOTIFICATION/V3 at end of file

(defun read-and-generate-error-response (packet)
  (let ((args nil))
    (loop :for field-type = (read-from-packet packet :byte)
          :until (= field-type 0)
          :do
          (let ((message (read-from-packet packet :cstring)))
            (push message args)
            (push
             (ecase (code-char field-type)
               ((#\S) :severity)
               ((#\C) :code)
               ((#\M) :message)
               ((#\D) :detail)
               ((#\H) :hint)
               ((#\P) :position)
               ((#\W) :where)
               ((#\F) :file)
               ((#\L) :line)
               ((#\R) :routine))
             args)))
    ;; we are trying to recover from errors too:
    (apply #'cerror
           "Try to continue, should do a rollback"
           'error-response
           args)))


(defun read-and-handle-notification-response (connection packet)
  (declare (type pg-packet packet)
           (type pgcon-v3 connection))

  (let* ((pid (read-from-packet packet :int32))
         (name-condition (read-from-packet packet :cstring))
         (additional-information (read-from-packet packet :cstring)))
    (setf (pgcon-pid connection) pid)
    (format t "~&Got notice: ~S, ~S"
            name-condition
            additional-information)
    (push name-condition (pgcon-notices connection))))



;; the main function

(defun read-packet (connection)
  "Reads a packet from the connection.
Returns the packet, handles errors and notices automagically,
but will still return them"
  (let* ((stream (pgcon-stream connection))
         (type   (%read-net-int8 stream))
         (length (%read-net-int32 stream)))
    ;; detect a bogus protocol response from the backend, which
    ;; probably means that we're in PG-CONNECT/V3 but talking to an
    ;; old backend that only understands the V2 protocol. Heuristics
    ;; for this detection are the same as in libpq, file fe-connect.c
    (when (eql (char-code #\E) type)
      (unless (< 8 length 30000)
        (close stream)
        (error 'protocol-error
               :reason "Probable old PostgreSQL backend")))

    (let* ((data   (%read-bytes stream (- length 4)))
           (packet (make-instance 'pg-packet
                                  :type (code-char type)
                                  :length length
                                  :data data
                                  :connection connection)))
      (case (pg-packet-type packet)
        (( #\E)                                ; error
         (read-and-generate-error-response packet)
         packet)
        (( #\N)                                ; Notice
         (handle-notice/v3 connection packet)
         packet)
        (t
         ;; return the packet
         packet)))))

;; Not to get at the data:

(defgeneric read-from-packet (packet type)
  (:documentation
   "Reads an integer from the given PACKET with type TYPE")
  (:method ((packet pg-packet) (type (eql :char)))
    (with-slots (data position)
        packet

      (prog1
          (elt data position)
        (incf position))))
  (:method ((packet pg-packet) (type (eql :byte)))
    (with-slots (data position)
        packet

      (let ((result (elt data position)))
        (incf position)
        (when (= 1 (ldb (byte 1 7) result))
          ;; negative
          (setf result (-
                        (1+ (logxor result
                                    #xFF)))))
        result)))
  (:method ((packet pg-packet) (type (eql :int16)))
    (with-slots (data position)
        packet

      (let ((result (+ (* 256 (elt data position))
                       (elt data (1+ position)))))
        (incf position 2)
        (when (= 1 (ldb (byte 1 15) result))
          ;; negative
          (setf result (-
                        (1+ (logxor result
                                    #xFFFF)))))
        result)))
  (:method ((packet pg-packet) (type (eql :int32)))
    (with-slots (data position)
        packet

      (let ((result (+ (* 256 256 256 (elt data position))
                       (* 256 256 (elt data (1+ position)))
                       (* 256 (elt data (+ 2 position)))
                       (elt data (+ 3 position)))))

        (incf position 4)
        (when (= 1 (ldb (byte 1 31) result))
          ;; negative
          (setf result (-
                        (1+ (logxor result
                                    #xFFFFFFFF)))))
        result)))

  ;; a string that does not get encoded
  (:method ((packet pg-packet) (type (eql :ucstring)))
    (with-slots (data position) packet
      (let* ((end (position 0 data :start position))
             (result (unless (eql end position)
                       (make-array (- end position)
                                   :element-type 'base-char))))
        (when result
          (loop :for i :from position :below end
                :for j :from 0
                :do
                (setf (elt result j)
                      (code-char
                       (elt data i))))
          (setf position (1+ end))
          result))))

  ;; a string that does get encoded, if the current connection has set
  ;; its prefered encoding
  (:method ((packet pg-packet) (type (eql :cstring)))
    (with-slots (data position connection) packet
      (cond ((pgcon-encoding connection)
             (let* ((end (position 0 data :start position))
                    (result (unless (eql end position)
                              (convert-string-from-bytes (subseq data position end)))))
               (when result (setf position (1+ end)))
               result))
            ;; the encoding has not yet been set, so revert to :ucstring behaviour
            (t
             (read-from-packet packet :ucstring))))))


;; FIXME need to check all callers of this function to distinguish
;; between uses that expect charset encoding to be handled, and those
;; that really want READ-OCTET-ARRAY-FROM-PACKET
(defgeneric read-string-from-packet (packet length)
  (:documentation
   "Reads a string of LENGTH characters from the packet")
  (:method ((packet pg-packet) (length (eql -1)))
    nil)
  (:method ((packet pg-packet) (length (eql 0)))
    nil)
  (:method ((packet pg-packet) (length integer))
    (when (< length 0)
      (error "length cannot be negative. is: ~S"
             length))
    (let ((result (make-array length
                              :element-type 'base-char)))
      (with-slots (data position)
          packet
        (loop :for i :from 0 :below length
              :do
              (setf (elt result i)
                    (code-char
                     (the (unsigned-byte 8)
                       (elt data (+ i position))))))
        (incf position length)
        result))))

(defmethod read-octets-from-packet ((packet pg-packet) (length integer))
  (let ((result (make-array length :element-type '(unsigned-byte 8))))
    (with-slots (data position) packet
      (replace result data :start2 position :end2 (+ position length))
      (incf position length)
      result)))
  


(defun send-packet (connection code description)
  "Sends a packet to the connection. CODE is the
character code of the packet, description is a list
of items with as first element one of :byte, :char
:int16 :int32 or :cstring and as second element the
value of the parameter"
  (declare (type base-char code))

  (let* ((length (+ 4
                    (loop for (type value) in description
                          sum (ecase type
                                ((:byte :char) 1)
                                ((:int16) 2)
                                ((:int32) 4)
                                ((:rawdata) (length value))
                                ((:cstring) (1+ (length (convert-string-to-bytes value))))
                                ((:ucstring) (1+ (length value)))))))
         (data (make-array (- length 4)
                           :element-type '(unsigned-byte 8)))
         (stream (pgcon-stream connection)))

    (loop for (type value) in description
          with position = 0
          do
          (ecase type
            ((:byte)
             (check-type value (unsigned-byte 8))
             (setf (elt data position) value)
             (incf position))
            ((:char)
             (check-type value base-char)
             (setf (elt data position) (char-code value))
             (incf position))
            ((:int16)
             (check-type value (unsigned-byte 16))
             (setf (elt data position) (ldb (byte 8 8) value))
             (setf (elt data (+ 1 position)) (ldb (byte 8 0) value))
             (incf position 2))
            ((:int32)
             (check-type value (unsigned-byte 32))

             (setf (elt data position) (ldb (byte 8 24) value))
             (setf (elt data (+ 1 position)) (ldb (byte 8 16) value))
             (setf (elt data (+ 2 position)) (ldb (byte 8 8) value))
             (setf (elt data (+ 3 position)) (ldb (byte 8 0) value))
             (incf position 4))

            ((:ucstring)
             (check-type value string)
             (loop for char across value
                   do
                   (setf (elt data position)
                         (char-code char))
                   (incf position))
             (setf (elt data position) 0)
             (incf position))

            ((:cstring)
             (check-type value string)
             (let ((encoded (convert-string-to-bytes value)))
               (replace data encoded :start1 position)
               (incf position (length encoded)))
             (setf (elt data position) 0)
             (incf position))

	    ((:rawdata)
             (check-type value (array (unsigned-byte 8) *))
	     (replace data value :start1 position)
	     (incf position (length value)))))

    (%send-net-int stream (char-code code) 1)
    (%send-net-int stream length 4 )
    (write-sequence data stream)))


(defun pg-connect/v3 (dbname user &key (host "localhost") (port 5432) (password ""))
  "Initiate a connection with the PostgreSQL backend.
Connect to the database DBNAME with the username USER,
on PORT of HOST, providing PASSWORD if necessary. Return a
connection to the database (as an opaque type). If HOST is nil, attempt
to connect to the database using a Unix socket."
  (let* ((stream (socket-connect port host))
         (connection (make-instance 'pgcon-v3 :stream stream :host host :port port))
         (user-packet-length (+ 4 ; length
                                4 ; protocol version
                                (length "user")
                                1
                                (length user)
                                1
                                (length "database")
                                1
                                (length dbname)
                                1
                                1)))
    ;; send the startup packet
    ;; this is one of the only non-standard packets!
    (%send-net-int stream user-packet-length 4)
    (%send-net-int stream 3 2)          ; major
    (%send-net-int stream 0 2)          ; minor
    (%send-cstring stream "user")
    (%send-cstring stream user)
    (%send-cstring stream "database")
    (%send-cstring stream dbname)
    (%send-net-int stream 0 1)
    (%flush connection)

    (loop
     :for packet = (read-packet connection)
     :do
     (case (pg-packet-type packet)
       ((#\R)
        ;; Authentication Request:
        (let* ((code (read-from-packet packet :int32)))
          (case code
            ((0)                        ;; AuthOK
             )
            ((1)                          ; AuthKerberos4
             (error 'authentication-failure
                    :reason "Kerberos4 authentication not supported"))
            ((2)                          ; AuthKerberos5
             (error 'authentication-failure
                    :reason "Kerberos5 authentication not supported"))
            ((3)                          ; AuthUnencryptedPassword
             (send-packet connection #\p `((:ucstring ,password)))
             (%flush connection))
            ((4)                          ; AuthEncryptedPassword
             (let* ((salt (read-string-from-packet packet 2))
                    (crypted (crypt password salt)))
               #+debug
               (format *debug-io* "CryptAuth: Got salt of ~s~%" salt)
               (send-packet connection #\p `((:ucstring ,crypted)))
               (%flush connection)))
            ((5)                          ; AuthMD5Password
             #+debug
             (format *debug-io* "MD5Auth: got salt of ~s~%" salt)
             (force-output *debug-io*)
             (let* ((salt (read-string-from-packet packet 4))
                    (ciphered (md5-encode-password user password salt)))
               (send-packet connection #\p `((:ucstring ,ciphered)))
               (%flush connection)))
            ((6)                          ; AuthSCMPassword
             (error 'authentication-failure
                    :reason "SCM authentication not supported"))
            (t (error 'authentication-failure
                      :reason "unknown authentication type")))))
       (( #\K)
        ;; Cancelation
        (let* ((pid  (read-from-packet packet :int32))
               (secret (read-from-packet packet :int32)))
          #+debug
          (format t "~&Got cancelation data")

          (setf (pgcon-pid connection) pid)
          (setf (pgcon-secret connection) secret)))
       (( #\S)
        ;; Status
        (let* ((parameter (read-from-packet packet :ucstring))
               (value (read-from-packet packet :ucstring)))
          (push (cons parameter value) (pgcon-parameters connection))))
       ((#\Z)
        ;; Ready for Query
        (let* ((status (read-from-packet packet :byte)))
          (unless (= status
                     (char-code #\I))
            (warn "~&Got status ~S but wanted I~%"
                  (code-char status)))
          
          (when *pg-client-encoding*
            (setf (pg-client-encoding connection) *pg-client-encoding*))
          (and (not *pg-disable-type-coercion*)
               (null *parsers*)
               (initialize-parsers connection))
          (when *pg-date-style*
            (setf (pg-date-style connection) *pg-date-style*))
          (return connection)))
       ((#\E)
        ;; an error, we should abort.
        (return nil))
       ((#\N)
        ;; We ignore Notices
        t)
       (t (error 'protocol-error
                 :reason "expected an authentication response"))))))


(defun do-followup-query (connection)
  "Does the followup of a query"

  (let ((tuples '())
        (attributes '())
        (result (make-pgresult :connection connection)))

    (%flush connection)

    (loop
     :for packet = (read-packet connection)
     :with got-data-p = nil
     :with receive-data-p = nil
     :do
     (when packet
       (case (pg-packet-type packet)
         ((#\S)
          ;; Parameter status? not documented as return!
          ;; XXX investigate
          (let* ((parameter (read-from-packet packet :cstring))
                 (value (read-from-packet packet :cstring)))
            (push (cons parameter value) (pgcon-parameters connection))))
         ((#\A)
          ;; NotificationResponse
          ;; Not documented?
          ;; XXX investigate
          (read-and-handle-notification-response connection packet))
         ((#\C)
          ;; CommandComplete
          (let ((status (read-from-packet packet :cstring)))
            (setf (pgresult-status result) status)
            (setf (pgresult-tuples result) (nreverse tuples))
            (setf (pgresult-attributes result) attributes))
          (setf got-data-p t))
         ((#\G)
          ;; CopyInResponse
	  (cond
	    ((and (streamp (pgcon-sql-stream connection))
		  (input-stream-p (pgcon-sql-stream connection)))
	     ;; we ignore the data stuff.
	     (handler-case
	      (progn
		(loop :with buffer = (make-array 4096
						 :element-type '(unsigned-byte 8)
						 :adjustable t)
		      :for length = (read-sequence buffer (pgcon-sql-stream connection))
		      :until (= length 0)
		      :do
		      ;; send data
		      (unless (= length 4096)
			(setf buffer
			      (adjust-array buffer (list length))))
		      (send-packet connection
				   #\d
				   `((:rawdata ,buffer))))
		
		;; CopyDone
		(send-packet connection
			     #\c
			     nil))
	      ((or error serious-condition) (condition)
	       (warn "Got an error while writing sql data: ~S aborting transfer!"
		     condition)
	       (send-packet connection
			    #\f
			    ;;CopyFail
			    '((:cstring "No input data provided")))))
	     (%flush connection))
	    (t
	     (warn "We had to provide data, but my sql-stream isn't an input-stream. Aborting transfer")

	     (send-packet connection
			  #\f
			  ;;CopyFail
			  '((:cstring "No input data provided"))))))
         ((#\H)
          ;; CopyOutResponse
	  (cond
	    ((and (streamp (pgcon-sql-stream connection))
		  (output-stream-p (pgcon-sql-stream connection)))
	     (setf receive-data-p t))
	    (t
	     (setf receive-data-p nil)
	     (warn "I should receive data but my sql-stream isn't an outputstream!~%Ignoring data"))))
         (( #\d)
	  ;; CopyData
	  (when receive-data-p
	    ;; we break the nice packet abstraction here to
	    ;; get some speed:
	    (let ((length (- (pg-packet-length packet) 4)))
	      (write-sequence (make-array length
					  :element-type '(unsigned-byte 8)
					  :displaced-to (slot-value packet
								    'data)
					  :displaced-index-offset
					  (slot-value packet 'position))
			      (pgcon-sql-stream connection)))))
	 (( #\c )
	  ;;CopyDone
	  ;; we do nothing (the exec will return and the user
	  ;; can do something if he/she wants
	  (setf receive-data-p nil)
          t)
         ((#\T)
          ;; RowDescription (metadata for subsequent tuples), #\T
          (and attributes (error "Cannot handle multiple result group"))
          (setq attributes (read-attributes/v3 packet)))
         ((#\D)
          ;; AsciiRow (text data transfer), #\D
          (setf got-data-p t)
          (setf (pgcon-binary-p connection) nil)
          (unless attributes
            (error 'protocol-error :reason "Tuple received before metadata"))
          (push (read-tuple/v3 packet attributes) tuples))
         ((#\I)
          ;; EmptyQueryResponse, #\I
          ;; so no result.
          (setf got-data-p t)
          (setf (pgresult-status result) "SELECT")
          (setf (pgresult-tuples result) nil)
          (setf (pgresult-attributes result) nil))
         ((#\Z)
          ;; ReadyForQuery
          ;;
          ;; it might be a result from a previous
          ;; query
          (when got-data-p
            (return result)))
          ((#\s)
           ;; PortalSuspend
           ;; we're done in any case:
           (return result))
          ((#\V)
           ;; FunctionCallResponse -- not clear why we would get these here instead of in FN
           (let* ((length (read-from-packet packet :int32))
                  (response (unless (= length -1)
                              (read-string-from-packet packet length))))
             (setf (pgresult-status result) response)))
          ((#\2
            ;; BindComplete
           #\1
           ;; ParseComplete
           #\3
           ;; CloseComplete
           #\n
           ;; NoData
           )
          ;; we ignore these messages
          t)
         ((#\E
          ;; an error, we bravely try to recover...
           #\N)
          ;; and we ignore Notices
          t)
         (t
          (warn "Got unexpected packet: ~S, resetting connection"
                packet)
          ;; sync
          (send-packet connection
                       #\S
                       nil)
          (%flush connection)))))))

(defmethod pg-exec ((connection pgcon-v3) &rest args)
  "Execute the SQL command given by the concatenation of ARGS
on the database to which we are connected via CONNECTION. Return
a result structure which can be decoded using `pg-result'."
  (let ((sql (apply #'concatenate 'simple-string args)))
    (when (> (length sql) +MAX_MESSAGE_LEN+)
      (error "SQL statement too long: ~A" sql))

    (send-packet connection #\Q `((:cstring ,sql)))
    (%flush connection)
    (do-followup-query connection)))


(defmethod pg-disconnect ((connection pgcon-v3))
  (send-packet connection #\X nil)
  (%flush connection)
  (close (pgcon-stream connection))
  (values))


;; Attribute information is as follows
(defun read-attributes/v3 (packet)
  (let ((attribute-count (read-from-packet packet :int16))
        (attributes '()))
    (do ((i attribute-count (- i 1)))
        ((zerop i) (nreverse attributes))
      (let* ((type-name (read-from-packet packet :cstring))
             (table-id (read-from-packet packet :int32))
             (column-id (read-from-packet packet :int16))
             (type-id (read-from-packet packet :int32))
             (type-len   (read-from-packet packet :int16))
             (type-mod  (read-from-packet packet :int32))
             (format-code (read-from-packet packet :int16)))
        (declare (ignore type-mod format-code
                         table-id column-id))
        (push (list type-name type-id type-len) attributes)))))

(defun read-tuple/v3 (packet attributes)
  (let* ((num-attributes (length attributes))
         (number (read-from-packet packet :int16))
         (tuples '()))
    (unless (= num-attributes
               number)
      (error "Should ~S not be equal to ~S"
            num-attributes
            number))
    (do ((i 0 (+ i 1))
         (type-ids (mapcar #'second attributes) (cdr type-ids)))
        ((= i num-attributes) (nreverse tuples))
      (let* ((length (read-from-packet packet :int32))
             (raw   (unless (= length -1)
                      (read-string-from-packet packet length))))
        (if raw
            (push (parse raw (car type-ids)) tuples)
            (push nil tuples))))))

;; Execute one of the large-object functions (lo_open, lo_close etc).
;; Argument FN is either an integer, in which case it is the OID of an
;; element in the pg_proc table, and otherwise it is a string which we
;; look up in the alist *lo-functions* to find the corresponding OID.
(defmethod fn ((connection pgcon-v3) fn binary-result &rest args)
    (or *lo-initialized* (lo-init connection))
  (let ((fnid (cond ((integerp fn) fn)
                    ((not (stringp fn))
                     (error "Expecting a string or an integer: ~s" fn))
                    ((assoc fn *lo-functions* :test #'string=)
                     (cdr (assoc fn *lo-functions* :test #'string=)))
                    (t (error "Unknown builtin function ~s" fn)))))
    (send-packet connection
                 #\F
                 `((:int32 ,fnid)
                   (:int16 ,(length args))
                   ,@(let ((result nil))
                          (dolist (arg args)
                            (etypecase arg
                              (integer
                               (push `(:int16 1) result))
                              ((vector (unsigned-byte 8))
                               (push `(:int16 1) result))
                              (string
                               (push `(:int16 0) result))))
                          (nreverse result))
                   (:int16 ,(length args))
                   ,@(let ((result nil))
                          (dolist (arg args)
                            (etypecase arg
                              (integer
                               (push '(:int32 4) result)
                               (push `(:int32 ,arg) result))
                              ((vector (unsigned-byte 8))
                               (push `(:int32 ,(length arg)) result)
                               (push `(:rawdata ,arg) result))
                              (string
                               ;; FIXME this should be STRING-OCTET-LENGTH instead of LENGTH
                               (push `(:int32 ,(1+ (length arg))) result)
                               (push `(:cstring ,arg) result))))
                          (nreverse result))
                   (:int16 ,(if binary-result 1 0))))
    (%flush connection)
    (loop :with result = nil
          :for packet = (read-packet connection)
          :do
          (case (pg-packet-type packet)
            ((#\V) ; FunctionCallResponse
             (let* ((length (read-from-packet packet :int32))
                    (data (unless (= length -1)
                            (if binary-result
                                (case length
                                  ((1)
                                   (read-from-packet packet :byte))
                                  ((2)
                                   (read-from-packet packet :int16))
                                  ((4)
                                   (read-from-packet packet :int32))
                                  (t
                                   (read-octets-from-packet packet length)))
                                (read-string-from-packet packet length)))))
               (if data
                   (setf result data)
                   (return-from fn nil))))
            ((#\Z)
             (return-from fn result))
            ((#\E)
             ;; an error, we should abort.
             (return nil))
            ((#\N)
             ;; We ignore Notices
             t)
            (t
             (warn "Got unexpected packet: ~S, resetting connection"
                   packet)
             ;; sync
             (send-packet connection
                          #\S
                          nil)
             (%flush connection))))))



(defclass backend-notification ()
  ((severity)
   (code)
   (message :initform nil)
   (detail :initform nil)
   (hint :initform nil)
   (position)
   (where)
   (file)
   (line)
   (routine)))

#+nil
(defmethod print-object ((self backend-notification) stream)
  (print-unreadable-object (object stream :type t)
    (with-slots (message detail) self
      (format stream "Message: ~A, ~A"
              message detail))))


(defun handle-notice/v3 (connection packet)
  (loop :with notification = (make-instance 'backend-notification)
        :for field-type = (read-from-packet packet :byte)
        :until (= field-type 0)
        :do (let ((message (read-from-packet packet :cstring))
                  (slot (ecase (code-char field-type)
                          ((#\S) 'severity)
                          ((#\C) 'code)
                          ((#\M) 'message)
                          ((#\D) 'detail)
                          ((#\H) 'hint)
                          ((#\P) 'position)
                          ((#\W) 'where)
                          ((#\F) 'file)
                          ((#\L) 'line)
                          ((#\R) 'routine))))
              (setf (slot-value notification slot) message))
        :finally (push notification (pgcon-notices connection)))
  packet)



;; prepare/bind/execute functions

(defmethod pg-supports-pbe ((connection pgcon-v3))
    (declare (ignore connection))
  t)

(defmethod pg-prepare ((connection pgcon-v3) (statement-name string) (sql-statement string) &optional type-of-parameters)
    (let ((types (when type-of-parameters
                 (loop :for type :in type-of-parameters
                       :for oid = (or (lookup-type type)
                                      (error "type not found"))
                       :collect `(:int32 ,oid)))))

    (cond
      (types
       (send-packet connection
                    #\P
                    `((:cstring ,statement-name)
                      (:cstring ,sql-statement)
                      (:int16 ,(length types))
                      ,@(when types
                              types))))
      (t
       (send-packet connection
                    #\P
                    `((:cstring ,statement-name)
                      (:cstring ,sql-statement)
                      (:int16 0)))))
      t))

(defmethod pg-bind ((connection pgcon-v3) (portal string)  (statement-name string) list-of-types-and-values)
    (let ((formats (when list-of-types-and-values
                   (loop :for (type value) :in list-of-types-and-values
                         :collect
                         (ecase type
                           ((:string) `(:int16 0))
                           ((:byte :int16 :int32 :char) `(:int16 1))))))
        (data  nil))

    (when list-of-types-and-values
      (loop :for  (type value) :in list-of-types-and-values
            :do
            (ecase type
              ((:int32)
               (push '(:int32 4) data)
               (push `(:int32 ,value) data))
              ((:int16)
               (push '(:int32 2) data)
               (push `(:int16 ,value) data))
              ((:byte)
               (push '(:int32 1) data)
               (push `(:int8 ,value) data))
              ((:char)
               (push '(:int32 1) data)
               (push `(:int8 ,(char-code value)) data))
              ((:string)
               (push `(:int32 ,(1+ (length value))) data)
               (push `(:cstring ,value) data))))

      (setf data (nreverse data)))

    (cond
      (list-of-types-and-values
       (send-packet connection
                    #\B
                    `((:cstring ,portal)
                      (:cstring ,statement-name)
                      (:int16 ,(length formats))
                      ,@formats
                      (:int16 ,(length formats))
                      ,@data
                      (:int16 0))))
      (t
       (send-packet connection
                    #\B
                    `((:cstring ,portal)
                      (:cstring ,statement-name)
                      (:int16 0)
                      (:int16 0)
                      (:int16 0)))))
    t))

(defmethod pg-execute ((connection pgcon-v3) (portal string) &optional (maxinum-number-of-rows 0))

  ;; have it describe the result:
  (send-packet connection
               #\D
               `((:char #\P)
                 (:cstring ,portal)))
  ;; execute the query:
  (send-packet connection
               #\E
               `((:cstring ,portal)
                 (:int32 ,maxinum-number-of-rows)))
  ;; send all data:
  (send-packet connection
               #\S
               nil)
  (%flush connection)

  (do-followup-query connection))

(defun pg-close (connection name type)
  (declare (type pgcon connection)
           (type string name)
           (type base-char type))

  (send-packet connection
               #\C
               `((:char ,type)
                 (:cstring ,name)))
  ;; make it a sync point
  (send-packet connection
               #\S
               nil)
  (%flush connection)
  (loop :for packet = (read-packet connection)
        :do
        (case (pg-packet-type packet)
          ((#\3 #\Z)
           ;; Close Complete
           ;; or
           ;; ReadyForQuery
           (return))
          (t
           (warn "Got unexpected packet: ~S, resetting connection"
                 packet)
           ;; sync
           (send-packet connection
                        #\S
                        nil)
           (%flush connection))))
  t)

(defmethod pg-close-statement ((connection pgcon-v3) (statement-name string))
    (pg-close connection statement-name #\s))

(defmethod pg-close-portal ((connection pgcon-v3) (portal string))
    (pg-close connection portal #\P))

;; EOF