diff --git a/lsm-tree.cabal b/lsm-tree.cabal index 21fe77910..9121b318c 100644 --- a/lsm-tree.cabal +++ b/lsm-tree.cabal @@ -386,6 +386,7 @@ test-suite lsm-tree-test Test.Database.LSMTree.StateMachine.DL Test.Database.LSMTree.StateMachine.Op Test.Database.LSMTree.UnitTests + Test.FS Test.System.Posix.Fcntl.NoCache Test.Util.Arbitrary Test.Util.FS diff --git a/test/Main.hs b/test/Main.hs index 9318b63f5..a351e022e 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -37,6 +37,7 @@ import qualified Test.Database.LSMTree.Monoidal import qualified Test.Database.LSMTree.StateMachine import qualified Test.Database.LSMTree.StateMachine.DL import qualified Test.Database.LSMTree.UnitTests +import qualified Test.FS import qualified Test.System.Posix.Fcntl.NoCache import Test.Tasty @@ -75,6 +76,7 @@ main = do , Test.Database.LSMTree.UnitTests.tests , Test.Database.LSMTree.StateMachine.tests , Test.Database.LSMTree.StateMachine.DL.tests + , Test.FS.tests , Test.System.Posix.Fcntl.NoCache.tests , Test.Data.Arena.tests ] diff --git a/test/Test/FS.hs b/test/Test/FS.hs new file mode 100644 index 000000000..d3264ca7d --- /dev/null +++ b/test/Test/FS.hs @@ -0,0 +1,85 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +-- TODO: upstream to fs-sim +module Test.FS (tests) where + +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 System.FS.API +import qualified System.FS.Sim.MockFS as MockFS +import Test.QuickCheck +import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) +import Test.Util.FS + +tests :: TestTree +tests = testGroup "Test.FS" [ + -- Simulated file system properties + testProperty "prop_propNumOpenHandles" prop_propNumOpenHandles + , testProperty "prop_propNoOpenHandles" prop_propNoOpenHandles + , testProperty "prop_propNumDirEntries" prop_propNumDirEntries + , testProperty "prop_propNoDirEntries" prop_propNoDirEntries + ] + +{------------------------------------------------------------------------------- + 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'] + ] + +prop_propNumOpenHandles :: UniqueList Path -> Property +prop_propNumOpenHandles (UniqueList paths) = runSimOrThrow $ + withSimHasFS prop MockFS.empty $ \hfs _ -> do + forM_ paths $ \(Path p) -> hOpen hfs p (WriteMode MustBeNew) + where + prop = propNumOpenHandles (length paths) + +prop_propNoOpenHandles :: Property +prop_propNoOpenHandles = once $ runSimOrThrow $ + withSimHasFS propNoOpenHandles MockFS.empty $ \_ _ -> pure () + +prop_propNumDirEntries :: Path -> InfiniteList Bool -> UniqueList Path -> Property +prop_propNumDirEntries (Path dir) isFiles (UniqueList paths) = runSimOrThrow $ + withSimHasFS prop MockFS.empty $ \hfs _ -> do + createDirectoryIfMissing hfs False dir + forM_ (zip (getInfiniteList isFiles) paths) $ \(isFile, Path p) -> + if isFile then + void $ hOpen hfs (dir p) (WriteMode MustBeNew) + else + createDirectory hfs (dir p) + where + prop = propNumDirEntries dir (length paths) + +prop_propNoDirEntries :: Path -> Property +prop_propNoDirEntries (Path dir) = runSimOrThrow $ + withSimHasFS (propNoDirEntries dir) MockFS.empty $ \hfs _ -> do + createDirectoryIfMissing hfs False dir diff --git a/test/Test/Util/FS.hs b/test/Test/Util/FS.hs index 422693033..6f48f8be5 100644 --- a/test/Test/Util/FS.hs +++ b/test/Test/Util/FS.hs @@ -13,7 +13,10 @@ module Test.Util.FS ( , withSimErrorHasFS , withSimErrorHasBlockIO -- * Simulated file system properties + , propNumOpenHandles , propNoOpenHandles + , propNumDirEntries + , propNoDirEntries , assertNoOpenHandles , assertNumOpenHandles ) where @@ -22,9 +25,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) @@ -135,13 +140,38 @@ withSimErrorHasBlockIO post fs errs k = Simulated file system properties -------------------------------------------------------------------------------} +{-# 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)