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.
  74 Duplicated from clsql-uffi package so that this interface
  75 doesn't depend on UFFI."
  76   (let ((length-types (length types))
  77         (new-types '()))
  78     (loop for i from 0 below (length auto-list)
  79           do
  80           (if (>= i length-types)
  81               (push t new-types) ;; types is shorted than num-fields
  82               (push
  83                (case (nth i types)
  84                  (:int
  85                   (case (nth i auto-list)
  86                     (:int32
  87                      :int32)
  88                     (:int64
  89                      :int64)
  90                     (t
  91                      t)))
  92                  (:double
  93                   (case (nth i auto-list)
  94                     (:double
  95                      :double)
  96                     (t
  97                      t)))
  98                  (t
  99                   t))
 100                new-types)))
 101     (nreverse new-types)))
 102
 103
 104 (defun convert-to-clsql-warning (database condition)
 105   (ecase *backend-warning-behavior*
 106     (:warn
 107      (warn 'sql-database-warning :database database
 108            :message (postgresql-condition-message condition)))
 109     (:error
 110      (error 'sql-database-error :database database
 111             :message (format nil "Warning upgraded to error: ~A"
 112                              (postgresql-condition-message condition))))
 113     ((:ignore nil)
 114      ;; do nothing
 115      )))
 116
 117 (defun convert-to-clsql-error (database expression condition)
 118   (error 'sql-database-data-error
 119          :database database
 120          :expression expression
 121          :error-id (type-of condition)
 122          :message (postgresql-condition-message condition)))
 123
 124 (defmacro with-postgresql-handlers
 125     ((database &optional expression)
 126      &body body)
 127   (let ((database-var (gensym))
 128         (expression-var (gensym)))
 129     `(let ((,database-var ,database)
 130            (,expression-var ,expression))
 131        (handler-bind ((postgresql-warning
 132                        (lambda (c)
 133                          (convert-to-clsql-warning ,database-var c)))
 134                       (postgresql-error
 135                        (lambda (c)
 136                          (convert-to-clsql-error
 137                           ,database-var ,expression-var c))))
 138          ,@body))))
 139
 140 (defmethod database-initialize-database-type ((database-type
 141                                                (eql :postgresql-socket)))
 142   t)
 143
 144 (defclass postgresql-socket-database (generic-postgresql-database)
 145   ((connection :accessor database-connection :initarg :connection
 146                :type postgresql-connection)))
 147
 148 (defmethod database-type ((database postgresql-socket-database))
 149   :postgresql-socket)
 150
 151 (defmethod database-name-from-spec (connection-spec
 152                                     (database-type (eql :postgresql-socket)))
 153   (check-connection-spec connection-spec database-type
 154                          (host db user password &optional port options tty))
 155   (destructuring-bind (host db user password &optional port options tty)
 156       connection-spec
 157     (declare (ignore password options tty))
 158     (concatenate 'string
 159       (etypecase host
 160         (null
 161          "localhost")
 162         (pathname (namestring host))
 163         (string host))
 164       (when port
 165         (concatenate 'string
 166                      ":"
 167                      (etypecase port
 168                        (integer (write-to-string port))
 169                        (string port))))
 170       "/" db "/" user)))
 171
 172 (defmethod database-connect (connection-spec
 173                              (database-type (eql :postgresql-socket)))
 174   (check-connection-spec connection-spec database-type
 175                          (host db user password &optional port options tty))
 176   (destructuring-bind (host db user password &optional
 177                             (port +postgresql-server-default-port+)
 178                             (options "") (tty ""))
 179       connection-spec
 180     (handler-case
 181         (handler-bind ((postgresql-warning
 182                         (lambda (c)
 183                           (warn 'sql-warning
 184                                 :format-control "~A"
 185                                 :format-arguments
 186                                 (list (princ-to-string c))))))
 187           (open-postgresql-connection :host host :port port
 188                                       :options options :tty tty
 189                                       :database db :user user
 190                                       :password password))
 191       (postgresql-error (c)
 192         ;; Connect failed
 193         (error 'sql-connection-error
 194                :database-type database-type
 195                :connection-spec connection-spec
 196                :error-id (type-of c)
 197                :message (postgresql-condition-message c)))
 198       (:no-error (connection)
 199                  ;; Success, make instance
 200                  (make-instance 'postgresql-socket-database
 201                                 :name (database-name-from-spec connection-spec
 202                                                                database-type)
 203                                 :database-type :postgresql-socket
 204                                 :connection-spec connection-spec
 205                                 :connection connection)))))
 206
 207 (defmethod database-disconnect ((database postgresql-socket-database))
 208   (close-postgresql-connection (database-connection database))
 209   t)
 210
 211 (defmethod database-query (expression (database postgresql-socket-database) result-types field-names)
 212   (let ((connection (database-connection database)))
 213     (with-postgresql-handlers (database expression)
 214       (start-query-execution connection expression)
 215       (multiple-value-bind (status cursor)
 216           (wait-for-query-results connection)
 217         (unless (eq status :cursor)
 218           (close-postgresql-connection connection)
 219           (error 'sql-database-data-error
 220                  :database database
 221                  :expression expression
 222                  :error-id "missing-result"
 223                  :message "Didn't receive result cursor for query."))
 224         (setq result-types (canonicalize-types result-types cursor))
 225         (values
 226          (loop for row = (read-cursor-row cursor result-types)
 227                while row
 228                collect row
 229                finally
 230                (unless (null (wait-for-query-results connection))
 231                  (close-postgresql-connection connection)
 232                  (error 'sql-database-data-error
 233                         :database database
 234                         :expression expression
 235                         :error-id "multiple-results"
 236                         :message "Received multiple results for query.")))
 237          (when field-names
 238            (mapcar #'car (postgresql-cursor-fields cursor))))))))
 239
 240 (defmethod database-execute-command
 241     (expression (database postgresql-socket-database))
 242   (let ((connection (database-connection database)))
 243     (with-postgresql-handlers (database expression)
 244       (start-query-execution connection expression)
 245       (multiple-value-bind (status result)
 246           (wait-for-query-results connection)
 247         (when (eq status :cursor)
 248           (loop
 249             (multiple-value-bind (row stuff)
 250                 (skip-cursor-row result)
 251               (unless row
 252                 (setq status :completed result stuff)
 253                 (return)))))
 254         (cond
 255          ((null status)
 256           t)
 257          ((eq status :completed)
 258           (unless (null (wait-for-query-results connection))
 259              (close-postgresql-connection connection)
 260              (error 'sql-database-data-error
 261                     :database database
 262                     :expression expression
 263                     :error-id "multiple-results"
 264                     :message "Received multiple results for command."))
 265           result)
 266           (t
 267            (close-postgresql-connection connection)
 268            (error 'sql-database-data-error
 269                   :database database
 270                   :expression expression
 271                   :errno "missing-result"
 272                   :message "Didn't receive completion for command.")))))))
 273
 274 (defstruct postgresql-socket-result-set
 275   (done nil)
 276   (cursor nil)
 277   (types nil))
 278
 279 (defmethod database-query-result-set ((expression string)
 280                                       (database postgresql-socket-database)
 281                                       &key full-set result-types)
 282   (declare (ignore full-set))
 283   (let ((connection (database-connection database)))
 284     (with-postgresql-handlers (database expression)
 285       (start-query-execution connection expression)
 286       (multiple-value-bind (status cursor)
 287           (wait-for-query-results connection)
 288         (unless (eq status :cursor)
 289           (close-postgresql-connection connection)
 290           (error 'sql-database-data-error
 291                  :database database
 292                  :expression expression
 293                  :error-id "missing-result"
 294                  :message "Didn't receive result cursor for query."))
 295         (values (make-postgresql-socket-result-set
 296                  :done nil
 297                  :cursor cursor
 298                  :types (canonicalize-types result-types cursor))
 299                 (length (postgresql-cursor-fields cursor)))))))
 300
 301 (defmethod database-dump-result-set (result-set
 302                                      (database postgresql-socket-database))
 303   (if (postgresql-socket-result-set-done result-set)
 304       t
 305       (with-postgresql-handlers (database)
 306         (loop while (skip-cursor-row
 307                      (postgresql-socket-result-set-cursor result-set))
 308           finally (setf (postgresql-socket-result-set-done result-set) t)))))
 309
 310 (defmethod database-store-next-row (result-set
 311                                     (database postgresql-socket-database)
 312                                     list)
 313   (let ((cursor (postgresql-socket-result-set-cursor result-set)))
 314     (with-postgresql-handlers (database)
 315       (if (copy-cursor-row cursor
 316                            list
 317                            (postgresql-socket-result-set-types
 318                             result-set))
 319           t
 320           (prog1 nil
 321             (setf (postgresql-socket-result-set-done result-set) t)
 322             (wait-for-query-results (database-connection database)))))))
 323
 324 (defmethod database-create (connection-spec (type (eql :postgresql-socket)))
 325   (destructuring-bind (host name user password &optional port options tty) connection-spec
 326     (let ((database (database-connect (list host "postgres" user password)
 327                                       type)))
 328       (setf (slot-value database 'clsql-sys::state) :open)
 329       (unwind-protect
 330            (database-execute-command (format nil "create database ~A" name) database)
 331         (database-disconnect database)))))
 332
 333 (defmethod database-destroy (connection-spec (type (eql :postgresql-socket)))
 334   (destructuring-bind (host name user password &optional port optional tty) connection-spec
 335     (let ((database (database-connect (list host "postgres" user password)
 336                                       type)))
 337       (setf (slot-value database 'clsql-sys::state) :open)
 338       (unwind-protect
 339           (database-execute-command (format nil "drop database ~A" name) database)
 340         (database-disconnect database)))))
 341
 342
 343 (defmethod database-probe (connection-spec (type (eql :postgresql-socket)))
 344   (when (find (second connection-spec) (database-list connection-spec type)
 345               :test #'string-equal)
 346     t))
 347
 348
 349 ;; Database capabilities
 350
 351 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket)))
 352   nil)
 353
 354 (defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket)))
 355   t)
 356
 357 (defmethod db-type-default-case ((db-type (eql :postgresql-socket)))
 358   :lower)
 359
 360 (defmethod database-underlying-type ((database postgresql-socket-database))
 361   :postgresql)
 362
 363 (when (clsql-sys:database-type-library-loaded :postgresql-socket)
 364   (clsql-sys:initialize-database-type :database-type :postgresql-socket))