Merge branch 'dropproof'

1 files changed, 26 insertions, 13 deletions

diff --git a/Utility/LockFile/Posix.hs b/Utility/LockFile/Posix.hs
index 18d9e4fc1..cf88fa87d 100644
--- a/Utility/LockFile/Posix.hs
+++ b/Utility/LockFile/Posix.hs
@@ -9,6 +9,7 @@ module Utility.LockFile.Posix (
 	LockHandle,
 	lockShared,
 	lockExclusive,
+	tryLockShared,
 	tryLockExclusive,
 	checkLocked,
 	getLockStatus,
@@ -36,31 +37,43 @@ lockShared = lock ReadLock
 lockExclusive :: Maybe FileMode -> LockFile -> IO LockHandle
 lockExclusive = lock WriteLock
 
+-- Tries to take a shared lock, but does not block.
+tryLockShared :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
+tryLockShared = tryLock ReadLock
+
 -- Tries to take an exclusive lock, but does not block.
 tryLockExclusive :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
-tryLockExclusive mode lockfile = do
-	l <- openLockFile mode lockfile
-	v <- tryIO $ setLock l (WriteLock, AbsoluteSeek, 0, 0)
-	case v of
-		Left _ -> do
-			closeFd l
-			return Nothing
-		Right _ -> return $ Just $ LockHandle l
+tryLockExclusive = tryLock WriteLock
 
 -- Setting the FileMode allows creation of a new lock file.
 -- If it's Nothing then this only succeeds when the lock file already exists.
 lock :: LockRequest -> Maybe FileMode -> LockFile -> IO LockHandle
 lock lockreq mode lockfile = do
-	l <- openLockFile mode lockfile
+	l <- openLockFile lockreq mode lockfile
 	waitToSetLock l (lockreq, AbsoluteSeek, 0, 0)
 	return (LockHandle l)
 
+-- Tries to take an lock, but does not block.
+tryLock :: LockRequest -> Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
+tryLock lockreq mode lockfile = do
+	l <- openLockFile lockreq mode lockfile
+	v <- tryIO $ setLock l (lockreq, AbsoluteSeek, 0, 0)
+	case v of
+		Left _ -> do
+			closeFd l
+			return Nothing
+		Right _ -> return $ Just $ LockHandle l
+
 -- Close on exec flag is set so child processes do not inherit the lock.
-openLockFile :: Maybe FileMode -> LockFile -> IO Fd
-openLockFile filemode lockfile = do
-	l <- openFd lockfile ReadWrite filemode defaultFileFlags
+openLockFile :: LockRequest -> Maybe FileMode -> LockFile -> IO Fd
+openLockFile lockreq filemode lockfile = do
+	l <- openFd lockfile openfor filemode defaultFileFlags
 	setFdOption l CloseOnExec True
 	return l
+  where
+	openfor = case lockreq of
+		ReadLock -> ReadOnly
+		_ -> ReadWrite
 
 -- Returns Nothing when the file doesn't exist, for cases where
 -- that is different from it not being locked.
@@ -81,7 +94,7 @@ getLockStatus lockfile = do
 getLockStatus' :: LockFile -> IO (Maybe (Maybe ProcessID))
 getLockStatus' lockfile = go =<< catchMaybeIO open
   where
-	open = openFd lockfile ReadOnly Nothing defaultFileFlags
+	open = openLockFile ReadLock Nothing lockfile
 	go Nothing = return Nothing
 	go (Just h) = do
 		v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)