postmodern/connect.lisp

   1 (in-package :postmodern)
   2
   3 (defclass pooled-database-connection (database-connection)
   4   ((pool-type :initarg :pool-type :accessor connection-pool-type))
   5   (:documentation "Type for database connections that are pooled.
   6 Stores the arguments used to create it, so different pools can be
   7 distinguished."))
   8
   9 (defparameter *database* nil
  10   "Special holding the current database. Most functions and macros
  11 operating on a database assume this contains a connected database.")
  12
  13 (defparameter *default-use-ssl* :no)
  14
  15 (defun connect (database user password host &key (port 5432) pooled-p (use-ssl *default-use-ssl*) (service "postgres"))
  16   "Create and return a database connection."
  17   (cond (pooled-p
  18          (let ((type (list database user password host port use-ssl)))
  19            (or (get-from-pool type)
  20                (let ((connection (open-database database user password host port use-ssl)))
  21                  (change-class connection 'pooled-database-connection :pool-type type)
  22                  connection))))
  23         (t (open-database database user password host port use-ssl service))))
  24
  25 (defun connected-p (database)
  26   "Test whether a database connection is still connected."
  27   (database-open-p database))
  28
  29 (defun connect-toplevel (database user password host &key (port 5432) (use-ssl *default-use-ssl*))
  30   "Set *database* to a new connection. Use this if you only need one
  31 connection, or if you want a connection for debugging from the REPL."
  32   (when (and *database* (connected-p *database*))
  33     (restart-case (error "Top-level database already connected.")
  34       (replace () :report "Replace it with a new connection." (disconnect-toplevel))
  35       (leave () :report "Leave it." (return-from connect-toplevel nil))))
  36   (setf *database* (connect database user password host :port port :use-ssl use-ssl))
  37   (values))
  38
  39 (defgeneric disconnect (database)
  40   (:method ((connection database-connection))
  41     (close-database connection))
  42   (:documentation "Close a database connection. Returns it to a pool
  43 if it is a pooled connection."))
  44
  45 (defgeneric reconnect (database)
  46   (:method ((database database-connection))
  47     (reopen-database database))
  48   (:method ((connection pooled-database-connection))
  49     (error "Can not reconnect a pooled database."))
  50   (:documentation "Reconnect a database connection."))
  51
  52 (defun disconnect-toplevel ()
  53   "Disconnect *database*."
  54   (when (and *database* (connected-p *database*))
  55     (disconnect *database*))
  56   (setf *database* nil))
  57
  58 (defun call-with-connection (spec thunk)
  59   "Binds *database* to a new connection, as specified by the spec
  60 argument, which should be a list of arguments that can be passed to
  61 connect, and runs the function given as a second argument with that
  62 database."
  63   (let ((*database* (apply #'connect spec)))
  64     (unwind-protect (funcall thunk)
  65       (disconnect *database*))))
  66
  67 (defmacro with-connection (spec &body body)
  68   "Locally establish a database connection, and bind *database* to it."
  69   `(let ((*database* (apply #'connect ,spec)))
  70     (unwind-protect (progn ,@body)
  71       (disconnect *database*))))
  72
  73 (defvar *max-pool-size* nil
  74   "The maximum amount of connection that will be kept in a single
  75 pool, or NIL for no maximum.")
  76
  77 (defvar *connection-pools* (make-hash-table :test 'equal)
  78   "Maps pool specifiers to lists of pooled connections.")
  79
  80 #+postmodern-thread-safe
  81 (defvar *pool-lock*
  82   (bordeaux-threads:make-lock "connection-pool-lock")
  83   "A lock to prevent multiple threads from messing with the connection
  84 pool at the same time.")
  85
  86 (defmacro with-pool-lock (&body body)
  87   "Aquire a lock for the pool when evaluating body \(if thread support
  88 is present)."
  89   #+postmodern-thread-safe
  90   `(bordeaux-threads:with-lock-held (*pool-lock*) ,@body)
  91   #-postmodern-thread-safe
  92   `(progn ,@body))
  93
  94 (defun get-from-pool (type)
  95   "Get a database connection from the specified pool, returns nil if
  96 no connection was available."
  97   (with-pool-lock
  98     (pop (gethash type *connection-pools*))))
  99
 100 (defmethod disconnect ((connection pooled-database-connection))
 101   "Add the connection to the corresponding pool, or drop it when the
 102 pool is full."
 103   (macrolet ((the-pool ()
 104                '(gethash (connection-pool-type connection) *connection-pools* ())))
 105     (when (database-open-p connection)
 106       (with-pool-lock
 107         (if (or (not *max-pool-size*) (< (length (the-pool)) *max-pool-size*))
 108             (push connection (the-pool))
 109             (call-next-method))))
 110     (values)))
 111
 112 (defun clear-connection-pool ()
 113   "Disconnect and remove all connections in the connection pool."
 114   (with-pool-lock
 115     (maphash
 116      (lambda (type connections)
 117        (declare (ignore type))
 118        (dolist (conn connections)
 119          (close-database conn)))
 120      *connection-pools*)
 121     (setf *connection-pools* (make-hash-table :test 'equal))
 122     (values)))