cl-postgres/interpret.lisp

   1 (in-package :cl-postgres)
   2
   3 (defparameter *timestamp-format* :unbound
   4   "This is used to communicate the format \(integer or float) used for
   5 timestamps and intervals in the current connection, so that the
   6 interpreters for those types know how to parse them.")
   7
   8 (defparameter *sql-readtable* (make-hash-table)
   9   "The exported special var holding the current read table, a hash
  10 mapping OIDs to instances of the type-interpreter class that contain
  11 functions for retreiving values from the database in text, and
  12 possible binary, form.")
  13
  14 (defun interpret-as-text (stream size)
  15   "This interpreter is used for types that we have no specific
  16 interpreter for -- it just reads the value as a string. \(Values of
  17 unknown types are passed in text form.)"
  18   (enc-read-string stream :byte-length size))
  19
  20 (defclass type-interpreter ()
  21   ((oid :initarg :oid :accessor type-interpreter-oid)
  22    (use-binary :initarg :use-binary :accessor type-interpreter-use-binary)
  23    (binary-reader :initarg :binary-reader :accessor type-interpreter-binary-reader)
  24    (text-reader :initarg :text-reader :accessor type-interpreter-text-reader))
  25   (:documentation "Information about type interpreter for types coming
  26   back from the database. use-binary is either T for binary, nil for
  27   text, or a function of no arguments to be called to determine if
  28   binary or text should be used. The idea is that there will always be
  29   a text reader, there may be a binary reader, and there may be times
  30   when one wants to use the text reader."))
  31
  32 (defun interpreter-binary-p (interp)
  33   "If the interpreter's use-binary field is a function, call it and
  34 return the value, otherwise, return T or nil as appropriate."
  35   (let ((val (type-interpreter-use-binary interp)))
  36     (typecase val
  37       (function (funcall val))
  38       (t val))))
  39
  40 (defun interpreter-reader (interp)
  41   "Determine if we went the text or binary reader for this type
  42 interpreter and return the appropriate reader."
  43   (if (interpreter-binary-p interp)
  44       (type-interpreter-binary-reader interp)
  45       (type-interpreter-text-reader interp)))
  46
  47 (let ((default-interpreter (make-instance 'type-interpreter
  48                                           :oid :default
  49                                           :use-binary nil
  50                                           :text-reader #'interpret-as-text)))
  51   (defun get-type-interpreter (oid)
  52     "Returns a type-interpreter containing interpretation rules for
  53 this type."
  54     (gethash oid *sql-readtable* default-interpreter)))
  55
  56 (defun set-sql-reader (oid function &key (table *sql-readtable*) binary-p)
  57   "Add an sql reader to a readtable. When the reader is not binary, it
  58 is wrapped by a function that will read the string from the socket."
  59   (if function
  60       (setf (gethash oid table)
  61             (make-instance 'type-interpreter
  62                            :oid oid
  63                            :use-binary binary-p
  64                            :binary-reader
  65                            (when binary-p function)
  66                            :text-reader
  67                            (if binary-p
  68                                'interpret-as-text
  69                                (lambda (stream size)
  70                                  (funcall function
  71                                           (enc-read-string stream :byte-length size))))))
  72       (remhash oid table))
  73   table)
  74
  75 (defmacro binary-reader (fields &body value)
  76   "A slightly convoluted macro for defining interpreter functions. It
  77 allows two forms. The first is to pass a single type identifier, in
  78 which case a value of this type will be read and returned directly.
  79 The second is to pass a list of lists containing names and types, and
  80 then a body. In this case the names will be bound to values read from
  81 the socket and interpreted as the given types, and then the body will
  82 be run in the resulting environment. If the last field is of type
  83 bytes, string, or uint2s, all remaining data will be read and
  84 interpreted as an array of the given type."
  85   (let ((stream-name (gensym))
  86         (size-name (gensym))
  87         (length-used 0))
  88     (flet ((read-type (type &optional modifier)
  89              (ecase type
  90                (bytes `(read-bytes ,stream-name (- ,size-name ,length-used)))
  91                (string `(enc-read-string ,stream-name :byte-length (- ,size-name ,length-used)))
  92                (uint2s `(let* ((size (/ (- ,size-name ,length-used) 2))
  93                                (result (make-array size :element-type '(unsigned-byte 16))))
  94                          (dotimes (i size)
  95                            (setf (elt result i) (read-uint2 ,stream-name)))
  96                          result))
  97                (int (assert (integerp modifier))
  98                     (incf length-used modifier)
  99                     `(,(integer-reader-name modifier t) ,stream-name))
 100                (uint (assert (integerp modifier))
 101                      (incf length-used modifier)
 102                      `(,(integer-reader-name modifier nil) ,stream-name)))))
 103       `(lambda (,stream-name ,size-name)
 104          (declare (type stream ,stream-name)
 105                   (type integer ,size-name)
 106                   (ignorable ,size-name))
 107          ,(if (consp fields)
 108               `(let ,(loop :for field :in fields
 109                            :collect `(,(first field) ,(apply #'read-type (cdr field))))
 110                  ,@value)
 111               (read-type fields (car value)))))))
 112
 113 (defmacro define-interpreter (oid name fields &body value)
 114   "Shorthand for defining binary readers."
 115   (declare (ignore name)) ;; Names are there just for clarity
 116   `(set-sql-reader ,oid (binary-reader ,fields ,@value) :binary-p t))
 117
 118 (define-interpreter oid:+char+ "char" int 1)
 119 (define-interpreter oid:+int2+ "int2" int 2)
 120 (define-interpreter oid:+int4+ "int4" int 4)
 121 (define-interpreter oid:+int8+ "int8" int 8)
 122
 123 (define-interpreter oid:+oid+ "oid" uint 4)
 124
 125 (define-interpreter oid:+bool+ "bool" ((value int 1))
 126   (if (zerop value) nil t))
 127
 128 (define-interpreter oid:+bytea+ "bytea" bytes)
 129 (define-interpreter oid:+text+ "text" string)
 130 (define-interpreter oid:+bpchar+ "bpchar" string)
 131 (define-interpreter oid:+varchar+ "varchar" string)
 132
 133 (defun read-row-value (stream size)
 134   (declare (type stream stream)
 135            (type integer size)
 136            (ignore size))
 137   (let ((num-fields (read-uint4 stream)))
 138     (loop for i below num-fields
 139        collect (let ((oid (read-uint4 stream))
 140                      (size (read-int4 stream)))
 141                  (declare (type (signed-byte 32) size))
 142                  (if (eq size -1)
 143                      :null
 144                      (funcall (interpreter-reader (get-type-interpreter oid)) stream size))))))
 145
 146 ;; "row" types
 147 (defparameter *read-row-values-as-binary* nil
 148   "Controls whether row values (as in select row(1, 'foo') ) should be
 149   received from the database in text or binary form. The default value
 150   is nil, specifying that the results be sent back as text. Set this
 151   to t to cause the results to be read as binary.")
 152
 153 (set-sql-reader 2249 #'read-row-value :binary-p (lambda () *read-row-values-as-binary*))
 154
 155 (defmacro with-binary-row-values (&body body)
 156   "Helper macro to locally set *read-row-values-as-binary* to t while
 157 executing body so that row values will be returned as binary."
 158   `(let ((*read-row-values-as-binary* t))
 159     ,@body))
 160
 161 (defmacro with-text-row-values (&body body)
 162   "Helper macro to locally set *read-row-values-as-binary* to nil while
 163 executing body so that row values will be returned as t."
 164   `(let ((*read-row-values-as-binary* nil))
 165     ,@body))
 166
 167 (defun read-binary-bits (stream size)
 168   (declare (type stream stream)
 169            (type integer size))
 170   (let ((byte-count (- size 4))
 171         (bit-count (read-uint4 stream)))
 172     (let ((bit-bytes (read-bytes stream byte-count))
 173           (bit-array (make-array (list bit-count) :element-type 'bit)))
 174       (loop for i below bit-count
 175          do (let ((cur-byte (ash i -3))
 176                   (cur-bit (ldb (byte 3 0) i)))
 177               (setf (aref bit-array i)
 178                     (ldb (byte 1 (logxor cur-bit 7)) (aref bit-bytes cur-byte)))))
 179       bit-array)))
 180
 181 (set-sql-reader 1560 #'read-binary-bits :binary-p t)
 182 (set-sql-reader 1562 #'read-binary-bits :binary-p t)
 183
 184 (defun read-binary-array-value (stream size)
 185   (declare (type stream stream)
 186            (type integer size)
 187            (ignore size))
 188   (let ((num-dims (read-uint4 stream))
 189         (has-null (read-uint4 stream))
 190         (element-type (read-uint4 stream)))
 191      (cond
 192       ((zerop num-dims)
 193        ;; Should we return nil or a (make-array nil) when num-dims is
 194        ;; 0? Returning nil for now.
 195        nil)
 196       (t
 197        (let* ((array-dims
 198                (loop for i below num-dims
 199                   collect (let ((dim (read-uint4 stream))
 200                                 (lb (read-uint4 stream)))
 201                             (declare (ignore lb))
 202                             dim)))
 203               (num-items (reduce #'* array-dims)))
 204          (let ((results (make-array array-dims)))
 205            (loop for i below num-items
 206               do (let ((size (read-int4 stream)))
 207                    (declare (type (signed-byte 32) size))
 208                    (setf (row-major-aref results i)
 209                          (if (eq size -1)
 210                              :null
 211                              (funcall (interpreter-reader (get-type-interpreter element-type)) stream size)))))
 212            results))))))
 213
 214 (dolist (oid '(
 215                1000 ;; boolean array
 216                1001 ;; bytea array
 217                1002 ;; char array
 218                1003 ;; name (internal PG type) array
 219                1005 ;; int2 array
 220                1007 ;; integer array
 221                1009 ;; text array
 222                1014 ;; bpchar array
 223                1015 ;; varchar array
 224                1016 ;; int8 array
 225                1017 ;; point array
 226                1018 ;; lseg array
 227                1020 ;; box array
 228                1021 ;; float4 array
 229                1022 ;; float8 array
 230                1028 ;; oid array
 231                1115 ;; timestamp array
 232                1182 ;; date array
 233                1187 ;; interval array
 234                1561 ;; bit array
 235                1563 ;; varbit array
 236                1231 ;; numeric array
 237                ))
 238   (set-sql-reader oid #'read-binary-array-value :binary-p t))
 239
 240 ;; 2287 record array
 241 ;;
 242 ;; NOTE: need to treat this separately because if we want the record
 243 ;; (row types) to come back as text, we have to read the array value
 244 ;; as text.
 245 (set-sql-reader oid:+record-array+ #'read-binary-array-value :binary-p (lambda () *read-row-values-as-binary*))
 246
 247 (define-interpreter oid:+point+ "point" ((point-x-bits uint 8)
 248                                  (point-y-bits uint 8))
 249   (list (cl-postgres-ieee-floats:decode-float64 point-x-bits)
 250         (cl-postgres-ieee-floats:decode-float64 point-y-bits)))
 251
 252 (define-interpreter oid:+lseg+ "lseg" ((point-x1-bits uint 8)
 253                                 (point-y1-bits uint 8)
 254                                 (point-x2-bits uint 8)
 255                                 (point-y2-bits uint 8))
 256   (list (list (cl-postgres-ieee-floats:decode-float64 point-x1-bits)
 257               (cl-postgres-ieee-floats:decode-float64 point-y1-bits))
 258         (list (cl-postgres-ieee-floats:decode-float64 point-x2-bits)
 259               (cl-postgres-ieee-floats:decode-float64 point-y2-bits))))
 260
 261 (define-interpreter oid:+box+ "box" ((point-x1-bits uint 8)
 262                                (point-y1-bits uint 8)
 263                                (point-x2-bits uint 8)
 264                                (point-y2-bits uint 8))
 265   (list (list (cl-postgres-ieee-floats:decode-float64 point-x1-bits)
 266               (cl-postgres-ieee-floats:decode-float64 point-y1-bits))
 267         (list (cl-postgres-ieee-floats:decode-float64 point-x2-bits)
 268               (cl-postgres-ieee-floats:decode-float64 point-y2-bits))))
 269
 270 (define-interpreter 700 "float4" ((bits uint 4))
 271   (cl-postgres-ieee-floats:decode-float32 bits))
 272 (define-interpreter 701 "float8" ((bits uint 8))
 273   (cl-postgres-ieee-floats:decode-float64 bits))
 274
 275 ;; Numeric types are rather involved. I got some clues on their
 276 ;; structure from http://archives.postgresql.org/pgsql-interfaces/2004-08/msg00000.php
 277 (define-interpreter 1700 "numeric"
 278     ((length uint 2)
 279      (weight int 2)
 280      (sign int 2)
 281      (dscale int 2)
 282      (digits uint2s))
 283   (declare (ignore dscale))
 284   (let ((total (loop :for i :from (1- length) :downto 0
 285                      :for scale = 1 :then (* scale #.(expt 10 4))
 286                      :summing (* scale (elt digits i))))
 287         (scale (- length weight 1)))
 288     (unless (zerop sign)
 289       (setf total (- total)))
 290     (/ total (expt 10000 scale))))
 291
 292 ;; Since date and time types are the most likely to require custom
 293 ;; readers, there is a hook for easily adding binary readers for them.
 294
 295 (defun set-date-reader (f table)
 296   (set-sql-reader 1082 (binary-reader ((days int 4))
 297                          (funcall f days))
 298                   :table table
 299                   :binary-p t))
 300
 301 (defun interpret-usec-bits (bits)
 302   "Decode a 64 bit time-related value based on the timestamp format
 303 used. Correct for sign bit when using integer format."
 304   (ecase *timestamp-format*
 305     (:float (round (* (cl-postgres-ieee-floats:decode-float64 bits) 1000000)))
 306     (:integer (if (logbitp 63 bits)
 307                   (dpb bits (byte 63 0) -1)
 308                   bits))))
 309
 310 (defun set-interval-reader (f table)
 311   (set-sql-reader 1186 (binary-reader ((usec-bits uint 8) (days int 4) (months int 4))
 312                          (funcall f months days (interpret-usec-bits usec-bits)))
 313                   :table table
 314                   :binary-p t))
 315
 316 (defun set-usec-reader (oid f table)
 317   (set-sql-reader oid (binary-reader ((usec-bits uint 8))
 318                         (funcall f (interpret-usec-bits usec-bits)))
 319                   :table table
 320                   :binary-p t))
 321
 322 ;; Public interface for adding date/time readers
 323
 324 (defconstant +timestamp-oid+ 1114)
 325 (defconstant +timestamptz-oid+ 1184)
 326 (defconstant +time-oid+ 1083)
 327
 328 (defun set-sql-datetime-readers (&key date timestamp timestamp-with-timezone interval time
 329                                  (table *sql-readtable*))
 330   (when date (set-date-reader date table))
 331   (when timestamp (set-usec-reader +timestamp-oid+ timestamp table))
 332   (when timestamp-with-timezone (set-usec-reader +timestamptz-oid+ timestamp-with-timezone table))
 333   (when interval (set-interval-reader interval table))
 334   (when time (set-usec-reader +time-oid+ time table))
 335   table)
 336
 337 ;; Provide meaningful defaults for the date/time readers.
 338
 339 (defconstant +start-of-2000+ (encode-universal-time 0 0 0 1 1 2000 0))
 340 (defconstant +seconds-in-day+ (* 60 60 24))
 341
 342 (set-sql-datetime-readers
 343  :date (lambda (days-since-2000)
 344          (+ +start-of-2000+ (* days-since-2000 +seconds-in-day+)))
 345  :timestamp (lambda (useconds-since-2000)
 346               (+ +start-of-2000+ (floor useconds-since-2000 1000000)))
 347  :timestamp-with-timezone (lambda (useconds-since-2000)
 348                             (+ +start-of-2000+ (floor useconds-since-2000 1000000)))
 349  :interval (lambda (months days useconds)
 350              (multiple-value-bind (sec us) (floor useconds 1000000)
 351                `((:months ,months) (:days ,days) (:seconds ,sec) (:useconds ,us))))
 352  :time (lambda (usecs)
 353          (multiple-value-bind (seconds usecs)
 354              (floor usecs 1000000)
 355            (multiple-value-bind (minutes seconds)
 356                (floor seconds 60)
 357              (multiple-value-bind (hours minutes)
 358                  (floor minutes 60)
 359                `((:hours ,hours) (:minutes ,minutes) (:seconds ,seconds) (:microseconds ,usecs)))))))
 360
 361 ;; Readers for a few of the array types
 362
 363 (defun read-array-value (transform)
 364   (declare #.*optimize*)
 365   (lambda (value)
 366     (declare (type string value))
 367     (let ((pos 0))
 368       (declare (type fixnum pos))
 369       (labels ((readelt ()
 370                  (case (char value pos)
 371                    (#\" (interpret
 372                          (with-output-to-string (out)
 373                            (loop :with escaped := nil :for ch := (char value (incf pos)) :do
 374                               (when (and (char= ch #\") (not escaped)) (return))
 375                               (setf escaped (and (not escaped) (char= ch #\\)))
 376                               (unless escaped (write-char ch out)))
 377                            (incf pos))))
 378                    (#\{ (incf pos)
 379                         (unless (char= (char value pos) #\})
 380                           (loop :for val := (readelt) :collect val :into vals :do
 381                              (let ((next (char value pos)))
 382                                (incf pos)
 383                                (ecase next (#\,) (#\} (return vals)))))))
 384                    (t (let ((start pos))
 385                         (loop :for ch := (char value pos) :do
 386                            (when (or (char= ch #\,) (char= ch #\}))
 387                              (return (interpret (subseq value start pos))))
 388                            (incf pos))))))
 389                (interpret (word)
 390                  (if (string= word "NULL") :null (funcall transform word))))
 391         (let* ((arr (readelt))
 392                (dim (if arr (loop :for x := arr :then (car x) :while (consp x) :collect (length x)) '(0))))
 393           (make-array dim :initial-contents arr))))))
 394
 395 ;; Working with tables.
 396
 397 (defun copy-sql-readtable (&optional (table *sql-readtable*))
 398   (let ((new-table (make-hash-table)))
 399     (maphash (lambda (oid interpreter) (setf (gethash oid new-table) interpreter))
 400              table)
 401     new-table))
 402
 403 (defparameter *default-sql-readtable* (copy-sql-readtable *sql-readtable*)
 404   "A copy of the default readtable that client code can fall back
 405   on.")
 406
 407 (defun default-sql-readtable ()
 408   *default-sql-readtable*)