;;; parsers.lisp -- type coercion support
;;;
;;; Author: Eric Marsden <eric.marsden@free.fr>
;;
;;
;; When returning data from a SELECT statement, PostgreSQL starts by
;; sending some metadata describing the attributes. This information
;; is read by `PG:READ-ATTRIBUTES', and consists of each attribute's
;; name (as a string), its size (in bytes), and its type (as an oid
;; which points to a row in the PostgreSQL system table pg_type). Each
;; row in pg_type includes the type's name (as a string).
;;
;; We are able to parse a certain number of the PostgreSQL types (for
;; example, numeric data is converted to a numeric Common Lisp type,
;; dates are converted to the CL date representation, booleans to
;; lisp booleans). However, there isn't a fixed mapping from a
;; type to its OID which is guaranteed to be stable across database
;; installations, so we need to build a table mapping OIDs to parser
;; functions.
;;
;; This is done by the procedure `PG:INITIALIZE-PARSERS', which is run
;; the first time a connection is initiated with the database from
;; this invocation of CL, and which issues a SELECT statement to
;; extract the required information from pg_type. This initialization
;; imposes a slight overhead on the first request, which you can avoid
;; by setting `*PG-DISABLE-TYPE-COERCION*' to non-nil if it bothers you.
;; ====================================================================


;;; TODO ============================================================
;;
;; * add a mechanism for parsing user-defined types. The user should
;;   be able to define a parse function and a type-name; we query
;;   pg_type to get the type's OID and add the information to
;;   pg:*parsers*.
;;


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


(in-package :postgresql)


(defvar *pg-disable-type-coercion* nil
  "Non-nil disables the type coercion mechanism.
The default is nil, which means that data recovered from the
database is coerced to the corresponding Common Lisp type before
being returned; for example numeric data is transformed to CL
numbers, and booleans to booleans.

The coercion mechanism requires an initialization query to the
database, in order to build a table mapping type names to OIDs. This
option is provided mainly in case you wish to avoid the overhead of
this initial query. The overhead is only incurred once per session
(not per connection to the backend).")

;; alist of (oid . parser) pairs. This is built dynamically at
;; initialization of the connection with the database (once generated,
;; the information is shared between connections).
;; (defvar *parsers* '())


(defvar *type-to-oid*
  (make-hash-table :test #'eq)
  "Is a hashtable for turning a typename into a OID.
Needed to define the type of objects in pg-prepare")

(defvar *oid-to-type*
  (make-hash-table :test #'eq))


(defgeneric parse-value (data type))

(defgeneric serialize-value (value type connection))

;; possibly also need serialize-value/text to serialize to a format that you could
;; include in an SQL statement

(defgeneric generate-random-value (type))



;; (defmacro define-postgresql-type (name &key parse-function serialize-function generate-random)
;;   (let ((dispatch-name 
;;   `(DEFMETHOD PARSE-VALUE ((DATA STRING) (TYPE (EQL ,


;; see `man pgbuiltin' for details on PostgreSQL builtin types
;;
;; === http://developer.postgresql.org/cvsweb.cgi/pgsql/src/backend/utils/adt/

;; fallback parser 
(defmethod parse-value ((data string) type)
  (declare (ignore type))
  data)

;; == bool type === 
(defmethod parse-value ((data string) (type (eql :bool)))
  (cond ((string= "t" data) t)
        ((string= "f" data) nil)
        (t (error 'protocol-error
                  :reason "Badly formed boolean from backend: ~s" data))))

(defmethod serialize-value ((value t) (type (eql :bool)) connection)
  (declare (ignore connection))
  (values :byte 1 (if value 1 0)))

(defmethod generate-random-value ((type (eql :bool)))
  (if (> (random 2) 0) t nil))


;;; == char type
(defmethod parse-value ((data string) (type (eql :char)))
  (char data 0))

(defmethod serialize-value ((value character) (type (eql :char)) connection)
  (serialize-value (string value) :text connection))

(defmethod generate-random-value ((type (eql :char)))
  (code-char (random 256)))

;; == text type. This is not a NUL-terminated string, so send exactly
;; the string length rather than 1+ the length
(defmethod parse-value ((data string) (type (eql :text)))
  data)

(defmethod serialize-value ((value string) (type (eql :text)) connection)
  (let ((converted (cond ((pg-client-encoding connection)
                          (convert-string-to-bytes value (pg-client-encoding connection)))
                         (t value))))
    (values :rawdata (length converted) converted)))

(defmethod generate-random-value ((type (eql :text)))
  (coerce (loop :for i :below 100 :collect (generate-random-value :char)) 'string))


(defmethod parse-value ((data string) (type (eql :varchar)))
  data)

(defmethod serialize-value ((value string) (type (eql :varchar)) connection)
  (serialize-value value :text connection))

(defmethod generate-random-value ((type (eql :varchar)))
  (generate-random-value :text))


(defmethod parse-value ((value string) (type (eql :int2)))
  (parse-integer value))

(defmethod serialize-value ((value integer) (type (eql :int2)) connection)
  (declare (ignore connection))
  (values :int16 2 value))

(defmethod generate-random-value ((type (eql :int2)))
  (random (expt 2 16)))

(defmethod parse-value ((value string) (type (eql :int4)))
  (parse-integer value))

(defmethod serialize-value ((value integer) (type (eql :int4)) connection)
  (declare (ignore connection))
  (values :int32 4 value))

(defmethod generate-random-value ((type (eql :int4)))
  (random (expt 2 32)))

(defmethod parse-value ((value string) (type (eql :int8)))
  (parse-integer value))

;; being lazy: send as a string rather than encoding in binary
(defmethod serialize-value ((value integer) (type (eql :int8)) connection)
  (declare (ignore connection))
  (let ((text (princ-to-string value)))
    (values :string (length text) text)))

(defmethod generate-random-value ((type (eql :int8)))
  (random (expt 2 35)))

(defmethod parse-value ((value string) (type (eql :oid)))
  (parse-integer value))

(defmethod serialize-value ((value integer) (type (eql :oid)) connection)
  (declare (ignore connection))
  (values :int32 4 value))

(defmethod generate-random-value ((type (eql :oid)))
  42)

;; from Risto Sakari Laakso <rlaakso@cc.hut.fi>
;; 
;; http://www.postgresql.org/docs/7.4/static/datatype.html#DATATYPE-NUMERIC-DECIMAL
;; 
;; NUMERIC(precision, scale)
;; 
;; The scale of a numeric is the count of decimal digits in the
;; fractional part, to the right of the decimal point. The precision of a
;; numeric is the total count of significant digits in the whole number, that
;; is, the number of digits to both sides of the decimal point.
(defmethod parse-value ((data string) (type (eql :numeric)))
  (let ((dot-pos (position #\. data))
        integer-part
        (decimal-part 0))
    ;; parse up to #\., or whole string if #\. not present 
    (setq integer-part (parse-integer (subseq data 0 dot-pos)))
    ;; if #\. present ..
    (when dot-pos
      (let* ((decimal-str (subseq data (1+ dot-pos)))
             (dec-str-len (length decimal-str)))
        ;; if has at least one digit after #\.
        (when (> dec-str-len 0)
          ;; parse integer after #\. and divide by 10^(digits), i.e. ".023" => 23/1000
          (setq decimal-part (/ (parse-integer decimal-str) (expt 10 dec-str-len))))))
    (+ integer-part decimal-part)))

;; http://developer.postgresql.org/cvsweb.cgi/pgsql/src/backend/utils/adt/numeric.c?only_with_tag=HEAD
;;
;; We are taking the easy way out and using the textual format for
;; this type, rather than the binary format specified above that is
;; tied to PostgreSQL's internal representation of NUMERIC data
;;
;; FIXME should handle NaN specially
(defmethod serialize-value ((value number) (type (eql :numeric)) connection)
  (serialize-value (princ-to-string value) :text connection))

(defmethod generate-random-value ((type (eql :numeric)))
  (float (/ (random (expt 2 32)) 1000) 100000.0))


;; http://developer.postgresql.org/cvsweb.cgi/pgsql/src/backend/utils/adt/float.c?rev=1.130
;;
;; FIXME should check for "NaN", "Infinity", "-Infinity"
(defmethod parse-value ((value string) (type (eql :float4)))
  (let ((*read-eval* nil))
    (read-from-string value)))

;; for now cheat and use the text format
(defmethod serialize-value ((value number) (type (eql :float4)) connection)
  (serialize-value (princ-to-string value) :text connection))

(defmethod generate-random-value ((type (eql :float4)))
  (float (/ (random (expt 2 32)) 1000) 100000.0))

;; FIXME should check for "NaN", "Infinity", "-Infinity"
(defmethod parse-value ((value string) (type (eql :float8)))
  (let ((*read-eval* nil))
    (read-from-string value)))

;; for now cheat and use the text format
(defmethod serialize-value ((value number) (type (eql :float8)) connection)
  (serialize-value (princ-to-string value) :text connection))

(defmethod generate-random-value ((type (eql :float8)))
  (float (/ (random (expt 2 32)) 1000) 100000.0))


(defmethod serialize-value ((value number) (type (eql :money)) connection)
  (serialize-value (princ-to-string value) :text connection))

(defmethod generate-random-value ((type (eql :money)))
  (random (expt 2 32)))


;; http://www.postgresql.org/docs/8.1/interactive/sql-expressions.html#SQL-SYNTAX-ROW-CONSTRUCTORS
;;
;; these are in the format "(foo,bar,baz)"
(defmethod parse-value ((data string) (type (eql :record)))
  (assert (char= #\( (char data 0)))
  (loop :with start = 1
        :with last = (- (length data) 1)
        :for end = (or (position #\, data :start start) last)
        :collect (subseq data start end)
        :do (setq start (1+ end))
        :until (>= end last)))

(defmethod serialize-value ((data list) (type (eql :record)) connection)
  (serialize-value (format nil "(~{~A~^,~})" data) :text connection))

(defmethod generate-random-value ((type (eql :record)))
  (list 1 2 3))


;; === timestamps etc

;; format for abstime/timestamp etc with ISO output syntax is
;;
;;    "1999-01-02 05:11:23.0345645+01"
;;
;; which we convert to a CL universal time. Thanks to James Anderson
;; for a fix for timestamp format in PostgreSQL 7.3 (with or without
;; tz, with or without milliseconds).
(defun parse-timestamp (str)
  (declare (type simple-string str))
  (let* ((year (parse-integer str :start 0 :end 4))
         (month (parse-integer str :start 5 :end 7))
         (day (parse-integer str :start 8 :end 10))
         (hours (parse-integer str :start 11 :end 13))
         (minutes (parse-integer str :start 14 :end 16))
         (seconds (parse-integer str :start 17 :end 19))
         (length (length str))
         (start-tz (if (find (char str (- length 3)) "+-")
                       (- length 3)))
         (tz (when start-tz
               (parse-integer str :start start-tz)))
         (milliseconds (if (and (< 19 length) (eql (char str 19) #\.))
                           (parse-integer str :start 20 :end start-tz)
                           0)))
    (values year month day hours minutes seconds milliseconds tz)))

(defmethod parse-value ((data string) (type (eql :timestamp)))
  ;; Test for the special values 'infinity' and '-infinity'
  (cond ((digit-char-p (schar data 0))
         (multiple-value-bind (year month day hours minutes seconds milliseconds)
             (parse-timestamp data)
           (values (encode-universal-time seconds minutes hours day month year)
                   milliseconds)))
	((equal data "infinity") :infinity)
	((equal data "-infinity") :-infinity)
	(t (error "Unknown special timestamp value ~A" data))))

;; FIXME
(defmethod serialize-value ((data integer) (type (eql :timestamp)) connection)
  (serialize-value (convert-to-iso8861 data) :text connection))

(defmethod generate-random-value ((type (eql :timestamp)))
  (generate-random-value :date))

(defmethod parse-value ((data string) (type (eql :abstime)))
  (parse-value data :timestamp))

(defmethod generate-random-value ((type (eql :abstime)))
  (encode-universal-time (random 60)
                         (random 60)
                         (random 24)
                         (1+ (random 28)) ; date
                         (1+ (random 12)) ; month
                         (random 99))) ; year

(defmethod parse-value ((data string) (type (eql :timestampz)))
  (parse-value data :timestamp))

(defmethod generate-random-value ((type (eql :timestampz)))
  (generate-random-value :abstime))

(defmethod parse-value ((data string) (type (eql :datetime)))
  (parse-value data :timestamp))

(defmethod generate-random-value ((type (eql :datetime)))
  (generate-random-value :abstime))


;; An interval is what you get when you subtract two timestamps. We
;; convert to a number of seconds.
(defmethod parse-value ((data string) (type (eql :interval)))
  (let* ((hours (parse-integer data :start 0 :end 2))
         (minutes (parse-integer data :start 3 :end 5))
         (seconds (parse-integer data :start 6 :end 8))
         (milliseconds (parse-integer data :start 9)))
    (+ (/ milliseconds (expt 10.0 (- (length data) 9)))
       seconds
       (* 60 minutes)
       (* 60 60 hours))))

(defmethod generate-random-value ((type (eql :interval)))
  (random 60))

(defmethod parse-value ((data string) (type (eql :tinterval)))
  (parse-value data :interval))

(defmethod generate-random-value ((type (eql :tinterval)))
  (random 60))

(defmethod parse-value ((data string) (type (eql :timespan)))
  (parse-value data :interval))

(defmethod generate-random-value ((type (eql :timespan)))
  (generate-random-value :tinterval))


;; FIXME currently not used
;;
;; format for abstime/timestamp etc with ISO output syntax is
;;;    "1999-01-02 00:00:00+01"
;; which we convert to a CL universal time
(defun isodate-parser (data)
  (let ((year    (parse-integer data :start 0 :end 4))
        (month   (parse-integer data :start 5 :end 7))
        (day     (parse-integer data :start 8 :end 10))
        (hours   (parse-integer data :start 11 :end 13))
        (minutes (parse-integer data :start 14 :end 16))
        (seconds (parse-integer data :start 17 :end 19))
        (tz      (parse-integer data :start 19 :end 22)))
    (encode-universal-time seconds minutes hours day month year tz)))



;; format for date with ISO output syntax is
;;;    "1999-01-02"
;; which we convert to a CL universal time
(defmethod parse-value ((data string) (type (eql :date)))
  (let ((year    (parse-integer data :start 0 :end 4))
        (month   (parse-integer data :start 5 :end 7))
        (day     (parse-integer data :start 8 :end 10)))
    (encode-universal-time 0 0 0 day month year)))

(defmethod generate-random-value ((type (eql :date)))
  (generate-random-value :abstime))

;; FIXME: if we wanted to parse array data correctly, we would need to
;; define parsers for each array element-type, such as "_bool" for
;; arrays of booleans, "_int2" for arrays of int2 etc. Currently we
;; don't attempt to parse arrays.



(defun my-eql-specializer (type)
  #+openmcl (ccl::intern-eql-specializer type)
  #+sbcl (list 'eql type)
  #+cmu (list 'eql type))


(defun initialize-parsers (connection)
  (setf *type-to-oid* (clrhash *type-to-oid*))
  (setf *oid-to-type* (clrhash *oid-to-type*))
  (let* ((pgtypes (pg-exec connection "SELECT typname,oid FROM pg_type"))
         (tuples (pg-result pgtypes :tuples)))
    (loop :for (typname oid/text) :in tuples :do
          (let ((type (intern (string-upcase typname) :keyword))
                (oid (parse-integer oid/text)))
            (when (find-method #'parse-value nil `(,(find-class 'string) ,(my-eql-specializer type)) nil)
              (setf (gethash type *type-to-oid*) oid)
              (setf (gethash oid *oid-to-type*) type))))))


;; FIXME should perhaps resignal parse errors as a condition derived
;; from POSTGRESQL-ERROR
(defun parse (str oid)
  (declare (type simple-string str))
  (parse-value str (gethash oid *oid-to-type*)))

(defun lookup-type (type-name)
  "Given the name of a type, returns the oid of the type or NIL if
not found"
  (let ((type (etypecase type-name
                (symbol type-name)
                (string (intern (string-upcase type-name) :keyword)))))
    (gethash type *type-to-oid*)))



;; PQescapeBytea - converts from binary string to the minimal encoding
;; necessary to include the string in an SQL INSERT statement with a
;; bytea type column as the target.
;; 
;; The following transformations are applied
;; '\0' == ASCII  0 == \000
;; '\'' == ASCII 39 == ''
;; '\\' == ASCII 92 == \\
;; anything < 0x20, or > 0x7e ---> \ooo
;; 								(where ooo is an octal expression)
;; If not std_strings, all backslashes sent to the output are doubled.
;;
;; http://www.postgresql.org/docs/8.1/static/datatype-binary.html
(defun bytea->string (data)
  (declare (type (vector (unsigned-byte 8) *) data))
  (with-output-to-string (out)
    (loop :for octet :across data :do
          (cond ((<= 32 octet 126)
                 (write-char (code-char octet) out))
                (t
                 (format out "\\~3,'0O" octet))))))


;; EOF
