lock pools to work around non-concurrency/composition safety of POSIX fcntl
This commit is contained in:
parent
af6b313456
commit
6915b71c57
8 changed files with 327 additions and 12 deletions
|
@ -140,7 +140,7 @@ checkTransfer t = do
|
|||
let lck = transferLockFile tfile
|
||||
v <- getLockStatus lck
|
||||
case v of
|
||||
Just (pid, _) -> catchDefaultIO Nothing $
|
||||
Just pid -> catchDefaultIO Nothing $
|
||||
readTransferInfoFile (Just pid) tfile
|
||||
Nothing -> do
|
||||
-- Take a non-blocking lock while deleting
|
||||
|
|
|
@ -12,7 +12,6 @@ module Utility.LockFile.Posix (
|
|||
tryLockExclusive,
|
||||
createLockFile,
|
||||
openExistingLockFile,
|
||||
isLocked,
|
||||
checkLocked,
|
||||
getLockStatus,
|
||||
dropLock,
|
||||
|
@ -73,28 +72,23 @@ openLockFile filemode lockfile = do
|
|||
setFdOption l CloseOnExec True
|
||||
return l
|
||||
|
||||
-- Check if a file is locked, either exclusively, or with shared lock.
|
||||
-- When the file doesn't exist, it's considered not locked.
|
||||
isLocked :: LockFile -> IO Bool
|
||||
isLocked = fromMaybe False <$$> checkLocked
|
||||
|
||||
-- Returns Nothing when the file doesn't exist, for cases where
|
||||
-- that is different from it not being locked.
|
||||
checkLocked :: LockFile -> IO (Maybe Bool)
|
||||
checkLocked = maybe Nothing (Just . isJust) <$$> getLockStatus'
|
||||
|
||||
getLockStatus :: LockFile -> IO (Maybe (ProcessID, FileLock))
|
||||
getLockStatus :: LockFile -> IO (Maybe ProcessID)
|
||||
getLockStatus = fromMaybe Nothing <$$> getLockStatus'
|
||||
|
||||
getLockStatus' :: LockFile -> IO (Maybe (Maybe (ProcessID, FileLock)))
|
||||
getLockStatus' :: LockFile -> IO (Maybe (Maybe ProcessID))
|
||||
getLockStatus' lockfile = go =<< catchMaybeIO open
|
||||
where
|
||||
open = openFd lockfile ReadOnly Nothing defaultFileFlags
|
||||
go Nothing = return Nothing
|
||||
go (Just h) = do
|
||||
ret <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
|
||||
v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
|
||||
closeFd h
|
||||
return (Just ret)
|
||||
return (Just (fmap fst v))
|
||||
|
||||
dropLock :: LockHandle -> IO ()
|
||||
dropLock (LockHandle fd) = closeFd fd
|
||||
|
|
|
@ -22,7 +22,7 @@ type LockFile = FilePath
|
|||
type LockHandle = HANDLE
|
||||
|
||||
{- Tries to lock a file with a shared lock, which allows other processes to
|
||||
- also lock it shared. Fails is the file is exclusively locked. -}
|
||||
- also lock it shared. Fails if the file is exclusively locked. -}
|
||||
lockShared :: LockFile -> IO (Maybe LockHandle)
|
||||
lockShared = openLock fILE_SHARE_READ
|
||||
|
||||
|
|
36
Utility/LockPool.hs
Normal file
36
Utility/LockPool.hs
Normal file
|
@ -0,0 +1,36 @@
|
|||
{- Lock pool.
|
||||
-
|
||||
- This avoids a problem with unix fcntl locks: They are not composition-safe.
|
||||
-
|
||||
- For example, if one thread is holding a lock, and another thread opens the
|
||||
- lock file (to attempt to take or check the lock), and then closes it,
|
||||
- the lock will be released, despite the first thread still having the
|
||||
- lockfile open.
|
||||
-
|
||||
- Or, if a process is already holding an exclusive lock on a file, an
|
||||
- re-opens it and tries to take another exclusive lock, it won't block
|
||||
- on the first lock.
|
||||
-
|
||||
- To avoid these problems, this implements a lock pool. This keeps track
|
||||
- of which lock files are being used by the process, and avoids
|
||||
- re-opening them. Instead, if a lockfile is in use by the current
|
||||
- process, STM is used to handle further concurrent uses of that lock
|
||||
- file.
|
||||
-
|
||||
- Note that, like Utility.LockFile, this does *not* attempt to be a
|
||||
- portability shim; the native locking of the OS is used.
|
||||
-
|
||||
- Copyright 2015 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- License: BSD-2-clause
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Utility.LockPool (module X) where
|
||||
|
||||
#ifndef mingw32_HOST_OS
|
||||
import Utility.LockPool.Posix as X
|
||||
#else
|
||||
import Utility.LockPool.Windows as X
|
||||
#endif
|
52
Utility/LockPool/LockHandle.hs
Normal file
52
Utility/LockPool/LockHandle.hs
Normal file
|
@ -0,0 +1,52 @@
|
|||
{- Handles for lock pools.
|
||||
-
|
||||
- Copyright 2015 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- License: BSD-2-clause
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Utility.LockPool.LockHandle where
|
||||
|
||||
import qualified Utility.LockPool.STM as P
|
||||
#ifndef mingw32_HOST_OS
|
||||
import qualified Utility.LockFile.Posix as F
|
||||
#else
|
||||
import qualified Utility.LockFile.Windows as F
|
||||
#endif
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception
|
||||
|
||||
data LockHandle = LockHandle P.LockHandle F.LockHandle
|
||||
|
||||
dropLock :: LockHandle -> IO ()
|
||||
dropLock (LockHandle ph fh) = P.releaseLock ph (F.dropLock fh)
|
||||
|
||||
-- Take a lock, by first updating the lock pool, and then taking the file
|
||||
-- lock. If taking the file lock fails for any reason, take care to
|
||||
-- release the lock in the lock pool.
|
||||
makeLockHandle :: STM P.LockHandle -> IO F.LockHandle -> IO LockHandle
|
||||
makeLockHandle pa fa = bracketOnError setup cleanup go
|
||||
where
|
||||
setup = atomically pa
|
||||
cleanup ph = P.releaseLock ph (return ())
|
||||
go ph = do
|
||||
fh <- fa
|
||||
return $ LockHandle ph fh
|
||||
|
||||
tryMakeLockHandle :: STM (Maybe P.LockHandle) -> IO (Maybe F.LockHandle) -> IO (Maybe LockHandle)
|
||||
tryMakeLockHandle pa fa = bracketOnError setup cleanup go
|
||||
where
|
||||
setup = atomically pa
|
||||
cleanup Nothing = return ()
|
||||
cleanup (Just ph) = P.releaseLock ph (return ())
|
||||
go Nothing = return Nothing
|
||||
go (Just ph) = do
|
||||
mfh <- fa
|
||||
case mfh of
|
||||
Nothing -> do
|
||||
cleanup (Just ph)
|
||||
return Nothing
|
||||
Just fh -> return $ Just $ LockHandle ph fh
|
59
Utility/LockPool/Posix.hs
Normal file
59
Utility/LockPool/Posix.hs
Normal file
|
@ -0,0 +1,59 @@
|
|||
{- Posix lock files, using lock pools.
|
||||
-
|
||||
- Copyright 2015 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- License: BSD-2-clause
|
||||
-}
|
||||
|
||||
module Utility.LockPool.Posix (
|
||||
LockHandle,
|
||||
lockShared,
|
||||
lockExclusive,
|
||||
tryLockExclusive,
|
||||
checkLocked,
|
||||
getLockStatus,
|
||||
dropLock,
|
||||
checkSaneLock,
|
||||
) where
|
||||
|
||||
import qualified Utility.LockFile.Posix as F
|
||||
import qualified Utility.LockPool.STM as P
|
||||
import Utility.LockPool.STM (LockPool, LockFile, LockMode(..))
|
||||
import Utility.LockPool.LockHandle
|
||||
import Utility.Monad
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import System.IO
|
||||
import System.Posix
|
||||
import Data.Maybe
|
||||
import Control.Applicative
|
||||
import Prelude
|
||||
|
||||
-- Takes a shared lock, blocking until the lock is available.
|
||||
lockShared :: Maybe FileMode -> LockFile -> IO LockHandle
|
||||
lockShared mode file = makeLockHandle
|
||||
(P.waitTakeLock P.lockPool file LockShared)
|
||||
(F.lockShared mode file)
|
||||
|
||||
lockExclusive :: Maybe FileMode -> LockFile -> IO LockHandle
|
||||
lockExclusive mode file = makeLockHandle
|
||||
(P.waitTakeLock P.lockPool file LockExclusive)
|
||||
(F.lockExclusive mode file)
|
||||
|
||||
tryLockExclusive :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
|
||||
tryLockExclusive mode file = tryMakeLockHandle
|
||||
(P.tryTakeLock P.lockPool file LockExclusive)
|
||||
(F.tryLockExclusive mode file)
|
||||
|
||||
-- Returns Nothing when the file doesn't exist, for cases where
|
||||
-- that is different from it not being locked.
|
||||
checkLocked :: LockFile -> IO (Maybe Bool)
|
||||
checkLocked file = P.getLockStatus P.lockPool file (pure True)
|
||||
(F.checkLocked file)
|
||||
|
||||
getLockStatus :: LockFile -> IO (Maybe ProcessID)
|
||||
getLockStatus file = P.getLockStatus P.lockPool file getProcessID
|
||||
(F.getLockStatus file)
|
||||
|
||||
checkSaneLock :: LockFile -> LockHandle -> IO Bool
|
||||
checkSaneLock lockfile (LockHandle _ fh) = F.checkSaneLock lockfile fh
|
125
Utility/LockPool/STM.hs
Normal file
125
Utility/LockPool/STM.hs
Normal file
|
@ -0,0 +1,125 @@
|
|||
{- STM implementation of lock pools.
|
||||
-
|
||||
- Copyright 2015 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- License: BSD-2-clause
|
||||
-}
|
||||
|
||||
module Utility.LockPool.STM (
|
||||
LockPool,
|
||||
lockPool,
|
||||
LockFile,
|
||||
LockMode(..),
|
||||
LockHandle,
|
||||
waitTakeLock,
|
||||
tryTakeLock,
|
||||
getLockStatus,
|
||||
releaseLock,
|
||||
) where
|
||||
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.STM
|
||||
import Control.Applicative
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Data.Maybe
|
||||
|
||||
type LockFile = FilePath
|
||||
|
||||
data LockMode = LockExclusive | LockShared
|
||||
deriving (Eq)
|
||||
|
||||
-- This TMVar is full when the handle is open, and is emptied when it's
|
||||
-- closed.
|
||||
type LockHandle = TMVar (LockPool, LockFile)
|
||||
|
||||
type LockCount = Integer
|
||||
|
||||
data LockStatus = LockStatus LockMode LockCount
|
||||
|
||||
-- This TMVar is normally kept full.
|
||||
type LockPool = TMVar (M.Map LockFile LockStatus)
|
||||
|
||||
-- A shared global variable for the lockPool. Avoids callers needing to
|
||||
-- maintain state for this implementation detail.
|
||||
lockPool :: LockPool
|
||||
lockPool = unsafePerformIO (newTMVarIO M.empty)
|
||||
{-# NOINLINE lockPool #-}
|
||||
|
||||
-- Updates the LockPool, blocking as necessary if another thread is holding
|
||||
-- a conflicting lock.
|
||||
--
|
||||
-- Note that when a shared lock is held, an exclusive lock will block.
|
||||
-- While that blocking is happening, another call to this function to take
|
||||
-- the same shared lock should not be blocked on the exclusive lock.
|
||||
-- Keeping the whole Map in a TMVar accomplishes this, at the expense of
|
||||
-- sometimes retrying after unrelated changes in the map.
|
||||
waitTakeLock :: LockPool -> LockFile -> LockMode -> STM LockHandle
|
||||
waitTakeLock pool file mode = do
|
||||
m <- takeTMVar pool
|
||||
v <- case M.lookup file m of
|
||||
Just (LockStatus mode' n)
|
||||
| mode == LockShared && mode' == LockShared ->
|
||||
return $ LockStatus mode (succ n)
|
||||
| n > 0 -> retry -- wait for lock
|
||||
_ -> return $ LockStatus mode 1
|
||||
putTMVar pool (M.insert file v m)
|
||||
newTMVar (pool, file)
|
||||
|
||||
-- Avoids blocking if another thread is holding a conflicting lock.
|
||||
tryTakeLock :: LockPool -> LockFile -> LockMode -> STM (Maybe LockHandle)
|
||||
tryTakeLock pool file mode =
|
||||
(Just <$> waitTakeLock pool file mode)
|
||||
`orElse`
|
||||
return Nothing
|
||||
|
||||
-- Checks if a lock is being held. If it's held by the current process,
|
||||
-- runs the getdefault action; otherwise runs the checker action.
|
||||
--
|
||||
-- Note that the lock pool is left empty while the checker action is run.
|
||||
-- This allows checker actions that open/close files, and so would be in
|
||||
-- danger of conflicting with existing locks. Since the lock pool is
|
||||
-- kept empty, anything that attempts to take a lock will block,
|
||||
-- avoiding that race.
|
||||
getLockStatus :: LockPool -> LockFile -> IO v -> IO (Maybe v) -> IO (Maybe v)
|
||||
getLockStatus pool file getdefault checker = do
|
||||
v <- atomically $ do
|
||||
m <- takeTMVar pool
|
||||
let threadlocked = case M.lookup file m of
|
||||
Just (LockStatus _ n)
|
||||
| n > 0 -> True
|
||||
_ -> False
|
||||
if threadlocked
|
||||
then do
|
||||
putTMVar pool m
|
||||
return Nothing
|
||||
else return $ Just $ atomically $ putTMVar pool m
|
||||
case v of
|
||||
Nothing -> Just <$> getdefault
|
||||
Just restore -> bracket_ (return ()) restore checker
|
||||
|
||||
-- Only runs action to close underlying lock file when this is the last
|
||||
-- user of the lock, and when the handle has not already been closed.
|
||||
--
|
||||
-- Note that the lock pool is left empty while the closelockfile action
|
||||
-- is run, to avoid race with another thread trying to open the same lock
|
||||
-- file.
|
||||
releaseLock :: LockHandle -> IO () -> IO ()
|
||||
releaseLock h closelockfile = go =<< atomically (tryTakeTMVar h)
|
||||
where
|
||||
go (Just (pool, file)) = do
|
||||
(m, unused) <- atomically $ do
|
||||
m <- takeTMVar pool
|
||||
return $ case M.lookup file m of
|
||||
Just (LockStatus mode n)
|
||||
| n == 1 -> (M.delete file m, True)
|
||||
| otherwise ->
|
||||
(M.insert file (LockStatus mode (pred n)) m, False)
|
||||
Nothing -> (m, True)
|
||||
when unused
|
||||
closelockfile
|
||||
atomically $ putTMVar pool m
|
||||
-- The LockHandle was already closed.
|
||||
go Nothing = return ()
|
49
Utility/LockPool/Windows.hs
Normal file
49
Utility/LockPool/Windows.hs
Normal file
|
@ -0,0 +1,49 @@
|
|||
{- Windows lock files, using lock pools.
|
||||
-
|
||||
- Copyright 2015 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- License: BSD-2-clause
|
||||
-}
|
||||
|
||||
module Utility.LockPool.Windows (
|
||||
LockHandle,
|
||||
lockShared,
|
||||
lockExclusive,
|
||||
dropLock,
|
||||
waitToLock,
|
||||
) where
|
||||
|
||||
import qualified Utility.LockFile.Windows as F
|
||||
import qualified Utility.LockPool.STM as P
|
||||
import Utility.LockPool.LockHandle
|
||||
import Utility.LockPool.STM (LockPool, LockFile, LockMode(..))
|
||||
import Utility.Monad
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import System.IO
|
||||
import Data.Maybe
|
||||
import Control.Applicative
|
||||
import Prelude
|
||||
|
||||
{- Tries to lock a file with a shared lock, which allows other processes to
|
||||
- also lock it shared. Fails if the file is exclusively locked. -}
|
||||
lockShared :: LockFile -> IO (Maybe LockHandle)
|
||||
lockShared file = tryMakeLockHandle
|
||||
(P.tryTakeLock P.lockPool file LockShared)
|
||||
(F.lockShared mode file)
|
||||
|
||||
{- Tries to take an exclusive lock on a file. Fails if another process has
|
||||
- a shared or exclusive lock.
|
||||
-
|
||||
- Note that exclusive locking also prevents the file from being opened for
|
||||
- read or write by any other process. So for advisory locking of a file's
|
||||
- content, a separate LockFile should be used. -}
|
||||
lockExclusive :: LockFile -> IO (Maybe LockHandle)
|
||||
lockExclusive file = tryMakeLockHandle
|
||||
(P.tryTakeLock P.lockPool file LockExclusive)
|
||||
(F.lockExclusive file)
|
||||
|
||||
{- If the initial lock fails, this is a BUSY wait, and does not
|
||||
- guarentee FIFO order of waiters. In other news, Windows is a POS. -}
|
||||
waitToLock :: IO (Maybe LockHandle) -> IO LockHandle
|
||||
waitToLock = F.waitToLock
|
Loading…
Reference in a new issue