fine-grained locking when annex.pidlock is enabled

This locking has been missing from the beginning of annex.pidlock.
It used to be possble, when two threads are doing conflicting things,
for both to run at the same time despite using locking. Seems likely
that nothing actually had a problem, but it was possible, and this
eliminates that possible source of failure.

Sponsored-by: Dartmouth College's Datalad project
This commit is contained in:
Joey Hess 2021-12-03 17:20:21 -04:00
parent a5fcc03595
commit e5ca67ea1c
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
6 changed files with 121 additions and 61 deletions

View file

@ -8,7 +8,7 @@
{-# LANGUAGE CPP #-}
module Utility.LockPool.LockHandle (
LockHandle,
LockHandle(..),
FileLockOps(..),
dropLock,
#ifndef mingw32_HOST_OS
@ -86,4 +86,3 @@ mkLockHandle :: P.LockHandle -> FileLockOps -> IO LockHandle
mkLockHandle ph fo = do
atomically $ P.registerCloseLockFile ph (fDropLock fo)
return $ LockHandle ph fo

View file

@ -10,6 +10,7 @@ module Utility.LockPool.PidLock (
LockHandle,
waitLock,
tryLock,
tryLock',
checkLocked,
getLockStatus,
LockStatus(..),
@ -34,34 +35,72 @@ import Control.Monad.IO.Class
import Control.Applicative
import Prelude
-- Takes a pid lock, blocking until the lock is available or the timeout.
-- Does locking using a pid lock, blocking until the lock is available
-- or the timeout.
--
-- There are two levels of locks. A STM lock is used to handle
-- fine-grained locking amoung threads, locking a specific lockfile,
-- but only in memory. The pid lock handles locking between processes.
--
-- The Seconds is how long to delay if the pid lock is held by another
-- process.
waitLock
:: (MonadIO m, MonadMask m)
=> Seconds
-> LockFile
=> LockFile
-> LockMode
-> Seconds
-> F.PidLockFile
-> (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 $
waitLock stmlockfile lockmode timeout pidlockfile displaymessage = do
sl@(LockHandle ph _) <- takestmlock
pl <- takepidlock
-- When the STM lock gets dropped, also drop the pid lock.
liftIO $ atomically $
P.registerPostReleaseLock ph (dropLock pl)
return sl
where
takestmlock = makeLockHandle P.lockPool stmlockfile
(\p f -> P.waitTakeLock p f lockmode)
(\_ _ -> pure stmonlyflo)
takepidlock = makeLockHandle P.lockPool pidlockfile
-- LockShared because multiple threads can share the pid lock;
-- it remains locked until all threads using it drop
-- their locks.
(\p f -> P.waitTakeLock p f LockShared)
(\f (P.FirstLock firstlock firstlocksem) -> mkflo
<$> 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
tryLock :: LockFile -> LockMode -> F.PidLockFile -> IO (Maybe LockHandle)
tryLock stmlockfile lockmode pidlockfile = takestmlock >>= \case
Just (sl@(LockHandle ph _)) -> tryLock' pidlockfile >>= \case
Just pl -> do
liftIO $ atomically $
P.registerPostReleaseLock ph (dropLock pl)
return (Just sl)
Nothing -> do
dropLock sl
return Nothing
Nothing -> return Nothing
where
takestmlock = tryMakeLockHandle P.lockPool stmlockfile
(\p f -> P.tryTakeLock p f lockmode)
(\_ _ -> pure (Just stmonlyflo))
tryLock' :: F.PidLockFile -> IO (Maybe LockHandle)
tryLock' pidlockfile = tryMakeLockHandle P.lockPool pidlockfile
(\p f -> P.tryTakeLock p f LockShared)
(\f (P.FirstLock firstlock firstlocksem) -> fmap mk
(\f (P.FirstLock firstlock firstlocksem) -> fmap mkflo
<$> if firstlock
then do
lh <- F.tryLock f
@ -85,8 +124,14 @@ getLockStatus file = P.getLockStatus P.lockPool file
(StatusLockedBy <$> getProcessID)
(F.getLockStatus file)
mk :: F.LockHandle -> FileLockOps
mk h = FileLockOps
mkflo :: F.LockHandle -> FileLockOps
mkflo h = FileLockOps
{ fDropLock = F.dropLock h
, fCheckSaneLock = \f -> F.checkSaneLock f h
}
stmonlyflo :: FileLockOps
stmonlyflo = FileLockOps
{ fDropLock = return ()
, fCheckSaneLock = const (return True)
}

View file

@ -19,6 +19,7 @@ module Utility.LockPool.STM (
releaseLock,
CloseLockFile,
registerCloseLockFile,
registerPostReleaseLock,
) where
import Utility.Monad
@ -37,7 +38,7 @@ data LockMode = LockExclusive | LockShared
-- This TMVar is full when the handle is open, and is emptied when it's
-- closed.
type LockHandle = TMVar (LockPool, LockFile, CloseLockFile)
type LockHandle = TMVar (LockPool, LockFile, CloseLockFile, PostReleaseLock)
-- When a shared lock is taken, this will only be true for the first
-- process, not subsequent processes. The first process should
@ -54,8 +55,12 @@ type LockCount = Integer
data LockStatus = LockStatus LockMode LockCount FirstLockSem
-- Action that closes the underlying lock file.
type CloseLockFile = IO ()
-- Action that is run after the LockHandle is released.
type PostReleaseLock = IO ()
-- This TMVar is normally kept full.
type LockPool = TMVar (M.Map LockFile LockStatus)
@ -82,7 +87,7 @@ tryTakeLock pool file mode = do
m <- takeTMVar pool
let success firstlock v = do
putTMVar pool (M.insert file v m)
tmv <- newTMVar (pool, file, noop)
tmv <- newTMVar (pool, file, noop, noop)
return (Just (tmv, firstlock))
case M.lookup file m of
Just (LockStatus mode' n firstlocksem)
@ -96,14 +101,22 @@ tryTakeLock pool file mode = do
return Nothing
_ -> do
firstlocksem <- newEmptyTMVar
success (FirstLock True firstlocksem) $ LockStatus mode 1 firstlocksem
success (FirstLock True firstlocksem) $
LockStatus mode 1 firstlocksem
-- Call after waitTakeLock or tryTakeLock, to register a CloseLockFile
-- action to run when releasing the lock.
registerCloseLockFile :: LockHandle -> CloseLockFile -> STM ()
registerCloseLockFile h closelockfile = do
(p, f, c) <- takeTMVar h
putTMVar h (p, f, c >> closelockfile)
(p, f, c, r) <- takeTMVar h
putTMVar h (p, f, c >> closelockfile, r)
-- Call after waitTakeLock or tryTakeLock, to register a PostReleaseLock
-- action to run after releasing the lock.
registerPostReleaseLock :: LockHandle -> PostReleaseLock -> STM ()
registerPostReleaseLock h postreleaselock = do
(p, f, c, r) <- takeTMVar h
putTMVar h (p, f, c, r >> postreleaselock)
-- Checks if a lock is being held. If it's held by the current process,
-- runs the getdefault action; otherwise runs the checker action.
@ -134,11 +147,12 @@ getLockStatus pool file getdefault checker = do
--
-- 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.
-- file. However, the pool is full again when the PostReleaseLock action
-- runs.
releaseLock :: LockHandle -> IO ()
releaseLock h = go =<< atomically (tryTakeTMVar h)
where
go (Just (pool, file, closelockfile)) = do
go (Just (pool, file, closelockfile, postreleaselock)) = do
(m, lastuser) <- atomically $ do
m <- takeTMVar pool
return $ case M.lookup file m of
@ -147,7 +161,8 @@ releaseLock h = go =<< atomically (tryTakeTMVar h)
| otherwise ->
(M.insert file (LockStatus mode (pred n) firstlocksem) m, False)
Nothing -> (m, True)
() <- when lastuser closelockfile
when lastuser closelockfile
atomically $ putTMVar pool m
when lastuser postreleaselock
-- The LockHandle was already closed.
go Nothing = return ()