ed0afbc36b
Seem there are several races that happen when 2 threads run PidLock.tryLock at the same time. One involves checkSaneLock of the side lock file, which may be deleted by another process that is dropping the lock, causing checkSaneLock to fail. And even with the deletion disabled, it can still fail, Probably due to linkToLock failing when a second thread overwrites the lock file. The same can happen when 2 processes do, but then one process just fails to take the lock, which is fine. But with 2 threads, some actions where failing even though the process as a whole had the pid lock held. Utility.LockPool.PidLock already maintains a STM lock, and since it uses LockShared, 2 threads can hold the pidlock at the same time, and when the first thread drops the lock, it will remain held by the second thread, and so the pid lock file should not get deleted until the last thread to hold it drops the lock. Which is the right behavior, and why a LockShared STM lock is used in the first place. The problem is that each time it takes the STM lock, it then also calls PidLock.tryLock. So that was getting called repeatedly and concurrently. Fixed by noticing when the shared lock is already held, and stop calling PidLock.tryLock again, just use the pid lock that already exists then. Also, LockFile.PidLock.tryLock was deleting the pid lock when it failed to take the lock, which was entirely wrong. It should only drop the side lock. Sponsored-by: Dartmouth College's Datalad project
92 lines
2.8 KiB
Haskell
92 lines
2.8 KiB
Haskell
{- Pid locks, using lock pools.
|
|
-
|
|
- Copyright 2015-2021 Joey Hess <id@joeyh.name>
|
|
-
|
|
- License: BSD-2-clause
|
|
-}
|
|
|
|
module Utility.LockPool.PidLock (
|
|
P.LockFile,
|
|
LockHandle,
|
|
waitLock,
|
|
tryLock,
|
|
checkLocked,
|
|
getLockStatus,
|
|
LockStatus(..),
|
|
dropLock,
|
|
checkSaneLock,
|
|
) where
|
|
|
|
import qualified Utility.LockFile.PidLock as F
|
|
import Utility.LockFile.LockStatus
|
|
import qualified Utility.LockPool.STM as P
|
|
import Utility.LockPool.STM (LockFile, LockMode(..))
|
|
import Utility.LockPool.LockHandle
|
|
import Utility.ThreadScheduler
|
|
|
|
import System.IO
|
|
import System.Posix
|
|
import Control.Concurrent.STM
|
|
import Data.Maybe
|
|
import Control.Monad
|
|
import Control.Monad.Catch
|
|
import Control.Monad.IO.Class
|
|
import Control.Applicative
|
|
import Prelude
|
|
|
|
-- Takes a pid lock, blocking until the lock is available or the timeout.
|
|
waitLock
|
|
:: (MonadIO m, MonadMask m)
|
|
=> Seconds
|
|
-> LockFile
|
|
-> (String -> m ())
|
|
-> m LockHandle
|
|
waitLock timeout file displaymessage = makeLockHandle P.lockPool file
|
|
-- LockShared for STM lock, because a pid lock can be the top-level
|
|
-- lock with various other STM level locks gated behind it.
|
|
(\p f -> P.waitTakeLock p f LockShared)
|
|
(\f (P.FirstLock firstlock firstlocksem) -> mk
|
|
<$> if firstlock
|
|
then F.waitLock timeout f displaymessage $
|
|
void . atomically . tryPutTMVar firstlocksem . P.FirstLockSemWaited
|
|
else liftIO (atomically $ readTMVar firstlocksem) >>= \case
|
|
P.FirstLockSemWaited True -> F.alreadyLocked f
|
|
P.FirstLockSemTried True -> F.alreadyLocked f
|
|
P.FirstLockSemWaited False -> F.waitedLock timeout f displaymessage
|
|
P.FirstLockSemTried False -> F.waitLock timeout f displaymessage $
|
|
void . atomically . tryPutTMVar firstlocksem . P.FirstLockSemWaited
|
|
)
|
|
|
|
-- Tries to take a pid lock, but does not block.
|
|
tryLock :: LockFile -> IO (Maybe LockHandle)
|
|
tryLock file = tryMakeLockHandle P.lockPool file
|
|
(\p f -> P.tryTakeLock p f LockShared)
|
|
(\f (P.FirstLock firstlock firstlocksem) -> fmap mk
|
|
<$> if firstlock
|
|
then do
|
|
lh <- F.tryLock f
|
|
void $ atomically $ tryPutTMVar firstlocksem
|
|
(P.FirstLockSemTried (isJust lh))
|
|
return lh
|
|
else liftIO (atomically $ readTMVar firstlocksem) >>= \case
|
|
P.FirstLockSemWaited True -> Just <$> F.alreadyLocked f
|
|
P.FirstLockSemTried True -> Just <$> F.alreadyLocked f
|
|
P.FirstLockSemWaited False -> return Nothing
|
|
P.FirstLockSemTried False -> return Nothing
|
|
)
|
|
|
|
checkLocked :: LockFile -> IO (Maybe Bool)
|
|
checkLocked file = P.getLockStatus P.lockPool file
|
|
(pure (Just True))
|
|
(F.checkLocked file)
|
|
|
|
getLockStatus :: LockFile -> IO LockStatus
|
|
getLockStatus file = P.getLockStatus P.lockPool file
|
|
(StatusLockedBy <$> getProcessID)
|
|
(F.getLockStatus file)
|
|
|
|
mk :: F.LockHandle -> FileLockOps
|
|
mk h = FileLockOps
|
|
{ fDropLock = F.dropLock h
|
|
, fCheckSaneLock = \f -> F.checkSaneLock f h
|
|
}
|