Merge pull request #529 from IntersectMBO/jdral/display-exception

jorisdral · web-flow · commit b7f2f562bbdf · 2025-01-20T12:49:47.000Z
Display action registry exceptions in human-readable format
diff --git 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
@@ -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
diff --git 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
@@ -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
