fix: make requested changes from PR review

In addition to minor changes, this commit makes the following changes:

- Add classification of snapshot corruption exceptions in tests.
- Fix snapshot corruption to be hardlink safe.
- Clamp choice of bit-to-corrupt to avoid overflow.
- Add more specific tagging in statemachine tests.

Author: jorisdral

src-control/Control/ActionRegistry.hs

@@ -25,6 +25,7 @@ module Control.ActionRegistry (
   , CommitActionRegistryError (..)
   , AbortActionRegistryError (..)
   , AbortActionRegistryReason (..)
+  , getReasonExitCaseException
     -- * Registering actions #registeringActions#
     -- $registering-actions
   , withRollback
@@ -372,6 +373,11 @@ data AbortActionRegistryReason =
   | ReasonExitCaseAbort
   deriving stock Show
 
+getReasonExitCaseException :: AbortActionRegistryReason -> Maybe SomeException
+getReasonExitCaseException = \case
+  ReasonExitCaseException e -> Just e
+  ReasonExitCaseAbort -> Nothing
+
 data AbortActionRegistryError =
     AbortActionRegistryError AbortActionRegistryReason (NonEmpty ActionError)
   deriving stock Show

test/Database/LSMTree/Class.hs

@@ -28,7 +28,7 @@ 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.FS (flipRandomBitInRandomFileHardlinkSafe)
 import           Test.Util.QC (Choice)
 
 -- | Class abstracting over table operations.
@@ -249,7 +249,7 @@ rCorruptSnapshot choice name (RI.Table' t) =
       let hfs = RI.sessionHasFS seshEnv
           root = RI.sessionRoot seshEnv
           namedSnapDir = RIP.getNamedSnapshotDir (RIP.namedSnapshotDir root name)
-       in void $ flipRandomBitInRandomFile hfs choice namedSnapDir
+       in void $ flipRandomBitInRandomFileHardlinkSafe hfs choice namedSnapDir
 
 instance IsTable R.Table where
     type Session R.Table = R.Session

test/Database/LSMTree/Model/Session.hs

@@ -32,7 +32,7 @@ module Database.LSMTree.Model.Session (
   , runModelM
   , runModelMWithInjectedErrors
     -- ** Errors
-  , Err (.., DefaultErrDiskFault)
+  , Err (.., DefaultErrDiskFault, DefaultErrSnapshotCorrupted)
     -- * Tables
   , Table
   , TableConfig (..)
@@ -241,19 +241,23 @@ runModelMWithInjectedErrors (Just _) _ onErrors st =
 pattern DefaultErrDiskFault :: Err
 pattern DefaultErrDiskFault = ErrDiskFault "default"
 
+-- | The default 'ErrSnapshotCorrupted' that model operations will throw.
+pattern DefaultErrSnapshotCorrupted :: Err
+pattern DefaultErrSnapshotCorrupted = ErrSnapshotCorrupted "default"
+
 --
 -- Errors
 --
 
 data Err =
     ErrTableClosed
-  | ErrSnapshotCorrupted
   | ErrSnapshotExists
   | ErrSnapshotDoesNotExist
   | ErrSnapshotWrongType
   | ErrBlobRefInvalidated
   | ErrCursorClosed
     -- | Something went wrong with the file system.
+  | ErrSnapshotCorrupted String
   | ErrDiskFault String
   | ErrOther String
   deriving stock Eq
@@ -262,8 +266,6 @@ instance Show Err where
   showsPrec d = \case
       ErrTableClosed ->
         showString "ErrTableClosed"
-      ErrSnapshotCorrupted ->
-        showString "ErrSnapshotCorrupted"
       ErrSnapshotExists ->
         showString "ErrSnapshotExists"
       ErrSnapshotDoesNotExist ->
@@ -274,6 +276,10 @@ instance Show Err where
         showString "ErrBlobRefInvalidated"
       ErrCursorClosed ->
         showString "ErrCursorClosed"
+      ErrSnapshotCorrupted s ->
+        showParen (d > appPrec) $
+        showString "ErrSnapshotCorrupted " .
+        showParen True (showString s)
       ErrDiskFault s ->
         showParen (d > appPrec) $
         showString "ErrDiskFault " .
@@ -577,7 +583,7 @@ openSnapshot label name = do
         throwError ErrSnapshotDoesNotExist
       Just (Snapshot conf label' tbl corrupted) -> do
         when corrupted $
-          throwError ErrSnapshotCorrupted
+          throwError DefaultErrSnapshotCorrupted
         when (label /= label') $
           throwError ErrSnapshotWrongType
         case fromSomeTable tbl of
@@ -592,9 +598,9 @@ openSnapshot label name = do
           Just table' ->
             newTableWith conf table'
 
--- TODO: to match the implementation of the real table, this should not corrupt the
---       snapshot if there are _no non-empty files_; however, since there are no such
---       snapshots, this is probably fine
+-- To match the implementation of the real table, this should not corrupt the
+-- snapshot if there are _no non-empty files_; however, since there are no such
+-- snapshots, this is probably fine.
 corruptSnapshot ::
      (MonadState Model m, MonadError Err m)
   => SnapshotName

test/Test/Database/LSMTree/Internal/Snapshot/FS.hs

@@ -161,7 +161,7 @@ instance Arbitrary TestErrors where
   Snapshot corruption
 -------------------------------------------------------------------------------}
 
--- TODO: an alternative to generating doubles a priori is to run the monadic
+-- TODO: an alternative to generating a Choice a priori is to run the monadic
 -- code in @PropertyM (IOSim s)@, and then we can do quantification inside the
 -- monadic property using @pick@. This complicates matters, however, because
 -- functions like @withSimHasBlockIO@ and @withTable@ would have to run in