src/transactions.lisp

(in-package mito-transactions.dev)

;;;; New slot type and metaclass to avoid inconsistency between
;;;; in-image dao and sql tables.
;;;;
;;;; 1. Transactions which automatically update db for all changed daos on commit.
;;;; 2. Setting slots outside of a transaction is an error.

;;; Metaclass

;;; API

(defvar *transaction* nil "Current outermost transaction")

(defstruct (transaction
               (:constructor make-transaction ())
               (:copier nil)
               (:conc-name :||))
  (dirty-objects nil))

(defmethod (setf c2mop:slot-value-using-class) :before (new-value (class transaction-dao-class) obj slotd)
  (unless *ignore-transaction*
    (let ((slot-name (c2mop:slot-definition-name slotd)))
      (when (member slot-name (transaction-slots class))
        ;; Writing value outside of a transaction
        (unless *transaction*
          (error "Can only set slot values in a transaction"))
        ;; Remember old value unless there was already one
        (let ((value (if (slot-boundp obj slot-name) (slot-value obj slot-name) 'unbound)))
          (pushnew (cons slot-name value)
                   (value-backup obj)
                   :key #'car))
        ;; Remember that the object is dirty
        (pushnew obj (dirty-objects *transaction*))))))

(define-condition commit-transaction (condition) ())
(define-condition rollback-transaction (condition) ())

(defmacro with-transaction (() &body body)
  "Evaluate BODY as a mito transaction.
"
  (with-gensyms (thunk)
    `(let ((inner-transaction (not (null *transaction*))))
       (flet ((,thunk ()
                #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
                (flet ((commit () (if inner-transaction
                                      (error "Inner transactions can't use explicit COMMIT")
                                      (signal 'commit-transaction)))
                       (rollback () (signal 'rollback-transaction)))
                  ,@body)))
         (declare (dynamic-extent #',thunk))
         (call-with-transaction #',thunk)))))

(defun call-with-transaction (thunk)
  ;; Do not setup commit/rollback handlers more than once
  ;; If an inner transaction fails everything fails
  (if *transaction*
      (funcall thunk)
      (maybe-lock
        (let ((*transaction* (make-transaction))
              (local-return nil)
              (finished-manually nil))
          (unwind-protect
               (handler-case
                   (prog1
                       (funcall thunk)
                     (setf local-return t))
                 (commit-transaction () (setf finished-manually t) (commit%))
                 (rollback-transaction () (setf finished-manually t) (rollback%)))
            (unless finished-manually
              (if local-return
                  (commit%)
                  (rollback%))))))))

(defun commit% ()
  (dbi:with-transaction mito.connection:*connection*
    ;; Save it to the database first (it's where it will most likely fail)
    (dolist (obj (dirty-objects *transaction*))
      (mito:save-dao obj)))
  ;; Forget the old values
  (dolist (obj (dirty-objects *transaction*))
    (setf (value-backup obj) nil)))

(defun rollback% ()
  ;; Do nothing with the database
  #||||||#
  ;; Rollback the original values
  (let ((*ignore-transaction* t)) ; Bypass our (setf slot) method
    (dolist (obj (dirty-objects *transaction*))
      (dolist (backup (value-backup obj))
        (if (eq 'unbound (cdr backup))
            (slot-makunbound obj (car backup))
            (setf (slot-value obj (car backup)) (cdr backup))))
      (setf (value-backup obj) nil))))

(defmethod make-instance :around ((class transaction-dao-class) &key &allow-other-keys)
  (with-transaction ()
    (call-next-method)))