Merge pull request #555 from IntersectMBO/wenkokke/corrupt-snapshot-model

feat: add corruptSnapshot to model

Author: wenkokke

test/Database/LSMTree/Model/Session.hs

@@ -69,6 +69,7 @@ module Database.LSMTree.Model.Session (
   , SnapshotName
   , createSnapshot
   , openSnapshot
+  , corruptSnapshot
   , deleteSnapshot
   , listSnapshots
     -- * Multiple writable tables
@@ -241,6 +242,7 @@ runModelMWithInjectedErrors (Just _) _ onErrors st =
 
 data Err =
     ErrTableClosed
+  | ErrSnapshotCorrupted
   | ErrSnapshotExists
   | ErrSnapshotDoesNotExist
   | ErrSnapshotWrongType
@@ -253,6 +255,8 @@ instance Show Err where
   showsPrec d = \case
       ErrTableClosed ->
         showString "ErrTableClosed"
+      ErrSnapshotCorrupted ->
+        showString "ErrSnapshotCorrupted"
       ErrSnapshotExists ->
         showString "ErrSnapshotExists"
       ErrSnapshotDoesNotExist ->
@@ -270,6 +274,7 @@ instance Show Err where
 
 instance Eq Err where
   (==) ErrTableClosed ErrTableClosed = True
+  (==) ErrSnapshotCorrupted ErrSnapshotCorrupted = True
   (==) ErrSnapshotExists ErrSnapshotExists = True
   (==) ErrSnapshotDoesNotExist ErrSnapshotDoesNotExist = True
   (==) ErrSnapshotWrongType ErrSnapshotWrongType = True
@@ -280,6 +285,7 @@ instance Eq Err where
     where
       _coveredAllCases x = case x of
           ErrTableClosed{}          -> ()
+          ErrSnapshotCorrupted{}    -> ()
           ErrSnapshotExists{}       -> ()
           ErrSnapshotDoesNotExist{} -> ()
           ErrSnapshotWrongType{}    -> ()
@@ -540,7 +546,12 @@ invalidateBlobRefs Table{..} = do
   Snapshots
 -------------------------------------------------------------------------------}
 
-data Snapshot = Snapshot TableConfig SnapshotLabel SomeTable
+data Snapshot = Snapshot
+  { snapshotConfig    :: TableConfig
+  , snapshotLabel     :: SnapshotLabel
+  , snapshotTable     :: SomeTable
+  , snapshotCorrupted :: Bool
+  }
   deriving stock Show
 
 createSnapshot ::
@@ -558,7 +569,7 @@ createSnapshot label name t@Table{..} = do
     when (Map.member name snaps) $
       throwError ErrSnapshotExists
     modify (\m -> m {
-        snapshots = Map.insert name (Snapshot config label $ toSomeTable $ Model.snapshot table) (snapshots m)
+        snapshots = Map.insert name (Snapshot config label (toSomeTable $ Model.snapshot table) False) (snapshots m)
       })
 
 openSnapshot ::
@@ -575,7 +586,9 @@ openSnapshot label name = do
     case Map.lookup name snaps of
       Nothing ->
         throwError ErrSnapshotDoesNotExist
-      Just (Snapshot conf label' tbl) -> do
+      Just (Snapshot conf label' tbl corrupted) -> do
+        when corrupted $
+          throwError ErrSnapshotCorrupted
         when (label /= label') $
           throwError ErrSnapshotWrongType
         case fromSomeTable tbl of
@@ -590,6 +603,18 @@ openSnapshot label name = do
           Just table' ->
             newTableWith conf table'
 
+corruptSnapshot ::
+     (MonadState Model m, MonadError Err m)
+  => SnapshotName
+  -> m ()
+corruptSnapshot name = do
+  snapshots <- gets snapshots
+  if Map.notMember name snapshots
+    then throwError ErrSnapshotDoesNotExist
+    else modify $ \m -> m {snapshots = Map.adjust corruptSnapshotEntry name snapshots}
+  where
+    corruptSnapshotEntry (Snapshot c l t _) = Snapshot c l t True
+
 deleteSnapshot ::
      (MonadState Model m, MonadError Err m)
   => SnapshotName