fixed reconcileStaged crash when index is locked or in conflict

Eg, when git commit runs the smudge filter.

Commit 428c91606b introduced the crash,
as write-tree fails in those situations. Now it will work, and git-annex
always gets up-to-date information even in those situations. It does
need to do a bit more work, each time git-annex is run with the index
locked. Although if the index is unmodified from the last time
write-tree succeeded, that work is avoided.

Database/Keys.hs

@@ -45,7 +45,7 @@ import Git.Command
 import Git.Types
 import Git.Index
 import Git.Sha
-import Git.Branch (writeTree, update')
+import Git.Branch (writeTreeQuiet, update')
 import qualified Git.Ref
 import Config.Smudge
 import qualified Utility.RawFilePath as R
@@ -226,35 +226,48 @@ reconcileStaged qh = do
 	withTSDelta (liftIO . genInodeCache gitindex) >>= \case
 		Just cur -> 
 			liftIO (maybe Nothing readInodeCache <$> catchMaybeIO (readFile indexcache)) >>= \case
-				Nothing -> go cur indexcache
+				Nothing -> go cur indexcache =<< getindextree
 				Just prev -> ifM (compareInodeCaches prev cur)
 					( noop
-					, go cur indexcache
+					, go cur indexcache =<< getindextree
 					)
 		Nothing -> noop
   where
 	lastindexref = Ref "refs/annex/last-index"
 
-	go cur indexcache = do
-		oldtree <- fromMaybe emptyTree
-			<$> inRepo (Git.Ref.sha lastindexref)
-		newtree <- inRepo writeTree
+	getindextree = inRepo writeTreeQuiet
+
+	getoldtree = fromMaybe emptyTree <$> inRepo (Git.Ref.sha lastindexref)
+
+	go cur indexcache (Just newtree) = do
+		oldtree <- getoldtree
 		when (oldtree /= newtree) $ do
-			(l, cleanup) <- inRepo $ pipeNullSplit' $
-				diff oldtree newtree
-			changed <- procdiff l False
-			void $ liftIO cleanup
-			-- Flush database changes immediately
-			-- so other processes can see them.
-			when changed $
-				liftIO $ H.flushDbQueue qh
+			updatetodiff (fromRef oldtree) (fromRef newtree)
 			liftIO $ writeFile indexcache $ showInodeCache cur
 			-- Storing the tree in a ref makes sure it does not
 			-- get garbage collected, and is available to diff
 			-- against next time.
 			inRepo $ update' lastindexref newtree
+	-- git write-tree will fail if the index is locked or when there is
+	-- a merge conflict. To get up-to-date with the current index, 
+	-- diff --cached with the old index tree. The current index tree
+	-- is not known, so not recorded, and the inode cache is not updated,
+	-- so the next time git-annex runs, it will diff again, even
+	-- if the index is unchanged.
+	go _ _ Nothing = do
+		oldtree <- getoldtree
+		updatetodiff (fromRef oldtree) "--cached"
+		
+	updatetodiff old new = do
+		(l, cleanup) <- inRepo $ pipeNullSplit' $ diff old new
+		changed <- procdiff l False
+		void $ liftIO cleanup
+		-- Flush database changes immediately
+		-- so other processes can see them.
+		when changed $
+			liftIO $ H.flushDbQueue qh
 	
-	diff oldtree newtree =
+	diff old new =
 		-- Avoid running smudge or clean filters, since we want the
 		-- raw output, and they would block trying to access the
 		-- locked database. The --raw normally avoids git diff
@@ -264,6 +277,8 @@ reconcileStaged qh = do
 		-- (The -G option may make it be used otherwise.)
 		[ Param "-c", Param "diff.external="
 		, Param "diff"
+		, Param old
+		, Param new
 		, Param "--raw"
 		, Param "-z"
 		, Param "--no-abbrev"
@@ -279,8 +294,6 @@ reconcileStaged qh = do
 		-- Avoid other complications.
 		, Param "--ignore-submodules=all"
 		, Param "--no-ext-diff"
-		, Param (fromRef oldtree)
-		, Param (fromRef newtree)
 		]
 	
 	procdiff (info:file:rest) changed

Git/Branch.hs

@@ -185,8 +185,18 @@ commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha
 commitAlways commitmode message branch parentrefs repo = fromJust
 	<$> commit commitmode True message branch parentrefs repo
 
+-- Throws exception if the index is locked, with an error message output by
+-- git on stderr.
 writeTree :: Repo -> IO Sha
-writeTree repo = getSha "write-tree" $ pipeReadStrict [Param "write-tree"] repo
+writeTree repo = getSha "write-tree" $
+	pipeReadStrict [Param "write-tree"] repo
+
+-- Avoids error output if the command fails due to eg, the index being locked.
+writeTreeQuiet :: Repo -> IO (Maybe Sha)
+writeTreeQuiet repo = extractSha <$> withNullHandle go
+  where
+	go nullh = pipeReadStrict' (\p -> p { std_err = UseHandle nullh }) 
+		[Param "write-tree"] repo
 
 commitTree :: CommitMode -> String -> [Ref] -> Ref -> Repo -> IO Sha
 commitTree commitmode message parentrefs tree repo =

Git/Command.hs

@@ -70,17 +70,15 @@ pipeReadLazy params repo = assertLocal repo $ do
  - Nonzero exit status is ignored.
  -}
 pipeReadStrict :: [CommandParam] -> Repo -> IO S.ByteString
-pipeReadStrict = pipeReadStrict' S.hGetContents
+pipeReadStrict = pipeReadStrict' id
 
-{- The reader action must be strict. -}
-pipeReadStrict' :: (Handle -> IO a) -> [CommandParam] -> Repo -> IO a
-pipeReadStrict' reader params repo = assertLocal repo $ withCreateProcess p go
+pipeReadStrict' :: (CreateProcess -> CreateProcess) -> [CommandParam] -> Repo -> IO S.ByteString
+pipeReadStrict' fp params repo = assertLocal repo $ withCreateProcess p go
   where
-	p  = (gitCreateProcess params repo)
-		{ std_out = CreatePipe }
+	p = fp (gitCreateProcess params repo) { std_out = CreatePipe }
 
 	go _ (Just outh) _ pid = do
-		output <- reader outh
+		output <- S.hGetContents outh
 		hClose outh
 		void $ waitForProcess pid
 		return output