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



(declaim (optimize (speed 3) (safety 1)))


(in-package :postgresql)

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


(define-condition error-response (backend-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 (connection 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)))
    (send-packet connection #\S nil)
    ;; we are trying to recover from errors too:
    (apply #'cerror
           "Try to continue, should do a rollback"
           'error-response
           (append (list :reason "Backend error") 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))
         (condition-name (read-from-packet packet :cstring))
         (additional-information (read-from-packet packet :cstring)))
    (setf (pgcon-pid connection) pid)
    (format *debug-io* "~&Got notification: ~S, ~S~%"
            condition-name
            additional-information)
    (push condition-name (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 connection packet)
         packet)

        ((#\N)                                ; Notice
         (handle-notice/v3 connection packet)
         packet)

        ((#\A)
         (read-and-handle-notification-response 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 'character))))
        (when result
          (loop :for i :from position :below end
                :for j :from 0
                :do
                (setf (aref result j)
                      (code-char (aref 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)
                                                         (pgcon-encoding connection)))))
               (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 integer))
    (when (< length 0)
      (error "length cannot be negative. is: ~S"
             length))
    (with-slots (connection) packet
      (let* ((octets (read-octets-from-packet packet length))
             (encoding (if (or (eql #\R (pg-packet-type packet))
                               (eql #\E (pg-packet-type packet)))
                           "LATIN1"
                           (pgcon-encoding connection)))
             (string (convert-string-from-bytes octets encoding)))
        string))))


(defgeneric read-octets-from-packet (packet length))

(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))
                                ((:string) (length (convert-string-to-bytes value (pgcon-encoding connection))))
                                ((:cstring) (1+ (length (convert-string-to-bytes value (pgcon-encoding connection)))))
                                ((: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 (signed-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 (signed-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 (signed-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 (pgcon-encoding connection))))
               (declare (type (vector (unsigned-byte 8) *) encoded))
               (replace data encoded :start1 position)
               (incf position (length encoded)))
             (setf (elt data position) 0)
             (incf position))

            ;; a string without the trailing NUL character
            ((:string)
             (check-type value string)
             (let ((encoded (convert-string-to-bytes value (pgcon-encoding connection))))
               (declare (type (vector (unsigned-byte 8) *) encoded))
               (replace data encoded :start1 position)
               (incf position (length encoded))))

	    ((: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 "") (encoding *pg-client-encoding*))
  "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 a pathname or a string whose
first character is #\/, it designates the directory containing the
Unix socket on which the PostgreSQL backend is listening."
  (let* ((stream (socket-connect port host))
         (connection (make-instance 'pgcon-v3 :stream stream :host host :port port :encoding encoding))
         (connect-options `("user" ,user
                            "database" ,dbname))
         (user-packet-length (+ 4 4 (loop :for item :in connect-options :sum (1+ (length item))) 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
    (dolist (item connect-options)
      (%send-cstring stream item))
    (%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 encoding
            (setf (pg-client-encoding connection) 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) ;; a notice, that has already been handled in READ-PACKET
        t)

       (t (error 'protocol-error
                 :reason "expected an authentication response"))))))


(defun do-followup-query (connection)
  "Does the followup of a query"
  (let ((tuples (list))
        (attributes (list))
        (result (make-pgresult :connection connection)))
    (loop
     :for packet = (read-packet connection)
     :with got-data-p = nil
     :with receive-data-p = nil
     :do (case (pg-packet-type packet)
           ((#\S) ;; ParameterStatus
            (let* ((parameter (read-from-packet packet :cstring))
                   (value (read-from-packet packet :cstring)))
              (push (cons parameter value) (pgcon-parameters connection)))
            (setf got-data-p t))

           ((#\A) ;; NotificationResponse, that has already been handled in READ-PACKET
            (setf got-data-p t))

           ((#\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)
                  ;; CopyFail
                  (send-packet connection #\f '((: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")
               ;; CopyFail
               (send-packet connection #\f '((:cstring "No input data provided")))
               (%flush connection))))

           ((#\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)
            (setf got-data-p t)
            t)

           ((#\T) ;; RowDescription (metadata for subsequent tuples)
            ;; FIXME: implement multiple result groups
            (and attributes (error "Cannot handle multiple result group"))
            (setq attributes (read-attributes/v3 packet)))

           ((#\D) ;; AsciiRow (text data transfer)
            (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
            (setf (pgresult-status result) "SELECT")
            (setf (pgresult-tuples result) nil)
            (setf (pgresult-attributes result) nil)
            (return-from do-followup-query result))

           ((#\Z) ;; ReadyForQuery
            (let ((status (read-from-packet packet :byte)))
              (declare (ignore status))
              (when got-data-p
                (return-from do-followup-query result))))

           ((#\s) ;; PortalSuspend
            ;; an Execute statement has terminated before completing
            ;; the execution of a portal (due to reaching a nonzero
            ;; result-row count)
            (return-from do-followup-query 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))
            (setf got-data-p t))

           ;; BindComplete / ParseComplete / NoData
           ((#\2 #\1 #\3)
            (return-from do-followup-query result))

           ((#\n) ;; NoData
            (setf got-data-p t))
           
           ;; error messages will already have been handled in READ-PACKET
           ((#\E)
            (setq got-data-p t))

           ;; notice messages will already have been handled in READ-PACKET
           ((#\N)
            t)

           (t
            (warn "In PG::D-F-Q got unexpected packet: ~S, resetting connection" packet)
            (send-packet connection #\S nil) ; sync
            (%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)))
    (send-packet connection #\Q `((:cstring ,sql)))
    (%flush connection)
    (do-followup-query connection)))


(defmethod pg-disconnect ((connection pgcon-v3) &key abort)
  (cond
    (abort
     (close (pgcon-stream connection) :abort t))
    (t
     (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)
             (send-packet connection #\S nil) ; sync
             (%flush connection))))))



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

(defmethod print-object ((self backend-notification) stream)
  (print-unreadable-object (self 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 ===================================================
;;
;; Note that pg-dot-lisp is using the prepared statement support in
;; the FE/BE protocol in synchronous mode; whereas most other
;; PostgreSQL client interfaces use it asynchronously. This makes it
;; possible to support precise error reporting; errors are signaled by
;; the statement that provoked them, rather than by some later
;; statement that happened to read the error messages. However,
;; precision comes at some cost in performance.

(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))
                      ,@types)))
      (t
       (send-packet connection
                    #\P
                    `((:cstring ,statement-name)
                      (:cstring ,sql-statement)
                      (:int16 0)))))
    (send-packet connection #\H nil) ; Flush
    (%flush connection)
    (do-followup-query connection)))


(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
            (cond ((null value)
                   (push '(:int32 -1) data))
                  (t
                   (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))
                     ;; this is not a NUL-terminated string, so send exactly
                     ;; the string length rather than 1+
                     ((:string)
                      (let ((length (cond ((pg-client-encoding connection)
                                           (length (convert-string-to-bytes value (pg-client-encoding connection))))
                                          (t
                                           (length value)))))
                        (push `(:int32 ,length) data)
                        (push `(:string ,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)))))
    (send-packet connection #\H nil) ; Flush
    (%flush connection)
    (do-followup-query connection)))


(defmethod pg-execute ((connection pgcon-v3) (portal string) &optional (maximum-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 ,maximum-number-of-rows)))
  (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)
           t)
          ((#\Z) ;; CloseComplete or ReadyForQuery
           (return))
          (t
           (warn "Got unexpected packet in PG-CLOSE: ~S, resetting connection" packet)
           (send-packet connection #\S nil) ; sync
           (%flush connection)))))


(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))


;; split out from large-object.lisp
(defmethod pglo-read ((connection pgcon-v3) fd bytes)
  (fn connection "loread" t fd bytes))



;; EOF
