cl-postgres/public.lisp

   1 (in-package :cl-postgres)
   2
   3 (defclass database-connection ()
   4   ((host :initarg :host :reader connection-host)
   5    (port :initarg :port :reader connection-port)
   6    (database :initarg :db :reader connection-db)
   7    (user :initarg :user :reader connection-user)
   8    (password :initarg :password :reader connection-password)
   9    (use-ssl :initarg :ssl :reader connection-use-ssl)
  10    (service :initarg :service :accessor connection-service)
  11    (socket :initarg :socket :accessor connection-socket)
  12    (meta :initform nil)
  13    (available :initform t :accessor connection-available)
  14    (parameters :accessor connection-parameters)
  15    (timestamp-format :accessor connection-timestamp-format))
  16   (:documentation "Representation of a database connection. Contains
  17 login information in order to be able to automatically re-establish a
  18 connection when it is somehow closed."))
  19
  20 (defun connection-meta (connection)
  21   "Retrieves the meta field of a connection, the primary purpose of
  22 which is to store information about the prepared statements that
  23 exists for it."
  24   (or (slot-value connection 'meta)
  25       (let ((meta-data (make-hash-table)))
  26         (setf (slot-value connection 'meta) meta-data)
  27         meta-data)))
  28
  29 (defun database-open-p (connection)
  30   "Returns a boolean indicating whether the given connection is
  31 currently connected."
  32   (and (connection-socket connection)
  33        (open-stream-p (connection-socket connection))))
  34
  35 (defun open-database (database user password host &optional (port 5432) (use-ssl :no) (service "postgres"))
  36   "Create and connect a database object. use-ssl may be :no, :yes, or :try."
  37   (check-type database string)
  38   (check-type user string)
  39   (check-type password (or null string))
  40   (check-type host (or string (eql :unix)) "a string or :unix")
  41   (check-type port (integer 1 65535) "an integer from 1 to 65535")
  42   (check-type use-ssl (member :no :yes :try) ":no, :yes, or :try")
  43   (let ((conn (make-instance 'database-connection :host host :port port :user user
  44                              :password password :socket nil :db database :ssl use-ssl
  45                              :service service)))
  46     (initiate-connection conn)
  47     conn))
  48
  49 #+(and (or sbcl ccl allegro) unix)
  50 (progn
  51   (defparameter *unix-socket-dir*
  52     #-(or freebsd darwin) "/var/run/postgresql/"
  53     #+(or darwin freebsd) "/tmp/"
  54     "Directory where the Unix domain socket for PostgreSQL be found.")
  55
  56   (defun unix-socket-path (base-dir port)
  57     (unless (char= #\/ (aref base-dir (1- (length base-dir))))
  58       (setf base-dir (concatenate 'string base-dir "/")))
  59     (format nil "~a.s.PGSQL.~a" base-dir port))
  60
  61   #+sbcl
  62   (defun unix-socket-connect (path)
  63     (let ((sock (make-instance 'sb-bsd-sockets:local-socket :type :stream)))
  64       (sb-bsd-sockets:socket-connect sock path)
  65       (sb-bsd-sockets:socket-make-stream
  66        sock :input t :output t :element-type '(unsigned-byte 8))))
  67
  68   #+ccl
  69   (defun unix-socket-connect (path)
  70     (ccl:make-socket :type :stream
  71                      :address-family :file
  72                      :format :binary
  73                      :remote-filename path))
  74
  75   #+allegro
  76   (defun unix-socket-connect (path)
  77     (socket:make-socket :type :stream
  78                         :address-family :file
  79                         :format :binary
  80                         :remote-filename path)))
  81
  82 #+sbcl
  83 (defun get-host-address (host)
  84   "Returns valid IPv4 or IPv6 address for the host."
  85   ;; get all IPv4 and IPv6 addresses as a list
  86   (let* ((host-ents (multiple-value-list (sb-bsd-sockets:get-host-by-name host)))
  87          ;; remove protocols for which we don't have an address
  88          (addresses (remove-if-not #'sb-bsd-sockets:host-ent-address host-ents)))
  89     ;; Return the first one or nil,
  90     ;; but actually, it shouln't return nil, because
  91     ;; get-host-by-name should signal NAME-SERVICE-ERROR condition
  92     ;; if there isn't any address for the host.
  93     (first addresses)))
  94
  95
  96 #+sbcl
  97 (defun inet-socket-connect (host port)
  98   (let* ((host-ent (get-host-address host))
  99         (sock (make-instance (ecase (sb-bsd-sockets:host-ent-address-type host-ent)
 100                                (2  'sb-bsd-sockets:inet-socket)
 101                                (10 'sb-bsd-sockets:inet6-socket))
 102                              :type :stream :protocol :tcp))
 103          (address (sb-bsd-sockets:host-ent-address host-ent)))
 104     (sb-bsd-sockets:socket-connect sock address port)
 105     (sb-bsd-sockets:socket-make-stream
 106      sock :input t :output t :buffering :full :element-type '(unsigned-byte 8))))
 107
 108 #+ccl
 109 (defun inet-socket-connect (host port)
 110   (ccl:make-socket :format :binary
 111                    :remote-host host
 112                    :remote-port port))
 113
 114 #+allegro
 115 (defun inet-socket-connect (host port)
 116   (socket:make-socket :remote-host host
 117                       :remote-port port
 118                       :format :binary
 119                       :type :stream))
 120
 121 (defun initiate-connection (conn)
 122   "Check whether a connection object is connected, try to connect it
 123 if it isn't."
 124   (flet ((add-restart (err)
 125            (restart-case (error (wrap-socket-error err))
 126              (:reconnect () :report "Try again." (initiate-connection conn))))
 127          (assert-unix ()
 128            #+unix t
 129            #-unix (error "Unix sockets only available on Unix (really)")))
 130     (handler-case
 131         (let ((socket #-(or allegro sbcl ccl)
 132                       (usocket:socket-stream
 133                        (usocket:socket-connect (connection-host conn)
 134                                                (connection-port conn)
 135                                                :element-type '(unsigned-byte 8)))
 136                       #+(or allegro sbcl ccl)
 137                       (cond
 138                         ((equal (connection-host conn) :unix)
 139                          (assert-unix)
 140                          (unix-socket-connect (unix-socket-path *unix-socket-dir* (connection-port conn))))
 141                         ((and (stringp (connection-host conn))
 142                               (char= #\/ (aref (connection-host conn) 0)))
 143                          (assert-unix)
 144                          (unix-socket-connect (unix-socket-path (connection-host conn) (connection-port conn))))
 145                         ((and (pathnamep (connection-host conn))
 146                               (eql :absolute (pathname-directory (connection-host conn))))
 147                          (assert-unix)
 148                          (unix-socket-connect (unix-socket-path (namestring (connection-host conn))
 149                                                                 (connection-port conn))))
 150                         (t
 151                          (inet-socket-connect (connection-host conn)
 152                                               (connection-port conn)))))
 153               (finished nil)
 154               (*connection-params* (make-hash-table :test 'equal)))
 155           (setf (slot-value conn 'meta) nil
 156                 (connection-parameters conn) *connection-params*)
 157           (unwind-protect
 158                (setf socket (authenticate socket conn)
 159                      (connection-timestamp-format conn)
 160                      (if (string= (gethash "integer_datetimes" (connection-parameters conn)) "on")
 161                          :integer :float)
 162                      (connection-socket conn) socket
 163                      finished t)
 164             (unless finished
 165               (ensure-socket-is-closed socket))))
 166       #-(or allegro sbcl ccl)(usocket:socket-error (e) (add-restart e))
 167       #+ccl (ccl:socket-error (e) (add-restart e))
 168       #+allegro(excl:socket-error (e) (add-restart e))
 169       #+sbcl(sb-bsd-sockets:socket-error (e) (add-restart e))
 170       (stream-error (e) (add-restart e))))
 171     (values))
 172
 173 (defun reopen-database (conn)
 174   "Reconnect a disconnected database connection."
 175   (unless (database-open-p conn)
 176     (initiate-connection conn)))
 177
 178 (defun ensure-connection (conn)
 179   "Used to make sure a connection object is connected before doing
 180 anything with it."
 181   (unless conn
 182     (error "No database connection selected."))
 183   (unless (database-open-p conn)
 184     (restart-case (error 'database-connection-lost :message "Connection to database server lost.")
 185       (:reconnect () :report "Try to reconnect." (initiate-connection conn)))))
 186
 187 (defun close-database (connection)
 188   "Gracefully disconnect a database connection."
 189   (when (database-open-p connection)
 190     (terminate-connection (connection-socket connection)))
 191   (values))
 192
 193 (defmacro using-connection (connection &body body)
 194   "This is used to prevent a row-reader from recursively calling some
 195 query function. Because the connection is still returning results from
 196 the previous query when a row-reading is being executed, starting
 197 another query will not work as expected \(or at all, in general). This
 198 might also raise an error when you are using a single database
 199 connection from multiple threads, but you should not do that at all.
 200 Also binds *timestamp-format* and *connection-params*, which might be
 201 needed by the code interpreting the query results."
 202   (let ((connection-name (gensym)))
 203     `(let* ((,connection-name ,connection)
 204             (*timestamp-format* (connection-timestamp-format ,connection-name))
 205             (*connection-params* (connection-parameters ,connection-name)))
 206       (when (not (connection-available ,connection-name))
 207         (error 'database-error :message "This connection is still processing another query."))
 208       (setf (connection-available ,connection-name) nil)
 209       (unwind-protect (progn ,@body)
 210         (setf (connection-available ,connection-name) t)))))
 211
 212 (defmacro with-reconnect-restart (connection &body body)
 213   "When, inside the body, an error occurs that breaks the connection
 214 socket, a condition of type database-connection-error is raised,
 215 offering a :reconnect restart."
 216   (let ((connection-name (gensym))
 217         (body-name (gensym))
 218         (retry-name (gensym)))
 219   `(let ((,connection-name ,connection))
 220     (ensure-connection ,connection-name)
 221     (labels ((,body-name ()
 222                (handler-case (progn ,@body)
 223                  (stream-error (e)
 224                    (cond ((eq (connection-socket ,connection-name) (stream-error-stream e))
 225                           (ensure-socket-is-closed (connection-socket ,connection-name) :abort t)
 226                           (,retry-name (wrap-socket-error e)))
 227                          (t (error e))))
 228                  (cl-postgres-error:server-shutdown (e)
 229                    (ensure-socket-is-closed (connection-socket ,connection-name) :abort t)
 230                    (,retry-name e))))
 231              (,retry-name (err)
 232                (restart-case (error err)
 233                  (:reconnect () :report "Try to reconnect"
 234                              (reopen-database ,connection-name)
 235                              (,body-name)))))
 236       (,body-name)))))
 237
 238 (defun wait-for-notification (connection)
 239   "Perform a blocking wait for asynchronous notification. Return the
 240 channel string, the payload and notifying pid as multiple values."
 241   (block nil
 242     (with-reconnect-restart connection
 243       (handler-bind ((postgresql-notification
 244                       (lambda (c)
 245                         (return (values (postgresql-notification-channel c)
 246                                         (postgresql-notification-payload c)
 247                                         (postgresql-notification-pid c))))))
 248         (message-case (connection-socket connection))))))
 249
 250 (defun exec-query (connection query &optional (row-reader 'ignore-row-reader))
 251   "Execute a query string and apply the given row-reader to the
 252 result."
 253   (check-type query string)
 254   (with-reconnect-restart connection
 255     (using-connection connection
 256       (send-query (connection-socket connection) query row-reader))))
 257
 258 (defun prepare-query (connection name query)
 259   "Prepare a query string and store it under the given name."
 260   (check-type query string)
 261   (check-type name string)
 262   (with-reconnect-restart connection
 263     (using-connection connection
 264       (send-parse (connection-socket connection) name query)
 265       (values))))
 266
 267 (defun unprepare-query (connection name)
 268   "Close the prepared query given by name."
 269   (check-type name string)
 270   (with-reconnect-restart connection
 271     (using-connection connection
 272       (send-close (connection-socket connection) name)
 273       (values))))
 274
 275 (defun exec-prepared (connection name parameters &optional (row-reader 'ignore-row-reader))
 276   "Execute a previously prepared query with the given parameters,
 277 apply a row-reader to the result."
 278   (check-type name string)
 279   (check-type parameters list)
 280   (with-reconnect-restart connection
 281     (using-connection connection
 282       (send-execute (connection-socket connection)
 283                     name parameters row-reader))))
 284
 285 ;; A row-reader that returns a list of (field-name . field-value)
 286 ;; alist for the returned rows.
 287 (def-row-reader alist-row-reader (fields)
 288   (loop :while (next-row)
 289         :collect (loop :for field :across fields
 290                        :collect (cons (field-name field)
 291                                       (next-field field)))))
 292
 293 ;; Row-reader that returns a list of lists.
 294 (def-row-reader list-row-reader (fields)
 295   (loop :while (next-row)
 296         :collect (loop :for field :across fields
 297                        :collect (next-field field))))
 298
 299 ;; Row-reader that returns a vector of vectors.
 300 (def-row-reader vector-row-reader (fields)
 301   (let ((rows (make-array 1 :adjustable t :fill-pointer 0)))
 302     (loop :for row = (make-array (length fields))
 303           :while (next-row)
 304           :do (progn
 305                 (loop :for field :across fields
 306                       :for idx :upfrom 0
 307                       :do (setf (aref row idx) (next-field field)))
 308                 (vector-push-extend row rows)))
 309     rows))
 310
 311 ;; Row-reader that discards the query results.
 312 (def-row-reader ignore-row-reader (fields)
 313   (loop :while (next-row)
 314         :do (loop :for field :across fields
 315                   :do (next-field field)))
 316   (values))