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

4 files changed, 285 insertions, 0 deletions

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