module for PidLocks in LockPool

diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs
index d4290e91ca6a87b125a5dd053b8d736a9d9046d0..e968f18618684ece2e31b7512d636f989860ef33 100644 (file)
--- 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
 
-getLockStatus :: LockFile -> IO LockStatus
-getLockStatus = maybe StatusUnLocked (StatusLockedBy . lockingPid) <$$> readPidLock
-
 dropLock :: LockHandle -> IO ()
-dropLock (LockHandle lockfile lockhandle plh) = do
-       hClose lockhandle
+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
+
+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 (file)
index 0000000..3d90e4b
--- /dev/null
+++ b/Utility/LockPool/PidLock.hs
@@ -0,0 +1,63 @@
+{- Pid locks, using lock pools.
+ -
+ - Copyright 2015 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 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
+       }