@@ -82,6 +82,7 @@ import Control.Tracer (Tracer, nullTracer)
82
82
import Data.Bifunctor (Bifunctor (.. ))
83
83
import Data.Constraint (Dict (.. ))
84
84
import Data.Either (partitionEithers )
85
+ import Data.Foldable (for_ )
85
86
import Data.Kind (Type )
86
87
import Data.List.NonEmpty (NonEmpty (.. ))
87
88
import qualified Data.List.NonEmpty as NE
@@ -135,7 +136,8 @@ import qualified Test.QuickCheck.StateModel.Lockstep.Defaults as Lockstep.Defaul
135
136
import qualified Test.QuickCheck.StateModel.Lockstep.Run as Lockstep.Run
136
137
import Test.Tasty (TestTree , testGroup )
137
138
import Test.Tasty.QuickCheck (testProperty )
138
- import Test.Util.FS (approximateEqStream , noRemoveDirectoryRecursiveE ,
139
+ import Test.Util.FS (SilentCorruption (.. ), SilentCorruptions (.. ),
140
+ approximateEqStream , noRemoveDirectoryRecursiveE ,
139
141
propNoOpenHandles , propNumOpenHandles )
140
142
import Test.Util.PrettyProxy
141
143
import Test.Util.QLS
@@ -604,7 +606,7 @@ instance ( Show (Class.TableConfig h)
604
606
-- Snapshots
605
607
CreateSnapshot ::
606
608
C k v b
607
- => Maybe Errors
609
+ => Maybe ( Either SilentCorruptions Errors )
608
610
-> R. SnapshotLabel -> R. SnapshotName -> Var h (WrapTable h IO k v b )
609
611
-> Act h ()
610
612
OpenSnapshot ::
@@ -1125,11 +1127,12 @@ runModel lookUp = \case
1125
1127
RetrieveBlobs blobsVar ->
1126
1128
wrap (MVector . fmap (MBlob . WrapBlob ))
1127
1129
. 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 () )
1133
1136
OpenSnapshot _ merrs label name ->
1134
1137
wrap MTable
1135
1138
. Model. runModelMWithInjectedErrors merrs
@@ -1211,10 +1214,18 @@ runIO action lookUp = ReaderT $ \ !env -> do
1211
1214
Class. mupserts (unwrapTable $ lookUp' tableVar) kmups
1212
1215
RetrieveBlobs blobRefsVar -> catchErr handlers $
1213
1216
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)
1218
1229
OpenSnapshot _ merrs label name ->
1219
1230
runRealWithInjectedErrors " OpenSnapshot" env merrs
1220
1231
(WrapTable <$> Class. openSnapshot session label name)
@@ -1273,10 +1284,18 @@ runIOSim action lookUp = ReaderT $ \ !env -> do
1273
1284
Class. mupserts (unwrapTable $ lookUp' tableVar) kmups
1274
1285
RetrieveBlobs blobRefsVar -> catchErr handlers $
1275
1286
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)
1280
1299
OpenSnapshot _ merrs label name ->
1281
1300
runRealWithInjectedErrors " OpenSnapshot" env merrs
1282
1301
(WrapTable <$> Class. openSnapshot session label name)
0 commit comments