;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:     postgresql-socket-sql.sql
;;;; Purpose:  High-level PostgreSQL interface using socket
;;;; Authors:  Kevin M. Rosenberg based on original code by Pierre R. Mai
;;;; Created:  Feb 2002
;;;;
;;;; $Id$
;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2002-2007 by Kevin M. Rosenberg
;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
;;;;
;;;; CLSQL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************

(in-package #:cl-user)

(defpackage :clsql-postgresql-socket3
    (:use #:common-lisp #:clsql-sys #:postgresql-socket3)
    (:export #:postgresql-socket3-database)
    (:documentation "This is the CLSQL socket interface (protocol version 3) to PostgreSQL."))

(in-package #:clsql-postgresql-socket3)

(defvar *sqlreader* (cl-postgres:copy-sql-readtable))
(let ((dt-fn (lambda (useconds-since-2000)
	       (let ((sec (truncate
			   (/ useconds-since-2000
			      1000000)))
		     (usec (mod useconds-since-2000
				1000000)))
		 (clsql:make-time :year 2000 :second sec :usec usec)))))
  (cl-postgres:set-sql-datetime-readers
   :table *sqlreader*
   :date (lambda (days-since-2000)
	   (clsql:make-date :year 2000 :day (+ 1 days-since-2000)))
   :timestamp dt-fn
   :timestamp-with-timezone dt-fn))



;; interface foreign library loading routines

(clsql-sys:database-type-load-foreign :postgresql-socket3)


(defmethod database-initialize-database-type ((database-type
                                               (eql :postgresql-socket3)))
  t)


;; Field type conversion
(defun convert-to-clsql-warning (database condition)
  (ecase *backend-warning-behavior*
    (:warn
     (warn 'sql-database-warning :database database
           :message (cl-postgres:database-error-message condition)))
    (:error
     (error 'sql-database-error :database database
            :message (format nil "Warning upgraded to error: ~A"
                             (cl-postgres:database-error-message condition))))
    ((:ignore nil)
     ;; do nothing
     )))

(defun convert-to-clsql-error (database expression condition)
  (error 'sql-database-data-error
         :database database
         :expression expression
         :error-id (type-of condition)
         :message (cl-postgres:database-error-message condition)))

(defmacro with-postgresql-handlers
    ((database &optional expression)
     &body body)
  (let ((database-var (gensym))
        (expression-var (gensym)))
    `(let ((,database-var ,database)
           (,expression-var ,expression))
       (handler-bind ((postgresql-warning
                       (lambda (c)
                         (convert-to-clsql-warning ,database-var c)))
                      (cl-postgres:database-error
                       (lambda (c)
                         (convert-to-clsql-error
                          ,database-var ,expression-var c))))
         ,@body))))



(defclass postgresql-socket3-database (generic-postgresql-database)
  ((connection :accessor database-connection :initarg :connection
               :type cl-postgres:database-connection)))

(defmethod database-type ((database postgresql-socket3-database))
  :postgresql-socket3)

(defmethod database-name-from-spec (connection-spec (database-type (eql :postgresql-socket3)))
  (check-connection-spec connection-spec database-type
                         (host db user password &optional port options tty))
  (destructuring-bind (host db user password &optional port options tty)
      connection-spec
    (declare (ignore password options tty))
    (concatenate 'string
      (etypecase host
        (null
         "localhost")
        (keyword "unix")
        (pathname (namestring host))
        (string host))
      (when port
        (concatenate 'string
                     ":"
                     (etypecase port
                       (integer (write-to-string port))
                       (string port))))
      "/" db "/" user)))

(defmethod database-connect (connection-spec
                             (database-type (eql :postgresql-socket3)))
  (check-connection-spec connection-spec database-type
                         (host db user password &optional port options tty))
  (destructuring-bind (host db user password &optional
                            (port +postgresql-server-default-port+)
                            (options "") (tty ""))
      connection-spec
    (declare (ignore options tty))
    (handler-case
        (handler-bind ((warning
                        (lambda (c)
                          (warn 'sql-warning
                                :format-control "~A"
                                :format-arguments
                                (list (princ-to-string c))))))
          (cl-postgres:open-database db user password host port))
      (cl-postgres:database-error (c)
        ;; Connect failed
        (error 'sql-connection-error
               :database-type database-type
               :connection-spec connection-spec
               :error-id (type-of c)
               :message (cl-postgres:database-error-message c)))
      (:no-error (connection)
                 ;; Success, make instance
                 (make-instance 'postgresql-socket3-database
                                :name (database-name-from-spec connection-spec database-type)
                                :database-type :postgresql-socket3
                                :connection-spec connection-spec
                                :connection connection)))))

(defmethod database-disconnect ((database postgresql-socket3-database))
  (cl-postgres:close-database (database-connection database))
  t)

(defvar *include-field-names* nil)


;; THE FOLLOWING MACRO EXPANDS TO THE FUNCTION BELOW IT,
;; BUT TO GET null CONVENTIONS CORRECT I NEEDED TO TWEAK THE EXPANSION
;;
;; (cl-postgres:def-row-reader clsql-default-row-reader (fields)
;;   (values (loop :while (cl-postgres:next-row)
;; 		:collect (loop :for field :across fields
;; 			       :collect (cl-postgres:next-field field)))
;; 	  (when *include-field-names*
;; 	    (loop :for field :across fields
;; 		  :collect (cl-postgres:field-name field)))))



(defun clsql-default-row-reader (stream fields)
  (declare (type stream stream)
           (type (simple-array cl-postgres::field-description) fields))
  (flet ((cl-postgres:next-row ()
	   (cl-postgres::look-for-row stream))
	 (cl-postgres:next-field (cl-postgres::field)
	   (declare (type cl-postgres::field-description cl-postgres::field))
	   (let ((cl-postgres::size (cl-postgres::read-int4 stream)))
	     (declare (type (signed-byte 32) cl-postgres::size))
	     (if (eq cl-postgres::size -1)
		 nil
		 (funcall (cl-postgres::field-interpreter cl-postgres::field)
			  stream cl-postgres::size)))))
    (let ((results (loop :while (cl-postgres:next-row)
			 :collect (loop :for field :across fields
					:collect (cl-postgres:next-field field))))
	  (col-names (when *include-field-names*
		       (loop :for field :across fields
			     :collect (cl-postgres:field-name field)))))
      ;;multiple return values were not working here
      (list results col-names))))

(defmethod database-query ((expression string) (database postgresql-socket3-database) result-types field-names)
  (let ((connection (database-connection database))
	(cl-postgres:*sql-readtable* *sqlreader*))
    (with-postgresql-handlers (database expression)
      (let ((*include-field-names* field-names))
	(apply #'values (cl-postgres:exec-query connection expression #'clsql-default-row-reader)))
      )))

(defmethod query ((obj command-object) &key (database *default-database*)
                  (result-types :auto) (flatp nil) (field-names t))
  (clsql-sys::record-sql-command
   (format nil "~&~A~&{Params: ~{~A~^, ~}}"
           (expression obj)
           (parameters obj))
   database)
  (multiple-value-bind (rows names)
      (database-query obj database result-types field-names)
    (let ((result (if (and flatp (= 1 (length (car rows))))
                      (mapcar #'car rows)
		      rows)))
      (clsql-sys::record-sql-result result database)
      (if field-names
          (values result names)
	  result))))

(defmethod database-query ((obj command-object) (database postgresql-socket3-database) result-types field-names)
  (let ((connection (database-connection database))
	(cl-postgres:*sql-readtable* *sqlreader*))
    (with-postgresql-handlers (database obj)
      (let ((*include-field-names* field-names))
	(unless (has-been-prepared obj)
	  (cl-postgres:prepare-query connection (prepared-name obj) (expression obj))
	  (setf (has-been-prepared obj) T))
	(apply #'values (cl-postgres:exec-prepared
			 connection
			 (prepared-name obj)
			 (parameters obj)
			 #'clsql-default-row-reader))))))

(defmethod database-execute-command
    ((expression string) (database postgresql-socket3-database))
  (let ((connection (database-connection database)))
    (with-postgresql-handlers (database expression)
      ;; return row count?
      (second (multiple-value-list (cl-postgres:exec-query connection expression))))))

(defmethod execute-command ((obj command-object)
                            &key (database *default-database*))
  (clsql-sys::record-sql-command (expression obj) database)
  (let ((res (database-execute-command obj database)))
    (clsql-sys::record-sql-result res database)
    ;; return row count?
    res))

(defmethod database-execute-command
    ((obj command-object) (database postgresql-socket3-database))
  (let ((connection (database-connection database)))
    (with-postgresql-handlers (database obj)
      (unless (has-been-prepared obj)
	(cl-postgres:prepare-query connection (prepared-name obj) (expression obj))
	(setf (has-been-prepared obj) T))
      (second (multiple-value-list (cl-postgres:exec-prepared connection (prepared-name obj) (parameters obj)))))))

;;;; Cursoring interface


(defmethod database-query-result-set ((expression string)
                                      (database postgresql-socket3-database)
                                      &key full-set result-types)
  (declare (ignore result-types))
  (declare (ignore full-set))
  (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader"))

(defmethod database-dump-result-set (result-set
                                     (database postgresql-socket3-database))
  (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader")
  T)

(defmethod database-store-next-row (result-set
                                    (database postgresql-socket3-database)
                                    list)
  (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader"))


;;;;;;;;;;;;;;;;;;;;;;;;;;


(defmethod database-create (connection-spec (type (eql :postgresql-socket3)))
  (destructuring-bind (host name user password &optional port options tty) connection-spec
    (declare (ignore port options tty))
    (let ((database (database-connect (list host "postgres" user password)
                                      type)))
      (setf (slot-value database 'clsql-sys::state) :open)
      (unwind-protect
           (database-execute-command (format nil "create database ~A" name) database)
        (database-disconnect database)))))

(defmethod database-destroy (connection-spec (type (eql :postgresql-socket3)))
  (destructuring-bind (host name user password &optional port options tty) connection-spec
    (declare (ignore port options tty))
    (let ((database (database-connect (list host "postgres" user password)
                                      type)))
      (setf (slot-value database 'clsql-sys::state) :open)
      (unwind-protect
          (database-execute-command (format nil "drop database ~A" name) database)
        (database-disconnect database)))))


(defmethod database-probe (connection-spec (type (eql :postgresql-socket3)))
  (when (find (second connection-spec) (database-list connection-spec type)
              :test #'string-equal)
    t))


;; Database capabilities

(defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket3)))
  nil)

(defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket3)))
  t)

(defmethod db-type-default-case ((db-type (eql :postgresql-socket3)))
  :lower)

(defmethod database-underlying-type ((database postgresql-socket3-database))
  :postgresql)

(when (clsql-sys:database-type-library-loaded :postgresql-socket3)
  (clsql-sys:initialize-database-type :database-type :postgresql-socket3))


