Skip to content
Merged
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
21 changes: 19 additions & 2 deletions test/Test/Database/LSMTree/StateMachine.hs
Original file line number Diff line number Diff line change
Expand Up @@ -101,6 +101,7 @@ import Database.LSMTree.Extras.Generators (KeyForIndexCompact)
import Database.LSMTree.Extras.NoThunks (propNoThunks)
import Database.LSMTree.Internal (LSMTreeError (..))
import qualified Database.LSMTree.Internal as R.Internal
import Database.LSMTree.Internal.CRC32C (FileFormatError (..))
import Database.LSMTree.Internal.Serialise (SerialisedBlob,
SerialisedValue)
import qualified Database.LSMTree.Model.IO as ModelIO
Expand Down Expand Up @@ -188,7 +189,11 @@ propLockstep_ModelIOImpl =
env :: RealEnv ModelIO.Table IO
env = RealEnv {
envSession = session
, envHandlers = [handler, diskFaultErrorHandler]
, envHandlers = [
handler
, fileFormatErrorHandler
, diskFaultErrorHandler
]
, envErrors = errsVar
, envInjectFaultResults = faultsVar
}
Expand Down Expand Up @@ -291,6 +296,7 @@ propLockstep_RealImpl_RealFS_IO tr =
envSession = session
, envHandlers = [
realHandler @IO
, fileFormatErrorHandler
, diskFaultErrorHandler
]
, envErrors = errsVar
Expand Down Expand Up @@ -333,6 +339,7 @@ propLockstep_RealImpl_MockFS_IO tr =
envSession = session
, envHandlers = [
realHandler @IO
, fileFormatErrorHandler
, diskFaultErrorHandler
]
, envErrors = errsVar
Expand Down Expand Up @@ -361,6 +368,7 @@ propLockstep_RealImpl_MockFS_IOSim tr actions =
envSession = session
, envHandlers = [
realHandler @(IOSim s)
, fileFormatErrorHandler
, diskFaultErrorHandler
]
, envErrors = errsVar
Expand Down Expand Up @@ -434,6 +442,9 @@ realHandler = Handler $ pure . handler'
handler' (ErrBlobRefInvalid _) = Just Model.ErrBlobRefInvalidated
handler' _ = Nothing

-- | When combined with other handlers, 'diskFaultErrorHandler' has to go last
-- because it matches on 'SomeException', an no other handlers are run after
-- that. See the use of 'catches' in 'catchErr'.
diskFaultErrorHandler :: Monad m => Handler m (Maybe Model.Err)
diskFaultErrorHandler = Handler $ \e -> pure $
if isDiskFault e
Expand All @@ -448,7 +459,7 @@ isDiskFault e
= case reason of
ReasonExitCaseException e' -> isDiskFault e' && all isDiskFault' es
ReasonExitCaseAbort -> False
| Just (e' :: ActionError)<- fromException e
| Just (e' :: ActionError) <- fromException e
= isDiskFault' (getActionError e')
| Just FsError{} <- fromException e
= True
Expand All @@ -458,6 +469,12 @@ isDiskFault e
isDiskFault' :: forall e. Exception e => e -> Bool
isDiskFault' = isDiskFault . toException

fileFormatErrorHandler :: Monad m => Handler m (Maybe Model.Err)
fileFormatErrorHandler = Handler $ pure . handler'
where
handler' :: FileFormatError -> Maybe Model.Err
handler' e = Just (Model.ErrFsError (displayException e))

createSystemTempDirectory :: [Char] -> IO (FilePath, HasFS IO HandleIO, HasBlockIO IO HandleIO)
createSystemTempDirectory prefix = do
systemTempDir <- getCanonicalTemporaryDirectory
Expand Down