diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs index d4290e91ca..e968f18618 100644 --- a/Utility/LockFile/PidLock.hs +++ b/Utility/LockFile/PidLock.hs @@ -9,9 +9,11 @@ module Utility.LockFile.PidLock ( LockHandle, tryLock, waitLock, + dropLock, LockStatus(..), getLockStatus, - dropLock, + checkLocked, + checkSaneLock, ) where import Utility.PartialPrelude @@ -19,7 +21,6 @@ import Utility.Exception import Utility.Applicative import Utility.Directory import Utility.ThreadScheduler -import Utility.Tmp import Utility.Monad import Utility.Path import Utility.FileMode @@ -28,8 +29,6 @@ import qualified Utility.LockFile.Posix as Posix import System.IO import System.Posix -import System.Posix.IO -import System.Posix.Process import Data.Maybe import Data.List import Control.Applicative @@ -38,7 +37,7 @@ import System.FilePath type LockFile = FilePath -data LockHandle = LockHandle FilePath Handle (Maybe Posix.LockHandle) +data LockHandle = LockHandle FilePath Fd (Maybe Posix.LockHandle) data PidLock = PidLock { lockingPid :: ProcessID @@ -87,12 +86,12 @@ tryLock lockfile = trySideLock lockfile $ \sidelock -> do (tmp, h) <- openTempFile (takeDirectory lockfile) "locktmp" setFileMode tmp (combineModes readModes) hPutStr h . show =<< mkPidLock - hClose h + fd <- handleToFd h let failedlock = do - hClose h + closeFd fd nukeFile tmp return Nothing - let tooklock = return $ Just $ LockHandle lockfile h sidelock + let tooklock = return $ Just $ LockHandle lockfile fd sidelock ifM (isJust <$> catchMaybeIO (createLink tmp lockfile)) ( tooklock , do @@ -122,11 +121,28 @@ waitLock lockfile = go go = maybe (threadDelaySeconds (Seconds 1) >> go) return =<< tryLock lockfile +dropLock :: LockHandle -> IO () +dropLock (LockHandle lockfile fd plh) = do + closeFd fd + nukeFile lockfile + maybe noop Posix.dropLock plh + getLockStatus :: LockFile -> IO LockStatus getLockStatus = maybe StatusUnLocked (StatusLockedBy . lockingPid) <$$> readPidLock -dropLock :: LockHandle -> IO () -dropLock (LockHandle lockfile lockhandle plh) = do - hClose lockhandle - nukeFile lockfile - maybe noop Posix.dropLock plh +checkLocked :: LockFile -> IO (Maybe Bool) +checkLocked lockfile = conv <$> getLockStatus lockfile + where + conv (StatusLockedBy _) = Just True + conv _ = Just False + +-- 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 lockfile (LockHandle _ fd _) = + go =<< catchMaybeIO (getFileStatus lockfile) + where + go Nothing = return False + go (Just st) = do + fdst <- getFdStatus fd + return $ deviceID fdst == deviceID st && fileID fdst == fileID st diff --git a/Utility/LockPool/PidLock.hs b/Utility/LockPool/PidLock.hs new file mode 100644 index 0000000000..3d90e4b42d --- /dev/null +++ b/Utility/LockPool/PidLock.hs @@ -0,0 +1,63 @@ +{- Pid locks, using lock pools. + - + - Copyright 2015 Joey Hess + - + - 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 System.IO +import System.Posix +import Data.Maybe +import Control.Applicative +import Prelude + +-- Takes a pid lock, blocking until the lock is available. +-- +-- May block forever on stale locks, see PidLock documentation for details. +waitLock :: LockFile -> IO LockHandle +waitLock file = makeLockHandle + (P.waitTakeLock P.lockPool file LockExclusive) + (mk <$> F.waitLock file) + +-- Tries to take a pid lock, but does not block. +tryLock :: LockFile -> IO (Maybe LockHandle) +tryLock file = tryMakeLockHandle + (P.tryTakeLock P.lockPool file LockShared) + (fmap mk <$> F.tryLock file) + +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) + +checkSaneLock :: LockFile -> LockHandle -> IO Bool +checkSaneLock lockfile (LockHandle _ flo) = fCheckSaneLock flo lockfile + +mk :: F.LockHandle -> FileLockOps +mk h = FileLockOps + { fDropLock = F.dropLock h + , fCheckSaneLock = \f -> F.checkSaneLock f h + }