Fix transactions for objects fetched from the db (not created in this image)

src/cache.lisp

@@ -1,71 +1,73 b''
 
 (in-package mito-transactions.dev)
 
 ;;;; Cache for `mito` objects with the main purpose of avoiding
 ;;;; several instances of the same dao which are not `eq` to each
 ;;;; other. Cached objects are only removed when they are GC'ed so
 ;;;; next time they will have other identity but it's not a problem
 ;;;; beause there would be no previous objects to EQ against.
 
 (defmethod mito.dao.mixin:make-dao-instance ((obj cached-dao-class) &key &allow-other-keys)
   "This method is called on creation of dao instances loaded from the DB. "
   (declare (ignore obj))
   (maybe-lock
     (let ((*ignore-transaction* t))
-      (do-cache (call-next-method)))))
+      (let ((obj (call-next-method)))
+        (setf (value-backup obj) nil)
+        (do-cache obj)))))
 
 (defmethod mito:insert-dao ((obj cached-dao))
   (maybe-lock
     (call-next-method)
     (setf (gethash (mito:object-id obj) (class-cache obj)) obj)
     obj))
 
 (defmethod mito:delete-dao ((obj cached-dao))
   (maybe-lock
     (remhash (mito:object-id obj) (class-cache (class-of obj)))
     (call-next-method)))
 
 (defmethod mito:delete-by-values ((class cached-dao-class) &rest fields-and-values)
   (maybe-lock
     ;; We need their IDs to remove from the cache
     (let ((objs (apply #'mito:retrieve-dao class fields-and-values)))
       (call-next-method)
       (dolist (obj objs)
         (remhash (mito:object-id obj) (class-cache (class-of obj))))
       (values))))
 
 (defgeneric class-cache (class)
   (:method ((class cached-dao-class))
     (slot-value class 'cache))
   (:method ((obj cached-dao))
     (class-cache (class-of obj)))
   (:method ((classname symbol))
     (class-cache (find-class classname))))
 
 (defun get-dao (class id)
   "Fetch an object directly from the cache, only check the db if it's not cached."
   (maybe-lock
     (or (gethash id (class-cache class))
         (do-cache (first (mito:select-dao class (sxql:where (:= :id id))))))))
 
 (defun get-dao-from-cache-only (class id)
   "Fetch an object directly from the cache, return NIL if it's not cached."
   (maybe-lock
     (gethash id (class-cache class))))
 
 (defun do-cache (obj)
   (when obj
     (let ((cache (class-cache obj)))
       (sif (gethash (mito:object-id obj) cache)
            (copy-fields it obj)
            (setf it obj)))))
 
 (defun copy-fields (to from)
   (when (local-time:timestamp> (mito:object-updated-at from)
                                (mito:object-updated-at to))
     (let ((*ignore-transaction* t)
           (slot-names (mapcar #'c2mop:slot-definition-name
                               (mito.class.table:table-column-slots (class-of from)))))
       (dolist (slot-name slot-names)
         (setf (slot-value to slot-name) (slot-value from slot-name)))))
   to)

t/tests.lisp

@@ -1,80 +1,86 b''
 
 (in-package :cl-user)
 (defpackage mito-transactions.tests
   (:use :cl #:mito-transactions #:parachute))
 
 (in-package mito-transactions.tests)
 
 (setf mito:*auto-migration-mode* t)
 (setf mito:*migration-keep-temp-tables* nil)
 
 (deftable test-object ()
   ((slot :col-type (or :null :integer) :initarg :slot :initform 42)
    (ghost-slot :ghost t))
   (:conc-name :||))
 
 (defmethod print-object ((o test-object) stream)
   (print-unreadable-object (o stream :type t :identity t)
     (format stream "~A" (mito:object-id o))))
 
 (mito:connect-toplevel :sqlite3 :database-name (asdf:system-relative-pathname :mito-transactions "test.db"))
 (mito:ensure-table-exists 'test-object)
 
 (define-test suite)
 
 (define-test setup-db
   (delete-by-values 'test-object))
 
 (define-test (suite cache-select)
   :depends-on (setup-db)
   ;; Create an object
   (let ((obj (make-instance 'test-object)))
     ;; Check that it's the same object after any select function
     (is eq obj (get-dao 'test-object (object-id obj)))
     (is eq obj (find-dao 'test-object 'slot 42))
     (is eq obj (first (retrieve-dao 'test-object 'slot 42)))
     (is eq obj (first (select-dao 'test-object (sxql:where (:= :slot 42)))))))
 
 (define-test (suite cache-delete)
   :depends-on (setup-db cache-select)
   ;; Delete the object and check that it's removed from the cache too
   (let ((obj (make-instance 'test-object)))
     (delete-dao obj)
     (is eq nil (get-dao-from-cache-only 'test-object (object-id obj)) "DELETE-DAO didn't remove object from cache")
     (is eq nil (get-dao 'test-object (object-id obj)) "DELETE-DAO didn't remove object from db"))
     ;; Repeat for mito:delete-by-values
   (let ((obj (make-instance 'test-object)))
     (delete-by-values 'test-object 'slot 42)
     (is eq nil (get-dao-from-cache-only 'test-object (object-id obj)) "DELETE-BY-VALUES didn't remove objects from cache")
     (is eq nil (get-dao 'test-object (object-id obj)) "DELETE-BY-VALUES didn't remove objects from db")))
 
 (define-test (suite transactions)
   :depends-on (setup-db cache-select)
   (let ((obj (make-instance 'test-object :slot 1)))
     (with-transaction ()
       (setf (slot obj) 2)
       (setf (slot obj) 3)
       (commit)
       (true nil "Transaction continued after COMMIT"))
     (is = 3 (slot obj) "COMMIT didn't save slot value")
     (with-transaction ()
       (setf (slot obj) 4)
       (setf (slot obj) 5)
       (rollback)
       (true nil "Transaction continued after ROLLBACK"))
     (is = 3 (slot obj) "ROLLBACK didn't restore the initial slot value")
     (with-transaction ()
       (setf (slot obj) 1)
       (with-transaction ()
         (setf (slot obj) 2)
         (rollback)
         (true nil "Inner transaction continued after ROLLBACK"))
       (true nil "Outer transaction continued after ROLLBACK"))
     (is = 3 (slot obj) "ROLLBACK from a nested transaction didn't restore the initial slot value")
     (with-transaction ()
       (slot-makunbound obj 'slot))
     (false (slot-boundp obj 'slot) "Transaction failed to unbind a slot")
     (with-transaction ()
       (setf (slot obj) 42)
       (rollback))
-    (false (slot-boundp obj 'slot) "Transaction rollback failed to unbind a slot")))
+    (false (slot-boundp obj 'slot) "Transaction rollback failed to unbind a slot")
+    (remhash (mito:object-id obj) (mito-transactions.dev::class-cache 'test-object)))
+  (let (obj)
+    (with-transaction ()
+      (setf obj (find-dao 'test-object))
+      (setf (slot obj) 2))
+    (is = 2 (slot obj))))