Merge branch 'jdral/configurable-faults' into jdral/fault-test-writeb…

…ufferreader
IntersectMBO · Jan 17, 2025 · e8dfda6 · e8dfda6
2 parents 0a6ab58 + 17a7108
commit e8dfda6
Show file tree

Hide file tree

Showing 5 changed files with 542 additions and 331 deletions.
diff --git a/src-control/Control/ActionRegistry.hs b/src-control/Control/ActionRegistry.hs
@@ -17,13 +17,14 @@ module Control.ActionRegistry (
     -- $action-registry
   , ActionRegistry
   , ActionError
+  , getActionError
     -- * Runners
   , withActionRegistry
   , unsafeNewActionRegistry
   , unsafeFinaliseActionRegistry
-  , CommitActionRegistryError
-  , AbortActionRegistryError
-  , AbortActionRegistryReason
+  , CommitActionRegistryError (..)
+  , AbortActionRegistryError (..)
+  , AbortActionRegistryReason (..)
     -- * Registering actions #registeringActions#
     -- $registering-actions
   , withRollback
@@ -61,6 +62,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
 -------------------------------------------------------------------------------}
@@ -207,6 +225,7 @@ type ActionError :: Type
 
 mkAction :: HasCallStackIfDebug => m () -> Action m
 mkActionError :: SomeException -> Action m -> ActionError
+getActionError :: ActionError -> SomeException
 
 #ifdef NO_IGNORE_ASSERTS
 data Action m = Action {
@@ -216,11 +235,21 @@ 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
 
 mkActionError e a = ActionError e (actionCallStack a)
+
+getActionError (ActionError e _) = e
 #else
 newtype Action m = Action {
     runAction :: m ()
@@ -233,6 +262,8 @@ newtype ActionError = ActionError SomeException
 mkAction a = Action a
 
 mkActionError e _ = ActionError e
+
+getActionError (ActionError e) = e
 #endif
 
 {-------------------------------------------------------------------------------
@@ -305,7 +336,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 +375,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