rework annexed object locking in direct mode & support Windows

Seems that locking of annexed objects when they're being dropped was broken
in direct mode:

* When taking the lock before dropping, it created the .git/annex/objects
  file, as an empty file. It seems that the dropping code deleted that,
  but that is not right, and for all I know could in some situation cause
  a corrupted object to leak out.
* When the lock was checked, it actually tried to open each direct mode
  file, and checked if it was locked. Not the same lock used above, and
  could also fail if some consumer of the file locked it.

Fixed this, and added windows support by switching direct mode to lock a
.lck file.

5 files changed, 92 insertions, 32 deletions

diff --git a/Annex/Content.hs b/Annex/Content.hs
index 7cd2fb561..98603914a 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -1,6 +1,6 @@
 {- git-annex file content managing
  -
- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -57,6 +57,10 @@ import Annex.Content.Direct
 import Annex.ReplaceFile
 import Annex.Exception
 
+#ifdef mingw32_HOST_OS
+import Utility.WinLock
+#endif
+
 {- Checks if a given key's content is currently present. -}
 inAnnex :: Key -> Annex Bool
 inAnnex key = inAnnexCheck key $ liftIO . doesFileExist
@@ -90,60 +94,105 @@ inAnnex' isgood bad check key = withObjectLoc key checkindirect checkdirect
 {- A safer check; the key's content must not only be present, but
  - is not in the process of being removed. -}
 inAnnexSafe :: Key -> Annex (Maybe Bool)
-inAnnexSafe = inAnnex' (fromMaybe False) (Just False) go
+inAnnexSafe key = inAnnex' (fromMaybe False) (Just False) go key
   where
-	go f = liftIO $ openforlock f >>= check
+	is_locked = Nothing
+	is_unlocked = Just True
+	is_missing = Just False
+
+	go contentfile = maybe (checkindirect contentfile) (checkdirect contentfile)
+		=<< contentLockFile key
+
 #ifndef mingw32_HOST_OS
+	checkindirect f = liftIO $ openforlock f >>= check is_missing
+	{- In direct mode, the content file must exist, but
+	 - the lock file often generally won't exist unless a removal is in
+	 - process. This does not create the lock file, it only checks for
+	 - it. -}
+	checkdirect contentfile lockfile = liftIO $
+		ifM (doesFileExist contentfile)
+			( openforlock lockfile >>= check is_unlocked
+			, return is_missing
+			)
 	openforlock f = catchMaybeIO $
 		openFd f ReadOnly Nothing defaultFileFlags
-#else
-	openforlock _ = return $ Just ()
-#endif
-	check Nothing = return is_missing
-#ifndef mingw32_HOST_OS
-	check (Just h) = do
+	check _ (Just h) = do
 		v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
 		closeFd h
 		return $ case v of
 			Just _ -> is_locked
 			Nothing -> is_unlocked
+	check def Nothing = return def
 #else
-	check (Just _) = return is_unlocked
-#endif
-#ifndef mingw32_HOST_OS
-	is_locked = Nothing
+	checkindirect _ = return is_missing
+	{- In Windows, see if we can take a shared lock. If so, 
+	 - remove the lock file to clean up after ourselves. -}
+	checkdirect contentfile lockfile =
+		ifM (liftIO $ doesFileExist contentfile)
+			( modifyContent lockfile $ liftIO $ do
+				v <- lockShared lockfile
+				case v of
+					Nothing -> return is_locked
+					Just lockhandle -> do
+						dropLock lockhandle
+						void $ tryIO $ nukeFile lockfile
+						return is_unlocked
+			, return is_missing
+			)
 #endif
-	is_unlocked = Just True
-	is_missing = Just False
+
+{- Direct mode and especially Windows has to use a separate lock
+ - file from the content, since locking the actual content file
+ - would interfere with the user's use of it. -}
+contentLockFile :: Key -> Annex (Maybe FilePath)
+contentLockFile key = ifM isDirect
+	( Just <$> calcRepo (gitAnnexContentLock key)
+	, return Nothing
+	)
 
 {- Content is exclusively locked while running an action that might remove
  - it. (If the content is not present, no locking is done.) -}
 lockContent :: Key -> Annex a -> Annex a
-#ifndef mingw32_HOST_OS
 lockContent key a = do
-	file <- calcRepo $ gitAnnexLocation key
-	bracketIO (openforlock file >>= lock) unlock (const a)
+	contentfile <- calcRepo $ gitAnnexLocation key
+	lockfile <- contentLockFile key
+	maybe noop setuplockfile lockfile
+	bracketAnnex (liftIO $ lock contentfile lockfile) (unlock lockfile) (const a)
   where
-	{- Since files are stored with the write bit disabled, have
+	alreadylocked = error "content is locked"
+	setuplockfile lockfile = modifyContent lockfile $
+		void $ liftIO $ tryIO $
+			writeFile lockfile ""
+	cleanuplockfile lockfile = modifyContent lockfile $
+		void $ liftIO $ tryIO $
+			nukeFile lockfile
+#ifndef mingw32_HOST_OS
+	lock contentfile Nothing = opencontentforlock contentfile >>= dolock
+	lock _ (Just lockfile) = openforlock lockfile >>= dolock . Just
+	{- Since content files are stored with the write bit disabled, have
 	 - to fiddle with permissions to open for an exclusive lock. -}
-	openforlock f = catchMaybeIO $ ifM (doesFileExist f)
+	opencontentforlock f = catchMaybeIO $ ifM (doesFileExist f)
 		( withModifiedFileMode f
 			(`unionFileModes` ownerWriteMode)
-			open
-		, open
+			(openforlock f)
+		, openforlock f
 		)
-	  where
-		open = openFd f ReadWrite Nothing defaultFileFlags
-	lock Nothing = return Nothing
-	lock (Just fd) = do
+	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 _ -> error "content is locked"
+			Left _ -> alreadylocked
 			Right _ -> return $ Just fd
-	unlock Nothing = noop
-	unlock (Just l) = closeFd l
+	unlock mlockfile mfd = do
+		maybe noop cleanuplockfile mlockfile
+		liftIO $ maybe noop closeFd mfd
 #else
-lockContent _key a = a -- no locking for Windows!
+	lock _ (Just lockfile) = maybe alreadylocked (return . Just) =<< lockExclusive lockfile
+	lock _ Nothing = return Nothing
+	unlock mlockfile mlockhandle = do
+		liftIO $ maybe noop dropLock mlockhandle
+		maybe noop cleanuplockfile mlockfile
 #endif
 
 {- Runs an action, passing it a temporary filename to get,
diff --git a/Annex/Exception.hs b/Annex/Exception.hs
index 91347583e..11613d51b 100644
--- a/Annex/Exception.hs
+++ b/Annex/Exception.hs
@@ -14,6 +14,7 @@
 
 module Annex.Exception (
 	bracketIO,
+	bracketAnnex,
 	tryAnnex,
 	tryAnnexIO,
 	throwAnnex,
@@ -29,6 +30,9 @@ import Common.Annex
 bracketIO :: IO v -> (v -> IO b) -> (v -> Annex a) -> Annex a
 bracketIO setup cleanup = M.bracket (liftIO setup) (liftIO . cleanup)
 
+bracketAnnex :: Annex v -> (v -> Annex b) -> (v -> Annex a) -> Annex a
+bracketAnnex = M.bracket
+
 {- try in the Annex monad -}
 tryAnnex :: Annex a -> Annex (Either SomeException a)
 tryAnnex = M.try
diff --git a/Locations.hs b/Locations.hs
index 47a009590..1173677cf 100644
--- a/Locations.hs
+++ b/Locations.hs
@@ -14,6 +14,7 @@ module Locations (
 	objectDir,
 	gitAnnexLocation,
 	gitAnnexLink,
+	gitAnnexContentLock,
 	gitAnnexMapping,
 	gitAnnexInodeCache,
 	gitAnnexInodeSentinal,
@@ -142,6 +143,12 @@ gitAnnexLink file key r = do
   where
   	whoops = error $ "unable to normalize " ++ file
 
+{- File used to lock a key's content. -}
+gitAnnexContentLock :: Key -> Git.Repo -> GitConfig -> IO FilePath
+gitAnnexContentLock key r config = do
+	loc <- gitAnnexLocation key r config
+	return $ loc ++ ".lck"
+
 {- File that maps from a key to the file(s) in the git repository.
  - Used in direct mode. -}
 gitAnnexMapping :: Key -> Git.Repo -> GitConfig -> IO FilePath
diff --git a/debian/changelog b/debian/changelog
index f6eec27e1..a6c45e5b0 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -2,6 +2,8 @@ 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.
+  * Fixed direct mode annexed content locking code, which is used to
+    guard against recursive file drops.
 
  -- Joey Hess <joeyh@debian.org>  Tue, 28 Jan 2014 13:57:19 -0400
 
diff --git a/doc/todo/windows_support.mdwn b/doc/todo/windows_support.mdwn
index fea8241cc..c7aa402e3 100644
--- a/doc/todo/windows_support.mdwn
+++ b/doc/todo/windows_support.mdwn
@@ -7,8 +7,6 @@ now! --[[Joey]]
   support use of DOS style paths, which git-annex uses on Windows). 
   Must use Msysgit.
 * rsync special remotes are known buggy.
-* Bad file locking, it's probably not safe to run more than one git-annex
-  process at the same time on Windows.
 * Ssh connection caching does not work on Windows, so `git annex get`
   has to connect twice to the remote system over ssh per file, which
   is much slower than on systems supporting connection caching.