WIP: test for simulated file locks

blockio-api/test/Main.hs

@@ -41,7 +41,7 @@ main :: IO ()
 main = defaultMain tests
 
 tests :: TestTree
-tests = testGroup "fs-api-blockio" [
+tests = testGroup "blockio-api" [
       testCase "example_initClose" example_initClose
     , testCase "example_closeIsIdempotent" example_closeIsIdempotent
     , testProperty "prop_readWrite" prop_readWrite

blockio-sim/test/Main.hs

@@ -0,0 +1,81 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Main (main) where
+
+import           Data.Maybe
+import qualified System.FS.API as FS
+import           System.FS.BlockIO.API
+import           System.FS.BlockIO.Sim (simHasBlockIO')
+import qualified System.FS.Sim.MockFS as MockFS
+import           Test.QuickCheck
+import           Test.Tasty
+import           Test.Tasty.QuickCheck (testProperty)
+
+main :: IO ()
+main = defaultMain tests
+
+tests :: TestTree
+tests = testGroup "blockio-sim" [
+      testProperty "prop_tryLockFileTwice" prop_tryLockFileTwice
+    ]
+
+{-------------------------------------------------------------------------------
+  File locks
+-------------------------------------------------------------------------------}
+
+instance Arbitrary LockMode where
+  arbitrary = elements [SharedLock, ExclusiveLock]
+  shrink SharedLock    = []
+  shrink ExclusiveLock = []
+
+-- TODO: belongs in base
+deriving stock instance Show LockMode
+
+prop_tryLockFileTwice :: LockMode -> LockMode -> Property
+prop_tryLockFileTwice mode1 mode2 = ioProperty $ do
+    (_hfs, hbio) <- simHasBlockIO' MockFS.empty
+    let path = FS.mkFsPath ["lockfile"]
+
+    let expected@(x1, y1) = case (mode1, mode2) of
+          (ExclusiveLock, ExclusiveLock) -> (True, False)
+          (ExclusiveLock, SharedLock   ) -> (True, False)
+          (SharedLock   , ExclusiveLock) -> (True, False)
+          (SharedLock   , SharedLock   ) -> (True, True)
+
+    x2 <- tryLockFile hbio path mode1
+    y2 <- tryLockFile hbio path mode2
+
+    let addLabel = tabulate "modes" [show (mode1, mode2)]
+
+    let addCounterexample = counterexample
+                              ( "Expecting " <> showExpected expected <>
+                                " but got "  <> showReal (x2, y2) )
+
+    pure $ addCounterexample $ addLabel $
+      cmpBoolMaybeConstructor x1 x2 .&&. cmpBoolMaybeConstructor y1 y2
+
+cmpBoolMaybeConstructor :: Bool -> Maybe a -> Bool
+cmpBoolMaybeConstructor True  (Just _) = True
+cmpBoolMaybeConstructor False Nothing  = True
+cmpBoolMaybeConstructor _     _        = False
+
+showExpected :: (Bool, Bool) -> String
+showExpected (x, y) =
+    "("  <> showMaybeConstructor (if x then Just () else Nothing) <>
+    ", " <> showMaybeConstructor (if y then Just () else Nothing) <>
+    ")"
+
+showBoolAsMaybeConstructor :: Bool -> String
+showBoolAsMaybeConstructor b
+  | b         = "Just _"
+  | otherwise = "Nothing"
+
+showReal :: (Maybe a, Maybe a) -> String
+showReal (x, y) =
+    "("  <> showMaybeConstructor x <>
+    ", " <> showMaybeConstructor y <>
+    ")"
+
+showMaybeConstructor :: Maybe a -> String
+showMaybeConstructor Nothing  = "Nothing"
+showMaybeConstructor (Just _) = "Just _"

lsm-tree.cabal

@@ -779,6 +779,22 @@ library blockio-sim
     , lsm-tree:blockio-api
     , primitive              ^>=0.9
 
+test-suite blockio-sim-test
+  import:         language, warnings
+  type:           exitcode-stdio-1.0
+  hs-source-dirs: blockio-sim/test
+  main-is:        Main.hs
+  build-depends:
+    , base                  >=4.14 && <4.21
+    , bytestring
+    , fs-api
+    , fs-sim
+    , lsm-tree:blockio-api
+    , lsm-tree:blockio-sim
+    , QuickCheck
+    , tasty
+    , tasty-quickcheck
+
 library fcntl-nocache
   import:         language, warnings
   visibility:     private