3334130368This fixes behavior in this situation: l1 <- lockShared Nothing "lck" l2 <- lockShared Nothing "lck" dropLock l1 dropLock l2 Before, the lock was dropped upon the second dropLock call, but the fd remained open, and would never be closed while the program was running. Fixed by a rather round-about method, but it should work well enough. It would have been simpler to open open the shared lock once, and not open it again in the second call to lockShared. But, that's difficult to do atomically. This also affects Windows and PID locks, not just posix locks. In the case of pid locks, multiple calls to waitLock within the same process are allowed because the side lock is locked using a posix lock, and so multiple exclusive locks can be taken in the same process. So, this change fixes a similar problem with pid locks. l1 <- waitLock (Seconds 1) "lck" l2 <- waitLock (Seconds 1) "lck" dropLock l1 dropLock l2 Here the l2 side lock fd remained open but not locked, although the pid lock file was removed. After this change, the second dropLock will close both fds to the side lock, and delete the pidlock.
75 lines
2.1 KiB
Haskell
75 lines
2.1 KiB
Haskell
{- Handles for lock pools.
|
|
-
|
|
- Copyright 2015 Joey Hess <id@joeyh.name>
|
|
-
|
|
- License: BSD-2-clause
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Utility.LockPool.LockHandle (
|
|
LockHandle,
|
|
FileLockOps(..),
|
|
dropLock,
|
|
#ifndef mingw32_HOST_OS
|
|
checkSaneLock,
|
|
#endif
|
|
makeLockHandle,
|
|
tryMakeLockHandle,
|
|
) where
|
|
|
|
import qualified Utility.LockPool.STM as P
|
|
#ifndef mingw32_HOST_OS
|
|
import Utility.LockPool.STM (LockFile)
|
|
#endif
|
|
|
|
import Control.Concurrent.STM
|
|
import Control.Exception
|
|
|
|
data LockHandle = LockHandle P.LockHandle FileLockOps
|
|
|
|
data FileLockOps = FileLockOps
|
|
{ fDropLock :: IO ()
|
|
#ifndef mingw32_HOST_OS
|
|
, fCheckSaneLock :: LockFile -> IO Bool
|
|
#endif
|
|
}
|
|
|
|
dropLock :: LockHandle -> IO ()
|
|
dropLock (LockHandle ph _) = P.releaseLock ph
|
|
|
|
#ifndef mingw32_HOST_OS
|
|
checkSaneLock :: LockFile -> LockHandle -> IO Bool
|
|
checkSaneLock lockfile (LockHandle _ flo) = fCheckSaneLock flo lockfile
|
|
#endif
|
|
|
|
-- 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 :: P.LockPool -> LockFile -> (P.LockPool -> LockFile -> STM P.LockHandle) -> (LockFile -> IO FileLockOps) -> IO LockHandle
|
|
makeLockHandle pool file pa fa = bracketOnError setup cleanup go
|
|
where
|
|
setup = atomically (pa pool file)
|
|
cleanup ph = P.releaseLock ph
|
|
go ph = mkLockHandle pool file ph =<< fa file
|
|
|
|
tryMakeLockHandle :: P.LockPool -> LockFile -> (P.LockPool -> LockFile -> STM (Maybe P.LockHandle)) -> (LockFile -> IO (Maybe FileLockOps)) -> IO (Maybe LockHandle)
|
|
tryMakeLockHandle pool file pa fa = bracketOnError setup cleanup go
|
|
where
|
|
setup = atomically (pa pool file)
|
|
cleanup Nothing = return ()
|
|
cleanup (Just ph) = P.releaseLock ph
|
|
go Nothing = return Nothing
|
|
go (Just ph) = do
|
|
mfo <- fa file
|
|
case mfo of
|
|
Nothing -> do
|
|
cleanup (Just ph)
|
|
return Nothing
|
|
Just fo -> Just <$> mkLockHandle pool file ph fo
|
|
|
|
mkLockHandle :: P.LockPool -> LockFile -> P.LockHandle -> FileLockOps -> IO LockHandle
|
|
mkLockHandle pool file ph fo = do
|
|
atomically $ P.registerCloseLockFile pool file (fDropLock fo)
|
|
return $ LockHandle ph fo
|
|
|