cl-pg 1:20061216-5 / usr / share / common-lisp / source / pg / v2-protocol.lisp

;;; v2-protocol.lisp -- frontend/backend protocol prior to PostgreSQL 7.4
;;;
;;; Author: Eric Marsden <eric.marsden@free.fr>


(in-package :postgresql)

(defclass pgcon-v2 (pgcon)
  ())



(defun pg-connect/v2 (dbname user &key (host "localhost") (port 5432) (password "") (encoding *pg-client-encoding*))
  "Initiate a connection with the PostgreSQL backend, using protocol v2.
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-v2 :stream stream :host host :port port :encoding encoding))
         (user-packet-length (+ +SM_USER+ +SM_OPTIONS+ +SM_UNUSED+ +SM_TTY+)))
    ;; send the startup packet
    (send-int connection +STARTUP_PACKET_SIZE+ 4)
    (send-int connection 2 2)           ; protocol 6.3 major
    (send-int connection 0 2)           ; protocol 6.3 minor
    (send-string connection dbname +SM_DATABASE+)
    (send-string connection user user-packet-length)
    (%flush connection)
    (loop
     (case (read-byte stream)
       ;; ErrorResponse
       ((69)
        (close stream)
        (error 'authentication-failure
               :reason (%read-cstring stream 4096)))

       ;; Authentication
       ((82)
        (case (read-net-int connection 4)
          ((0)                          ; AuthOK
           (and (not *pg-disable-type-coercion*)
                (null *parsers*)
                (initialize-parsers connection))
           (when *pg-date-style*
             (setf (pg-date-style connection) *pg-date-style*))
           (when encoding
             (setf (pg-client-encoding connection) encoding))
           (return connection))
          ((3)                          ; AuthUnencryptedPassword
           (send-int connection (+ 5 (length password)) 4)
           (send-string connection password)
           (send-int connection 0 1)
           (%flush connection))
          ((4)                          ; AuthEncryptedPassword
           (let* ((salt (%read-chars stream 2))
                  (crypted (crypt password salt)))
             #+debug
             (format *debug-io* "Got salt of ~s~%" salt)
             (send-int connection (+ 4 (length crypted) 1) 4)
             (send-string connection crypted)
             (send-int connection 0 1)
             (%flush connection)))
          ((5)                          ; AuthMD5Password
           #+debug
           (format *debug-io* "MD5Auth: got salt of ~s~%" salt)
           (force-output *debug-io*)
           (let* ((salt (%read-chars stream 4))
                  (ciphered (md5-encode-password user password salt)))
             (send-int connection (+ 4 (length ciphered) 1) 4)
             (send-string connection ciphered)
             (send-int connection 0 1)
             (%flush connection)))

          ((1)                          ; AuthKerberos4
           (error 'authentication-failure
                  :reason "Kerberos4 authentication not supported"))
          ((2)                          ; AuthKerberos5
           (error 'authentication-failure
                  :reason "Kerberos5 authentication not supported"))
          (t (error 'authentication-failure
                    :reason "unknown authentication type"))))

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


(defmethod pg-exec ((connection pgcon-v2) &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))
        (stream (pgcon-stream connection))
        (tuples '())
        (attributes '())
        (result (make-pgresult :connection connection)))
    (when (> (length sql) +MAX_MESSAGE_LEN+)
      (error "SQL statement too long: ~A" sql))
    (write-byte 81 stream)
    (send-string connection sql)
    (write-byte 0 stream)
    (%flush connection)
    (do ((b (read-byte stream nil :eof)
            (read-byte stream nil :eof)))
        ((eq b :eof) (error 'protocol-error :reason "unexpected EOF from backend"))
      (case b
        ;; asynchronous notify, #\A
        ((65)
         ;; read the pid
         (read-net-int connection 4)
         (handle-notice connection))

        ;; BinaryRow, #\B
        ((66)
         (setf (pgcon-binary-p connection) t)
         (unless attributes
           (error 'protocol-error :reason "Tuple received before metadata"))
         (push (read-tuple/v2 connection attributes) tuples))

        ;; CompletedResponse, #\C
        ((67)
         (let ((status (%read-cstring stream +MAX_MESSAGE_LEN+)))
           (setf (pgresult-status result) status)
           (setf (pgresult-tuples result) (nreverse tuples))
           (setf (pgresult-attributes result) attributes)
           (return result)))

        ;; AsciiRow (text data transfer), #\D
        ((68)
         (setf (pgcon-binary-p connection) nil)
         (unless attributes
           (error 'protocol-error :reason "Tuple received before metadata"))
         (push (read-tuple/v2 connection attributes) tuples))

        ;; ErrorResponse, #\E
        ((69)
         (let ((msg (%read-cstring stream +MAX_MESSAGE_LEN+)))
           (error 'backend-error :reason msg)))

        ;; #\G and #\H: start copy in, start copy out

        ;; EmptyQueryResponse, #\I
        ((73)
         (let ((c (read-byte stream)))
           (when (< 0 c)
             (error 'protocol-error :reason "Garbled data"))))

        ;; BackendKeyData, #\K
        ((75)
         (setf (pgcon-pid connection) (read-net-int connection 4))
         (setf (pgcon-secret connection) (read-net-int connection 4)))

        ;; NotificationResponse, #\N
        ((78)
         (setf (pgcon-pid connection) (read-net-int connection 4))
         (handle-notice connection))

        ;; CursorResponse, #\P
        ((80)
         (let ((str (%read-cstring stream +MAX_MESSAGE_LEN+)))
           (declare (ignore str))
           ;; (format *debug-io* "Portal name ~a~%" str)
           ))

        ;; RowDescription (metadata for subsequent tuples), #\T
        ((84)
         (and attributes (error "Cannot handle multiple result group"))
         (setq attributes (read-attributes/v2 connection)))

        ;; ReadyForQuery
        ((90) t)

        (t
         (error 'protocol-error
                :reason (format nil "Unknown response type from backend ~d" b)))))))


;; 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-v2) fn integer-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-int connection 70 1)          ; function call
    (send-int connection 0 1)
    (send-int connection fnid 4)
    (send-int connection (length args) 4)
    (dolist (arg args)
      (cond ((integerp arg)
             (send-int connection 4 4)
             (send-int connection arg 4))
            ((stringp arg)
             (send-int connection (length arg) 4)
             (send-string connection arg))
            ((vectorp arg)
             (send-int connection (length arg) 4)
             (send-octets connection arg))
            (t (error 'protocol-error
                      :reason (format nil "Unknown fastpath type ~s" arg)))))
    (%flush connection)
    (loop :with result = nil
          :with ready = nil
          :for b = (read-byte (pgcon-stream connection) nil :eof) :do
          (case b
            ;; FunctionResultResponse
            ((86)
             (let ((res (read-byte (pgcon-stream connection) nil :eof)))
               (cond ((= res 0)         ; empty result
                      (return-from fn nil))
                     ((= res 71)        ; nonempty result
                      (let ((len (read-net-int connection 4)))
                        (if integer-result
                            (setq result (read-net-int connection len))
                          (setq result (%read-chars (pgcon-stream connection) len)))))
                     (t (error 'protocol-error :reason "wierd FunctionResultResponse")))))

            ;; end of FunctionResult
            ((48) (return-from fn result))

            ((69) (error 'backend-error :reason (%read-cstring (pgcon-stream connection) 4096)))

            ;; NoticeResponse
            ((78)
             (setf (pgcon-pid connection) (read-net-int connection 4))
             (handle-notice connection))

            ;; ReadyForQuery
            ((90) (setq ready t))

            (t (error 'protocol-error
                      :reason (format nil "Unexpected byte ~s" b)))))))


(defmethod pg-disconnect ((connection pgcon-v2) &key abort)
  (cond
    (abort
     (close (pgcon-stream connection) :abort t))
    (t
     (write-byte 88 (pgcon-stream connection))
     (%flush connection)
     (close (pgcon-stream connection))))
  (values))


;; Attribute information is as follows
;;    attribute-name (string)
;;    attribute-type as an oid from table pg_type
;;    attribute-size (in bytes?)
(defun read-attributes/v2 (connection)
  (let ((attribute-count (read-net-int connection 2))
        (attributes '()))
    (do ((i attribute-count (- i 1)))
        ((zerop i) (nreverse attributes))
      (let ((type-name (%read-cstring (pgcon-stream connection) +MAX_MESSAGE_LEN+))
            (type-id   (read-net-int connection 4))
            (type-len  (read-net-int connection 2))
            ;; this doesn't exist in the 6.3 protocol !!
            (type-modifier (read-net-int connection 4)))
        (declare (ignore type-modifier))
        (push (list type-name type-id type-len) attributes)))))

;; the bitmap is a string, which we interpret as a sequence of bytes
(defun bitmap-ref/v2 (bitmap ref)
  (multiple-value-bind (char-ref bit-ref)
      (floor ref 8)
    (logand #b10000000 (ash (aref bitmap char-ref) bit-ref))))

;; the server starts by sending a bitmap indicating which tuples are
;; NULL. "A bit map with one bit for each field in the row. The 1st
;; field corresponds to bit 7 (MSB) of the 1st byte, the 2nd field
;; corresponds to bit 6 of the 1st byte, the 8th field corresponds to
;; bit 0 (LSB) of the 1st byte, the 9th field corresponds to bit 7 of
;; the 2nd byte, and so on. Each bit is set if the value of the
;; corresponding field is not NULL. If the number of fields is not a
;; multiple of 8, the remainder of the last byte in the bit map is
;; wasted."
(defun read-tuple/v2 (connection attributes)
  (let* ((num-attributes (length attributes))
         (num-bytes (ceiling (/ num-attributes 8)))
         (bitmap (%read-bytes (pgcon-stream connection) num-bytes))
         (correction (if (pgcon-binary-p connection) 0 -4))
         (tuples '()))
    (do ((i 0 (+ i 1))
         (type-ids (mapcar #'second attributes) (cdr type-ids)))
        ((= i num-attributes) (nreverse tuples))
      (cond ((zerop (bitmap-ref/v2 bitmap i))
             (push nil tuples))
            (t
             (let* ((len (+ (read-net-int connection 4) correction))
                    (raw (%read-chars (pgcon-stream connection) (max 0 len)))
                    (parsed (parse raw (car type-ids))))
               (push parsed tuples)))))))

;; FIXME could signal a postgresql-notification condition
(defun handle-notice (connection)
  (push (%read-cstring (pgcon-stream connection) +MAX_MESSAGE_LEN+)
        (pgcon-notices connection)))


;; split out from large-object.lisp
(defmethod pglo-read ((connection pgcon-v2) fd bytes)
  (let ((octets (fn connection "loread" nil fd bytes)))
    (map '(vector (unsigned-byte 8)) #'char-code octets)))


;; EOF