From 870bca2d4c036be064d999127a21957fbc1224aa Mon Sep 17 00:00:00 2001
From: Joris Dral <joris@well-typed.com>
Date: Thu, 2 Jan 2025 18:26:00 +0100
Subject: [PATCH] Manually invalidate blob references in the model

This is required for properly modelling the model's response to disk faults in
`createSnapshot`. The current implementation for `createSnapshot` in the real
system can invalidate blob references even if creating the snapshot failed, so
the model will invalidate blob references as well. This change might become
obsolete once #478 is merged.
---
 test/Database/LSMTree/Model/Session.hs | 22 ++++++++++++++++++++++
 1 file changed, 22 insertions(+)

diff --git a/test/Database/LSMTree/Model/Session.hs b/test/Database/LSMTree/Model/Session.hs
index cb2c9c2f6..dce13c967 100644
--- a/test/Database/LSMTree/Model/Session.hs
+++ b/test/Database/LSMTree/Model/Session.hs
@@ -64,6 +64,7 @@ module Database.LSMTree.Model.Session (
     -- ** Blobs
   , BlobRef
   , retrieveBlobs
+  , invalidateBlobRefs
     -- * Snapshots
   , SnapshotName
   , createSnapshot
@@ -481,6 +482,27 @@ liftBlobRefs ::
   -> g (f (BlobRef b))
 liftBlobRefs hid = fmap (fmap (BlobRef hid))
 
+-- | Invalidate blob references that were created from the given table. This
+-- function assumes that it is called on an open table.
+--
+-- This is useful in tests where blob references should be invalidated for other
+-- reasons than normal operation of the model.
+--
+-- TODO: I (Joris) think this function will become obsolete once lsm-tree#478 is
+-- merged, because then createSnapshot won't flush the write buffer into the
+-- levels anymore.
+invalidateBlobRefs ::
+     MonadState Model m
+  => Table k v b
+  -> m ()
+invalidateBlobRefs Table{..} = do
+    gets (Map.lookup tableID . tables) >>= \case
+      Nothing -> error "invalidateBlobRefs: table is closed!"
+      Just (updc, tbl) -> do
+        modify (\m -> m {
+            tables = Map.insert tableID (updc + 1, tbl) (tables m)
+          })
+
 {-------------------------------------------------------------------------------
   Snapshots
 -------------------------------------------------------------------------------}