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