db-postgresql-socket/postgresql-socket-sql.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:     postgresql-socket-sql.sql
   6 ;;;; Purpose:  High-level PostgreSQL interface using socket
   7 ;;;; Authors:  Kevin M. Rosenberg based on original code by Pierre R. Mai
   8 ;;;; Created:  Feb 2002
   9 ;;;;
  10 ;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
  11 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
  12 ;;;;
  13 ;;;; CLSQL users are granted the rights to distribute and use this software
  14 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  15 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  16 ;;;; *************************************************************************
  17
  18 (in-package #:cl-user)
  19
  20 (defpackage :clsql-postgresql-socket
  21     (:use #:common-lisp #:clsql-sys #:postgresql-socket)
  22     (:export #:postgresql-socket-database)
  23     (:documentation "This is the CLSQL socket interface to PostgreSQL."))
  24
  25 (in-package #:clsql-postgresql-socket)
  26
  27 ;; interface foreign library loading routines
  28
  29
  30 (clsql-sys:database-type-load-foreign :postgresql-socket)
  31
  32
  33 ;; Field type conversion
  34
  35 (defun make-type-list-for-auto (cursor)
  36   (let* ((fields (postgresql-cursor-fields cursor))
  37          (num-fields (length fields))
  38          (new-types '()))
  39     (dotimes (i num-fields)
  40       (declare (fixnum i))
  41       (push (canonical-field-type fields i) new-types))
  42     (nreverse new-types)))
  43
  44 (defun canonical-field-type (fields index)
  45   "Extracts canonical field type from fields list"
  46   (let ((oid (cadr (nth index fields))))
  47     (case oid
  48       ((#.pgsql-ftype#bytea
  49         #.pgsql-ftype#int2
  50         #.pgsql-ftype#int4)
  51        :int32)
  52       (#.pgsql-ftype#int8
  53        :int64)
  54       ((#.pgsql-ftype#float4
  55         #.pgsql-ftype#float8)
  56        :double)
  57       (otherwise
  58        t))))
  59
  60 (defun canonicalize-types (types cursor)
  61   (if (null types)
  62       nil
  63       (let ((auto-list (make-type-list-for-auto cursor)))
  64         (cond
  65           ((listp types)
  66            (canonicalize-type-list types auto-list))
  67           ((eq types :auto)
  68            auto-list)
  69           (t
  70            nil)))))
  71
  72 (defun canonicalize-type-list (types auto-list)
  73   "Ensure a field type list meets expectations.  Essentially if we get a
  74    generic term for a type that our auto typer pulls a better type for,
  75    use it instead"
  76   (let ((length-types (length types)))
  77     (loop for i from 0 below (length auto-list)
  78           for auto = (nth i auto-list)
  79           collect
  80        (if (or (>= i length-types)
  81                (member (nth i types) (list T :int :double)))
  82            auto
  83            (nth i types)))))
  84
  85
  86 (defun convert-to-clsql-warning (database condition)
  87   (ecase *backend-warning-behavior*
  88     (:warn
  89      (warn 'sql-database-warning :database database
  90            :message (postgresql-condition-message condition)))
  91     (:error
  92      (error 'sql-database-error :database database
  93             :message (format nil "Warning upgraded to error: ~A"
  94                              (postgresql-condition-message condition))))
  95     ((:ignore nil)
  96      ;; do nothing
  97      )))
  98
  99 (defun convert-to-clsql-error (database expression condition)
 100   (error 'sql-database-data-error
 101          :database database
 102          :expression expression
 103          :error-id (type-of condition)
 104          :message (postgresql-condition-message condition)))
 105
 106 (defmacro with-postgresql-handlers
 107     ((database &optional expression)
 108      &body body)
 109   (let ((database-var (gensym))
 110         (expression-var (gensym)))
 111     `(let ((,database-var ,database)
 112            (,expression-var ,expression))
 113        (handler-bind ((postgresql-warning
 114                        (lambda (c)
 115                          (convert-to-clsql-warning ,database-var c)))
 116                       (postgresql-error
 117                        (lambda (c)
 118                          (convert-to-clsql-error
 119                           ,database-var ,expression-var c))))
 120          ,@body))))
 121
 122 (defmethod database-initialize-database-type ((database-type
 123                                                (eql :postgresql-socket)))
 124   t)
 125
 126 (defclass postgresql-socket-database (generic-postgresql-database)
 127   ((connection :accessor database-connection :initarg :connection
 128                :type postgresql-connection)))
 129
 130 (defmethod database-type ((database postgresql-socket-database))
 131   :postgresql-socket)
 132
 133 (defmethod database-name-from-spec (connection-spec
 134                                     (database-type (eql :postgresql-socket)))
 135   (check-connection-spec connection-spec database-type
 136                          (host db user password &optional port options tty))
 137   (destructuring-bind (host db user password &optional port options tty)
 138       connection-spec
 139     (declare (ignore password options tty))
 140     (concatenate 'string
 141       (etypecase host
 142         (null
 143          "localhost")
 144         (pathname (namestring host))
 145         (string host))
 146       (when port
 147         (concatenate 'string
 148                      ":"
 149                      (etypecase port
 150                        (integer (write-to-string port))
 151                        (string port))))
 152       "/" db "/" user)))
 153
 154 (defmethod database-connect (connection-spec
 155                              (database-type (eql :postgresql-socket)))
 156   (check-connection-spec connection-spec database-type
 157                          (host db user password &optional port options tty))
 158   (destructuring-bind (host db user password &optional
 159                             (port +postgresql-server-default-port+)
 160                             (options "") (tty ""))
 161       connection-spec
 162     (handler-case
 163         (handler-bind ((postgresql-warning
 164                         (lambda (c)
 165                           (warn 'sql-warning
 166                                 :format-control "~A"
 167                                 :format-arguments
 168                                 (list (princ-to-string c))))))
 169           (open-postgresql-connection :host host :port port
 170                                       :options options :tty tty
 171                                       :database db :user user
 172                                       :password password))
 173       (postgresql-error (c)
 174         ;; Connect failed
 175         (error 'sql-connection-error
 176                :database-type database-type
 177                :connection-spec connection-spec
 178                :error-id (type-of c)
 179                :message (postgresql-condition-message c)))
 180       (:no-error (connection)
 181                  ;; Success, make instance
 182                  (make-instance 'postgresql-socket-database
 183                                 :name (database-name-from-spec connection-spec
 184                                                                database-type)
 185                                 :database-type :postgresql-socket
 186                                 :connection-spec connection-spec
 187                                 :connection connection)))))
 188
 189 (defmethod database-disconnect ((database postgresql-socket-database))
 190   (close-postgresql-connection (database-connection database))
 191   t)
 192
 193 (defmethod database-query (expression (database postgresql-socket-database) result-types field-names)
 194   (let ((connection (database-connection database)))
 195     (with-postgresql-handlers (database expression)
 196       (start-query-execution connection expression)
 197       (multiple-value-bind (status cursor)
 198           (wait-for-query-results connection)
 199         (unless (eq status :cursor)
 200           (close-postgresql-connection connection)
 201           (error 'sql-database-data-error
 202                  :database database
 203                  :expression expression
 204                  :error-id "missing-result"
 205                  :message "Didn't receive result cursor for query."))
 206         (setq result-types (canonicalize-types result-types cursor))
 207         (values
 208          (loop for row = (read-cursor-row cursor result-types)
 209                while row
 210                collect row
 211                finally
 212                (unless (null (wait-for-query-results connection))
 213                  (close-postgresql-connection connection)
 214                  (error 'sql-database-data-error
 215                         :database database
 216                         :expression expression
 217                         :error-id "multiple-results"
 218                         :message "Received multiple results for query.")))
 219          (when field-names
 220            (mapcar #'car (postgresql-cursor-fields cursor))))))))
 221
 222 (defmethod database-execute-command
 223     (expression (database postgresql-socket-database))
 224   (let ((connection (database-connection database)))
 225     (with-postgresql-handlers (database expression)
 226       (start-query-execution connection expression)
 227       (multiple-value-bind (status result)
 228           (wait-for-query-results connection)
 229         (when (eq status :cursor)
 230           (loop
 231             (multiple-value-bind (row stuff)
 232                 (skip-cursor-row result)
 233               (unless row
 234                 (setq status :completed result stuff)
 235                 (return)))))
 236         (cond
 237          ((null status)
 238           t)
 239          ((eq status :completed)
 240           (unless (null (wait-for-query-results connection))
 241              (close-postgresql-connection connection)
 242              (error 'sql-database-data-error
 243                     :database database
 244                     :expression expression
 245                     :error-id "multiple-results"
 246                     :message "Received multiple results for command."))
 247           result)
 248           (t
 249            (close-postgresql-connection connection)
 250            (error 'sql-database-data-error
 251                   :database database
 252                   :expression expression
 253                   :errno "missing-result"
 254                   :message "Didn't receive completion for command.")))))))
 255
 256 (defstruct postgresql-socket-result-set
 257   (done nil)
 258   (cursor nil)
 259   (types nil))
 260
 261 (defmethod database-query-result-set ((expression string)
 262                                       (database postgresql-socket-database)
 263                                       &key full-set result-types)
 264   (declare (ignore full-set))
 265   (let ((connection (database-connection database)))
 266     (with-postgresql-handlers (database expression)
 267       (start-query-execution connection expression)
 268       (multiple-value-bind (status cursor)
 269           (wait-for-query-results connection)
 270         (unless (eq status :cursor)
 271           (close-postgresql-connection connection)
 272           (error 'sql-database-data-error
 273                  :database database
 274                  :expression expression
 275                  :error-id "missing-result"
 276                  :message "Didn't receive result cursor for query."))
 277         (values (make-postgresql-socket-result-set
 278                  :done nil
 279                  :cursor cursor
 280                  :types (canonicalize-types result-types cursor))
 281                 (length (postgresql-cursor-fields cursor)))))))
 282
 283 (defmethod database-dump-result-set (result-set
 284                                      (database postgresql-socket-database))
 285   (if (postgresql-socket-result-set-done result-set)
 286       t
 287       (with-postgresql-handlers (database)
 288         (loop while (skip-cursor-row
 289                      (postgresql-socket-result-set-cursor result-set))
 290           finally (setf (postgresql-socket-result-set-done result-set) t)))))
 291
 292 (defmethod database-store-next-row (result-set
 293                                     (database postgresql-socket-database)
 294                                     list)
 295   (let ((cursor (postgresql-socket-result-set-cursor result-set)))
 296     (with-postgresql-handlers (database)
 297       (if (copy-cursor-row cursor
 298                            list
 299                            (postgresql-socket-result-set-types
 300                             result-set))
 301           t
 302           (prog1 nil
 303             (setf (postgresql-socket-result-set-done result-set) t)
 304             (wait-for-query-results (database-connection database)))))))
 305
 306 (defmethod database-create (connection-spec (type (eql :postgresql-socket)))
 307   (destructuring-bind (host name user password &optional port options tty) connection-spec
 308     (let ((database (database-connect (list host "postgres" user password)
 309                                       type)))
 310       (setf (slot-value database 'clsql-sys::state) :open)
 311       (unwind-protect
 312            (database-execute-command (format nil "create database ~A" name) database)
 313         (database-disconnect database)))))
 314
 315 (defmethod database-destroy (connection-spec (type (eql :postgresql-socket)))
 316   (destructuring-bind (host name user password &optional port optional tty) connection-spec
 317     (let ((database (database-connect (list host "postgres" user password)
 318                                       type)))
 319       (setf (slot-value database 'clsql-sys::state) :open)
 320       (unwind-protect
 321           (database-execute-command (format nil "drop database ~A" name) database)
 322         (database-disconnect database)))))
 323
 324
 325 (defmethod database-probe (connection-spec (type (eql :postgresql-socket)))
 326   (when (find (second connection-spec) (database-list connection-spec type)
 327               :test #'string-equal)
 328     t))
 329
 330
 331 ;; Database capabilities
 332
 333 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket)))
 334   nil)
 335
 336 (defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket)))
 337   t)
 338
 339 (defmethod db-type-default-case ((db-type (eql :postgresql-socket)))
 340   :lower)
 341
 342 (defmethod database-underlying-type ((database postgresql-socket-database))
 343   :postgresql)
 344
 345 (when (clsql-sys:database-type-library-loaded :postgresql-socket)
 346   (clsql-sys:initialize-database-type :database-type :postgresql-socket))