From 0356f1b6e6d5905430e57eedf868095d13610b4c Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 12 Nov 2015 16:31:34 -0400
Subject: module for PidLocks in LockPool

---
 Utility/LockFile/PidLock.hs | 42 ++++++++++++++++++++----------
 Utility/LockPool/PidLock.hs | 63 +++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 92 insertions(+), 13 deletions(-)
 create mode 100644 Utility/LockPool/PidLock.hs

diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs
index d4290e91c..e968f1861 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
 
-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
index 000000000..3d90e4b42
--- /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
+	}
-- 
cgit v1.2.3