reorganize and refactor lock code

Added a convenience Utility.LockFile that is not a windows/posix
portability shim, but still manages to cut down on the boilerplate around
locking.

This commit was sponsored by Johan Herland.

Annex/Content.hs

@@ -56,10 +56,7 @@ import Annex.Perms
 import Annex.Link
 import Annex.Content.Direct
 import Annex.ReplaceFile
-
-#ifdef mingw32_HOST_OS
-import Utility.WinLock
-#endif
+import Utility.LockFile
 
 {- Checks if a given key's content is currently present. -}
 inAnnex :: Key -> Annex Bool
@@ -177,24 +174,21 @@ lockContent key a = do
 			nukeFile lockfile
 #ifndef mingw32_HOST_OS
 	lock contentfile Nothing = opencontentforlock contentfile >>= dolock
-	lock _ (Just lockfile) = openforlock lockfile >>= dolock . Just
+	lock _ (Just lockfile) = createLockFile Nothing lockfile >>= dolock . Just
 	{- Since content files are stored with the write bit disabled, have
 	 - to fiddle with permissions to open for an exclusive lock. -}
 	opencontentforlock f = catchMaybeIO $ ifM (doesFileExist f)
 		( withModifiedFileMode f
 			(`unionFileModes` ownerWriteMode)
-			(openforlock f)
-		, openforlock f
+			(createLockFie Nothing f)
+		, createLockFile Nothing f
 		)
-	openforlock f = openFd f ReadWrite Nothing defaultFileFlags
 	dolock Nothing = return Nothing
 	dolock (Just fd) = do
 		v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 		case v of
 			Left _ -> alreadylocked
-			Right _ -> do
-				setFdOption fd CloseOnExec True
-				return $ Just fd
+			Right _ -> return $ Just fd
 	unlock mlockfile mfd = do
 		maybe noop cleanuplockfile mlockfile
 		liftIO $ maybe noop closeFd mfd

Annex/LockFile.hs

@@ -19,13 +19,10 @@ import Annex
 import Types.LockPool
 import qualified Git
 import Annex.Perms
+import Utility.LockFile
 
 import qualified Data.Map as M
 
-#ifdef mingw32_HOST_OS
-import Utility.WinLock
-#endif
-
 {- Create a specified lock file, and takes a shared lock, which is retained
  - in the pool. -}
 lockFileShared :: FilePath -> Annex ()
@@ -35,10 +32,7 @@ lockFileShared file = go =<< fromLockPool file
 	go Nothing = do
 #ifndef mingw32_HOST_OS
 		mode <- annexFileMode
-		lockhandle <- liftIO $ noUmask mode $
-			openFd file ReadWrite (Just mode) defaultFileFlags
-		liftIO $ setFdOption lockhandle CloseOnExec True
-		liftIO $ waitToSetLock lockhandle (ReadLock, AbsoluteSeek, 0, 0)
+		lockhandle <- liftIO $ noUmask mode $ lockShared (Just mode) file
 #else
 		lockhandle <- liftIO $ waitToLock $ lockShared file
 #endif
@@ -48,11 +42,7 @@ unlockFile :: FilePath -> Annex ()
 unlockFile file = maybe noop go =<< fromLockPool file
   where
 	go lockhandle = do
-#ifndef mingw32_HOST_OS
-		liftIO $ closeFd lockhandle
-#else
 		liftIO $ dropLock lockhandle
-#endif
 		changeLockPool $ M.delete file
 
 getLockPool :: Annex LockPool
@@ -73,16 +63,10 @@ withExclusiveLock getlockfile a = do
 	lockfile <- fromRepo getlockfile
 	createAnnexDirectory $ takeDirectory lockfile
 	mode <- annexFileMode
-	bracketIO (lock lockfile mode) unlock (const a)
+	bracketIO (lock mode lockfile) dropLock (const a)
   where
 #ifndef mingw32_HOST_OS
-	lock lockfile mode = do
-		l <- noUmask mode $ createFile lockfile mode
-		setFdOption l CloseOnExec True
-		waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
-		return l
-	unlock = closeFd
+	lock mode = noUmask mode . lockExclusive (Just mode)
 #else
-	lock lockfile _mode = waitToLock $ lockExclusive lockfile
-	unlock = dropLock
+	lock _mode = waitToLock . lockExclusive
 #endif

Annex/Ssh.hs

@@ -35,6 +35,7 @@ import Config.Files
 import Utility.Env
 import Types.CleanupActions
 import Annex.Index (addGitEnv)
+import Utility.LockFile
 #ifndef mingw32_HOST_OS
 import Annex.Perms
 #endif
@@ -151,9 +152,7 @@ sshCleanup = mapM_ cleanup =<< enumSocketFiles
 		let lockfile = socket2lock socketfile
 		unlockFile lockfile
 		mode <- annexFileMode
-		fd <- liftIO $ noUmask mode $
-			openFd lockfile ReadWrite (Just mode) defaultFileFlags
-		liftIO $ setFdOption fd CloseOnExec True
+		fd <- liftIO $ noUmask mode $ createLockFile (Just mode) lockfile
 		v <- liftIO $ tryIO $
 			setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 		case v of

Command/PreCommit.hs

@@ -18,16 +18,12 @@ import Annex.Direct
 import Annex.Hook
 import Annex.View
 import Annex.View.ViewedFile
-import Annex.Perms
+import Annex.LockFile
 import Logs.View
 import Logs.MetaData
 import Types.View
 import Types.MetaData
 
-#ifdef mingw32_HOST_OS
-import Utility.WinLock
-#endif
-
 import qualified Data.Set as S
 
 def :: [Command]
@@ -92,20 +88,4 @@ showMetaDataChange = showLongNote . unlines . concatMap showmeta . fromMetaData
 
 {- Takes exclusive lock; blocks until available. -}
 lockPreCommitHook :: Annex a -> Annex a
-lockPreCommitHook a = do
-	lockfile <- fromRepo gitAnnexPreCommitLock
-	createAnnexDirectory $ takeDirectory lockfile
-	mode <- annexFileMode
-	bracketIO (lock lockfile mode) unlock (const a)
-  where
-#ifndef mingw32_HOST_OS
-	lock lockfile mode = do
-		l <- liftIO $ noUmask mode $ createFile lockfile mode
-		setFdOption l CloseOnExec True
-		liftIO $ waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
-		return l
-	unlock = closeFd
-#else
-	lock lockfile _mode = liftIO $ waitToLock $  lockExclusive lockfile
-	unlock = dropLock
-#endif
+lockPreCommitHook = withExclusiveLock gitAnnexPreCommitLock

Remote/Helper/Hooks.hs

@@ -16,10 +16,9 @@ import Types.Remote
 import Types.CleanupActions
 import qualified Annex
 import Annex.LockFile
+import Utility.LockFile
 #ifndef mingw32_HOST_OS
 import Annex.Perms
-#else
-import Utility.WinLock
 #endif
 
 {- Modifies a remote's access functions to first run the
@@ -84,9 +83,7 @@ runHooks r starthook stophook a = do
 		unlockFile lck
 #ifndef mingw32_HOST_OS
 		mode <- annexFileMode
-		fd <- liftIO $ noUmask mode $
-			openFd lck ReadWrite (Just mode) defaultFileFlags
-		liftIO $ setFdOption fd CloseOnExec True
+		fd <- liftIO $ noUmask mode $ createLockFile (Just mode) lck
 		v <- liftIO $ tryIO $
 			setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 		case v of

Types/LockPool.hs

@@ -5,20 +5,12 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP #-}
-
 module Types.LockPool (
 	LockPool,
 	LockHandle
 ) where
 
 import qualified Data.Map as M
-
-#ifndef mingw32_HOST_OS
-import System.Posix.Types (Fd)
-type LockHandle = Fd
-#else
-import Utility.WinLock -- defines LockHandle
-#endif
+import Utility.LockFile
 
 type LockPool = M.Map FilePath LockHandle

Utility/LockFile.hs

@@ -0,0 +1,20 @@
+{- Lock files
+ -
+ - Posix and Windows lock files are extremely different.
+ - This module does *not* attempt to be a portability shim, it just exposes
+ - the native locking of the OS.
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.LockFile (module X) where
+
+#ifndef mingw32_HOST_OS
+import Utility.LockFile.Posix as X
+#else
+import Utility.LockFile.Windows as X
+#endif

Utility/LockFile/Posix.hs

@@ -0,0 +1,47 @@
+{- Posix lock files
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.LockFile.Posix (
+	lockShared,
+	lockExclusive,
+	dropLock,
+	createLockFile,
+	LockHandle
+) where
+
+import System.IO
+import System.Posix
+
+type LockFile = FilePath
+
+newtype LockHandle = LockHandle Fd
+
+-- Takes a shared lock, blocking until the lock is available.
+lockShared :: Maybe FileMode -> LockFile -> IO LockHandle
+lockShared = lock ReadLock
+
+-- Takes an exclusive lock, blocking until the lock is available.
+lockExclusive :: Maybe FileMode -> LockFile -> IO LockHandle
+lockExclusive = lock WriteLock
+
+-- The FileMode is used when creating a new lock file.
+lock :: LockRequest -> Maybe FileMode -> LockFile -> IO LockHandle
+lock lockreq mode lockfile = do
+	l <- createLockFile mode lockfile
+	waitToSetLock l (lockreq, AbsoluteSeek, 0, 0)
+	return (LockHandle l)
+
+-- Create and opens lock file, does not lock it.
+-- Close on exec flag is set so child processes do not inherit the lock.
+createLockFile :: Maybe FileMode -> LockFile -> IO Fd
+createLockFile mode lockfile = do
+	l <- openFd lockfile ReadWrite mode defaultFileFlags
+	setFdOption l CloseOnExec True
+	return l
+
+dropLock :: LockHandle -> IO ()
+dropLock (LockHandle fd) = closeFd fd

Utility/LockFile/Windows.hs

@@ -5,7 +5,7 @@
  - License: BSD-2-clause
  -}
 
-module Utility.WinLock (
+module Utility.LockFile.Windows (
 	lockShared,
 	lockExclusive,
 	dropLock,
@@ -17,9 +17,6 @@ import System.Win32.Types
 import System.Win32.File
 import Control.Concurrent
 
-{- Locking is exclusive, and prevents the file from being opened for read
- - or write by any other process. So for advisory locking of a file, a
- - different LockFile should be used. -}
 type LockFile = FilePath
 
 type LockHandle = HANDLE
@@ -30,7 +27,11 @@ lockShared :: LockFile -> IO (Maybe LockHandle)
 lockShared = openLock fILE_SHARE_READ
 
 {- Tries to take an exclusive lock on a file. Fails if another process has
- - a shared or exclusive lock. -}
+ - a shared or exclusive lock.
+ -
+ - Note that exclusive locking also prevents the file from being opened for
+ - read or write by any other progess. So for advisory locking of a file's
+ - content, a different LockFile should be used. -}
 lockExclusive :: LockFile -> IO (Maybe LockHandle)
 lockExclusive = openLock fILE_SHARE_NONE