use locking on Windows

This is all the easy cases, where there was already a separate lock file.

8 files changed, 95 insertions, 40 deletions

diff --git a/Annex.hs b/Annex.hs
index 9beded53f..87a06615e 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -34,7 +34,6 @@ module Annex (
 
 import "mtl" Control.Monad.Reader
 import "MonadCatchIO-transformers" Control.Monad.CatchIO
-import System.Posix.Types (Fd)
 import Control.Concurrent
 
 import Common
@@ -58,6 +57,7 @@ import Types.Messages
 import Types.UUID
 import Types.FileMatcher
 import Types.NumCopies
+import Types.LockPool
 import qualified Utility.Matcher
 import qualified Data.Map as M
 import qualified Data.Set as S
@@ -106,7 +106,7 @@ data AnnexState = AnnexState
 	, trustmap :: Maybe TrustMap
 	, groupmap :: Maybe GroupMap
 	, ciphers :: M.Map StorableCipher Cipher
-	, lockpool :: M.Map FilePath Fd
+	, lockpool :: LockPool
 	, flags :: M.Map String Bool
 	, fields :: M.Map String String
 	, cleanup :: M.Map String (Annex ())
diff --git a/Annex/Journal.hs b/Annex/Journal.hs
index 8b88ab2fb..3f31cb941 100644
--- a/Annex/Journal.hs
+++ b/Annex/Journal.hs
@@ -20,6 +20,10 @@ import Annex.Exception
 import qualified Git
 import Annex.Perms
 
+#ifdef mingw32_HOST_OS
+import Utility.WinLock
+#endif
+
 {- Records content for a file in the branch to the journal.
  -
  - Using the journal, rather than immediatly staging content to the index
@@ -116,13 +120,8 @@ lockJournal a = do
 		l <- noUmask mode $ createFile lockfile mode
 		waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
 		return l
-#else
-	lock lockfile _mode = do
-		writeFile lockfile ""
-		return lockfile
-#endif
-#ifndef mingw32_HOST_OS
 	unlock = closeFd
 #else
-	unlock = removeFile
+	lock lockfile _mode = waitToLock $ lockExclusive lockfile
+	unlock = dropLock
 #endif
diff --git a/Annex/LockPool.hs b/Annex/LockPool.hs
index a9a0f3101..5fc167d28 100644
--- a/Annex/LockPool.hs
+++ b/Annex/LockPool.hs
@@ -1,6 +1,6 @@
 {- git-annex lock pool
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012, 2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -9,13 +9,16 @@
 
 module Annex.LockPool where
 
-import qualified Data.Map as M
-import System.Posix.Types (Fd)
-
 import Common.Annex
 import Annex
+import Types.LockPool
+
+import qualified Data.Map as M
+
 #ifndef mingw32_HOST_OS
 import Annex.Perms
+#else
+import Utility.WinLock
 #endif
 
 {- Create a specified lock file, and takes a shared lock. -}
@@ -26,31 +29,32 @@ lockFile file = go =<< fromPool file
 	go Nothing = do
 #ifndef mingw32_HOST_OS
 		mode <- annexFileMode
-		fd <- liftIO $ noUmask mode $
+		lockhandle <- liftIO $ noUmask mode $
 			openFd file ReadOnly (Just mode) defaultFileFlags
-		liftIO $ waitToSetLock fd (ReadLock, AbsoluteSeek, 0, 0)
+		liftIO $ waitToSetLock lockhandle (ReadLock, AbsoluteSeek, 0, 0)
 #else
-		liftIO $ writeFile file ""
-		let fd = 0
+		lockhandle <- liftIO $ waitToLock $ lockShared file
 #endif
-		changePool $ M.insert file fd
+		changePool $ M.insert file lockhandle
 
 unlockFile :: FilePath -> Annex ()
 unlockFile file = maybe noop go =<< fromPool file
   where
-	go fd = do
+	go lockhandle = do
 #ifndef mingw32_HOST_OS
-		liftIO $ closeFd fd
+		liftIO $ closeFd lockhandle
+#else
+		liftIO $ dropLock lockhandle
 #endif
 		changePool $ M.delete file
 
-getPool :: Annex (M.Map FilePath Fd)
+getPool :: Annex LockPool
 getPool = getState lockpool
 
-fromPool :: FilePath -> Annex (Maybe Fd)
+fromPool :: FilePath -> Annex (Maybe LockHandle)
 fromPool file = M.lookup file <$> getPool
 
-changePool :: (M.Map FilePath Fd -> M.Map FilePath Fd) -> Annex ()
+changePool :: (LockPool -> LockPool) -> Annex ()
 changePool a = do
 	m <- getPool
 	changeState $ \s -> s { lockpool = a m }
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index 97ec08895..39cae1106 100644
--- a/Logs/Transfer.hs
+++ b/Logs/Transfer.hs
@@ -29,6 +29,7 @@ import System.Posix.Types (ProcessID)
 #else
 import System.Win32.Process (ProcessId)
 import System.Win32.Process.Current (getCurrentProcessId)
+import Utility.WinLock
 #endif
 
 #ifndef mingw32_HOST_OS
@@ -147,7 +148,7 @@ runTransfer t file shouldretry a = do
 			openFd (transferLockFile tfile) ReadWrite (Just mode)
 				defaultFileFlags { trunc = True }
 		case mfd of
-			Nothing -> return (mfd, False)
+			Nothing -> return (Nothing, False)
 			Just fd -> do
 				locked <- catchMaybeIO $
 					setLock fd (WriteLock, AbsoluteSeek, 0, 0)
@@ -158,17 +159,28 @@ runTransfer t file shouldretry a = do
 						return (mfd, False)
 #else
 	prep tfile _mode info = do
-		mfd <- catchMaybeIO $ do
-			writeFile (transferLockFile tfile) ""
-			writeTransferInfoFile info tfile
-		return (mfd, False)
+		v <- catchMaybeIO $ lockExclusive (transferLockFile tfile)
+		case v of
+			Nothing -> return (Nothing, False)
+			Just Nothing -> return (Nothing, True)
+			Just (Just lockhandle) -> do
+				void $ tryIO $ writeTransferInfoFile info tfile
+				return (Just lockhandle, False)
 #endif
 	cleanup _ Nothing = noop
-	cleanup tfile (Just fd) = do
+	cleanup tfile (Just lockhandle) = do
 		void $ tryIO $ removeFile tfile
-		void $ tryIO $ removeFile $ transferLockFile tfile
 #ifndef mingw32_HOST_OS
-		closeFd fd
+		void $ tryIO $ removeFile $ transferLockFile tfile
+		closeFd lockhandle
+#else
+		{- Windows cannot delete the lockfile until the lock
+		 - is closed. So it's possible to race with another
+		 - process that takes the lock before it's removed,
+		 - so ignore failure to remove.
+		 -}
+		dropLock lockhandle
+		void $ tryIO $ removeFile $ transferLockFile tfile
 #endif
 	retry oldinfo metervar run = do
 		v <- tryAnnex run
@@ -246,11 +258,14 @@ checkTransfer t = do
 				Just (pid, _) -> liftIO $ catchDefaultIO Nothing $
 					readTransferInfoFile (Just pid) tfile
 #else
-	ifM (liftIO $ doesFileExist $ transferLockFile tfile)
-		( liftIO $ catchDefaultIO Nothing $
+	v <- liftIO $ lockShared $ transferLockFile tfile
+	liftIO $ case v of
+		Nothing -> catchDefaultIO Nothing $
 			readTransferInfoFile Nothing tfile
-		, return Nothing
-		)
+		Just lockhandle -> do
+			dropLock lockhandle
+			void $ tryIO $ removeFile $ transferLockFile tfile
+			return Nothing
 #endif
 
 {- Gets all currently running transfers. -}
diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs
index 91c6318bf..f876649f0 100644
--- a/Remote/Helper/Hooks.hs
+++ b/Remote/Helper/Hooks.hs
@@ -17,6 +17,8 @@ import qualified Annex
 import Annex.LockPool
 #ifndef mingw32_HOST_OS
 import Annex.Perms
+#else
+import Utility.WinLock
 #endif
 
 {- Modifies a remote's access functions to first run the
@@ -73,13 +75,13 @@ runHooks r starthook stophook a = do
 		run starthook
 
 		Annex.addCleanup (remoteid ++ "-stop-command") $ runstop lck
-#ifndef mingw32_HOST_OS
 	runstop lck = do
 		-- Drop any shared lock we have, and take an
 		-- exclusive lock, without blocking. If the lock
 		-- succeeds, we're the only process using this remote,
 		-- so can stop it.
 		unlockFile lck
+#ifndef mingw32_HOST_OS
 		mode <- annexFileMode
 		fd <- liftIO $ noUmask mode $
 			openFd lck ReadWrite (Just mode) defaultFileFlags
@@ -90,5 +92,10 @@ runHooks r starthook stophook a = do
 			Right _ -> run stophook
 		liftIO $ closeFd fd
 #else
-	runstop _lck = run stophook
+		v <- liftIO $ lockExclusive lck
+		case v of
+			Nothing -> noop
+			Just lockhandle -> do
+				run stophook
+				liftIO $ dropLock lockhandle
 #endif
diff --git a/Types/LockPool.hs b/Types/LockPool.hs
new file mode 100644
index 000000000..dd392f28b
--- /dev/null
+++ b/Types/LockPool.hs
@@ -0,0 +1,24 @@
+{- git-annex lock pool data types
+ - 
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - 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
+
+type LockPool = M.Map FilePath LockHandle
diff --git a/Utility/WinLock.hs b/Utility/WinLock.hs
index ebdba2b85..7b7cf7132 100644
--- a/Utility/WinLock.hs
+++ b/Utility/WinLock.hs
@@ -9,11 +9,10 @@ module Utility.WinLock (
 	lockShared,
 	lockExclusive,
 	dropLock,
-	waitToLock
+	waitToLock,
+	LockHandle
 ) where
 
-import Common
-
 import System.Win32.Types
 import System.Win32.File
 import Control.Concurrent
diff --git a/debian/changelog b/debian/changelog
index 894f92e42..f6eec27e1 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,10 @@
+git-annex (5.20140128) UNRELEASED; urgency=medium
+
+  * Windows: It's now safe to run multiple git-annex processes concurrently
+    on Windows; the lock files have been sorted out.
+
+ -- Joey Hess <joeyh@debian.org>  Tue, 28 Jan 2014 13:57:19 -0400
+
 git-annex (5.20140127) unstable; urgency=medium
 
   * sync --content: New option that makes the content of annexed files be