feat(issue558): add snapshot corruption to state machine tests

Author: wenkokke

test/Database/LSMTree/Class.hs

@@ -14,6 +14,7 @@ module Database.LSMTree.Class (
   , module Types
   ) where
 
+import           Control.Monad (void)
 import           Control.Monad.Class.MonadThrow (MonadThrow (..))
 import           Data.Kind (Constraint, Type)
 import           Data.List.NonEmpty (NonEmpty)
@@ -24,6 +25,10 @@ import           Database.LSMTree as Types (LookupResult (..), QueryResult (..),
                      resolveDeserialised)
 import qualified Database.LSMTree as R
 import           Database.LSMTree.Class.Common as Common
+import qualified Database.LSMTree.Internal as RI (SessionEnv (..), Table (..),
+                     Table' (..), withOpenSession)
+import qualified Database.LSMTree.Internal.Paths as RIP
+import           Test.Util.FS (flipRandomBitInRandomFile)
 import           Test.Util.QC (Choice)
 
 -- | Class abstracting over table operations.
@@ -231,6 +236,21 @@ withCursor offset tbl = bracket (newCursor offset tbl) (closeCursor (Proxy @h))
   Real instance
 -------------------------------------------------------------------------------}
 
+-- | Snapshot corruption for the real instance.
+--   Implemented here, instead of as part of the public API.
+rCorruptSnapshot ::
+      IOLike m
+   => Choice
+   -> SnapshotName
+   -> R.Table m k v b
+   -> m ()
+rCorruptSnapshot choice name (RI.Table' t) =
+   RI.withOpenSession (RI.tableSession t) $ \seshEnv ->
+      let hfs = RI.sessionHasFS seshEnv
+          root = RI.sessionRoot seshEnv
+          namedSnapDir = RIP.getNamedSnapshotDir (RIP.namedSnapshotDir root name)
+       in void $ flipRandomBitInRandomFile hfs choice namedSnapDir
+
 instance IsTable R.Table where
     type Session R.Table = R.Session
     type TableConfig R.Table = R.TableConfig
@@ -253,7 +273,7 @@ instance IsTable R.Table where
     readCursor _ = R.readCursor
 
     createSnapshot = R.createSnapshot
-    corruptSnapshot = error "TODO: not yet implemented"
+    corruptSnapshot = rCorruptSnapshot
     openSnapshot sesh snap = R.openSnapshot sesh R.configNoOverride snap
 
     duplicate = R.duplicate

test/Test/Database/LSMTree/StateMachine.hs

@@ -83,6 +83,7 @@ import           Control.Tracer (Tracer, nullTracer)
 import           Data.Bifunctor (Bifunctor (..))
 import           Data.Constraint (Dict (..))
 import           Data.Either (partitionEithers)
+import           Data.Foldable (for_)
 import           Data.Kind (Type)
 import           Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NE
@@ -136,7 +137,8 @@ import qualified Test.QuickCheck.StateModel.Lockstep.Defaults as Lockstep.Defaul
 import qualified Test.QuickCheck.StateModel.Lockstep.Run as Lockstep.Run
 import           Test.Tasty (TestTree, testGroup)
 import           Test.Tasty.QuickCheck (testProperty)
-import           Test.Util.FS (approximateEqStream, noRemoveDirectoryRecursiveE,
+import           Test.Util.FS (SilentCorruption (..), SilentCorruptions (..),
+                     approximateEqStream, noRemoveDirectoryRecursiveE,
                      propNoOpenHandles, propNumOpenHandles)
 import           Test.Util.PrettyProxy
 import qualified Test.Util.QLS as QLS
@@ -636,7 +638,7 @@ instance ( Show (Class.TableConfig h)
     -- Snapshots
     CreateSnapshot ::
          C k v b
-      => Maybe Errors
+      => Maybe (Either SilentCorruptions Errors)
       -> R.SnapshotLabel -> R.SnapshotName -> Var h (WrapTable h IO k v b)
       -> Act h ()
     OpenSnapshot   ::
@@ -1170,11 +1172,12 @@ runModel lookUp = \case
     RetrieveBlobs blobsVar ->
       wrap (MVector . fmap (MBlob . WrapBlob))
       . Model.runModelM (Model.retrieveBlobs (getBlobRefs . lookUp $ blobsVar))
-    CreateSnapshot merrs label name tableVar ->
-      wrap MUnit
-      . Model.runModelMWithInjectedErrors merrs
-          (Model.createSnapshot label name (getTable $ lookUp tableVar))
-          (pure ())
+    CreateSnapshot mcorrsOrErrs label name tableVar ->
+      wrap MUnit .
+        let mCreateSnapshot = Model.createSnapshot label name (getTable $ lookUp tableVar)
+        in case sequence mcorrsOrErrs of
+              Left _corrs -> Model.runModelM (mCreateSnapshot >> Model.corruptSnapshot name)
+              Right merrs -> Model.runModelMWithInjectedErrors merrs mCreateSnapshot (pure ())
     OpenSnapshot _ merrs label name ->
       wrap MTable
       . Model.runModelMWithInjectedErrors merrs
@@ -1256,10 +1259,18 @@ runIO action lookUp = ReaderT $ \ !env -> do
           Class.mupserts (unwrapTable $ lookUp' tableVar) kmups
         RetrieveBlobs blobRefsVar -> catchErr handlers $
           fmap WrapBlob <$> Class.retrieveBlobs (Proxy @h) session (unwrapBlobRef <$> lookUp' blobRefsVar)
-        CreateSnapshot merrs label name tableVar ->
-          runRealWithInjectedErrors "CreateSnapshot" env merrs
-            (Class.createSnapshot label name (unwrapTable $ lookUp' tableVar))
-            (\() -> Class.deleteSnapshot session name)
+        CreateSnapshot mcorrsOrErrs label name tableVar ->
+          let rCreateSnapshot = Class.createSnapshot label name (unwrapTable $ lookUp' tableVar) in
+          case sequence mcorrsOrErrs of
+            Left (SilentCorruptions corrs) -> do
+              rCreateSnapshot
+              for_ corrs $ \corr ->
+                Class.corruptSnapshot (bitChoice corr) name (unwrapTable $ lookUp' tableVar)
+              pure (Right ())
+            Right merrs ->
+              runRealWithInjectedErrors "CreateSnapshot" env merrs
+                rCreateSnapshot
+                (\() -> Class.deleteSnapshot session name)
         OpenSnapshot _ merrs label name ->
           runRealWithInjectedErrors "OpenSnapshot" env merrs
             (WrapTable <$> Class.openSnapshot session label name)
@@ -1318,10 +1329,18 @@ runIOSim action lookUp = ReaderT $ \ !env -> do
           Class.mupserts (unwrapTable $ lookUp' tableVar) kmups
         RetrieveBlobs blobRefsVar -> catchErr handlers $
           fmap WrapBlob <$> Class.retrieveBlobs (Proxy @h) session (unwrapBlobRef <$> lookUp' blobRefsVar)
-        CreateSnapshot merrs label name tableVar ->
-          runRealWithInjectedErrors "CreateSnapshot" env merrs
-            (Class.createSnapshot label name (unwrapTable $ lookUp' tableVar))
-            (\() -> Class.deleteSnapshot session name)
+        CreateSnapshot mcorrsOrErrs label name tableVar ->
+          let rCreateSnapshot = Class.createSnapshot label name (unwrapTable $ lookUp' tableVar) in
+          case sequence mcorrsOrErrs of
+            Left (SilentCorruptions corrs) -> do
+              rCreateSnapshot
+              for_ corrs $ \corr ->
+                Class.corruptSnapshot (bitChoice corr) name (unwrapTable $ lookUp' tableVar)
+              pure (Right ())
+            Right merrs ->
+              runRealWithInjectedErrors "CreateSnapshot" env merrs
+                rCreateSnapshot
+                (\() -> Class.deleteSnapshot session name)
         OpenSnapshot _ merrs label name ->
           runRealWithInjectedErrors "OpenSnapshot" env merrs
             (WrapTable <$> Class.openSnapshot session label name)

test/Test/Util/FS.hs

@@ -30,6 +30,8 @@ module Test.Util.FS (
   , listDirectoryRecursive
   , listDirectoryRecursiveFiles
     -- * Corruption
+  , SilentCorruptions (..)
+  , SilentCorruption (..)
   , flipRandomBitInRandomFile
   , flipFileBit
   , hFlipBit
@@ -351,6 +353,14 @@ listDirectoryFiles hfs = go Set.empty
   Corruption
 -------------------------------------------------------------------------------}
 
+newtype SilentCorruptions = SilentCorruptions {unSilentCorruptions :: NonEmpty SilentCorruption}
+  deriving stock (Eq, Show)
+  deriving newtype (Arbitrary)
+
+newtype SilentCorruption = SilentCorruption {bitChoice :: Choice}
+  deriving stock (Eq, Show)
+  deriving newtype (Arbitrary)
+
 -- | Flip a random bit in a random file in a given directory.
 flipRandomBitInRandomFile ::
      (PrimMonad m, MonadThrow m)