Skip to content

Simulate file locks in blockio-sim #415

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 2 commits into from
Oct 7, 2024
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion blockio-api/test/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
91 changes: 80 additions & 11 deletions blockio-sim/src/System/FS/BlockIO/Sim.hs
Original file line number Diff line number Diff line change
Expand Up @@ -10,18 +10,24 @@ 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 qualified Data.ByteString.Char8 as BS
import System.FS.API as API
import qualified System.FS.API.Lazy as API
import qualified System.FS.API.Strict 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
Expand All @@ -30,11 +36,74 @@ 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. Writers can not
-- coexist with readers.
--
-- 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.
--
-- Warning: regular file operations on the "locked" file, like 'hOpen' or
-- 'removeFile', will still work. 'simTryLockFile' only defines how multiple
-- lock acquisitions on the same file interact, not how lock acquisition
-- interacts with other file operations.
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The same is true for the normal API too.

--
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 <- BS.toStrict <$> API.hGetAllAt hfs h 0
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.hPutAllStrict 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
Expand All @@ -43,7 +112,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
Expand All @@ -52,7 +121,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)
Expand All @@ -62,7 +131,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)
Expand Down
90 changes: 90 additions & 0 deletions blockio-sim/test/Main.hs
Original file line number Diff line number Diff line change
@@ -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 _"
17 changes: 17 additions & 0 deletions lsm-tree.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
, io-classes:strict-stm
, lsm-tree:blockio-api
, lsm-tree:blockio-sim
, QuickCheck
, tasty
, tasty-quickcheck

library fcntl-nocache
import: language, warnings
visibility: private
Expand Down
Loading
Loading