From 94a3e606fb31150c969d63790ec1ef870f413cc1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 18 May 2015 14:16:49 -0400 Subject: lock pools to work around non-concurrency/composition safety of POSIX fcntl --- Logs/Transfer.hs | 2 +- Utility/LockFile/Posix.hs | 14 ++--- Utility/LockFile/Windows.hs | 2 +- Utility/LockPool.hs | 36 ++++++++++++ Utility/LockPool/LockHandle.hs | 52 +++++++++++++++++ Utility/LockPool/Posix.hs | 59 +++++++++++++++++++ Utility/LockPool/STM.hs | 125 +++++++++++++++++++++++++++++++++++++++++ Utility/LockPool/Windows.hs | 49 ++++++++++++++++ 8 files changed, 327 insertions(+), 12 deletions(-) create mode 100644 Utility/LockPool.hs create mode 100644 Utility/LockPool/LockHandle.hs create mode 100644 Utility/LockPool/Posix.hs create mode 100644 Utility/LockPool/STM.hs create mode 100644 Utility/LockPool/Windows.hs diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index 69b160331..244e9f375 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -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 diff --git a/Utility/LockFile/Posix.hs b/Utility/LockFile/Posix.hs index 9013bd32c..12275c48a 100644 --- a/Utility/LockFile/Posix.hs +++ b/Utility/LockFile/Posix.hs @@ -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 diff --git a/Utility/LockFile/Windows.hs b/Utility/LockFile/Windows.hs index 3c680d91c..fe57ff9eb 100644 --- a/Utility/LockFile/Windows.hs +++ b/Utility/LockFile/Windows.hs @@ -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 diff --git a/Utility/LockPool.hs b/Utility/LockPool.hs new file mode 100644 index 000000000..2a4ac5101 --- /dev/null +++ b/Utility/LockPool.hs @@ -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 + - + - 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 diff --git a/Utility/LockPool/LockHandle.hs b/Utility/LockPool/LockHandle.hs new file mode 100644 index 000000000..5582d7682 --- /dev/null +++ b/Utility/LockPool/LockHandle.hs @@ -0,0 +1,52 @@ +{- Handles for lock pools. + - + - Copyright 2015 Joey Hess + - + - 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 diff --git a/Utility/LockPool/Posix.hs b/Utility/LockPool/Posix.hs new file mode 100644 index 000000000..e460272f2 --- /dev/null +++ b/Utility/LockPool/Posix.hs @@ -0,0 +1,59 @@ +{- Posix lock files, using lock pools. + - + - Copyright 2015 Joey Hess + - + - 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 diff --git a/Utility/LockPool/STM.hs b/Utility/LockPool/STM.hs new file mode 100644 index 000000000..a60bbc7bf --- /dev/null +++ b/Utility/LockPool/STM.hs @@ -0,0 +1,125 @@ +{- STM implementation of lock pools. + - + - Copyright 2015 Joey Hess + - + - 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 () diff --git a/Utility/LockPool/Windows.hs b/Utility/LockPool/Windows.hs new file mode 100644 index 000000000..2537863e2 --- /dev/null +++ b/Utility/LockPool/Windows.hs @@ -0,0 +1,49 @@ +{- Windows lock files, using lock pools. + - + - Copyright 2015 Joey Hess + - + - 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 -- cgit v1.2.3