Merge pull request #518 from IntersectMBO/jdral/fs-sim-utils

More `MockFS` properties for testing with `fs-sim`

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
       ]
     ]

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
         ]
     ]
 

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"

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