Simulate file locks in blockio-sim

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/src/System/FS/BlockIO/Sim.hs

@@ -6,22 +6,26 @@ module System.FS.BlockIO.Sim (
   , simErrorHasBlockIO'
   ) where
 
+import qualified Data.ByteString.Char8 as BS
 import           Control.Concurrent.Class.MonadMVar
 import           Control.Concurrent.Class.MonadSTM.Strict
 import           Control.Monad.Class.MonadThrow
 import           Control.Monad.Primitive (PrimMonad)
-import           System.FS.API
-import           System.FS.BlockIO.API (HasBlockIO (..))
+import           System.FS.API as API
+import           System.FS.BlockIO.API (HasBlockIO (..),
+                     LockFileHandle (..), LockMode (..))
 import           System.FS.BlockIO.Serial
+import           System.FS.CallStack (prettyCallStack)
 import           System.FS.Sim.Error
-import           System.FS.Sim.MockFS
+import           System.FS.Sim.MockFS hiding (hClose, hOpen)
 import           System.FS.Sim.STM
 
 fromHasFS ::
-     (MonadThrow m, MonadMVar m, PrimMonad m)
+     forall m. (MonadCatch m, MonadMVar m, PrimMonad m)
   => HasFS m HandleMock
   -> m (HasBlockIO m HandleMock)
-fromHasFS = serialHasBlockIO hSetNoCache hAdvise hAllocate tryLockFile
+fromHasFS hfs =
+    serialHasBlockIO hSetNoCache hAdvise hAllocate (simTryLockFile hfs) hfs
   where
     -- TODO: It should be possible for the implementations and simulation to
     -- throw an FsError when doing file I/O with misaligned byte arrays after
@@ -30,11 +34,68 @@ fromHasFS = serialHasBlockIO hSetNoCache hAdvise hAllocate tryLockFile
     hSetNoCache _h _b = pure ()
     hAdvise _ _ _ _ = pure ()
     hAllocate _ _ _ = pure ()
-    -- TODO: implement simulated locks.
-    tryLockFile _ _ = pure Nothing
+
+-- | Lock files are reader\/writer locks.
+--
+-- We implement this using the content of the lock file. The content is a
+-- counter, positive for readers and negaive (specifically -1) for writers.
+-- There can be any number of readers, but only one writer.
+--
+-- Warning: This implementation is not robust under concurrent use (because
+-- operations on files are not atomic) but should be ok for casual use. A
+-- proper implementation would need to be part of the underlying 'HasFs'
+-- implementations.
+--
+simTryLockFile :: forall m h.
+                  MonadThrow m
+               => HasFS m h
+               -> FsPath
+               -> LockMode
+               -> m (Maybe (LockFileHandle m))
+simTryLockFile hfs path lockmode =
+    API.withFile hfs path (ReadWriteMode AllowExisting) $ \h -> do
+      n <- readCount h
+      case lockmode of
+        SharedLock    | n >= 0 -> do writeCount h (n+1)
+                                     return (Just LockFileHandle { hUnlock })
+        ExclusiveLock | n == 0 -> do writeCount h (-1)
+                                     return (Just LockFileHandle { hUnlock })
+        _                      -> return Nothing
+  where
+    hUnlock =
+      API.withFile hfs path (ReadWriteMode AllowExisting) $ \h -> do
+        n <- readCount h
+        case lockmode of
+          SharedLock    | n >  0  -> writeCount h (n-1)
+          ExclusiveLock | n == -1 -> writeCount h 0
+          _                       -> throwIO countCorrupt
+
+    readCount :: Handle h -> m Int
+    readCount h = do
+      content <- API.hGetSome hfs h 10
+      case reads (BS.unpack content) of
+        _ | BS.null content -> pure 0
+        [(n, "")]           -> pure n
+        _                   -> throwIO countCorrupt
+
+    writeCount :: Handle h -> Int -> m ()
+    writeCount h n = do
+      API.hSeek hfs h AbsoluteSeek 0
+      _ <- API.hPutSome hfs h (BS.pack (show n))
+      return ()
+
+    countCorrupt =
+      FsError {
+        fsErrorType   = FsOther,
+        fsErrorPath   = fsToFsErrorPathUnmounted path,
+        fsErrorString = "lock file content corrupted",
+        fsErrorNo     = Nothing,
+        fsErrorStack  = prettyCallStack,
+        fsLimitation  = False
+      }
 
 simHasBlockIO ::
-     (MonadThrow m, MonadMVar m, PrimMonad m, MonadSTM m)
+     (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m)
   => StrictTMVar m MockFS
   -> m (HasFS m HandleMock, HasBlockIO m HandleMock)
 simHasBlockIO var = do
@@ -43,7 +104,7 @@ simHasBlockIO var = do
     pure (hfs, hbio)
 
 simHasBlockIO' ::
-     (MonadThrow m, MonadMVar m, PrimMonad m, MonadSTM m)
+     (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m)
   => MockFS
   -> m (HasFS m HandleMock, HasBlockIO m HandleMock)
 simHasBlockIO' mockFS = do
@@ -52,7 +113,7 @@ simHasBlockIO' mockFS = do
     pure (hfs, hbio)
 
 simErrorHasBlockIO ::
-     forall m. (MonadThrow m, MonadMVar m, PrimMonad m, MonadSTM m)
+     forall m. (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m)
   => StrictTMVar m MockFS
   -> StrictTVar m Errors
   -> m (HasFS m HandleMock, HasBlockIO m HandleMock)
@@ -62,7 +123,7 @@ simErrorHasBlockIO fsVar errorsVar = do
     pure (hfs, hbio)
 
 simErrorHasBlockIO' ::
-     (MonadThrow m, MonadMVar m, PrimMonad m, MonadSTM m)
+     (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m)
   => MockFS
   -> Errors
   -> m (HasFS m HandleMock, HasBlockIO m HandleMock)

blockio-sim/test/Main.hs

@@ -0,0 +1,90 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Main (main) where
+
+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)
+
+import           Control.Concurrent.Class.MonadSTM.Strict
+
+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
+    fsvar <- newTMVarIO MockFS.empty
+    (_hfs, hbio) <- simHasBlockIO fsvar
+    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)
+
+    before <- atomically (readTMVar fsvar)
+    x2 <- tryLockFile hbio path mode1
+    after1 <- atomically (readTMVar fsvar)
+    y2 <- tryLockFile hbio path mode2
+    after2 <- atomically (readTMVar fsvar)
+
+    let addLabel = tabulate "modes" [show (mode1, mode2)]
+
+    let addCounterexample = counterexample
+                              ( "Expecting: " <> showExpected expected <>
+                                "\nbut got:   " <> showReal (x2, y2) )
+                          . counterexample
+                              ( "FS before: " ++ show before ++ "\n"
+                            <>  "FS after1: " ++ show after1 ++ "\n"
+                            <>  "FS after2: " ++ show after2)
+
+    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) =
+    "("  <> showBoolAsMaybeConstructor x <>
+    ", " <> showBoolAsMaybeConstructor y <>
+    ")"
+
+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

@@ -772,13 +772,30 @@ library blockio-sim
   exposed-modules: System.FS.BlockIO.Sim
   build-depends:
     , base                   >=4.14 && <4.21
+    , bytestring
     , fs-api                 ^>=0.3
     , fs-sim                 ^>=0.3
     , io-classes             ^>=1.6 || ^>=1.7
     , io-classes:strict-stm
     , 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
+    , fs-api
+    , fs-sim
+    , lsm-tree:blockio-api
+    , lsm-tree:blockio-sim
+    , io-classes:strict-stm
+    , QuickCheck
+    , tasty
+    , tasty-quickcheck
+
 library fcntl-nocache
   import:         language, warnings
   visibility:     private