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

8 files changed, 327 insertions, 12 deletions

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