Skip to content

Commit 72c438c

Browse files
jorisdraljorisdral
authored
Merge pull request #518 from IntersectMBO/jdral/fs-sim-utils
More `MockFS` properties for testing with `fs-sim`
2 parents 39343e5 + 4913132 commit 72c438c

File tree

5 files changed

+195
-77
lines changed

5 files changed

+195
-77
lines changed

‎test/Test/Database/LSMTree/Internal/Run.hs‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,7 @@ import qualified System.FS.API.Lazy as FSL
3737
import qualified System.FS.BlockIO.API as FS
3838
import qualified System.FS.BlockIO.IO as FS
3939
import qualified System.FS.IO as FsIO
40+
import qualified System.FS.Sim.MockFS as MockFS
4041
import qualified System.IO.Temp as Temp
4142
import Test.Database.LSMTree.Internal.RunReader (readKOps)
4243
import Test.Tasty (TestTree, testGroup)
@@ -67,16 +68,16 @@ tests = testGroup "Database.LSMTree.Internal.Run"
6768
(mkVal ("test-value-" <> BS.concat (replicate 500 "0123456789")))
6869
Nothing
6970
, testProperty "prop_WriteAndOpen" $ \wb ->
70-
ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio ->
71+
ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ ->
7172
prop_WriteAndOpen hfs hbio wb
7273
, testProperty "prop_WriteNumEntries" $ \wb ->
73-
ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio ->
74+
ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ ->
7475
prop_WriteNumEntries hfs hbio wb
7576
, testProperty "prop_WriteAndOpenWriteBuffer" $ \wb ->
76-
ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio ->
77+
ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ ->
7778
prop_WriteAndOpenWriteBuffer hfs hbio wb
7879
, testProperty "prop_WriteRunEqWriteWriteBuffer" $ \wb ->
79-
ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio ->
80+
ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ ->
8081
prop_WriteRunEqWriteWriteBuffer hfs hbio wb
8182
]
8283
]

‎test/Test/Database/LSMTree/Internal/RunBuilder.hs‎

Lines changed: 7 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ import Database.LSMTree.Internal.RunNumber
1212
import qualified System.FS.API as FS
1313
import System.FS.API (HasFS)
1414
import qualified System.FS.BlockIO.API as FS
15+
import qualified System.FS.Sim.MockFS as MockFS
1516
import Test.Tasty
1617
import Test.Tasty.QuickCheck
1718
import Test.Util.FS (propNoOpenHandles, withSimHasBlockIO,
@@ -29,11 +30,14 @@ tests = testGroup "Test.Database.LSMTree.Internal.RunBuilder" [
2930
]
3031
, testGroup "simHasFS" [
3132
testProperty "prop_newInExistingDir" $ ioProperty $
32-
withSimHasBlockIO propNoOpenHandles prop_newInExistingDir
33+
withSimHasBlockIO propNoOpenHandles MockFS.empty $
34+
\hfs hbio _ -> prop_newInExistingDir hfs hbio
3335
, testProperty "prop_newInNonExistingDir" $ ioProperty $
34-
withSimHasBlockIO propNoOpenHandles prop_newInNonExistingDir
36+
withSimHasBlockIO propNoOpenHandles MockFS.empty $
37+
\hfs hbio _ -> prop_newInNonExistingDir hfs hbio
3538
, testProperty "prop_newTwice" $ ioProperty $
36-
withSimHasBlockIO propNoOpenHandles prop_newTwice
39+
withSimHasBlockIO propNoOpenHandles MockFS.empty $
40+
\hfs hbio _ -> prop_newTwice hfs hbio
3741
]
3842
]
3943

‎test/Test/Database/LSMTree/Internal/RunReader.hs‎

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@ import qualified Database.LSMTree.Internal.RunReader as Reader
1717
import Database.LSMTree.Internal.Serialise
1818
import qualified System.FS.API as FS
1919
import qualified System.FS.BlockIO.API as FS
20+
import qualified System.FS.Sim.MockFS as MockFS
2021
import Test.Tasty (TestTree, testGroup)
2122
import Test.Tasty.QuickCheck
2223
import Test.Util.FS (propNoOpenHandles, withSimHasBlockIO,
@@ -27,19 +28,19 @@ tests :: TestTree
2728
tests = testGroup "Database.LSMTree.Internal.RunReader"
2829
[ testGroup "MockFS"
2930
[ testProperty "prop_read" $ \wb ->
30-
ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do
31+
ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do
3132
prop_readAtOffset hfs hbio wb Nothing
3233
, testProperty "prop_readAtOffset" $ \wb offset ->
33-
ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do
34+
ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do
3435
prop_readAtOffset hfs hbio wb (Just offset)
3536
, testProperty "prop_readAtOffsetExisting" $ \wb i ->
36-
ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do
37+
ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do
3738
prop_readAtOffsetExisting hfs hbio wb i
3839
, testProperty "prop_readAtOffsetIdempotence" $ \wb i ->
39-
ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do
40+
ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do
4041
prop_readAtOffsetIdempotence hfs hbio wb i
4142
, testProperty "prop_readAtOffsetReadHead" $ \wb ->
42-
ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do
43+
ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do
4344
prop_readAtOffsetReadHead hfs hbio wb
4445
]
4546
, testGroup "RealFS"

‎test/Test/FS.hs‎

Lines changed: 110 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,26 +3,135 @@
33
-- TODO: upstream to fs-sim
44
module Test.FS (tests) where
55

6+
import Control.Concurrent.Class.MonadSTM (MonadSTM (atomically))
7+
import Control.Concurrent.Class.MonadSTM.Strict.TMVar
8+
import Control.Monad
9+
import Control.Monad.IOSim (runSimOrThrow)
10+
import Data.Char (isAsciiLower, isAsciiUpper)
11+
import qualified Data.List as List
12+
import qualified Data.Text as Text
613
import GHC.Generics (Generic)
714
import System.FS.API
815
import System.FS.Sim.Error
16+
import qualified System.FS.Sim.MockFS as MockFS
917
import qualified System.FS.Sim.Stream as S
1018
import System.FS.Sim.Stream (InternalInfo (..), Stream (..))
1119
import Test.QuickCheck
1220
import Test.QuickCheck.Classes (eqLaws)
1321
import Test.QuickCheck.Instances ()
1422
import Test.Tasty
23+
import Test.Tasty.QuickCheck (testProperty)
1524
import Test.Util.FS
1625
import Test.Util.QC
1726

1827
tests :: TestTree
1928
tests = testGroup "Test.FS" [
20-
testClassLaws "Stream" $
29+
-- * Simulated file system properties
30+
testProperty "prop_numOpenHandles" prop_numOpenHandles
31+
, testProperty "prop_numDirEntries" prop_numDirEntries
32+
-- * Equality
33+
, testClassLaws "Stream" $
2134
eqLaws (Proxy @(Stream Int))
2235
, testClassLaws "Errors" $
2336
eqLaws (Proxy @Errors)
2437
]
2538

39+
{-------------------------------------------------------------------------------
40+
Simulated file system properties
41+
-------------------------------------------------------------------------------}
42+
43+
newtype Path = Path FsPath
44+
deriving stock (Show, Eq)
45+
46+
newtype UniqueList a = UniqueList [a]
47+
deriving stock Show
48+
49+
instance (Arbitrary a, Eq a) => Arbitrary (UniqueList a) where
50+
arbitrary = do
51+
xs <- arbitrary
52+
pure (UniqueList (List.nub xs))
53+
shrink (UniqueList []) = []
54+
shrink (UniqueList xs) = UniqueList . List.nub <$> shrink xs
55+
56+
instance Arbitrary Path where
57+
arbitrary = Path . mkFsPath . (:[]) <$> ((:) <$> genChar <*> listOf genChar)
58+
where
59+
genChar = elements (['A'..'Z'] ++ ['a'..'z'])
60+
shrink (Path p) = case fsPathToList p of
61+
[] -> []
62+
t:_ -> [
63+
Path p'
64+
| t' <- shrink t
65+
, let t'' = Text.filter (\c -> isAsciiUpper c || isAsciiLower c) t'
66+
, not (Text.null t'')
67+
, let p' = fsPathFromList [t']
68+
]
69+
70+
-- | Sanity check for 'propNoOpenHandles' and 'propNumOpenHandles'
71+
prop_numOpenHandles :: UniqueList Path -> Property
72+
prop_numOpenHandles (UniqueList paths) = runSimOrThrow $
73+
withSimHasFS propTrivial MockFS.empty $ \hfs fsVar -> do
74+
-- No open handles initially
75+
fs <- atomically $ readTMVar fsVar
76+
let prop = propNoOpenHandles fs
77+
78+
-- Open n handles
79+
hs <- forM paths $ \(Path p) -> hOpen hfs p (WriteMode MustBeNew)
80+
81+
-- Now there should be precisely n open handles
82+
fs' <- atomically $ readTMVar fsVar
83+
let prop' = propNumOpenHandles n fs'
84+
85+
-- Close all previously opened handles
86+
forM_ hs $ hClose hfs
87+
88+
-- No open handles again
89+
fs'' <- atomically $ readTMVar fsVar
90+
let prop'' = propNoOpenHandles fs''
91+
92+
pure (prop .&&. prop' .&&. prop'')
93+
where
94+
n = length paths
95+
96+
-- | Sanity check for 'propNoDirEntries' and 'propNumDirEntries'
97+
prop_numDirEntries :: Path -> InfiniteList Bool -> UniqueList Path -> Property
98+
prop_numDirEntries (Path dir) isFiles (UniqueList paths) = runSimOrThrow $
99+
withSimHasFS propTrivial MockFS.empty $ \hfs fsVar -> do
100+
createDirectoryIfMissing hfs False dir
101+
102+
-- No entries initially
103+
fs <- atomically $ readTMVar fsVar
104+
let prop = propNoDirEntries dir fs
105+
106+
-- Create n entries
107+
forM_ xs $ \(isFile, Path p) ->
108+
if isFile
109+
then withFile hfs (dir </> p) (WriteMode MustBeNew) $ \_ -> pure ()
110+
else createDirectory hfs (dir </> p)
111+
112+
-- Now there should be precisely n entries
113+
fs' <- atomically $ readTMVar fsVar
114+
let prop' = propNumDirEntries dir n fs'
115+
116+
-- Remove n entries
117+
forM_ xs $ \(isFile, Path p) ->
118+
if isFile
119+
then removeFile hfs (dir </> p)
120+
else removeDirectoryRecursive hfs (dir </> p)
121+
122+
-- No entries again
123+
fs'' <- atomically $ readTMVar fsVar
124+
let prop'' = propNoDirEntries dir fs''
125+
126+
pure (prop .&&. prop' .&&. prop'')
127+
where
128+
n = length paths
129+
xs = zip (getInfiniteList isFiles) paths
130+
131+
{-------------------------------------------------------------------------------
132+
Equality
133+
-------------------------------------------------------------------------------}
134+
26135
-- | This is not a fully lawful instance, because it uses 'approximateEqStream'.
27136
instance Eq a => Eq (Stream a) where
28137
(==) = approximateEqStream

0 commit comments

Comments
 (0)