Skip to content

Commit 0b53a70

Browse files
committed
add snapshot corruption to state machine tests
1 parent 6475391 commit 0b53a70

File tree

4 files changed

+67
-17
lines changed

4 files changed

+67
-17
lines changed

test/Database/LSMTree/Class.hs

Lines changed: 21 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@ module Database.LSMTree.Class (
1414
, module Types
1515
) where
1616

17+
import Control.Monad (void)
1718
import Control.Monad.Class.MonadThrow (MonadThrow (..))
1819
import Data.Kind (Constraint, Type)
1920
import Data.List.NonEmpty (NonEmpty)
@@ -24,6 +25,10 @@ import Database.LSMTree as Types (LookupResult (..), QueryResult (..),
2425
resolveDeserialised)
2526
import qualified Database.LSMTree as R
2627
import Database.LSMTree.Class.Common as Common
28+
import qualified Database.LSMTree.Internal as RI (SessionEnv (..), Table (..),
29+
Table' (..), withOpenSession)
30+
import qualified Database.LSMTree.Internal.Paths as RIP
31+
import Test.Util.FS (flipRandomBitInRandomFile)
2732
import Test.Util.QC (Choice)
2833

2934
-- | Class abstracting over table operations.
@@ -231,6 +236,21 @@ withCursor offset tbl = bracket (newCursor offset tbl) (closeCursor (Proxy @h))
231236
Real instance
232237
-------------------------------------------------------------------------------}
233238

239+
-- | Snapshot corruption for the real instance.
240+
-- Implemented here, instead of as part of the public API.
241+
rCorruptSnapshot ::
242+
IOLike m
243+
=> Choice
244+
-> SnapshotName
245+
-> R.Table m k v b
246+
-> m ()
247+
rCorruptSnapshot choice name (RI.Table' t) =
248+
RI.withOpenSession (RI.tableSession t) $ \seshEnv ->
249+
let hfs = RI.sessionHasFS seshEnv
250+
root = RI.sessionRoot seshEnv
251+
namedSnapDir = RIP.getNamedSnapshotDir (RIP.namedSnapshotDir root name)
252+
in void $ flipRandomBitInRandomFile hfs choice namedSnapDir
253+
234254
instance IsTable R.Table where
235255
type Session R.Table = R.Session
236256
type TableConfig R.Table = R.TableConfig
@@ -253,7 +273,7 @@ instance IsTable R.Table where
253273
readCursor _ = R.readCursor
254274

255275
createSnapshot = R.createSnapshot
256-
corruptSnapshot = error "TODO: not yet implemented"
276+
corruptSnapshot = rCorruptSnapshot
257277
openSnapshot sesh snap = R.openSnapshot sesh R.configNoOverride snap
258278

259279
duplicate = R.duplicate

test/Database/LSMTree/Model/Session.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -233,9 +233,10 @@ runModelMWithInjectedErrors ::
233233
-> Model -> (Either Err a, Model)
234234
runModelMWithInjectedErrors Nothing onNoErrors _ st =
235235
runModelM onNoErrors st
236-
runModelMWithInjectedErrors (Just _) _ onErrors st =
236+
runModelMWithInjectedErrors (Just _errors) _ onErrors st =
237237
runModelM (onErrors >> throwError (ErrFsError "modelled FsError")) st
238238

239+
239240
--
240241
-- Errors
241242
--

test/Test/Database/LSMTree/StateMachine.hs

Lines changed: 34 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -82,6 +82,7 @@ import Control.Tracer (Tracer, nullTracer)
8282
import Data.Bifunctor (Bifunctor (..))
8383
import Data.Constraint (Dict (..))
8484
import Data.Either (partitionEithers)
85+
import Data.Foldable (for_)
8586
import Data.Kind (Type)
8687
import Data.List.NonEmpty (NonEmpty (..))
8788
import qualified Data.List.NonEmpty as NE
@@ -135,7 +136,8 @@ import qualified Test.QuickCheck.StateModel.Lockstep.Defaults as Lockstep.Defaul
135136
import qualified Test.QuickCheck.StateModel.Lockstep.Run as Lockstep.Run
136137
import Test.Tasty (TestTree, testGroup)
137138
import Test.Tasty.QuickCheck (testProperty)
138-
import Test.Util.FS (approximateEqStream, noRemoveDirectoryRecursiveE,
139+
import Test.Util.FS (SilentCorruption (..), SilentCorruptions (..),
140+
approximateEqStream, noRemoveDirectoryRecursiveE,
139141
propNoOpenHandles, propNumOpenHandles)
140142
import Test.Util.PrettyProxy
141143
import Test.Util.QLS
@@ -604,7 +606,7 @@ instance ( Show (Class.TableConfig h)
604606
-- Snapshots
605607
CreateSnapshot ::
606608
C k v b
607-
=> Maybe Errors
609+
=> Maybe (Either SilentCorruptions Errors)
608610
-> R.SnapshotLabel -> R.SnapshotName -> Var h (WrapTable h IO k v b)
609611
-> Act h ()
610612
OpenSnapshot ::
@@ -1125,11 +1127,12 @@ runModel lookUp = \case
11251127
RetrieveBlobs blobsVar ->
11261128
wrap (MVector . fmap (MBlob . WrapBlob))
11271129
. Model.runModelM (Model.retrieveBlobs (getBlobRefs . lookUp $ blobsVar))
1128-
CreateSnapshot merrs label name tableVar ->
1129-
wrap MUnit
1130-
. Model.runModelMWithInjectedErrors merrs
1131-
(Model.createSnapshot label name (getTable $ lookUp tableVar))
1132-
(pure ())
1130+
CreateSnapshot mcorrsOrErrs label name tableVar ->
1131+
wrap MUnit .
1132+
let mCreateSnapshot = Model.createSnapshot label name (getTable $ lookUp tableVar)
1133+
in case sequence mcorrsOrErrs of
1134+
Left _corrs -> Model.runModelM (mCreateSnapshot >> Model.corruptSnapshot name)
1135+
Right merrs -> Model.runModelMWithInjectedErrors merrs mCreateSnapshot (pure ())
11331136
OpenSnapshot _ merrs label name ->
11341137
wrap MTable
11351138
. Model.runModelMWithInjectedErrors merrs
@@ -1211,10 +1214,18 @@ runIO action lookUp = ReaderT $ \ !env -> do
12111214
Class.mupserts (unwrapTable $ lookUp' tableVar) kmups
12121215
RetrieveBlobs blobRefsVar -> catchErr handlers $
12131216
fmap WrapBlob <$> Class.retrieveBlobs (Proxy @h) session (unwrapBlobRef <$> lookUp' blobRefsVar)
1214-
CreateSnapshot merrs label name tableVar ->
1215-
runRealWithInjectedErrors "CreateSnapshot" env merrs
1216-
(Class.createSnapshot label name (unwrapTable $ lookUp' tableVar))
1217-
(\() -> Class.deleteSnapshot session name)
1217+
CreateSnapshot mcorrsOrErrs label name tableVar ->
1218+
let rCreateSnapshot = Class.createSnapshot label name (unwrapTable $ lookUp' tableVar) in
1219+
case sequence mcorrsOrErrs of
1220+
Left (SilentCorruptions corrs) -> do
1221+
rCreateSnapshot
1222+
for_ corrs $ \corr ->
1223+
Class.corruptSnapshot (bitChoice corr) name (unwrapTable $ lookUp' tableVar)
1224+
pure (Right ())
1225+
Right merrs ->
1226+
runRealWithInjectedErrors "CreateSnapshot" env merrs
1227+
rCreateSnapshot
1228+
(\() -> Class.deleteSnapshot session name)
12181229
OpenSnapshot _ merrs label name ->
12191230
runRealWithInjectedErrors "OpenSnapshot" env merrs
12201231
(WrapTable <$> Class.openSnapshot session label name)
@@ -1273,10 +1284,18 @@ runIOSim action lookUp = ReaderT $ \ !env -> do
12731284
Class.mupserts (unwrapTable $ lookUp' tableVar) kmups
12741285
RetrieveBlobs blobRefsVar -> catchErr handlers $
12751286
fmap WrapBlob <$> Class.retrieveBlobs (Proxy @h) session (unwrapBlobRef <$> lookUp' blobRefsVar)
1276-
CreateSnapshot merrs label name tableVar ->
1277-
runRealWithInjectedErrors "CreateSnapshot" env merrs
1278-
(Class.createSnapshot label name (unwrapTable $ lookUp' tableVar))
1279-
(\() -> Class.deleteSnapshot session name)
1287+
CreateSnapshot mcorrsOrErrs label name tableVar ->
1288+
let rCreateSnapshot = Class.createSnapshot label name (unwrapTable $ lookUp' tableVar) in
1289+
case sequence mcorrsOrErrs of
1290+
Left (SilentCorruptions corrs) -> do
1291+
rCreateSnapshot
1292+
for_ corrs $ \corr ->
1293+
Class.corruptSnapshot (bitChoice corr) name (unwrapTable $ lookUp' tableVar)
1294+
pure (Right ())
1295+
Right merrs ->
1296+
runRealWithInjectedErrors "CreateSnapshot" env merrs
1297+
rCreateSnapshot
1298+
(\() -> Class.deleteSnapshot session name)
12801299
OpenSnapshot _ merrs label name ->
12811300
runRealWithInjectedErrors "OpenSnapshot" env merrs
12821301
(WrapTable <$> Class.openSnapshot session label name)

test/Test/Util/FS.hs

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,8 @@ module Test.Util.FS (
3030
, listDirectoryRecursive
3131
, listDirectoryRecursiveFiles
3232
-- * Corruption
33+
, SilentCorruptions (..)
34+
, SilentCorruption (..)
3335
, flipRandomBitInRandomFile
3436
, flipFileBit
3537
, hFlipBit
@@ -351,6 +353,14 @@ listDirectoryFiles hfs = go Set.empty
351353
Corruption
352354
-------------------------------------------------------------------------------}
353355

356+
newtype SilentCorruptions = SilentCorruptions {unSilentCorruptions :: NonEmpty SilentCorruption}
357+
deriving stock (Eq, Show)
358+
deriving newtype (Arbitrary)
359+
360+
newtype SilentCorruption = SilentCorruption {bitChoice :: Choice}
361+
deriving stock (Eq, Show)
362+
deriving newtype (Arbitrary)
363+
354364
-- | Flip a random bit in a random file in a given directory.
355365
flipRandomBitInRandomFile ::
356366
(PrimMonad m, MonadThrow m)

0 commit comments

Comments
 (0)