From e64ccd6fb7f2f6e78442a249b883888c605fae54 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Tue, 14 Jan 2025 15:53:05 +0100 Subject: [PATCH 1/2] Display action registry exceptions in human-readable format --- src-control/Control/ActionRegistry.hs | 48 ++++++++++++++++++--- test-control/Test/Control/ActionRegistry.hs | 9 +++- 2 files changed, 50 insertions(+), 7 deletions(-) diff --git a/src-control/Control/ActionRegistry.hs b/src-control/Control/ActionRegistry.hs index 266a9fcf4..f020eed3b 100644 --- a/src-control/Control/ActionRegistry.hs +++ b/src-control/Control/ActionRegistry.hs @@ -21,8 +21,8 @@ module Control.ActionRegistry ( , withActionRegistry , unsafeNewActionRegistry , unsafeFinaliseActionRegistry - , CommitActionRegistryError - , AbortActionRegistryError + , CommitActionRegistryError (..) + , AbortActionRegistryError (..) , AbortActionRegistryReason -- * Registering actions #registeringActions# -- $registering-actions @@ -61,6 +61,23 @@ import GHC.Stack #define HasCallStackIfDebug () #endif +{------------------------------------------------------------------------------- + Printing utilities +-------------------------------------------------------------------------------} + +tabLines1 :: String -> String +tabLines1 = tabLinesN 1 + +#ifdef NO_IGNORE_ASSERTS +tabLines2 :: String -> String +tabLines2 = tabLinesN 2 +#endif + +tabLinesN :: Int -> String -> String +tabLinesN n = unlines . fmap (ts++) . lines + where + ts = concat $ replicate n " " + {------------------------------------------------------------------------------- Modify mutable state -------------------------------------------------------------------------------} @@ -216,7 +233,15 @@ data Action m = Action { data ActionError = ActionError SomeException CallStack deriving stock Show - deriving anyclass Exception + +instance Exception ActionError where + displayException (ActionError err registerSite) = unlines [ + "A registered action threw an error: " + , tabLines1 "The error:" + , tabLines2 (displayException err) + , tabLines1 "Registration site:" + , tabLines2 (prettyCallStack registerSite) + ] mkAction a = Action a callStack @@ -305,7 +330,13 @@ unsafeCommitActionRegistry reg = do data CommitActionRegistryError = CommitActionRegistryError (NonEmpty ActionError) deriving stock Show - deriving anyclass Exception + +instance Exception CommitActionRegistryError where + displayException (CommitActionRegistryError es) = unlines $ [ + "Exceptions thrown while committing an action registry." + ] <> NE.toList (fmap displayOne es) + where + displayOne e = tabLines1 (displayException e) {-# SPECIALISE unsafeAbortActionRegistry :: ActionRegistry IO @@ -338,7 +369,14 @@ data AbortActionRegistryReason = data AbortActionRegistryError = AbortActionRegistryError AbortActionRegistryReason (NonEmpty ActionError) deriving stock Show - deriving anyclass Exception + +instance Exception AbortActionRegistryError where + displayException (AbortActionRegistryError reason es) = unlines $ [ + "Exceptions thrown while aborting an action registry." + , ("Reason for aborting the registry: " ++ show reason) + ] <> NE.toList (fmap displayOne es) + where + displayOne e = tabLines1 (displayException e) {-# SPECIALISE runActions :: [Action IO] -> IO [ActionError] #-} -- | Run all actions even if previous actions threw exceptions. diff --git a/test-control/Test/Control/ActionRegistry.hs b/test-control/Test/Control/ActionRegistry.hs index 80bab559a..35e974a6e 100644 --- a/test-control/Test/Control/ActionRegistry.hs +++ b/test-control/Test/Control/ActionRegistry.hs @@ -21,7 +21,8 @@ prop_commitActionRegistryError = once $ ioProperty $ do delayedCommit reg (throwIO (userError "delayed action failed")) pure $ case eith of - Left e -> tabulate "Printed error" [show e] $ property True + Left e -> + tabulate "displayException" [displayExceptionNewline e] $ property True Right () -> property False -- | An example where an exception happens while an action registry is being @@ -36,5 +37,9 @@ prop_abortActionRegistryError = once $ ioProperty $ do (\_ -> throwIO (userError "rollback action failed")) throwIO (userError "error in withActionRegistry scope") pure $ case eith of - Left e -> tabulate "Printed error" [show e] $ property True + Left e -> + tabulate "displayException" [displayExceptionNewline e] $ property True Right () -> property False + +displayExceptionNewline :: Exception e => e -> String +displayExceptionNewline e = '\n':displayException e From d18f9e12c5dbb717f759cfaf1a83ca185d227e11 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Tue, 14 Jan 2025 15:53:53 +0100 Subject: [PATCH 2/2] Display exceptions in state machine tests Previously, converting a real exception to the model `ErrFsError` would lose information. This commit makes sure that an `ErrFsError` now has an additional string argument that can be used to put printed exceptions in. This string argument is ignored when comparing exceptions in the state machine tests. --- test/Database/LSMTree/Model/Session.hs | 47 +++++++++++++++++++--- test/Test/Database/LSMTree/StateMachine.hs | 40 ++++++++++++++---- 2 files changed, 75 insertions(+), 12 deletions(-) diff --git a/test/Database/LSMTree/Model/Session.hs b/test/Database/LSMTree/Model/Session.hs index 8f94569b1..5558da6dd 100644 --- a/test/Database/LSMTree/Model/Session.hs +++ b/test/Database/LSMTree/Model/Session.hs @@ -98,6 +98,7 @@ import Database.LSMTree.Model.Table (LookupResult (..), QueryResult (..), Range (..), ResolveSerialisedValue (..), Update (..), getResolve, noResolve) import qualified Database.LSMTree.Model.Table as Model +import GHC.Show (appPrec) {------------------------------------------------------------------------------- Model @@ -232,7 +233,7 @@ runModelMWithInjectedErrors :: runModelMWithInjectedErrors Nothing onNoErrors _ st = runModelM onNoErrors st runModelMWithInjectedErrors (Just _) _ onErrors st = - runModelM (onErrors >> throwError ErrFsError) st + runModelM (onErrors >> throwError (ErrFsError "modelled FsError")) st -- -- Errors @@ -245,11 +246,47 @@ data Err = | ErrSnapshotWrongType | ErrBlobRefInvalidated | ErrCursorClosed - -- | Passed zero tables to 'unions' - | ErrUnionsZeroTables -- | Some file system error occurred - | ErrFsError - deriving stock (Show, Eq) + | ErrFsError String + +instance Show Err where + showsPrec d = \case + ErrTableClosed -> + showString "ErrTableClosed" + ErrSnapshotExists -> + showString "ErrSnapshotExists" + ErrSnapshotDoesNotExist -> + showString "ErrSnapshotDoesNotExist" + ErrSnapshotWrongType -> + showString "ErrSnapshotWrongType" + ErrBlobRefInvalidated -> + showString "ErrBlobRefInvalidated" + ErrCursorClosed -> + showString "ErrCursorCosed" + ErrFsError s -> + showParen (d > appPrec) $ + showString "ErrFsError " . + showParen True (showString s) + +instance Eq Err where + (==) ErrTableClosed ErrTableClosed = True + (==) ErrSnapshotExists ErrSnapshotExists = True + (==) ErrSnapshotDoesNotExist ErrSnapshotDoesNotExist = True + (==) ErrSnapshotWrongType ErrSnapshotWrongType = True + (==) ErrBlobRefInvalidated ErrBlobRefInvalidated = True + (==) ErrCursorClosed ErrCursorClosed = True + (==) (ErrFsError _) (ErrFsError _) = True + (==) _ _ = False + where + _coveredAllCases x = case x of + ErrTableClosed{} -> () + ErrSnapshotExists{} -> () + ErrSnapshotDoesNotExist{} -> () + ErrSnapshotWrongType{} -> () + ErrBlobRefInvalidated{} -> () + ErrCursorClosed{} -> () + ErrFsError{} -> () + {------------------------------------------------------------------------------- Tables diff --git a/test/Test/Database/LSMTree/StateMachine.hs b/test/Test/Database/LSMTree/StateMachine.hs index 79d07a055..f4e3caf2a 100644 --- a/test/Test/Database/LSMTree/StateMachine.hs +++ b/test/Test/Database/LSMTree/StateMachine.hs @@ -9,6 +9,7 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuantifiedConstraints #-} @@ -64,11 +65,14 @@ module Test.Database.LSMTree.StateMachine ( , Action (..) ) where +import Control.ActionRegistry (AbortActionRegistryError (..), + CommitActionRegistryError (..)) import Control.Concurrent.Class.MonadMVar.Strict import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad (forM_, void, (<=<)) -import Control.Monad.Class.MonadThrow (Handler (..), MonadCatch (..), - MonadThrow (..), catches) +import Control.Monad.Class.MonadThrow (Exception (..), Handler (..), + MonadCatch (..), MonadThrow (..), catches, + displayException) import Control.Monad.IOSim import Control.Monad.Primitive import Control.Monad.Reader (ReaderT (..)) @@ -160,7 +164,7 @@ tests = testGroup "Test.Database.LSMTree.StateMachine" [ Handler f -> do throwIO (dummyFsError s) `catch` \e -> do e' <- f e - pure (e' QC.=== Just Model.ErrFsError) + pure (e' QC.=== Just (Model.ErrFsError ("dummy: " ++ s))) ] labelledExamples :: IO () @@ -284,7 +288,11 @@ propLockstep_RealImpl_RealFS_IO tr = env :: RealEnv R.Table IO env = RealEnv { envSession = session - , envHandlers = [realHandler @IO, fsErrorHandler] + , envHandlers = [ + realHandler @IO + , fsErrorHandler + , actionRegistryErrorHandler + ] , envErrors = errsVar , envInjectFaultResults = faultsVar } @@ -321,7 +329,11 @@ propLockstep_RealImpl_MockFS_IO tr = env :: RealEnv R.Table IO env = RealEnv { envSession = session - , envHandlers = [realHandler @IO, fsErrorHandler] + , envHandlers = [ + realHandler @IO + , fsErrorHandler + , actionRegistryErrorHandler + ] , envErrors = errsVar , envInjectFaultResults = faultsVar } @@ -346,7 +358,11 @@ propLockstep_RealImpl_MockFS_IOSim tr actions = env :: RealEnv R.Table (IOSim s) env = RealEnv { envSession = session - , envHandlers = [realHandler @(IOSim s), fsErrorHandler] + , envHandlers = [ + realHandler @(IOSim s) + , fsErrorHandler + , actionRegistryErrorHandler + ] , envErrors = errsVar , envInjectFaultResults = faultsVar } @@ -423,7 +439,17 @@ fsErrorHandler :: Monad m => Handler m (Maybe Model.Err) fsErrorHandler = Handler $ pure . handler' where handler' :: FsError -> Maybe Model.Err - handler' _ = Just Model.ErrFsError + handler' e = Just (Model.ErrFsError (displayException e)) + +actionRegistryErrorHandler :: Monad m => Handler m (Maybe Model.Err) +actionRegistryErrorHandler = Handler $ \e -> pure $ + if + | Just AbortActionRegistryError{} <- fromException e + -> Just (Model.ErrFsError (displayException e)) + | Just CommitActionRegistryError{} <- fromException e + -> Just (Model.ErrFsError (displayException e)) + | otherwise + -> Nothing createSystemTempDirectory :: [Char] -> IO (FilePath, HasFS IO HandleIO, HasBlockIO IO HandleIO) createSystemTempDirectory prefix = do