QLS: refactor error handlers

test/Database/LSMTree/Model/Session.hs

@@ -233,7 +233,10 @@ runModelMWithInjectedErrors ::
 runModelMWithInjectedErrors Nothing onNoErrors _ st =
     runModelM onNoErrors st
 runModelMWithInjectedErrors (Just _) _ onErrors st =
-    runModelM (onErrors >> throwError (ErrDiskFault "modelled FsError")) st
+    runModelM (onErrors >> throwError modelErrDiskFault) st
+
+modelErrDiskFault :: Err
+modelErrDiskFault = ErrDiskFault "modelled disk fault"
 
 --
 -- Errors
@@ -249,6 +252,7 @@ data Err =
     -- | A catch-all error for cases where /something/ went wrong with the file
     -- system.
   | ErrDiskFault String
+  | ErrOther String
 
 instance Show Err where
   showsPrec d = \case
@@ -268,6 +272,10 @@ instance Show Err where
         showParen (d > appPrec) $
         showString "ErrDiskFault " .
         showParen True (showString s)
+      ErrOther s ->
+        showParen (d > appPrec) $
+        showString "ErrOther " .
+        showParen True (showString s)
 
 -- Approximate equality for errors.
 --
@@ -291,6 +299,9 @@ instance Eq Err where
   (==) ErrSnapshotWrongType ErrSnapshotWrongType = True
   (==) ErrBlobRefInvalidated ErrBlobRefInvalidated = True
   (==) ErrCursorClosed ErrCursorClosed = True
+  (==) (ErrOther s1) (ErrOther s2) = s1 == s2
+  (==) _ (ErrOther _) = False
+  (==) (ErrOther _) _ = False
   (==) _ (ErrDiskFault _) = True
   (==) (ErrDiskFault _) _ = True
   (==) _ _ = False
@@ -303,6 +314,7 @@ instance Eq Err where
           ErrBlobRefInvalidated{}   -> ()
           ErrCursorClosed{}         -> ()
           ErrDiskFault{}            -> ()
+          ErrOther{}                -> ()
 
 {-------------------------------------------------------------------------------
   Tables

test/Test/Database/LSMTree/Model/Session.hs

@@ -30,6 +30,7 @@ instance Arbitrary Err where
       , pure ErrBlobRefInvalidated
       , pure ErrCursorClosed
       , ErrDiskFault <$> arbitrary
+      , ErrOther <$> arbitrary
       ]
     where
       _coveredAllCases x = case x of
@@ -40,8 +41,10 @@ instance Arbitrary Err where
           ErrBlobRefInvalidated{}   -> ()
           ErrCursorClosed{}         -> ()
           ErrDiskFault{}            -> ()
+          ErrOther{}                -> ()
 
   shrink (ErrDiskFault s) = ErrDiskFault <$> shrink s
+  shrink (ErrOther s)     = ErrOther <$> shrink s
   shrink _                = []
 
 deriving stock instance Generic Err

test/Test/Database/LSMTree/StateMachine.hs

@@ -190,11 +190,7 @@ propLockstep_ModelIOImpl =
               env :: RealEnv ModelIO.Table IO
               env = RealEnv {
                   envSession = session
-                , envHandlers = [
-                      handler
-                    , fileFormatErrorHandler
-                    , diskFaultErrorHandler
-                    ]
+                , envHandlers = [handler]
                 , envErrors = errsVar
                 , envInjectFaultResults = faultsVar
                 }
@@ -295,11 +291,7 @@ propLockstep_RealImpl_RealFS_IO tr =
               env :: RealEnv R.Table IO
               env = RealEnv {
                   envSession = session
-                , envHandlers = [
-                      realHandler @IO
-                    , fileFormatErrorHandler
-                    , diskFaultErrorHandler
-                    ]
+                , envHandlers = realErrorHandlers @IO
                 , envErrors = errsVar
                 , envInjectFaultResults = faultsVar
                 }
@@ -338,11 +330,7 @@ propLockstep_RealImpl_MockFS_IO tr =
               env :: RealEnv R.Table IO
               env = RealEnv {
                   envSession = session
-                , envHandlers = [
-                      realHandler @IO
-                    , fileFormatErrorHandler
-                    , diskFaultErrorHandler
-                    ]
+                , envHandlers = realErrorHandlers @IO
                 , envErrors = errsVar
                 , envInjectFaultResults = faultsVar
                 }
@@ -375,11 +363,7 @@ propLockstep_RealImpl_MockFS_IOSim tr actions =
           env :: RealEnv R.Table (IOSim s)
           env = RealEnv {
               envSession = session
-            , envHandlers = [
-                  realHandler @(IOSim s)
-                , fileFormatErrorHandler
-                , diskFaultErrorHandler
-                ]
+            , envHandlers = realErrorHandlers @(IOSim s)
             , envErrors = errsVar
             , envInjectFaultResults = faultsVar
             }
@@ -439,8 +423,30 @@ getAllSessionCursors (R.Internal.Session' s) =
       cs <- readMVar (R.Internal.sessionOpenCursors seshEnv)
       pure ((\x -> SomeCursor (R.Internal.Cursor' x))  <$> Map.elems cs)
 
-realHandler :: Monad m => Handler m (Maybe Model.Err)
-realHandler = Handler $ pure . handler'
+createSystemTempDirectory ::  [Char] -> IO (FilePath, HasFS IO HandleIO, HasBlockIO IO HandleIO)
+createSystemTempDirectory prefix = do
+    systemTempDir <- getCanonicalTemporaryDirectory
+    tempDir <- createTempDirectory systemTempDir prefix
+    let hasFS = ioHasFS (MountPoint tempDir)
+    hasBlockIO <- ioHasBlockIO hasFS defaultIOCtxParams
+    pure (tempDir, hasFS, hasBlockIO)
+
+{-------------------------------------------------------------------------------
+  Error handlers
+-------------------------------------------------------------------------------}
+
+realErrorHandlers :: Monad m => [Handler m (Maybe Model.Err)]
+realErrorHandlers = [
+      lsmTreeErrorHandler
+    , commitActionRegistryErrorHandler
+    , abortActionRegistryErrorHandler
+    , fsErrorHandler
+    , fileFormatErrorHandler
+    , catchAllErrorHandler
+    ]
+
+lsmTreeErrorHandler :: Monad m => Handler m (Maybe Model.Err)
+lsmTreeErrorHandler = Handler $ pure . handler'
   where
     handler' :: LSMTreeError -> Maybe Model.Err
     handler' ErrTableClosed               = Just Model.ErrTableClosed
@@ -449,48 +455,65 @@ realHandler = Handler $ pure . handler'
     handler' (ErrSnapshotExists _snap)    = Just Model.ErrSnapshotExists
     handler' ErrSnapshotWrongTableType{}  = Just Model.ErrSnapshotWrongType
     handler' (ErrBlobRefInvalid _)        = Just Model.ErrBlobRefInvalidated
-    handler' _                            = Nothing
+    handler' e                            = Just (Model.ErrOther (displayException e))
 
--- | 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
-      then Just (Model.ErrDiskFault (displayException e))
-      else Nothing
+commitActionRegistryErrorHandler :: Monad m => Handler m (Maybe Model.Err)
+commitActionRegistryErrorHandler = Handler $ pure . handler'
+  where
+    handler' :: CommitActionRegistryError -> Maybe Model.Err
+    handler' e
+      | isDiskFault (toException e) = Just (Model.ErrDiskFault (displayException e))
+      | otherwise                   = Just (Model.ErrOther (displayException e))
 
+abortActionRegistryErrorHandler :: Monad m => Handler m (Maybe Model.Err)
+abortActionRegistryErrorHandler = Handler $ pure . handler'
+  where
+    handler' :: AbortActionRegistryError -> Maybe Model.Err
+    handler' e
+      | isDiskFault (toException e) = Just (Model.ErrDiskFault (displayException e))
+      | otherwise                   = Just (Model.ErrOther (displayException e))
+
+-- | Some exceptions contain other exceptions. We check recursively if there is
+-- *any* exception that must have occurred because of a disk fault, and if so we
+-- consider the whole structure of exceptions a disk fault exception.
 isDiskFault :: SomeException -> Bool
 isDiskFault e
   | Just (CommitActionRegistryError es) <- fromException e
-  = all isDiskFault' es
+  = any isDiskFault' es
   | Just (AbortActionRegistryError reason es) <- fromException e
   = case reason of
-      ReasonExitCaseException e' -> isDiskFault e' && all isDiskFault' es
+      ReasonExitCaseException e' -> isDiskFault e' || any isDiskFault' es
       ReasonExitCaseAbort        -> False
   | Just (e' :: ActionError) <- fromException e
   = isDiskFault' (getActionError e')
   | Just FsError{} <- fromException e
   = True
+  | Just FileFormatError{} <- fromException e
+  = True
   | otherwise
   = False
   where
     isDiskFault' :: forall e. Exception e => e -> Bool
     isDiskFault' = isDiskFault . toException
 
+fsErrorHandler :: Monad m => Handler m (Maybe Model.Err)
+fsErrorHandler = Handler $ pure . handler'
+  where
+    handler' :: FsError -> Maybe Model.Err
+    handler' e = Just (Model.ErrDiskFault (displayException e))
+
 fileFormatErrorHandler :: Monad m => Handler m (Maybe Model.Err)
 fileFormatErrorHandler = Handler $ pure . handler'
   where
     handler' :: FileFormatError -> Maybe Model.Err
     handler' e = Just (Model.ErrDiskFault (displayException e))
 
-createSystemTempDirectory ::  [Char] -> IO (FilePath, HasFS IO HandleIO, HasBlockIO IO HandleIO)
-createSystemTempDirectory prefix = do
-    systemTempDir <- getCanonicalTemporaryDirectory
-    tempDir <- createTempDirectory systemTempDir prefix
-    let hasFS = ioHasFS (MountPoint tempDir)
-    hasBlockIO <- ioHasBlockIO hasFS defaultIOCtxParams
-    pure (tempDir, hasFS, hasBlockIO)
+-- | When combined with other handlers, 'catchAllErrorHandler' has to go last
+-- because it matches on 'SomeException', an no other handlers are run after
+-- that. See the use of 'catches' in 'catchErr'.
+catchAllErrorHandler :: Monad m => Handler m (Maybe Model.Err)
+catchAllErrorHandler = Handler $ \(e :: SomeException) ->
+    pure $ Just (Model.ErrOther (displayException e))
 
 {-------------------------------------------------------------------------------
   Key and value types