More MockFS properties

These are useful when testing with `fs-sim` errors, in which case we sould check
how many open handles and/or files exist when disk faults occur.

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

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
     ]

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

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)