diff --git a/test/Test/Database/LSMTree/Internal/Run.hs b/test/Test/Database/LSMTree/Internal/Run.hs index e991e37e8..393bf5f51 100644 --- a/test/Test/Database/LSMTree/Internal/Run.hs +++ b/test/Test/Database/LSMTree/Internal/Run.hs @@ -37,6 +37,7 @@ import qualified System.FS.API.Lazy as FSL import qualified System.FS.BlockIO.API as FS import qualified System.FS.BlockIO.IO as FS import qualified System.FS.IO as FsIO +import qualified System.FS.Sim.MockFS as MockFS import qualified System.IO.Temp as Temp import Test.Database.LSMTree.Internal.RunReader (readKOps) import Test.Tasty (TestTree, testGroup) @@ -67,16 +68,16 @@ tests = testGroup "Database.LSMTree.Internal.Run" (mkVal ("test-value-" <> BS.concat (replicate 500 "0123456789"))) Nothing , testProperty "prop_WriteAndOpen" $ \wb -> - ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> + ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> prop_WriteAndOpen hfs hbio wb , testProperty "prop_WriteNumEntries" $ \wb -> - ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> + ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> prop_WriteNumEntries hfs hbio wb , testProperty "prop_WriteAndOpenWriteBuffer" $ \wb -> - ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> + ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> prop_WriteAndOpenWriteBuffer hfs hbio wb , testProperty "prop_WriteRunEqWriteWriteBuffer" $ \wb -> - ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> + ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> prop_WriteRunEqWriteWriteBuffer hfs hbio wb ] ] diff --git a/test/Test/Database/LSMTree/Internal/RunBuilder.hs b/test/Test/Database/LSMTree/Internal/RunBuilder.hs index e7178fd62..ce6a2693e 100644 --- a/test/Test/Database/LSMTree/Internal/RunBuilder.hs +++ b/test/Test/Database/LSMTree/Internal/RunBuilder.hs @@ -12,6 +12,7 @@ import Database.LSMTree.Internal.RunNumber import qualified System.FS.API as FS import System.FS.API (HasFS) import qualified System.FS.BlockIO.API as FS +import qualified System.FS.Sim.MockFS as MockFS import Test.Tasty import Test.Tasty.QuickCheck import Test.Util.FS (propNoOpenHandles, withSimHasBlockIO, @@ -29,11 +30,14 @@ tests = testGroup "Test.Database.LSMTree.Internal.RunBuilder" [ ] , testGroup "simHasFS" [ testProperty "prop_newInExistingDir" $ ioProperty $ - withSimHasBlockIO propNoOpenHandles prop_newInExistingDir + withSimHasBlockIO propNoOpenHandles MockFS.empty $ + \hfs hbio _ -> prop_newInExistingDir hfs hbio , testProperty "prop_newInNonExistingDir" $ ioProperty $ - withSimHasBlockIO propNoOpenHandles prop_newInNonExistingDir + withSimHasBlockIO propNoOpenHandles MockFS.empty $ + \hfs hbio _ -> prop_newInNonExistingDir hfs hbio , testProperty "prop_newTwice" $ ioProperty $ - withSimHasBlockIO propNoOpenHandles prop_newTwice + withSimHasBlockIO propNoOpenHandles MockFS.empty $ + \hfs hbio _ -> prop_newTwice hfs hbio ] ] diff --git a/test/Test/Database/LSMTree/Internal/RunReader.hs b/test/Test/Database/LSMTree/Internal/RunReader.hs index 651d07d79..89aa419ab 100644 --- a/test/Test/Database/LSMTree/Internal/RunReader.hs +++ b/test/Test/Database/LSMTree/Internal/RunReader.hs @@ -17,6 +17,7 @@ import qualified Database.LSMTree.Internal.RunReader as Reader import Database.LSMTree.Internal.Serialise import qualified System.FS.API as FS import qualified System.FS.BlockIO.API as FS +import qualified System.FS.Sim.MockFS as MockFS import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck import Test.Util.FS (propNoOpenHandles, withSimHasBlockIO, @@ -27,19 +28,19 @@ tests :: TestTree tests = testGroup "Database.LSMTree.Internal.RunReader" [ testGroup "MockFS" [ testProperty "prop_read" $ \wb -> - ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do + ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do prop_readAtOffset hfs hbio wb Nothing , testProperty "prop_readAtOffset" $ \wb offset -> - ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do + ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do prop_readAtOffset hfs hbio wb (Just offset) , testProperty "prop_readAtOffsetExisting" $ \wb i -> - ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do + ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do prop_readAtOffsetExisting hfs hbio wb i , testProperty "prop_readAtOffsetIdempotence" $ \wb i -> - ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do + ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do prop_readAtOffsetIdempotence hfs hbio wb i , testProperty "prop_readAtOffsetReadHead" $ \wb -> - ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do + ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do prop_readAtOffsetReadHead hfs hbio wb ] , testGroup "RealFS" diff --git a/test/Test/FS.hs b/test/Test/FS.hs index cdbc72496..cacca09e3 100644 --- a/test/Test/FS.hs +++ b/test/Test/FS.hs @@ -3,26 +3,135 @@ -- TODO: upstream to fs-sim module Test.FS (tests) where +import Control.Concurrent.Class.MonadSTM (MonadSTM (atomically)) +import Control.Concurrent.Class.MonadSTM.Strict.TMVar +import Control.Monad +import Control.Monad.IOSim (runSimOrThrow) +import Data.Char (isAsciiLower, isAsciiUpper) +import qualified Data.List as List +import qualified Data.Text as Text import GHC.Generics (Generic) import System.FS.API import System.FS.Sim.Error +import qualified System.FS.Sim.MockFS as MockFS import qualified System.FS.Sim.Stream as S import System.FS.Sim.Stream (InternalInfo (..), Stream (..)) import Test.QuickCheck import Test.QuickCheck.Classes (eqLaws) import Test.QuickCheck.Instances () import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) import Test.Util.FS import Test.Util.QC tests :: TestTree tests = testGroup "Test.FS" [ - testClassLaws "Stream" $ + -- * Simulated file system properties + testProperty "prop_numOpenHandles" prop_numOpenHandles + , testProperty "prop_numDirEntries" prop_numDirEntries + -- * Equality + , testClassLaws "Stream" $ eqLaws (Proxy @(Stream Int)) , testClassLaws "Errors" $ eqLaws (Proxy @Errors) ] +{------------------------------------------------------------------------------- + Simulated file system properties +-------------------------------------------------------------------------------} + +newtype Path = Path FsPath + deriving stock (Show, Eq) + +newtype UniqueList a = UniqueList [a] + deriving stock Show + +instance (Arbitrary a, Eq a) => Arbitrary (UniqueList a) where + arbitrary = do + xs <- arbitrary + pure (UniqueList (List.nub xs)) + shrink (UniqueList []) = [] + shrink (UniqueList xs) = UniqueList . List.nub <$> shrink xs + +instance Arbitrary Path where + arbitrary = Path . mkFsPath . (:[]) <$> ((:) <$> genChar <*> listOf genChar) + where + genChar = elements (['A'..'Z'] ++ ['a'..'z']) + shrink (Path p) = case fsPathToList p of + [] -> [] + t:_ -> [ + Path p' + | t' <- shrink t + , let t'' = Text.filter (\c -> isAsciiUpper c || isAsciiLower c) t' + , not (Text.null t'') + , let p' = fsPathFromList [t'] + ] + +-- | Sanity check for 'propNoOpenHandles' and 'propNumOpenHandles' +prop_numOpenHandles :: UniqueList Path -> Property +prop_numOpenHandles (UniqueList paths) = runSimOrThrow $ + withSimHasFS propTrivial MockFS.empty $ \hfs fsVar -> do + -- No open handles initially + fs <- atomically $ readTMVar fsVar + let prop = propNoOpenHandles fs + + -- Open n handles + hs <- forM paths $ \(Path p) -> hOpen hfs p (WriteMode MustBeNew) + + -- Now there should be precisely n open handles + fs' <- atomically $ readTMVar fsVar + let prop' = propNumOpenHandles n fs' + + -- Close all previously opened handles + forM_ hs $ hClose hfs + + -- No open handles again + fs'' <- atomically $ readTMVar fsVar + let prop'' = propNoOpenHandles fs'' + + pure (prop .&&. prop' .&&. prop'') + where + n = length paths + +-- | Sanity check for 'propNoDirEntries' and 'propNumDirEntries' +prop_numDirEntries :: Path -> InfiniteList Bool -> UniqueList Path -> Property +prop_numDirEntries (Path dir) isFiles (UniqueList paths) = runSimOrThrow $ + withSimHasFS propTrivial MockFS.empty $ \hfs fsVar -> do + createDirectoryIfMissing hfs False dir + + -- No entries initially + fs <- atomically $ readTMVar fsVar + let prop = propNoDirEntries dir fs + + -- Create n entries + forM_ xs $ \(isFile, Path p) -> + if isFile + then withFile hfs (dir p) (WriteMode MustBeNew) $ \_ -> pure () + else createDirectory hfs (dir p) + + -- Now there should be precisely n entries + fs' <- atomically $ readTMVar fsVar + let prop' = propNumDirEntries dir n fs' + + -- Remove n entries + forM_ xs $ \(isFile, Path p) -> + if isFile + then removeFile hfs (dir p) + else removeDirectoryRecursive hfs (dir p) + + -- No entries again + fs'' <- atomically $ readTMVar fsVar + let prop'' = propNoDirEntries dir fs'' + + pure (prop .&&. prop' .&&. prop'') + where + n = length paths + xs = zip (getInfiniteList isFiles) paths + +{------------------------------------------------------------------------------- + Equality +-------------------------------------------------------------------------------} + -- | This is not a fully lawful instance, because it uses 'approximateEqStream'. instance Eq a => Eq (Stream a) where (==) = approximateEqStream diff --git a/test/Test/Util/FS.hs b/test/Test/Util/FS.hs index c0ddea0ec..d3b80c9b2 100644 --- a/test/Test/Util/FS.hs +++ b/test/Test/Util/FS.hs @@ -10,11 +10,13 @@ module Test.Util.FS ( , withSimHasBlockIO -- * Simulated file system with errors , withSimErrorHasFS - , withSimErrorHasFS' , withSimErrorHasBlockIO - , withSimErrorHasBlockIO' -- * Simulated file system properties + , propTrivial + , propNumOpenHandles , propNoOpenHandles + , propNumDirEntries + , propNoDirEntries , assertNoOpenHandles , assertNumOpenHandles -- * Equality @@ -25,15 +27,16 @@ import Control.Concurrent.Class.MonadMVar import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (assert) import Control.Monad.Class.MonadThrow (MonadCatch, MonadThrow) +import Control.Monad.IOSim (runSimOrThrow) import Control.Monad.Primitive (PrimMonad) +import qualified Data.Set as Set import GHC.Stack -import System.FS.API +import System.FS.API as FS import System.FS.BlockIO.API import System.FS.BlockIO.IO import System.FS.BlockIO.Sim (fromHasFS) import System.FS.IO import System.FS.Sim.Error -import qualified System.FS.Sim.MockFS as MockFS import System.FS.Sim.MockFS import System.FS.Sim.STM import System.FS.Sim.Stream (InternalInfo (..), Stream (..)) @@ -61,27 +64,36 @@ withTempIOHasBlockIO path action = {-# INLINABLE withSimHasFS #-} withSimHasFS :: - (MonadSTM m, MonadThrow m, PrimMonad m) - => (MockFS -> Property) - -> (HasFS m HandleMock -> m Property) + (MonadSTM m, MonadThrow m, PrimMonad m, Testable prop1, Testable prop2) + => (MockFS -> prop1) + -> MockFS + -> ( HasFS m HandleMock + -> StrictTMVar m MockFS + -> m prop2 + ) -> m Property -withSimHasFS post k = do - var <- newTMVarIO MockFS.empty +withSimHasFS post fs k = do + var <- newTMVarIO fs let hfs = simHasFS var - x <- k hfs - fs <- atomically $ readTMVar var - pure (x .&&. post fs) + x <- k hfs var + fs' <- atomically $ readTMVar var + pure (x .&&. post fs') {-# INLINABLE withSimHasBlockIO #-} withSimHasBlockIO :: - (MonadMVar m, MonadSTM m, MonadCatch m, PrimMonad m) - => (MockFS -> Property) - -> (HasFS m HandleMock -> HasBlockIO m HandleMock -> m Property) + (MonadMVar m, MonadSTM m, MonadCatch m, PrimMonad m, Testable prop1, Testable prop2) + => (MockFS -> prop1) + -> MockFS + -> ( HasFS m HandleMock + -> HasBlockIO m HandleMock + -> StrictTMVar m MockFS + -> m prop2 + ) -> m Property -withSimHasBlockIO post k = do - withSimHasFS post $ \hfs -> do +withSimHasBlockIO post fs k = do + withSimHasFS post fs $ \hfs fsVar -> do hbio <- fromHasFS hfs - k hfs hbio + k hfs hbio fsVar {------------------------------------------------------------------------------- Simulated file system with errors @@ -107,28 +119,13 @@ withSimErrorHasFS post fs errs k = do fs' <- atomically $ readTMVar fsVar pure (x .&&. post fs') -{-# INLINABLE withSimErrorHasFS' #-} -withSimErrorHasFS' :: - (MonadSTM m, MonadThrow m, PrimMonad m, Testable prop1, Testable prop2) - => (MockFS -> prop1) - -> MockFS - -> Errors - -> (HasFS m HandleMock -> m prop2) - -> m Property -withSimErrorHasFS' post fs errs k = do - fsVar <- newTMVarIO fs - errVar <- newTVarIO errs - let hfs = simErrorHasFS fsVar errVar - x <- k hfs - fs' <- atomically $ readTMVar fsVar - pure (x .&&. post fs') - {-# INLINABLE withSimErrorHasBlockIO #-} withSimErrorHasBlockIO :: ( MonadSTM m, MonadCatch m, MonadMVar m, PrimMonad m , Testable prop1, Testable prop2 ) => (MockFS -> prop1) + -> MockFS -> Errors -> ( HasFS m HandleMock -> HasBlockIO m HandleMock @@ -137,44 +134,50 @@ withSimErrorHasBlockIO :: -> m prop2 ) -> m Property -withSimErrorHasBlockIO post errs k = do - fsVar <- newTMVarIO MockFS.empty - errVar <- newTVarIO errs - let hfs = simErrorHasFS fsVar errVar - hbio <- fromHasFS hfs - x <- k hfs hbio fsVar errVar - fs <- atomically $ readTMVar fsVar - pure (x .&&. post fs) - -{-# INLINABLE withSimErrorHasBlockIO' #-} -withSimErrorHasBlockIO' :: - ( MonadSTM m, MonadCatch m, MonadMVar m, PrimMonad m - , Testable prop1, Testable prop2 - ) - => (MockFS -> prop1) - -> Errors - -> (HasFS m HandleMock -> HasBlockIO m HandleMock -> m prop2) - -> m Property -withSimErrorHasBlockIO' post errs k = do - fsVar <- newTMVarIO MockFS.empty - errVar <- newTVarIO errs - let hfs = simErrorHasFS fsVar errVar - hbio <- fromHasFS hfs - x <- k hfs hbio - fs <- atomically $ readTMVar fsVar - pure (x .&&. post fs) +withSimErrorHasBlockIO post fs errs k = + withSimErrorHasFS post fs errs $ \hfs fsVar errsVar -> do + hbio <- fromHasFS hfs + k hfs hbio fsVar errsVar {------------------------------------------------------------------------------- Simulated file system properties -------------------------------------------------------------------------------} +propTrivial :: MockFS -> Property +propTrivial _ = property True + +{-# INLINABLE propNumOpenHandles #-} +propNumOpenHandles :: Int -> MockFS -> Property +propNumOpenHandles expected fs = + counterexample (printf "Expected %d open handles, but found %d" expected actual) $ + counterexample ("Open handles: " <> show (openHandles fs)) $ + printMockFSOnFailure fs $ + expected == actual + where actual = numOpenHandles fs + {-# INLINABLE propNoOpenHandles #-} propNoOpenHandles :: MockFS -> Property -propNoOpenHandles fs = - counterexample ("Expected 0 open handles, but found " <> show n) $ +propNoOpenHandles fs = propNumOpenHandles 0 fs + +{-# INLINABLE propNumDirEntries #-} +propNumDirEntries :: FsPath -> Int -> MockFS -> Property +propNumDirEntries path expected fs = + counterexample + (printf "Expected %d entries in the directory at %s, but found %d" + expected + (show path) actual) $ printMockFSOnFailure fs $ - n == 0 - where n = numOpenHandles fs + expected === actual + where + actual = + let (contents, _) = runSimOrThrow $ + runSimFS fs $ \hfs -> + FS.listDirectory hfs path + in Set.size contents + +{-# INLINABLE propNoDirEntries #-} +propNoDirEntries :: FsPath -> MockFS -> Property +propNoDirEntries path fs = propNumDirEntries path 0 fs printMockFSOnFailure :: Testable prop => MockFS -> prop -> Property printMockFSOnFailure fs = counterexample ("Mocked file system: " <> pretty fs)