lock pools to work around non-concurrency/composition safety of POSIX fcntl

This commit is contained in:
Joey Hess 2015-05-18 14:16:49 -04:00
parent af6b313456
commit 6915b71c57
8 changed files with 327 additions and 12 deletions

View file

@ -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

View file

@ -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

View file

@ -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
View 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

View 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
View 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
View 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 ()

View 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