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 8342d9e68..d3b80c9b2 100644 --- a/test/Test/Util/FS.hs +++ b/test/Test/Util/FS.hs @@ -12,7 +12,11 @@ module Test.Util.FS ( , withSimErrorHasFS , withSimErrorHasBlockIO -- * Simulated file system properties + , propTrivial + , propNumOpenHandles , propNoOpenHandles + , propNumDirEntries + , propNoDirEntries , assertNoOpenHandles , assertNumOpenHandles -- * Equality @@ -23,9 +27,11 @@ 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) @@ -137,13 +143,41 @@ withSimErrorHasBlockIO post fs errs k = 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)