cl-postgres/messages.lisp

   1 (in-package :cl-postgres)
   2
   3 ;; For more information about the PostgreSQL scocket protocol, see
   4 ;; http://www.postgresql.org/docs/current/interactive/protocol.html
   5
   6 (defmacro define-message (name id (&rest arglist) &body parts)
   7   "This macro synthesizes a function to send messages of a specific
   8 type. It takes care of the plumbing -- calling writer functions on a
   9 stream, keeping track of the length of the message -- so that the
  10 message definitions themselves stay readable."
  11   (let ((writers nil)
  12         (socket (gensym))
  13         (strings ())
  14         (base-length 4)
  15         (extra-length ()))
  16     (setf writers
  17           (mapcar (lambda (part)
  18                     (let ((name (gensym)))
  19                       (ecase (first part)
  20                         (uint
  21                          (incf base-length (second part))
  22                          `(,(integer-writer-name (second part) nil) ,socket ,(third part)))
  23                         (string
  24                          (push `(,name ,(second part)) strings)
  25                          (incf base-length 1) ;; The null terminator
  26                          (push `(enc-byte-length ,name) extra-length)
  27                          `(write-str ,socket ,name))
  28                         (bytes
  29                          (push `(,name ,(second part)) strings)
  30                          (push `(length ,name) extra-length)
  31                          `(write-bytes ,socket ,name)))))
  32                   parts))
  33     (push `(write-uint4 ,socket (+ ,base-length ,@extra-length))
  34           writers)
  35     (when id
  36       (push `(write-uint1 ,socket ,(char-code id)) writers))
  37     `(defun ,name ,(cons socket arglist)
  38       (declare (type stream ,socket)
  39                #.*optimize*)
  40       (let ,strings ,@writers))))
  41
  42 ;; Try to enable SSL for a connection.
  43 (define-message ssl-request-message nil ()
  44   (uint 4 80877103))
  45
  46 ;; Sends the initial message and sets a few parameters.
  47 (define-message startup-message nil (user database)
  48   (uint 4 196608) ;; Identifies protocol 3.0
  49   (string "user")
  50   (string user)
  51   (string "database")
  52   (string database)
  53   (string "client_encoding")
  54   (string *client-encoding*)
  55   (uint 1 0)) ;; Terminates the parameter list
  56
  57 ;; Identify a user with a plain-text password.
  58 (define-message plain-password-message #\p (password)
  59   (string password))
  60
  61 (defun bytes-to-hex-string (bytes)
  62   "Convert an array of 0-255 numbers into the corresponding string of
  63 \(lowercase) hex codes."
  64   (declare (type (vector (unsigned-byte 8)) bytes)
  65            #.*optimize*)
  66   (let ((digits #.(coerce "0123456789abcdef" 'simple-base-string))
  67         (result (make-string (* (length bytes) 2) :element-type 'base-char)))
  68     (loop :for byte :across bytes
  69           :for pos :from 0 :by 2
  70           :do (setf (char result pos) (aref digits (ldb (byte 4 4) byte))
  71                     (char result (1+ pos)) (aref digits (ldb (byte 4 0) byte))))
  72     result))
  73
  74 (defun md5-password (password user salt)
  75   "Apply the hashing that PostgreSQL expects to a password."
  76   (declare (type string user password)
  77            (type (vector (unsigned-byte 8)) salt)
  78            #.*optimize*)
  79   (flet ((md5-and-hex (sequence)
  80            (bytes-to-hex-string (md5:md5sum-sequence sequence))))
  81     (let* ((pass1 (md5-and-hex (enc-string-bytes (concatenate 'string password user))))
  82            (pass2 (md5-and-hex (concatenate '(vector (unsigned-byte 8) *) (enc-string-bytes pass1) salt))))
  83       (concatenate 'string "md5" pass2))))
  84
  85 ;; Identify a user with an MD5-hashed password.
  86 (define-message md5-password-message #\p (password user salt)
  87   (string (md5-password password user salt)))
  88
  89 (define-message gss-auth-buffer-message #\p (buf)
  90   (bytes buf))
  91
  92 ;; Send a query, the simple way.
  93 (define-message query-message #\Q (query)
  94   (string query))
  95
  96 ;; Parse a query
  97 (define-message simple-parse-message #\P (query)
  98   (uint 1 0) ;; Name of the prepared statement
  99   (string query)
 100   (uint 2 0)) ;; Parameter types
 101
 102 ;; Parse a query, giving it a name.
 103 (define-message parse-message #\P (name query)
 104   (string name)
 105   (string query)
 106   (uint 2 0))
 107
 108 ;; Close a named parsed query, freeing the name.
 109 (define-message close-prepared-message #\C (name)
 110   (uint 1 #.(char-code #\S)) ;; Prepared statement
 111   (string name))
 112
 113 (defun formats-to-bytes (formats)
 114   "Formats have to be passed as arrays of 2-byte integers, with 1
 115 indicating binary and 0 indicating plain text."
 116   (declare (type vector formats)
 117            #.*optimize*)
 118   (let* ((result (make-array (* 2 (length formats))
 119                              :element-type '(unsigned-byte 8)
 120                              :initial-element 0)))
 121     (loop :for format :across formats
 122           :for pos :from 1 :by 2
 123           :do (when format (setf (elt result pos) 1)))
 124     result))
 125
 126 ;; Bind the unnamed prepared query, asking for the given result
 127 ;; formats.
 128 (define-message simple-bind-message #\B (formats)
 129   (uint 1 0) ;; Name of the portal
 130   (uint 1 0) ;; Name of the prepared statement
 131   (uint 2 0) ;; Number of parameter format specs
 132   (uint 2 0) ;; Number of parameter specifications
 133   (uint 2 (length formats)) ;; Number of result format specifications
 134   (bytes (formats-to-bytes formats))) ;; Result format
 135
 136 ;; This one was a bit too complex to put into define-message format,
 137 ;; so it does everything by hand.
 138 (defun bind-message (socket name result-formats parameters)
 139   "Bind a prepared statement, ask for the given formats, and pass the
 140 given parameters, that can be either string or byte vector.
 141 \(vector \(unsigned-byte 8)) parameters will be sent as binary data, useful
 142 for binding data for binary long object columns."
 143   (declare (type stream socket)
 144            (type string name)
 145            (type vector result-formats)
 146            (type list parameters)
 147            #.*optimize*)
 148   (let* ((n-params (length parameters))
 149          (param-formats (make-array n-params :element-type 'fixnum))
 150          (param-sizes (make-array n-params :element-type 'fixnum))
 151          (param-values (make-array n-params))
 152          (n-result-formats (length result-formats)))
 153     (declare (type (unsigned-byte 16) n-params n-result-formats))
 154     (loop :for param :in parameters
 155           :for i :from 0
 156           :do (flet ((set-param (format size value)
 157                        (setf (aref param-formats i) format
 158                              (aref param-sizes i) size
 159                              (aref param-values i) value)))
 160                 (declare (inline set-param))
 161                 (cond ((eq param :null)
 162                        (set-param 0 0 nil))
 163                       ((typep param '(vector (unsigned-byte 8)))
 164                        (set-param 1 (length param) param))
 165                       (t
 166                        (unless (typep param 'string)
 167                          (setf param (serialize-for-postgres param)))
 168                        (etypecase param
 169                          (string
 170                           (set-param 0 (enc-byte-length param) param))
 171                          ((vector (unsigned-byte 8))
 172                           (set-param 1 (length param) param)))))))
 173     (write-uint1 socket #.(char-code #\B))
 174     (write-uint4 socket (+ 12
 175                            (enc-byte-length name)
 176                            (* 6 n-params)   ;; Input formats and sizes
 177                            (* 2 n-result-formats)
 178                            (loop :for size :of-type fixnum :across param-sizes
 179                                  :sum size)))
 180     (write-uint1 socket 0)                  ;; Name of the portal
 181     (write-str socket name)                 ;; Name of the prepared statement
 182     (write-uint2 socket n-params)           ;; Number of parameter format specs
 183     (loop :for format :across param-formats ;; Param formats (text/binary)
 184           :do (write-uint2 socket format))
 185     (write-uint2 socket n-params)           ;; Number of parameter specifications
 186     (loop :for param :across param-values
 187           :for size :across param-sizes
 188           :do (write-int4 socket (if param size -1))
 189           :do (when param
 190                 (if (typep param '(vector (unsigned-byte 8)))
 191                     (write-sequence param socket)
 192                     (enc-write-string param socket))))
 193     (write-uint2 socket n-result-formats)   ;; Number of result formats
 194     (loop :for format :across result-formats ;; Result formats (text/binary)
 195           :do (write-uint2 socket (if format 1 0)))))
 196
 197 ;; Describe the anonymous portal, so we can find out what kind of
 198 ;; result types will be passed.
 199 (define-message simple-describe-message #\D ()
 200   (uint 1 #.(char-code #\S)) ;; This is a statement describe
 201   (uint 1 0)) ;; Name of the portal
 202
 203 ;; Describe a named portal.
 204 (define-message describe-prepared-message #\D (name)
 205   (uint 1 #.(char-code #\S)) ;; This is a statement describe
 206   (string name))
 207
 208 ;; Execute a bound statement.
 209 (define-message simple-execute-message #\E ()
 210   (uint 1 0) ;; Name of the portal
 211   (uint 4 0)) ;; Max amount of rows (0 = all rows)
 212
 213 ;; Flush the sent messages, force server to start responding.
 214 (define-message flush-message #\H ())
 215
 216 ;; For re-synchronizing a socket.
 217 (define-message sync-message #\S ())
 218
 219 ;; Tell the server we are about to close the connection.
 220 (define-message terminate-message #\X ())
 221
 222 ;; To get out of the copy-in protocol.
 223 (define-message copy-done-message #\c ())
 224
 225 (defun copy-data-message (socket data)
 226   (declare (type string data)
 227            #.*optimize*)
 228   (write-uint1 socket 100)
 229   (write-uint4 socket (+ 4 (length data)))
 230   (enc-write-string data socket))
 231
 232 (define-message copy-fail-message #\f (reason)
 233   (string reason))