QLS: catch missed disk fault errors

src-control/Control/ActionRegistry.hs

@@ -17,13 +17,14 @@ module Control.ActionRegistry (
     -- $action-registry
   , ActionRegistry
   , ActionError
+  , getActionError
     -- * Runners
   , withActionRegistry
   , unsafeNewActionRegistry
   , unsafeFinaliseActionRegistry
   , CommitActionRegistryError (..)
   , AbortActionRegistryError (..)
-  , AbortActionRegistryReason
+  , AbortActionRegistryReason (..)
     -- * Registering actions #registeringActions#
     -- $registering-actions
   , withRollback
@@ -224,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 {
@@ -246,6 +248,8 @@ instance Exception ActionError where
 mkAction a = Action a callStack
 
 mkActionError e a = ActionError e (actionCallStack a)
+
+getActionError (ActionError e _) = e
 #else
 newtype Action m = Action {
     runAction :: m ()
@@ -258,6 +262,8 @@ newtype ActionError = ActionError SomeException
 mkAction a = Action a
 
 mkActionError e _ = ActionError e
+
+getActionError (ActionError e) = e
 #endif
 
 {-------------------------------------------------------------------------------

test/Test/Database/LSMTree/StateMachine.hs

@@ -66,13 +66,14 @@ module Test.Database.LSMTree.StateMachine (
   ) where
 
 import           Control.ActionRegistry (AbortActionRegistryError (..),
-                     CommitActionRegistryError (..))
+                     AbortActionRegistryReason (..), ActionError,
+                     CommitActionRegistryError (..), getActionError)
 import           Control.Concurrent.Class.MonadMVar.Strict
 import           Control.Concurrent.Class.MonadSTM.Strict
 import           Control.Monad (forM_, void, (<=<))
 import           Control.Monad.Class.MonadThrow (Exception (..), Handler (..),
-                     MonadCatch (..), MonadThrow (..), catches,
-                     displayException)
+                     MonadCatch (..), MonadThrow (..), SomeException, catches,
+                     displayException, fromException)
 import           Control.Monad.IOSim
 import           Control.Monad.Primitive
 import           Control.Monad.Reader (ReaderT (..))
@@ -107,12 +108,10 @@ import qualified Database.LSMTree.Model.Session as Model
 import           NoThunks.Class
 import           Prelude hiding (init)
 import           System.Directory (removeDirectoryRecursive)
-import qualified System.FS.API as FS
 import           System.FS.API (FsError (..), HasFS, MountPoint (..), mkFsPath)
 import           System.FS.BlockIO.API (HasBlockIO, defaultIOCtxParams)
 import           System.FS.BlockIO.IO (ioHasBlockIO)
 import           System.FS.BlockIO.Sim (simErrorHasBlockIO)
-import qualified System.FS.CallStack as FS
 import           System.FS.IO (HandleIO, ioHasFS)
 import qualified System.FS.Sim.Error as FSSim
 import           System.FS.Sim.Error (Errors)
@@ -158,18 +157,15 @@ tests = testGroup "Test.Database.LSMTree.StateMachine" [
 
     , testProperty "propLockstep_RealImpl_MockFS_IOSim" $
         propLockstep_RealImpl_MockFS_IOSim nullTracer
-
-    , testProperty "prop_dummyFsError" $ \s -> QC.ioProperty $
-        case fsErrorHandler of
-          Handler f -> do
-            throwIO (dummyFsError s) `catch` \e -> do
-              e' <- f e
-              pure (e' QC.=== Just (Model.ErrFsError ("dummy: " ++ s)))
     ]
 
 labelledExamples :: IO ()
 labelledExamples = QC.labelledExamples $ Lockstep.Run.tagActions (Proxy @(ModelState R.Table))
 
+{-------------------------------------------------------------------------------
+  propLockstep: reference implementation
+-------------------------------------------------------------------------------}
+
 instance Arbitrary Model.TableConfig where
   arbitrary :: Gen Model.TableConfig
   arbitrary = pure Model.TableConfig
@@ -191,7 +187,7 @@ propLockstep_ModelIOImpl =
               env :: RealEnv ModelIO.Table IO
               env = RealEnv {
                   envSession = session
-                , envHandlers = [handler, fsErrorHandler]
+                , envHandlers = [handler, diskFaultErrorHandler]
                 , envErrors = errsVar
                 , envInjectFaultResults = faultsVar
                 }
@@ -216,6 +212,10 @@ propLockstep_ModelIOImpl =
         handler' :: ModelIO.Err -> Maybe Model.Err
         handler' (ModelIO.Err err) = Just err
 
+{-------------------------------------------------------------------------------
+  propLockstep: real implementation
+-------------------------------------------------------------------------------}
+
 instance Arbitrary R.TableConfig where
   arbitrary = do
     confMergeSchedule <- QC.frequency [
@@ -290,8 +290,7 @@ propLockstep_RealImpl_RealFS_IO tr =
                   envSession = session
                 , envHandlers = [
                       realHandler @IO
-                    , fsErrorHandler
-                    , actionRegistryErrorHandler
+                    , diskFaultErrorHandler
                     ]
                 , envErrors = errsVar
                 , envInjectFaultResults = faultsVar
@@ -331,8 +330,7 @@ propLockstep_RealImpl_MockFS_IO tr =
                   envSession = session
                 , envHandlers = [
                       realHandler @IO
-                    , fsErrorHandler
-                    , actionRegistryErrorHandler
+                    , diskFaultErrorHandler
                     ]
                 , envErrors = errsVar
                 , envInjectFaultResults = faultsVar
@@ -360,8 +358,7 @@ propLockstep_RealImpl_MockFS_IOSim tr actions =
               envSession = session
             , envHandlers = [
                   realHandler @(IOSim s)
-                , fsErrorHandler
-                , actionRegistryErrorHandler
+                , diskFaultErrorHandler
                 ]
             , envErrors = errsVar
             , envInjectFaultResults = faultsVar
@@ -435,21 +432,29 @@ realHandler = Handler $ pure . handler'
     handler' (ErrBlobRefInvalid _)        = Just Model.ErrBlobRefInvalidated
     handler' _                            = Nothing
 
-fsErrorHandler :: Monad m => Handler m (Maybe Model.Err)
-fsErrorHandler = Handler $ pure . handler'
+diskFaultErrorHandler :: Monad m => Handler m (Maybe Model.Err)
+diskFaultErrorHandler = Handler $ \e -> pure $
+    if isDiskFault e
+      then Just (Model.ErrFsError (displayException e))
+      else Nothing
+
+isDiskFault :: SomeException -> Bool
+isDiskFault e
+  | Just (CommitActionRegistryError es) <- fromException e
+  = all isDiskFault' es
+  | Just (AbortActionRegistryError reason es) <- fromException e
+  = case reason of
+      ReasonExitCaseException e' -> isDiskFault e' && all isDiskFault' es
+      ReasonExitCaseAbort        -> False
+  | Just (e' :: ActionError)<- fromException e
+  = isDiskFault' (getActionError e')
+  | Just FsError{} <- fromException e
+  = True
+  | otherwise
+  = False
   where
-    handler' :: FsError -> Maybe Model.Err
-    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
+    isDiskFault' :: forall e. Exception e => e -> Bool
+    isDiskFault' = isDiskFault . toException
 
 createSystemTempDirectory ::  [Char] -> IO (FilePath, HasFS IO HandleIO, HasBlockIO IO HandleIO)
 createSystemTempDirectory prefix = do
@@ -1191,12 +1196,12 @@ runIO action lookUp = ReaderT $ \ !env -> do
           Class.mupserts (unwrapTable $ lookUp' tableVar) kmups
         RetrieveBlobs blobRefsVar -> catchErr handlers $
           fmap WrapBlob <$> Class.retrieveBlobs (Proxy @h) session (unwrapBlobRef <$> lookUp' blobRefsVar)
-        CreateSnapshot merrs label name tableVar -> catchErr handlers $
-          runRealWithInjectedErrors faultsVar "CreateSnapshot" errsVar merrs
+        CreateSnapshot merrs label name tableVar ->
+          runRealWithInjectedErrors "CreateSnapshot" env merrs
             (Class.createSnapshot label name (unwrapTable $ lookUp' tableVar))
             (\() -> Class.deleteSnapshot session name)
-        OpenSnapshot _ merrs label name -> catchErr handlers $
-          runRealWithInjectedErrors faultsVar "OpenSnapshot" errsVar merrs
+        OpenSnapshot _ merrs label name ->
+          runRealWithInjectedErrors "OpenSnapshot" env merrs
             (WrapTable <$> Class.openSnapshot session label name)
             (\(WrapTable t) -> Class.close t)
         DeleteSnapshot name -> catchErr handlers $
@@ -1212,8 +1217,6 @@ runIO action lookUp = ReaderT $ \ !env -> do
       where
         session = envSession env
         handlers = envHandlers env
-        errsVar = envErrors env
-        faultsVar = envInjectFaultResults env
 
     lookUp' :: Var h x -> Realized IO x
     lookUp' = lookUpGVar (Proxy @(RealMonad h IO)) lookUp
@@ -1255,12 +1258,12 @@ runIOSim action lookUp = ReaderT $ \ !env -> do
           Class.mupserts (unwrapTable $ lookUp' tableVar) kmups
         RetrieveBlobs blobRefsVar -> catchErr handlers $
           fmap WrapBlob <$> Class.retrieveBlobs (Proxy @h) session (unwrapBlobRef <$> lookUp' blobRefsVar)
-        CreateSnapshot merrs label name tableVar -> catchErr handlers $
-          runRealWithInjectedErrors faultsVar "CreateSnapshot" errsVar merrs
+        CreateSnapshot merrs label name tableVar ->
+          runRealWithInjectedErrors "CreateSnapshot" env merrs
             (Class.createSnapshot label name (unwrapTable $ lookUp' tableVar))
             (\() -> Class.deleteSnapshot session name)
-        OpenSnapshot _ merrs label name -> catchErr handlers $
-          runRealWithInjectedErrors faultsVar "OpenSnapshot" errsVar merrs
+        OpenSnapshot _ merrs label name ->
+          runRealWithInjectedErrors "OpenSnapshot" env merrs
             (WrapTable <$> Class.openSnapshot session label name)
             (\(WrapTable t) -> Class.close t)
         DeleteSnapshot name -> catchErr handlers $
@@ -1276,8 +1279,6 @@ runIOSim action lookUp = ReaderT $ \ !env -> do
       where
         session = envSession env
         handlers = envHandlers env
-        errsVar = envErrors env
-        faultsVar = envInjectFaultResults env
 
     lookUp' :: Var h x -> Realized (IOSim s) x
     lookUp' = lookUpGVar (Proxy @(RealMonad h (IOSim s))) lookUp
@@ -1294,46 +1295,41 @@ runIOSim action lookUp = ReaderT $ \ !env -> do
 -- delete that snapshot.
 runRealWithInjectedErrors ::
      (MonadCatch m, MonadSTM m, PrimMonad m)
-  => MutVar (PrimState m) [InjectFaultResult]
-  -> String -- ^ Name of the action
-  -> StrictTVar m Errors
+  => String -- ^ Name of the action
+  -> RealEnv h m
   -> Maybe Errors
-  -> m t -- ^ Action to run
+  -> m t-- ^ Action to run
   -> (t -> m ()) -- ^ Rollback if the action *accidentally* succeeded
-  -> m t
-runRealWithInjectedErrors faultsVar s errsVar merrs k rollback =
+  -> m (Either Model.Err t)
+runRealWithInjectedErrors s env merrs k rollback =
   case merrs of
     Nothing -> do
       modifyMutVar faultsVar (InjectFaultNone s :)
-      k
+      catchErr handlers k
     Just errs -> do
-      eith <- try @_ @FsError $ FSSim.withErrors errsVar errs k
+      eith <- catchErr handlers $ FSSim.withErrors errsVar errs k
       case eith of
-        Left e  -> do
+        Left (Model.ErrFsError _) -> do
           modifyMutVar faultsVar (InjectFaultInducedError s :)
-          throwIO e
+          pure eith
+        Left _ ->
+          pure eith
         Right x -> do
           modifyMutVar faultsVar (InjectFaultAccidentalSuccess s :)
           rollback x
-          throwIO (dummyFsError s)
+          pure $ Left $ Model.ErrFsError ("dummy: " <> s)
+  where
+    errsVar = envErrors env
+    faultsVar = envInjectFaultResults env
+    handlers = envHandlers env
 
 catchErr ::
-     forall m a. MonadCatch m
-  => [Handler m (Maybe Model.Err)] -> m a -> m (Either Model.Err a)
+     forall m a e. MonadCatch m
+  => [Handler m (Maybe e)] -> m a -> m (Either e a)
 catchErr hs action = catches (Right <$> action) (fmap f hs)
   where
     f (Handler h) = Handler $ \e -> maybe (throwIO e) (pure . Left) =<< h e
 
-dummyFsError :: String -> FsError
-dummyFsError s = FsError {
-      fsErrorType = FS.FsOther
-    , fsErrorPath = FS.FsErrorPath Nothing (FS.mkFsPath [])
-    , fsErrorString = "dummy: " ++ s
-    , fsErrorNo = Nothing
-    , fsErrorStack = FS.prettyCallStack
-    , fsLimitation = False
-    }
-
 {-------------------------------------------------------------------------------
   Generator and shrinking
 -------------------------------------------------------------------------------}