diff --git a/Annex/LockPool/PosixOrPid.hs b/Annex/LockPool/PosixOrPid.hs index 151a5b3193..91e34c25ec 100644 --- a/Annex/LockPool/PosixOrPid.hs +++ b/Annex/LockPool/PosixOrPid.hs @@ -1,7 +1,7 @@ {- Wraps Utility.LockPool, making pid locks be used when git-annex is so - configured. - - - Copyright 2015-2020 Joey Hess <id@joeyh.name> + - Copyright 2015-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} @@ -28,7 +28,7 @@ import qualified Utility.LockPool.PidLock as Pid import qualified Utility.LockPool.LockHandle as H import Utility.LockPool.LockHandle (LockHandle, dropLock) import Utility.LockFile.Posix (openLockFile) -import Utility.LockPool.STM (LockFile) +import Utility.LockPool.STM (LockFile, LockMode(..)) import Utility.LockFile.LockStatus import Config (pidLockFile) import Messages (warning) @@ -36,16 +36,16 @@ import Messages (warning) import System.Posix lockShared :: Maybe FileMode -> LockFile -> Annex LockHandle -lockShared m f = pidLock m f $ Posix.lockShared m f +lockShared m f = pidLock m f LockShared $ Posix.lockShared m f lockExclusive :: Maybe FileMode -> LockFile -> Annex LockHandle -lockExclusive m f = pidLock m f $ Posix.lockExclusive m f +lockExclusive m f = pidLock m f LockExclusive $ Posix.lockExclusive m f tryLockShared :: Maybe FileMode -> LockFile -> Annex (Maybe LockHandle) -tryLockShared m f = tryPidLock m f $ Posix.tryLockShared m f +tryLockShared m f = tryPidLock m f LockShared $ Posix.tryLockShared m f tryLockExclusive :: Maybe FileMode -> LockFile -> Annex (Maybe LockHandle) -tryLockExclusive m f = tryPidLock m f $ Posix.tryLockExclusive m f +tryLockExclusive m f = tryPidLock m f LockExclusive $ Posix.tryLockExclusive m f checkLocked :: LockFile -> Annex (Maybe Bool) checkLocked f = Posix.checkLocked f `pidLockCheck` checkpid @@ -67,22 +67,22 @@ pidLockCheck :: IO a -> (LockFile -> IO a) -> Annex a pidLockCheck posixcheck pidcheck = debugLocks $ liftIO . maybe posixcheck pidcheck =<< pidLockFile -pidLock :: Maybe FileMode -> LockFile -> IO LockHandle -> Annex LockHandle -pidLock m f posixlock = debugLocks $ go =<< pidLockFile +pidLock :: Maybe FileMode -> LockFile -> LockMode -> IO LockHandle -> Annex LockHandle +pidLock m f lockmode posixlock = debugLocks $ go =<< pidLockFile where go Nothing = liftIO posixlock go (Just pidlock) = do timeout <- annexPidLockTimeout <$> Annex.getGitConfig liftIO $ dummyPosixLock m f - Pid.waitLock timeout pidlock warning + Pid.waitLock f lockmode timeout pidlock warning -tryPidLock :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle) -> Annex (Maybe LockHandle) -tryPidLock m f posixlock = debugLocks $ liftIO . go =<< pidLockFile +tryPidLock :: Maybe FileMode -> LockFile -> LockMode -> IO (Maybe LockHandle) -> Annex (Maybe LockHandle) +tryPidLock m f lockmode posixlock = debugLocks $ liftIO . go =<< pidLockFile where go Nothing = posixlock go (Just pidlock) = do dummyPosixLock m f - Pid.tryLock pidlock + Pid.tryLock f lockmode pidlock -- The posix lock file is created even when using pid locks, in order to -- avoid complicating any code that might expect to be able to see that diff --git a/Annex/PidLock.hs b/Annex/PidLock.hs index c1bb91c9eb..74755a0e0b 100644 --- a/Annex/PidLock.hs +++ b/Annex/PidLock.hs @@ -1,6 +1,6 @@ {- Pid locking support. - - - Copyright 2014-2020 Joey Hess <id@joeyh.name> + - Copyright 2014-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} @@ -53,7 +53,7 @@ pidLockChildProcess cmd ps f a = do cleanup (go gonopidlock p pidlock) where - setup pidlock = PidP.tryLock pidlock + setup pidlock = PidP.tryLock' pidlock cleanup (Just h) = dropLock h cleanup Nothing = return () @@ -83,7 +83,7 @@ runsGitAnnexChildProcessViaGit a = pidLockFile >>= \case Nothing -> a Just pidlock -> bracket (setup pidlock) cleanup (go pidlock) where - setup pidlock = liftIO $ PidP.tryLock pidlock + setup pidlock = liftIO $ PidP.tryLock' pidlock cleanup (Just h) = liftIO $ dropLock h cleanup Nothing = return () @@ -112,7 +112,7 @@ runsGitAnnexChildProcessViaGit' r a = pidLockFile >>= \case Nothing -> liftIO $ a r Just pidlock -> liftIO $ bracket (setup pidlock) cleanup (go pidlock) where - setup pidlock = PidP.tryLock pidlock + setup pidlock = PidP.tryLock' pidlock cleanup (Just h) = dropLock h cleanup Nothing = return () diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs index 786b961572..83541b7b94 100644 --- a/Utility/LockFile/PidLock.hs +++ b/Utility/LockFile/PidLock.hs @@ -8,6 +8,7 @@ {-# LANGUAGE OverloadedStrings #-} module Utility.LockFile.PidLock ( + PidLockFile, LockHandle, tryLock, waitLock, @@ -53,13 +54,13 @@ import System.FilePath import Control.Applicative import Prelude -type LockFile = RawFilePath +type PidLockFile = RawFilePath data LockHandle - = LockHandle LockFile FileStatus SideLockHandle + = LockHandle PidLockFile FileStatus SideLockHandle | ParentLocked -type SideLockHandle = Maybe (LockFile, Posix.LockHandle) +type SideLockHandle = Maybe (RawFilePath, Posix.LockHandle) data PidLock = PidLock { lockingPid :: ProcessID @@ -72,13 +73,13 @@ mkPidLock = PidLock <$> getProcessID <*> getHostName -readPidLock :: LockFile -> IO (Maybe PidLock) +readPidLock :: PidLockFile -> IO (Maybe PidLock) readPidLock lockfile = (readish =<<) <$> catchMaybeIO (readFile (fromRawFilePath lockfile)) -- To avoid races when taking over a stale pid lock, a side lock is used. -- This is a regular posix exclusive lock. -trySideLock :: LockFile -> (SideLockHandle -> IO a) -> IO a +trySideLock :: PidLockFile -> (SideLockHandle -> IO a) -> IO a trySideLock lockfile a = do sidelock <- sideLockFile lockfile mlck <- catchDefaultIO Nothing $ @@ -113,7 +114,7 @@ dropSideLock (Just (f, h)) = do -- The side lock is put in /dev/shm. This will work on most any -- Linux system, even if its whole root filesystem doesn't support posix -- locks. /tmp is used as a fallback. -sideLockFile :: LockFile -> IO LockFile +sideLockFile :: PidLockFile -> IO RawFilePath sideLockFile lockfile = do f <- fromRawFilePath <$> absPath lockfile let base = intercalate "_" (splitDirectories (makeRelative "/" f)) @@ -136,7 +137,7 @@ sideLockFile lockfile = do -- -- If a parent process is holding the lock, determined by a -- "PIDLOCK_lockfile" environment variable, does not block either. -tryLock :: LockFile -> IO (Maybe LockHandle) +tryLock :: PidLockFile -> IO (Maybe LockHandle) tryLock lockfile = do abslockfile <- absPath lockfile lockenv <- pidLockEnv abslockfile @@ -256,7 +257,7 @@ checkInsaneLustre dest = do -- -- After the first second waiting, runs the callback to display a message, -- so the user knows why it's stalled. -waitLock :: MonadIO m => Seconds -> LockFile -> (String -> m ()) -> (Bool -> IO ()) -> m LockHandle +waitLock :: MonadIO m => Seconds -> PidLockFile -> (String -> m ()) -> (Bool -> IO ()) -> m LockHandle waitLock (Seconds timeout) lockfile displaymessage sem = go timeout where go n @@ -273,14 +274,14 @@ waitLock (Seconds timeout) lockfile displaymessage sem = go timeout liftIO $ sem False waitedLock (Seconds timeout) lockfile displaymessage -waitedLock :: MonadIO m => Seconds -> LockFile -> (String -> m ()) -> m LockHandle +waitedLock :: MonadIO m => Seconds -> PidLockFile -> (String -> m ()) -> m LockHandle waitedLock (Seconds timeout) lockfile displaymessage = do displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ fromRawFilePath lockfile giveup $ "Gave up waiting for pid lock file " ++ fromRawFilePath lockfile -- | Use when the pid lock has already been taken by another thread of the -- same process, or perhaps is in the process of being taken. -alreadyLocked :: MonadIO m => LockFile -> m LockHandle +alreadyLocked :: MonadIO m => PidLockFile -> m LockHandle alreadyLocked lockfile = liftIO $ do abslockfile <- absPath lockfile st <- getFileStatus abslockfile @@ -294,10 +295,10 @@ dropLock (LockHandle lockfile _ sidelock) = do removeWhenExistsWith removeLink lockfile dropLock ParentLocked = return () -getLockStatus :: LockFile -> IO LockStatus +getLockStatus :: PidLockFile -> IO LockStatus getLockStatus = maybe StatusUnLocked (StatusLockedBy . lockingPid) <$$> readPidLock -checkLocked :: LockFile -> IO (Maybe Bool) +checkLocked :: PidLockFile -> IO (Maybe Bool) checkLocked lockfile = conv <$> getLockStatus lockfile where conv (StatusLockedBy _) = Just True @@ -305,7 +306,7 @@ checkLocked lockfile = conv <$> getLockStatus lockfile -- Checks that the lock file still exists, and is the same file that was -- locked to get the LockHandle. -checkSaneLock :: LockFile -> LockHandle -> IO Bool +checkSaneLock :: PidLockFile -> LockHandle -> IO Bool checkSaneLock lockfile (LockHandle _ st _) = go =<< catchMaybeIO (getFileStatus lockfile) where diff --git a/Utility/LockPool/LockHandle.hs b/Utility/LockPool/LockHandle.hs index cbc649c803..e60dffb60e 100644 --- a/Utility/LockPool/LockHandle.hs +++ b/Utility/LockPool/LockHandle.hs @@ -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 - diff --git a/Utility/LockPool/PidLock.hs b/Utility/LockPool/PidLock.hs index d16509074e..97f94dd25a 100644 --- a/Utility/LockPool/PidLock.hs +++ b/Utility/LockPool/PidLock.hs @@ -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) + } diff --git a/Utility/LockPool/STM.hs b/Utility/LockPool/STM.hs index d5ab6b4e41..84c68faf3e 100644 --- a/Utility/LockPool/STM.hs +++ b/Utility/LockPool/STM.hs @@ -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 ()