File: v2-protocol.lisp

package info (click to toggle)
cl-pg 1:20061216-4
  • links: PTS
  • area: main
  • in suites: lenny
  • size: 276 kB
  • ctags: 233
  • sloc: lisp: 3,125; makefile: 43
file content (312 lines) | stat: -rw-r--r-- 12,483 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
;;; 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