postmodern/transaction.lisp

   1 (in-package :postmodern)
   2
   3 (defparameter *transaction-level* 0)
   4 (defparameter *current-logical-transaction* nil)
   5
   6 (defclass transaction-handle ()
   7   ((open-p :initform t :accessor transaction-open-p)
   8    (connection :initform *database* :reader transaction-connection)
   9    (commit-hooks :initform nil :accessor commit-hooks)
  10    (abort-hooks :initform nil :accessor abort-hooks))
  11   (:documentation "Simple box type for storing the status and the
  12 associated database connection of a transaction. When open-p is nil,
  13 the transaction has been aborted or committed. commit-hooks and
  14 abort-hooks hold lists of functions (which should require no
  15 arguments) to be executed at commit and abort time, respectively."))
  16
  17 (defun call-with-transaction (body)
  18   (let ((transaction (make-instance 'transaction-handle)))
  19     (execute "BEGIN")
  20     (unwind-protect
  21          (multiple-value-prog1
  22              (let ((*transaction-level* (1+ *transaction-level*))
  23                    (*current-logical-transaction* transaction))
  24                (funcall body transaction))
  25            (commit-transaction transaction))
  26       (abort-transaction transaction))))
  27
  28 (defmacro with-transaction ((&optional name) &body body)
  29   "Execute the body within a database transaction, committing when the
  30 body exits normally, and aborting otherwise. An optional name can be
  31 given to the transaction, which can be used to force a commit or abort
  32 before the body unwinds."
  33   (let ((transaction-name (or name (gensym "anonymous-transaction"))))
  34     `(call-with-transaction (lambda (,transaction-name)
  35                               (declare (ignorable ,transaction-name)) ,@body))))
  36
  37 (defun abort-transaction (transaction)
  38   "Immediately abort an open transaction."
  39   (when (transaction-open-p transaction)
  40     (let ((*database* (transaction-connection transaction)))
  41       (execute "ABORT"))
  42     (setf (transaction-open-p transaction) nil)
  43     (mapc #'funcall (abort-hooks transaction))))
  44
  45 (defun commit-transaction (transaction)
  46   "Immediately commit an open transaction."
  47   (when (transaction-open-p transaction)
  48     (let ((*database* (transaction-connection transaction)))
  49       (execute "COMMIT"))
  50     (setf (transaction-open-p transaction) nil)
  51     (mapc #'funcall (commit-hooks transaction))))
  52
  53
  54 (defclass savepoint-handle (transaction-handle)
  55   ((name :initform (error "Savepoint name is not provided.")
  56          :initarg :name :reader savepoint-name)
  57    (open-p :initform t :accessor savepoint-open-p)
  58    (connection :initform *database* :reader savepoint-connection))
  59   (:documentation "Simple box type for storing the state and the
  60 associated database connection of a savepoint."))
  61
  62 (defun call-with-savepoint (name body)
  63   (let ((savepoint (make-instance 'savepoint-handle :name (to-sql-name name))))
  64     (execute (format nil "SAVEPOINT ~A" (savepoint-name savepoint)))
  65     (unwind-protect
  66          (multiple-value-prog1
  67              (let ((*transaction-level* (1+ *transaction-level*))
  68                    (*current-logical-transaction* savepoint))
  69                (funcall body savepoint))
  70            (release-savepoint savepoint))
  71       (rollback-savepoint savepoint))))
  72
  73 (defmacro with-savepoint (name &body body)
  74   "Execute the body within a savepoint, releasing savepoint when the
  75 body exits normally, and rolling back otherwise. NAME is both the
  76 variable that can be used to release or rolled back before the body
  77 unwinds, and the SQL name of the savepoint."
  78   `(call-with-savepoint ',name (lambda (,name) (declare (ignorable ,name)) ,@body)))
  79
  80 (defun rollback-savepoint (savepoint)
  81   "Immediately roll back a savepoint, aborting it results."
  82   (when (savepoint-open-p savepoint)
  83     (let ((*database* (savepoint-connection savepoint)))
  84       (execute (format nil "ROLLBACK TO SAVEPOINT ~A"
  85                        (savepoint-name savepoint))))
  86     (setf (savepoint-open-p savepoint) nil)
  87     (mapc #'funcall (abort-hooks savepoint))))
  88
  89 (defun release-savepoint (savepoint)
  90   "Immediately release a savepoint, commiting its results."
  91   (when (savepoint-open-p savepoint)
  92     (let ((*database* (savepoint-connection savepoint)))
  93       (execute (format nil "RELEASE SAVEPOINT ~A"
  94                        (savepoint-name savepoint))))
  95     (setf (transaction-open-p savepoint) nil)
  96     (mapc #'funcall (commit-hooks savepoint))))
  97
  98 (defun call-with-logical-transaction (name body)
  99   (if (zerop *transaction-level*)
 100       (call-with-transaction body)
 101       (call-with-savepoint name body)))
 102
 103 (defmacro with-logical-transaction ((&optional (name nil name-p)) &body body)
 104   "Executes the body within a with-transaction (if no transaction is
 105 already in progress) or a with-savepoint (if one is), binding the
 106 transaction or savepoint to NAME (if supplied)"
 107   (let* ((effective-name (if name-p
 108                              name
 109                              (gensym)))
 110          (effective-body (if name-p
 111                              `(lambda (,name) ,@body)
 112                              `(lambda (,effective-name)
 113                                 (declare (ignore ,effective-name))
 114                                 ,@body))))
 115     `(call-with-logical-transaction ',effective-name ,effective-body)))
 116
 117 (defmethod abort-logical-transaction ((savepoint savepoint-handle))
 118   (rollback-savepoint savepoint))
 119
 120 (defmethod abort-logical-transaction ((transaction transaction-handle))
 121   (abort-transaction transaction))
 122
 123 (defmethod commit-logical-transaction ((savepoint savepoint-handle))
 124   (commit-transaction savepoint))
 125
 126 (defmethod commit-logical-transaction ((transaction transaction-handle))
 127   (commit-transaction transaction))
 128
 129 (defun call-with-ensured-transaction (thunk)
 130   (if (zerop *transaction-level*)
 131       (with-transaction () (funcall thunk))
 132       (funcall thunk)))
 133
 134 (defmacro ensure-transaction (&body body)
 135   "Executes body within a with-transaction form if and only if no
 136 transaction is already in progress."
 137   `(call-with-ensured-transaction (lambda () ,@body)))