diff --git a/lsm-tree.cabal b/lsm-tree.cabal index a4fd7cff2..daafafc9d 100644 --- a/lsm-tree.cabal +++ b/lsm-tree.cabal @@ -401,6 +401,7 @@ test-suite lsm-tree-test Test.System.Posix.Fcntl.NoCache Test.Util.Arbitrary Test.Util.FS + Test.Util.FS.Error Test.Util.Orphans Test.Util.PrettyProxy Test.Util.QC @@ -410,6 +411,7 @@ test-suite lsm-tree-test build-depends: , ansi-terminal + , barbies , base , bitvec , bytestring @@ -445,6 +447,7 @@ test-suite lsm-tree-test , quickcheck-instances , quickcheck-lockstep , random + , safe-wild-cards , semialign , split , stm diff --git a/src-control/Control/RefCount.hs b/src-control/Control/RefCount.hs index 53f521c66..a41e7f6e5 100644 --- a/src-control/Control/RefCount.hs +++ b/src-control/Control/RefCount.hs @@ -30,6 +30,8 @@ module Control.RefCount ( -- * Test API , checkForgottenRefs , ignoreForgottenRefs + , enableForgottenRefChecks + , disableForgottenRefChecks ) where import Control.DeepSeq @@ -451,9 +453,11 @@ data RefTracker = RefTracker !RefId globalRefIdSupply :: PrimVar RealWorld Int globalRefIdSupply = unsafePerformIO $ newPrimVar 0 +data Enabled a = Enabled !a | Disabled + {-# NOINLINE globalForgottenRef #-} -globalForgottenRef :: IORef (Maybe (RefId, CallStack)) -globalForgottenRef = unsafePerformIO $ newIORef Nothing +globalForgottenRef :: IORef (Enabled (Maybe (RefId, CallStack))) +globalForgottenRef = unsafePerformIO $ newIORef (Enabled Nothing) -- | This version of 'unsafeIOToPrim' is strict in the result of the arument -- action. @@ -492,27 +496,29 @@ finaliserRefTracker inner refid allocSite = do -- Add it to a global var which we can poll elsewhere. mref <- readIORef globalForgottenRef case mref of + Disabled -> pure () -- Just keep one, but keep the last allocated one. -- The reason for last is that when there are nested structures with -- refs then the last allocated is likely to be the outermost, which -- is the best place to start hunting for ref leaks. Otherwise one can -- go on a wild goose chase tracking down inner refs that were only -- forgotten due to an outer ref being forgotten. - Just (refid', _) | refid < refid' -> return () - _ -> writeIORef globalForgottenRef (Just (refid, allocSite)) + Enabled (Just (refid', _)) | refid < refid' -> return () + Enabled _ -> writeIORef globalForgottenRef (Enabled (Just (refid, allocSite))) assertNoForgottenRefs :: (PrimMonad m, MonadThrow m) => m () assertNoForgottenRefs = do mrefs <- unsafeIOToPrimStrict $ readIORef globalForgottenRef case mrefs of - Nothing -> return () - Just (refid, allocSite) -> do + Disabled -> return () + Enabled Nothing -> return () + Enabled (Just (refid, allocSite)) -> do -- Clear the var so we don't assert again. -- -- Using the strict version is important here: if @m ~ IOSim s@, then -- using the non-strict version will lead to @RefNeverReleased@ -- exceptions. - unsafeIOToPrimStrict $ writeIORef globalForgottenRef Nothing + unsafeIOToPrimStrict $ writeIORef globalForgottenRef (Enabled Nothing) throwIO (RefNeverReleased refid allocSite) @@ -592,3 +598,26 @@ performMajorGCWithBlockingIfAvailable = do performMajorGC #endif #endif + +-- | Enable forgotten reference checks. +enableForgottenRefChecks :: IO () + +-- | Disable forgotten reference checks. This will error if there are already +-- forgotten references while we are trying to disable the checks. +disableForgottenRefChecks :: IO () + +#ifdef NO_IGNORE_ASSERTS +enableForgottenRefChecks = + modifyIORef globalForgottenRef $ \case + Disabled -> Enabled Nothing + Enabled _ -> error "enableForgottenRefChecks: already enabled" + +disableForgottenRefChecks = + modifyIORef globalForgottenRef $ \case + Disabled -> error "disableForgottenRefChecks: already disabled" + Enabled Nothing -> Disabled + Enabled _ -> error "disableForgottenRefChecks: can not disable when there are forgotten references" +#else +enableForgottenRefChecks = pure () +disableForgottenRefChecks = pure () +#endif diff --git a/test/Test/Database/LSMTree/StateMachine.hs b/test/Test/Database/LSMTree/StateMachine.hs index 1d443b7d5..c8cc5fef9 100644 --- a/test/Test/Database/LSMTree/StateMachine.hs +++ b/test/Test/Database/LSMTree/StateMachine.hs @@ -56,6 +56,9 @@ module Test.Database.LSMTree.StateMachine ( , propLockstep_RealImpl_RealFS_IO , propLockstep_RealImpl_MockFS_IO , propLockstep_RealImpl_MockFS_IOSim + , CheckCleanup (..) + , CheckFS (..) + , CheckRefs (..) -- * Lockstep , ModelState (..) , Key (..) @@ -73,7 +76,6 @@ import Control.Applicative (Alternative (..)) import Control.Concurrent.Class.MonadMVar.Strict import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (assert) -import qualified Control.Exception import Control.Monad (forM_, void, (<=<)) import Control.Monad.Class.MonadThrow (Exception (..), Handler (..), MonadCatch (..), MonadThrow (..), SomeException, catches, @@ -119,7 +121,6 @@ import System.Directory (removeDirectoryRecursive) 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 System.FS.IO (HandleIO, ioHasFS) import qualified System.FS.Sim.Error as FSSim import System.FS.Sim.Error (Errors) @@ -144,6 +145,7 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Test.Util.FS (approximateEqStream, noRemoveDirectoryRecursiveE, propNoOpenHandles, propNumOpenHandles) +import Test.Util.FS.Error import Test.Util.PrettyProxy import Test.Util.QC (Choice) import qualified Test.Util.QLS as QLS @@ -163,10 +165,10 @@ tests = testGroup "Test.Database.LSMTree.StateMachine" [ propLockstep_RealImpl_RealFS_IO nullTracer , testProperty "propLockstep_RealImpl_MockFS_IO" $ - propLockstep_RealImpl_MockFS_IO nullTracer + propLockstep_RealImpl_MockFS_IO nullTracer CheckCleanup CheckFS CheckRefs , testProperty "propLockstep_RealImpl_MockFS_IOSim" $ - propLockstep_RealImpl_MockFS_IOSim nullTracer + propLockstep_RealImpl_MockFS_IOSim nullTracer CheckCleanup CheckFS CheckRefs ] labelledExamples :: IO () @@ -189,9 +191,11 @@ propLockstep_ModelIOImpl :: propLockstep_ModelIOImpl = runActionsBracket (Proxy @(ModelState ModelIO.Table)) + CheckCleanup + NoCheckRefs -- there are no references to check for in the ModelIO implementation acquire release - (\r (session, errsVar) -> do + (\r (session, errsVar, logVar) -> do faultsVar <- newMutVar [] let env :: RealEnv ModelIO.Table IO @@ -199,6 +203,7 @@ propLockstep_ModelIOImpl = envSession = session , envHandlers = [handler] , envErrors = errsVar + , envErrorsLog = logVar , envInjectFaultResults = faultsVar } prop <- runReaderT r env @@ -207,14 +212,15 @@ propLockstep_ModelIOImpl = ) tagFinalState' where - acquire :: IO (Class.Session ModelIO.Table IO, StrictTVar IO Errors) + acquire :: IO (Class.Session ModelIO.Table IO, StrictTVar IO Errors, StrictTVar IO ErrorsLog) acquire = do session <- Class.openSession ModelIO.NoSessionArgs errsVar <- newTVarIO FSSim.emptyErrors - pure (session, errsVar) + logVar <- newTVarIO emptyLog + pure (session, errsVar, logVar) - release :: (Class.Session ModelIO.Table IO, StrictTVar IO Errors) -> IO () - release (session, _) = Class.closeSession session + release :: (Class.Session ModelIO.Table IO, StrictTVar IO Errors, StrictTVar IO ErrorsLog) -> IO () + release (session, _, _) = Class.closeSession session handler :: Handler IO (Maybe Model.Err) handler = Handler $ pure . handler' @@ -290,9 +296,11 @@ propLockstep_RealImpl_RealFS_IO :: propLockstep_RealImpl_RealFS_IO tr = runActionsBracket (Proxy @(ModelState R.Table)) + CheckCleanup + CheckRefs acquire release - (\r (_, session, errsVar) -> do + (\r (_, session, errsVar, logVar) -> do faultsVar <- newMutVar [] let env :: RealEnv R.Table IO @@ -300,6 +308,7 @@ propLockstep_RealImpl_RealFS_IO tr = envSession = session , envHandlers = realErrorHandlers @IO , envErrors = errsVar + , envErrorsLog = logVar , envInjectFaultResults = faultsVar } prop <- runReaderT r env @@ -308,15 +317,16 @@ propLockstep_RealImpl_RealFS_IO tr = ) tagFinalState' where - acquire :: IO (FilePath, Class.Session R.Table IO, StrictTVar IO Errors) + acquire :: IO (FilePath, Class.Session R.Table IO, StrictTVar IO Errors, StrictTVar IO ErrorsLog) acquire = do (tmpDir, hasFS, hasBlockIO) <- createSystemTempDirectory "prop_lockstepIO_RealImpl_RealFS" session <- R.openSession tr hasFS hasBlockIO (mkFsPath []) errsVar <- newTVarIO FSSim.emptyErrors - pure (tmpDir, session, errsVar) + logVar <- newTVarIO emptyLog + pure (tmpDir, session, errsVar, logVar) - release :: (FilePath, Class.Session R.Table IO, StrictTVar IO Errors) -> IO Property - release (tmpDir, !session, _) = do + release :: (FilePath, Class.Session R.Table IO, StrictTVar IO Errors, StrictTVar IO ErrorsLog) -> IO Property + release (tmpDir, !session, _, _) = do !prop <- propNoThunks session R.closeSession session removeDirectoryRecursive tmpDir @@ -324,14 +334,19 @@ propLockstep_RealImpl_RealFS_IO tr = propLockstep_RealImpl_MockFS_IO :: Tracer IO R.LSMTreeTrace + -> CheckCleanup + -> CheckFS + -> CheckRefs -> Actions (Lockstep (ModelState R.Table)) -> QC.Property -propLockstep_RealImpl_MockFS_IO tr = +propLockstep_RealImpl_MockFS_IO tr cleanupFlag fsFlag refsFlag = runActionsBracket (Proxy @(ModelState R.Table)) + cleanupFlag + refsFlag (acquire_RealImpl_MockFS tr) - release_RealImpl_MockFS - (\r (_, session, errsVar) -> do + (release_RealImpl_MockFS fsFlag) + (\r (_, session, errsVar, logVar) -> do faultsVar <- newMutVar [] let env :: RealEnv R.Table IO @@ -339,6 +354,7 @@ propLockstep_RealImpl_MockFS_IO tr = envSession = session , envHandlers = realErrorHandlers @IO , envErrors = errsVar + , envErrorsLog = logVar , envInjectFaultResults = faultsVar } prop <- runReaderT r env @@ -357,14 +373,17 @@ propLockstep_RealImpl_MockFS_IO tr = -- the counterexamples to see which one is more interesting. propLockstep_RealImpl_MockFS_IOSim :: (forall s. Tracer (IOSim s) R.LSMTreeTrace) + -> CheckCleanup + -> CheckFS + -> CheckRefs -> Actions (Lockstep (ModelState R.Table)) -> QC.Property -propLockstep_RealImpl_MockFS_IOSim tr actions = +propLockstep_RealImpl_MockFS_IOSim tr cleanupFlag fsFlag refsFlag actions = monadicIOSim_ prop where prop :: forall s. PropertyM (IOSim s) Property prop = do - (fsVar, session, errsVar) <- QC.run (acquire_RealImpl_MockFS tr) + (fsVar, session, errsVar, logVar) <- QC.run (acquire_RealImpl_MockFS tr) faultsVar <- QC.run $ newMutVar [] let env :: RealEnv R.Table (IOSim s) @@ -372,34 +391,42 @@ propLockstep_RealImpl_MockFS_IOSim tr actions = envSession = session , envHandlers = realErrorHandlers @(IOSim s) , envErrors = errsVar + , envErrorsLog = logVar , envInjectFaultResults = faultsVar } void $ QD.runPropertyReaderT (QD.runActions @(Lockstep (ModelState R.Table)) actions) env faults <- QC.run $ readMutVar faultsVar - p <- QC.run $ release_RealImpl_MockFS (fsVar, session, errsVar) + p <- QC.run $ propCleanup cleanupFlag $ + release_RealImpl_MockFS fsFlag (fsVar, session, errsVar, logVar) + p' <- QC.run $ propRefs refsFlag pure $ tagFinalState actions tagFinalState' $ QC.tabulate "Fault results" (fmap show faults) - $ p + $ p QC..&&. p' acquire_RealImpl_MockFS :: R.IOLike m => Tracer m R.LSMTreeTrace - -> m (StrictTMVar m MockFS, Class.Session R.Table m, StrictTVar m Errors) + -> m (StrictTMVar m MockFS, Class.Session R.Table m, StrictTVar m Errors, StrictTVar m ErrorsLog) acquire_RealImpl_MockFS tr = do fsVar <- newTMVarIO MockFS.empty errsVar <- newTVarIO FSSim.emptyErrors - (hfs, hbio) <- simErrorHasBlockIO fsVar errsVar + logVar <- newTVarIO emptyLog + (hfs, hbio) <- simErrorHasBlockIOLogged fsVar errsVar logVar session <- R.openSession tr hfs hbio (mkFsPath []) - pure (fsVar, session, errsVar) + pure (fsVar, session, errsVar, logVar) + +-- | Flag that turns on\/off file system checks. +data CheckFS = CheckFS | NoCheckFS release_RealImpl_MockFS :: R.IOLike m - => (StrictTMVar m MockFS, Class.Session R.Table m, StrictTVar m Errors) + => CheckFS + -> (StrictTMVar m MockFS, Class.Session R.Table m, StrictTVar m Errors, StrictTVar m ErrorsLog) -> m Property -release_RealImpl_MockFS (fsVar, session, _) = do +release_RealImpl_MockFS fsFlag (fsVar, session, _, _) = do sts <- getAllSessionTables session forM_ sts $ \(SomeTable t) -> R.close t scs <- getAllSessionCursors session @@ -407,7 +434,9 @@ release_RealImpl_MockFS (fsVar, session, _) = do mockfs1 <- atomically $ readTMVar fsVar R.closeSession session mockfs2 <- atomically $ readTMVar fsVar - pure (propNumOpenHandles 1 mockfs1 QC..&&. propNoOpenHandles mockfs2) + pure $ case fsFlag of + CheckFS -> propNumOpenHandles 1 mockfs1 QC..&&. propNoOpenHandles mockfs2 + NoCheckFS -> QC.property () data SomeTable m = SomeTable (forall k v b. R.Table m k v b) data SomeCursor m = SomeCursor (forall k v b. R.Cursor m k v b) @@ -1009,7 +1038,10 @@ instance Eq (Obs h a) where -- See also 'Model.runModelMWithInjectedErrors' and -- 'runRealWithInjectedErrors'. (OEither (Left (OId lhs)), OEither (Left (OId rhs))) - | Just (_ :: Model.Err) <- cast lhs + | Just (e :: Model.Err) <- cast lhs + , case e of + Model.ErrOther _ -> False + _ -> True , Just Model.DefaultErrDiskFault <- cast rhs -> True @@ -1088,6 +1120,11 @@ data RealEnv h m = RealEnv { -- variable can be used to enable/disable errors locally, for example on a -- per-action basis. , envErrors :: !(StrictTVar m Errors) + -- | A variable holding a log of simulated disk faults. + -- + -- Errors that are injected into the simulated file system using 'envErrors' + -- are logged here. + , envErrorsLog :: !(StrictTVar m ErrorsLog) -- | The results of fault injection , envInjectFaultResults :: !(MutVar (PrimState m) [InjectFaultResult]) } @@ -1670,19 +1707,43 @@ runRealWithInjectedErrors s env merrs k rollback = modifyMutVar faultsVar (InjectFaultNone s :) catchErr handlers k Just errs -> do + atomically $ writeTVar logVar emptyLog eith <- catchErr handlers $ FSSim.withErrors errsVar errs k + errsLog <- readTVarIO logVar case eith of - Left (Model.ErrDiskFault _) -> do + Left e@(Model.ErrDiskFault _) -> do modifyMutVar faultsVar (InjectFaultInducedError s :) - pure eith - Left _ -> - pure eith + if countNoisyErrors errsLog == 0 then + pure $ Left $ Model.ErrOther $ + -- If we injected 0 disk faults, but we still found an + -- ErrDiskFault, then there is a bug in our code. ErrDiskFaults + -- should not occur on the happy path. + "Found an ErrDiskFault error, but no disk faults were injected: " <> show e + else + pure eith + Left e -> do + if countNoisyErrors errsLog > 0 then + pure $ Left $ Model.ErrOther $ + -- If we injected 1 or more disk faults, but we did not find an + -- ErrDiskFault, then there is a bug in our code. An injected disk + -- fault should always lead to an ErrDiskFault. + "Found a non-ErrDiskFault error, but disk faults were injected: " <> show e + else + pure eith Right x -> do modifyMutVar faultsVar (InjectFaultAccidentalSuccess s :) rollback x - pure $ Left $ Model.ErrDiskFault ("dummy: " <> s) + if (countNoisyErrors errsLog > 0) then + pure $ Left $ Model.ErrOther $ + -- If we injected 1 or more disk faults, but the action + -- accidentally succeeded, then 1 or more errors were swallowed + -- that should have been found as ErrDiskFault. + "Action succeeded, but disk faults were injected. Errors were swallowed!" + else + pure $ Left $ Model.ErrDiskFault ("dummy: " <> s) where errsVar = envErrors env + logVar = envErrorsLog env faultsVar = envInjectFaultResults env handlers = envHandlers env @@ -2754,29 +2815,30 @@ runActionsBracket :: , QC.Testable prop ) => Proxy state + -> CheckCleanup + -> CheckRefs -> IO st -> (st -> IO prop) -> (m QC.Property -> st -> IO QC.Property) -> (Lockstep state -> [(String, [FinalTag])]) -> Actions (Lockstep state) -> QC.Property -runActionsBracket p init cleanup runner tagger actions = +runActionsBracket p cleanupFlag refsFlag init cleanup runner tagger actions = tagFinalState actions tagger $ QLS.runActionsBracket p init cleanup' runner actions where cleanup' st = do - x <- cleanup st `onException` ignoreForgottenRefs - -- We want to do checkForgottenRefs after cleanup, since cleanup itself - -- may lead to forgotten refs. And checkForgottenRefs has the crucial - -- side effect of reseting the forgotten refs state. If we don't do this - -- then the next test run (e.g. during shrinking) will encounter a + -- We want to run forgotten reference checks after cleanup, since cleanup + -- itself may lead to forgotten refs. The reference checks have the + -- crucial side effect of reseting the forgotten refs state. If we don't + -- do this then the next test run (e.g. during shrinking) will encounter a -- false/stale forgotten refs exception. But we also have to make sure - -- that if cleanup itself fails, that we reset the forgotten refs state! - e <- Control.Exception.try checkForgottenRefs - pure (x QC..&&. propCheckForgottenRefs e) - - propCheckForgottenRefs :: Either RefException () -> Property - propCheckForgottenRefs (Left e) = QC.counterexample (show e) False - propCheckForgottenRefs (Right ()) = QC.property True + -- that if cleanup itself fails, that we still run the reference checks. + -- 'propCleanup' will make sure to catch any exceptions that are thrown by + -- the 'cleanup' action. 'propRefs' will then definitely run afterwards so + -- that the frogotten reference checks are definitely performed. + x <- propCleanup cleanupFlag $ cleanup st + y <- propRefs refsFlag + pure (x QC..&&. y) tagFinalState :: forall state. StateModel (Lockstep state) @@ -2791,3 +2853,50 @@ tagFinalState actions tagger = finalAnnState = stateAfter @(Lockstep state) actions finalTags = tagger $ underlyingState finalAnnState + +propException :: (Exception e, QC.Testable prop) => String -> Either e prop -> Property +propException s (Left e) = QC.counterexample (s <> displayException e) False +propException _ (Right prop) = QC.property prop + +{------------------------------------------------------------------------------- + Cleanup exceptions +-------------------------------------------------------------------------------} + +-- | Flag that turns on\/off cleanup checks. +-- +-- If injected errors left the database in an inconsistent state, then property +-- cleanup might throw exceptions. If 'CheckCleanup' is used, this will lead to +-- failing properties, otherwise the exceptions are ignored. +data CheckCleanup = CheckCleanup | NoCheckCleanup + +propCleanup :: (MonadCatch m, QC.Testable prop) => CheckCleanup -> m prop -> m Property +propCleanup flag cleanupAction = + propException "Cleanup exception: " <$> checkCleanupM flag cleanupAction + +checkCleanupM :: (MonadCatch m, QC.Testable prop) => CheckCleanup -> m prop -> m (Either SomeException Property) +checkCleanupM flag cleanupAction = do + eith <- try @_ @SomeException cleanupAction + case flag of + CheckCleanup -> pure $ QC.property <$> eith + NoCheckCleanup -> pure (Right $ QC.property ()) + +{------------------------------------------------------------------------------- + Reference checks +-------------------------------------------------------------------------------} + +-- | Flag that turns on\/off reference checks. +-- +-- If injected errors left the database in an inconsistent state, then some +-- references might be forgotten, which leads to reference exceptions. If +-- 'CheckRefs' is used, this will lead to failing properties, otherwise the +-- exceptions are ignored. +data CheckRefs = CheckRefs | NoCheckRefs + +propRefs :: (PrimMonad m, MonadCatch m) => CheckRefs -> m Property +propRefs flag = propException "Reference exception: " <$> checkRefsM flag + +checkRefsM :: (PrimMonad m, MonadCatch m) => CheckRefs -> m (Either RefException ()) +checkRefsM flag = case flag of + CheckRefs -> try checkForgottenRefs + NoCheckRefs -> Right <$> ignoreForgottenRefs + diff --git a/test/Test/Database/LSMTree/StateMachine/DL.hs b/test/Test/Database/LSMTree/StateMachine/DL.hs index dd16ed3c8..9dfec8ff6 100644 --- a/test/Test/Database/LSMTree/StateMachine/DL.hs +++ b/test/Test/Database/LSMTree/StateMachine/DL.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + {-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -5,6 +7,8 @@ module Test.Database.LSMTree.StateMachine.DL ( tests ) where +import Control.Monad (void) +import Control.RefCount import Control.Tracer import qualified Data.Map.Strict as Map import qualified Data.Vector as V @@ -12,21 +16,28 @@ import Database.LSMTree as R import qualified Database.LSMTree.Model.Session as Model (fromSomeTable, tables) import qualified Database.LSMTree.Model.Table as Model (values) import Prelude +import SafeWildCards +import System.FS.API.Types +import System.FS.Sim.Error hiding (Blob) +import qualified System.FS.Sim.Stream as Stream +import System.FS.Sim.Stream (Stream) import Test.Database.LSMTree.StateMachine hiding (tests) import Test.Database.LSMTree.StateMachine.Op -import Test.QuickCheck as QC +import Test.QuickCheck as QC hiding (label) import Test.QuickCheck.DynamicLogic import qualified Test.QuickCheck.Gen as QC import qualified Test.QuickCheck.Random as QC import Test.QuickCheck.StateModel.Lockstep -import Test.Tasty (TestTree, testGroup) +import qualified Test.QuickCheck.StateModel.Lockstep.Defaults as QLS +import Test.QuickCheck.StateModel.Variables +import Test.Tasty (TestTree, testGroup, withResource) import qualified Test.Tasty.QuickCheck as QC import Test.Util.PrettyProxy tests :: TestTree tests = testGroup "Test.Database.LSMTree.StateMachine.DL" [ - QC.testProperty "prop_example" prop_example + , test_noSwallowedExceptions ] instance DynLogicModel (Lockstep (ModelState R.Table)) @@ -44,7 +55,7 @@ prop_example = -- Run the example ... forAllDL dl_example $ -- ... with the given lockstep property - propLockstep_RealImpl_MockFS_IO tr + propLockstep_RealImpl_MockFS_IO tr CheckCleanup CheckFS CheckRefs where -- To enable tracing, use something like @show `contramap` stdoutTracer@ -- instead @@ -81,3 +92,203 @@ dl_example = do | Just tbl <- (Model.fromSomeTable @Key @Value @Blob smTbl) -> Map.size (Model.values tbl) == Map.size kvs _ -> False + +{------------------------------------------------------------------------------- + Swallowed exceptions +-------------------------------------------------------------------------------} + +-- | See 'prop_noSwallowedExceptions'. +-- +-- Forgotten reference checks are disabled completely, because we allow bugs +-- (like forgotten references) in exception unsafe code where we inject disk +-- faults. +test_noSwallowedExceptions :: TestTree +test_noSwallowedExceptions = + withResource + (checkForgottenRefs >> disableForgottenRefChecks) + (\_ -> enableForgottenRefChecks) $ \ !_ -> + QC.testProperty "prop_noSwallowedExceptions" prop_noSwallowedExceptions + +-- | Test that the @lsm-tree@ library does not swallow exceptions. +-- +-- A functional requirement for the @lsm-tree@ library is that all exceptions +-- are properly communicated to the user. An alternative way of stating this +-- requirement is that no exceptions should be /swallowed/ by the library. We +-- test this requirement by running the state machine test with injected disk +-- errors using @fs-sim@, and asserting that no exceptions are swallowed. +-- +-- The state machine test compares the SUT against a model by checking that +-- their responses to @lsm-tree@ actions are the same. As of writing this +-- property, not all of these actions on the SUT are guaranteed to be fully +-- exception safe. As a result, an exception might leave the database (i.e., +-- session, tables, cursors) in an inconsistent state. The results of subsequent +-- operations on the inconsistent database should be considered undefined. As +-- such, it is highly likely that the SUT and model will thereafter disagree, +-- leading to a failing property. +-- +-- Still, we want to run the swallowed error assertion on /all/ operations, +-- regardless of whether they are exception safe. We overcome this problem by +-- /definitely/ injecting errors (and running a swallowed error assertion) for +-- the last action in a sequence of actions. This may leave the final database +-- state inconsistent, but that is okay. However, we'll also have to disable +-- sanity checks like 'NoCheckCleanup', 'NoCheckFS', and 'NoCheckRefs', because +-- they are likely to fail if the database is an inconsistent state. +-- +-- TODO: running only one swallowed exception assertion per action sequence is +-- restrictive, but this automatically improves as we make more actions +-- exceptions safe. When we generate injected errors for these errors by default +-- (in @arbitraryWithVars@), the swallowed exception assertion automatically +-- runs for those actions as well. +prop_noSwallowedExceptions :: Property +prop_noSwallowedExceptions = forAllDL dl_noSwallowExceptions runner + where + -- disable all file system and reference checks + runner = propLockstep_RealImpl_MockFS_IO tr NoCheckCleanup NoCheckFS NoCheckRefs + tr = nullTracer + +-- | Run any number of actions using the default actions generator, and finally +-- run a single action with errors *definitely* enabled. +dl_noSwallowExceptions :: DL (Lockstep (ModelState R.Table)) () +dl_noSwallowExceptions = do + -- Run any number of actions as normal + anyActions_ + + -- Generate a single action as normal + varCtx <- getVarContextDL + st <- getModelStateDL + let + gen = QLS.arbitraryAction varCtx st + predicate (Some a) = QLS.precondition st a + shr (Some a) = QLS.shrinkAction varCtx st a + Some a <- forAllQ $ withGenQ gen predicate shr + + -- Overwrite the maybe errors of the generated action with *definitely* just + -- errors. + case a of + Action _merrs a' -> do + HasNoVariables errs <- + forAllQ $ hasNoVariablesQ $ withGenQ arbitraryErrors (\_ -> True) shrinkErrors + -- Run the modified action + void $ action $ Action (Just errs) a' + +-- | Generate an 'Errors' with arbitrary probabilities of exceptions. +-- +-- The default 'genErrors' from @fs-sim@ generates streams of 'Maybe' exceptions +-- with a fixed probability for a 'Just' or 'Nothing'. The version here +-- generates an arbitrary probability for each stream, which should generate a +-- larger variety of 'Errors' structures. +-- +-- TODO: upstream to @fs-sim@ to replase the default 'genErrors'? +arbitraryErrors :: Gen Errors +arbitraryErrors = do + dumpStateE <- genStream arbitrary + hCloseE <- genStream arbitrary + hTruncateE <- genStream arbitrary + doesDirectoryExistE <- genStream arbitrary + doesFileExistE <- genStream arbitrary + hOpenE <- genStream arbitrary + hSeekE <- genStream arbitrary + hGetSomeE <- genErrorStreamGetSome + hGetSomeAtE <- genErrorStreamGetSome + hPutSomeE <- genErrorStreamPutSome + hGetSizeE <- genStream arbitrary + createDirectoryE <- genStream arbitrary + createDirectoryIfMissingE <- genStream arbitrary + listDirectoryE <- genStream arbitrary + removeDirectoryRecursiveE <- genStream arbitrary + removeFileE <- genStream arbitrary + renameFileE <- genStream arbitrary + hGetBufSomeE <- genErrorStreamGetSome + hGetBufSomeAtE <- genErrorStreamGetSome + hPutBufSomeE <- genErrorStreamPutSome + hPutBufSomeAtE <- genErrorStreamPutSome + return $ filterErrors Errors {..} + where + -- Generate a stream using 'genLikelihoods' for its 'Maybe' elements. + genStream :: forall a. Gen a -> Gen (Stream a) + genStream genA = do + (pNothing, pJust) <- genLikelihoods + Stream.genInfinite $ Stream.genMaybe pNothing pJust genA + + -- Generate two integer likelihoods for 'Nothing' and 'Just' constructors. + genLikelihoods :: Gen (Int, Int) + genLikelihoods = do + NonNegative pNothing <- arbitrary + NonNegative pJust <- arbitrary + if pNothing == 0 then + pure (0, 1) + else if pJust == 0 then + pure (1, 0) + else + pure (pNothing, pJust) + + genErrorStreamGetSome :: Gen ErrorStreamGetSome + genErrorStreamGetSome = genStream $ liftArbitrary2 arbitrary arbitrary + + genErrorStreamPutSome :: Gen ErrorStreamPutSome + genErrorStreamPutSome = genStream $ flip liftArbitrary2 arbitrary $ do + errorType <- arbitrary + maybePutCorruption <- liftArbitrary genPutCorruption + pure (errorType, maybePutCorruption) + + genPutCorruption :: Gen PutCorruption + genPutCorruption = oneof [ + PartialWrite <$> arbitrary + , SubstituteWithJunk <$> arbitrary + ] + where + _coveredAllCases x = case x of + PartialWrite{} -> pure () + SubstituteWithJunk{} -> pure () + + -- TODO: there is one case where an 'FsReachEOF' error is swallowed. Is that + -- valid behaviour, or should we change it? + filterErrors errs = errs { + hGetBufSomeE = Stream.filter (not . isFsReachedEOF) (hGetBufSomeE errs) + } + + isFsReachedEOF Nothing = False + isFsReachedEOF (Just (Left e)) = case e of + FsReachedEOF -> True + _ -> False + isFsReachedEOF (Just (Right _)) = False + +-- | Shrink each error stream and all error stream elements. +-- +-- The default 'shrink' from @fs-sim@ shrinks only the stream structure, but not +-- the elements contained in those streams. +-- +-- TODO: upstream to @fs-sim@ to replace the default 'shrink'? +shrinkErrors :: Errors -> [Errors] +shrinkErrors err@($(fields 'Errors)) + | allNull err = [] + | otherwise = emptyErrors : concatMap (filter (not . allNull)) + [ (\s' -> err { dumpStateE = s' }) <$> Stream.liftShrinkStream shrink dumpStateE + , (\s' -> err { hOpenE = s' }) <$> Stream.liftShrinkStream shrink hOpenE + , (\s' -> err { hCloseE = s' }) <$> Stream.liftShrinkStream shrink hCloseE + , (\s' -> err { hSeekE = s' }) <$> Stream.liftShrinkStream shrink hSeekE + , (\s' -> err { hGetSomeE = s' }) <$> Stream.liftShrinkStream shrink hGetSomeE + , (\s' -> err { hGetSomeAtE = s' }) <$> Stream.liftShrinkStream shrink hGetSomeAtE + , (\s' -> err { hPutSomeE = s' }) <$> Stream.liftShrinkStream shrink hPutSomeE + , (\s' -> err { hTruncateE = s' }) <$> Stream.liftShrinkStream shrink hTruncateE + , (\s' -> err { hGetSizeE = s' }) <$> Stream.liftShrinkStream shrink hGetSizeE + , (\s' -> err { createDirectoryE = s' }) <$> Stream.liftShrinkStream shrink createDirectoryE + , (\s' -> err { createDirectoryIfMissingE = s' }) <$> Stream.liftShrinkStream shrink createDirectoryIfMissingE + , (\s' -> err { listDirectoryE = s' }) <$> Stream.liftShrinkStream shrink listDirectoryE + , (\s' -> err { doesDirectoryExistE = s' }) <$> Stream.liftShrinkStream shrink doesDirectoryExistE + , (\s' -> err { doesFileExistE = s' }) <$> Stream.liftShrinkStream shrink doesFileExistE + , (\s' -> err { removeDirectoryRecursiveE = s' }) <$> Stream.liftShrinkStream shrink removeDirectoryRecursiveE + , (\s' -> err { removeFileE = s' }) <$> Stream.liftShrinkStream shrink removeFileE + , (\s' -> err { renameFileE = s' }) <$> Stream.liftShrinkStream shrink renameFileE + , (\s' -> err { hGetBufSomeE = s' }) <$> Stream.liftShrinkStream shrink hGetBufSomeE + , (\s' -> err { hGetBufSomeAtE = s' }) <$> Stream.liftShrinkStream shrink hGetBufSomeAtE + , (\s' -> err { hPutBufSomeE = s' }) <$> Stream.liftShrinkStream shrink hPutBufSomeE + , (\s' -> err { hPutBufSomeAtE = s' }) <$> Stream.liftShrinkStream shrink hPutBufSomeAtE + ] + +deriving stock instance Enum FsErrorType +deriving stock instance Bounded FsErrorType + +instance Arbitrary FsErrorType where + arbitrary = arbitraryBoundedEnum + shrink = shrinkBoundedEnum diff --git a/test/Test/Util/FS/Error.hs b/test/Test/Util/FS/Error.hs new file mode 100644 index 000000000..22b798237 --- /dev/null +++ b/test/Test/Util/FS/Error.hs @@ -0,0 +1,226 @@ +module Test.Util.FS.Error ( + -- * Errors log + ErrorsLog + , emptyLog + , countNoisyErrors + -- * Logged HasFS and HasBlockIO + , simErrorHasBlockIOLogged + , simErrorHasFS + ) where + +import Control.Concurrent.Class.MonadMVar (MonadMVar) +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad.Class.MonadThrow +import Control.Monad.Primitive +import Data.Functor.Barbie +import Data.Monoid +import GHC.Generics +import System.FS.API +import System.FS.BlockIO.API +import System.FS.BlockIO.Sim +import System.FS.Sim.Error +import System.FS.Sim.MockFS (HandleMock, MockFS) +import System.FS.Sim.Stream + +{------------------------------------------------------------------------------- + Higher-kinded datatype +-------------------------------------------------------------------------------} + +-- | A higher-kinded datatype (HKD) version of the 'Errors' type. 'Errors' is +-- equivalent to @'HKD' 'Stream'@. +-- +-- 'HKD' has instances for @barbies@ classes, which lets us manipulate 'HKD' +-- with a small set of combinators like 'bpure' and 'bmap'. This makes writing +-- functions operating on 'HKD' less arduous than writing the functions out +-- fully. +-- +-- TODO: admittedly, we are not getting the full benefis from higher-kinded +-- datatypes because 'Errors' and 'HasFS' are not HKDs, meaning we still have to +-- write some stuff out manually, like in 'simErrorHasFSLogged'. We could take +-- the HKD approach even further, but it is likely going to require quite a bit +-- of boilerplate to set up before we can start programming with HKDs. At that +-- point one might ask whether the costs of defining the HKD boilerplate +-- outweighs the benefits of programming with HKDs. +data HKD f = HKD { + dumpStateHKD :: f FsErrorType + , hOpenHKD :: f FsErrorType + , hCloseHKD :: f FsErrorType + , hSeekHKD :: f FsErrorType + , hGetSomeHKD :: f (Either FsErrorType Partial) + , hGetSomeAtHKD :: f (Either FsErrorType Partial) + , hPutSomeHKD :: f (Either (FsErrorType, Maybe PutCorruption) Partial) + , hTruncateHKD :: f FsErrorType + , hGetSizeHKD :: f FsErrorType + , createDirectoryHKD :: f FsErrorType + , createDirectoryIfMissingHKD:: f FsErrorType + , listDirectoryHKD :: f FsErrorType + , doesDirectoryExistHKD :: f FsErrorType + , doesFileExistHKD :: f FsErrorType + , removeDirectoryRecursiveHKD:: f FsErrorType + , removeFileHKD :: f FsErrorType + , renameFileHKD :: f FsErrorType + , hGetBufSomeHKD :: f (Either FsErrorType Partial) + , hGetBufSomeAtHKD :: f (Either FsErrorType Partial) + , hPutBufSomeHKD :: f (Either (FsErrorType, Maybe PutCorruption) Partial) + , hPutBufSomeAtHKD :: f (Either (FsErrorType, Maybe PutCorruption) Partial) + } + deriving stock Generic + +deriving anyclass instance FunctorB HKD +deriving anyclass instance ApplicativeB HKD +deriving anyclass instance TraversableB HKD +deriving anyclass instance ConstraintsB HKD + +{------------------------------------------------------------------------------- + Errors log +-------------------------------------------------------------------------------} + +type ErrorsLog = HKD [] + +emptyLog :: ErrorsLog +emptyLog = bpure [] + +{------------------------------------------------------------------------------- + Count noisy errors in the log +-------------------------------------------------------------------------------} + +class IsNoisy a where + isNoisy :: a -> Bool + +instance IsNoisy FsErrorType where + isNoisy _ = True + +instance IsNoisy (Either FsErrorType b) where + isNoisy (Left x) = isNoisy x + isNoisy (Right _) = False + +instance IsNoisy (Either (FsErrorType, b) c) where + isNoisy (Left (x, _)) = isNoisy x + isNoisy (Right _) = False + +countNoisyErrors :: ErrorsLog -> Int +countNoisyErrors = getSum . bfoldMapC @IsNoisy (Sum . length . Prelude.filter isNoisy) + +{------------------------------------------------------------------------------- + Logged HasFS and HasBlockIO +-------------------------------------------------------------------------------} + +-- | Like 'simErrorHasFSLogged', but also produces a simulated 'HasBlockIO'. +simErrorHasBlockIOLogged :: + forall m. (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m) + => StrictTMVar m MockFS + -> StrictTVar m Errors + -> StrictTVar m (HKD []) + -> m (HasFS m HandleMock, HasBlockIO m HandleMock) +simErrorHasBlockIOLogged fsVar errorsVar logVar = do + let hfs = simErrorHasFSLogged fsVar errorsVar logVar + hbio <- fromHasFS hfs + pure (hfs, hbio) + +-- | Produce a simulated file system with injected errors and a logger for those +-- errors. +-- +-- Every time a 'HasFS' primitive is used and an error from 'Errors' is used, it +-- will be logged in 'ErrorsLog'. +simErrorHasFSLogged :: + forall m. (MonadSTM m, MonadThrow m, PrimMonad m) + => StrictTMVar m MockFS + -> StrictTVar m Errors + -> StrictTVar m ErrorsLog + -> HasFS m HandleMock +simErrorHasFSLogged fsVar errorsVar logVar = + HasFS { + dumpState = do + addToLog dumpStateE dumpStateHKD (\l x -> l { dumpStateHKD = x} ) + dumpState hfs + , hOpen = \a b -> do + addToLog hOpenE hOpenHKD (\l x -> l { hOpenHKD = x} ) + hOpen hfs a b + , hClose = \a -> do + addToLog hCloseE hCloseHKD (\l x -> l { hCloseHKD = x} ) + hClose hfs a + , hIsOpen = \a -> + hIsOpen hfs a + , hSeek = \a b c -> do + addToLog hSeekE hSeekHKD (\l x -> l { hSeekHKD = x} ) + hSeek hfs a b c + , hGetSome = \a b -> do + addToLog hGetSomeE hGetSomeHKD (\l x -> l { hGetSomeHKD = x} ) + hGetSome hfs a b + , hGetSomeAt = \a b c -> do + addToLog hGetSomeAtE hGetSomeAtHKD (\l x -> l { hGetSomeAtHKD = x} ) + hGetSomeAt hfs a b c + , hPutSome = \a b -> do + addToLog hPutSomeE hPutSomeHKD (\l x -> l { hPutSomeHKD = x} ) + hPutSome hfs a b + , hTruncate = \a b -> do + addToLog hTruncateE hTruncateHKD (\l x -> l { hTruncateHKD = x} ) + hTruncate hfs a b + , hGetSize = \a -> do + addToLog hGetSizeE hGetSizeHKD (\l x -> l { hGetSizeHKD = x} ) + hGetSize hfs a + , createDirectory = \a -> do + addToLog createDirectoryE createDirectoryHKD (\l x -> l { createDirectoryHKD = x} ) + createDirectory hfs a + , createDirectoryIfMissing = \a b -> do + addToLog createDirectoryIfMissingE createDirectoryIfMissingHKD (\l x -> l { createDirectoryIfMissingHKD = x} ) + createDirectoryIfMissing hfs a b + , listDirectory = \a -> do + addToLog listDirectoryE listDirectoryHKD (\l x -> l { listDirectoryHKD = x} ) + listDirectory hfs a + , doesDirectoryExist = \a -> do + addToLog doesDirectoryExistE doesDirectoryExistHKD (\l x -> l { doesDirectoryExistHKD = x} ) + doesDirectoryExist hfs a + , doesFileExist = \a -> do + addToLog doesFileExistE doesFileExistHKD (\l x -> l { doesFileExistHKD = x} ) + doesFileExist hfs a + , removeDirectoryRecursive = \a -> do + addToLog removeDirectoryRecursiveE removeDirectoryRecursiveHKD (\l x -> l { removeDirectoryRecursiveHKD = x} ) + removeDirectoryRecursive hfs a + , removeFile = \a -> do + addToLog removeFileE removeFileHKD (\l x -> l { removeFileHKD = x} ) + removeFile hfs a + , renameFile = \a b -> do + addToLog renameFileE renameFileHKD (\l x -> l { renameFileHKD = x} ) + renameFile hfs a b + , mkFsErrorPath = mkFsErrorPath hfs + , unsafeToFilePath = unsafeToFilePath hfs + , hGetBufSome = \a b c d -> do + addToLog hGetBufSomeE hGetBufSomeHKD (\l x -> l { hGetBufSomeHKD = x} ) + hGetBufSome hfs a b c d + , hGetBufSomeAt = \a b c d e -> do + addToLog hGetBufSomeAtE hGetBufSomeAtHKD (\l x -> l { hGetBufSomeAtHKD = x} ) + hGetBufSomeAt hfs a b c d e + , hPutBufSome = \a b c d -> do + addToLog hPutBufSomeE hPutBufSomeHKD (\l x -> l { hPutBufSomeHKD = x} ) + hPutBufSome hfs a b c d + , hPutBufSomeAt = \a b c d e -> do + addToLog hPutBufSomeAtE hPutBufSomeAtHKD (\l x -> l { hPutBufSomeAtHKD = x} ) + hPutBufSomeAt hfs a b c d e + } + where + hfs = simErrorHasFS fsVar errorsVar + + -- Peek at the first element from an error stream and add it to the errors + -- log if it is 'Just' an error. + addToLog :: + (Errors -> Stream e) + -> (ErrorsLog -> [e]) + -> (ErrorsLog -> [e] -> ErrorsLog) + -> m () + addToLog getE getL setL = do + errors <- readTVarIO errorsVar + logs <- readTVarIO logVar + let s = getE errors + let x = peek s + case x of + Nothing -> pure () + Just y -> + atomically $ writeTVar logVar $ + setL logs $ (++ [y]) $ getL logs + + -- Peek at the first element from an error stream. + peek :: Stream a -> Maybe a + peek (UnsafeStream _ xs) = case xs of + [] -> Nothing + (x:_) -> x