Can now restart certain long-running git processes if they crash, and continue working.

Fuzz tests have shown that git cat-file --batch sometimes stops running.
It's not yet known why (no error message; repo seems ok). But this is
something we can deal with in the CoProcess framework, since all 3 types of
long-running git processes should be restartable if they fail.

Note that, as implemented, only IO errors are caught. So an error thrown
by the reveiver, when it sees something that is not valid output from
git cat-file (etc) will not cause a restart. I don't want it to retry
if git commands change their output or are just outputting garbage.
This does mean that if the command did a partial output and crashed in the
middle, it would still not be restarted.

There is currently no guard against restarting a command repeatedly, if,
for example, it crashes repeatedly on startup.

6 files changed, 69 insertions, 22 deletions

diff --git a/Git/CatFile.hs b/Git/CatFile.hs
index 5ab10b187..d95972393 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -29,7 +29,7 @@ import qualified Utility.CoProcess as CoProcess
 type CatFileHandle = CoProcess.CoProcessHandle
 
 catFileStart :: Repo -> IO CatFileHandle
-catFileStart = CoProcess.rawMode <=< gitCoProcessStart
+catFileStart = CoProcess.rawMode <=< gitCoProcessStart True
 	[ Param "cat-file"
 	, Param "--batch"
 	]
diff --git a/Git/CheckAttr.hs b/Git/CheckAttr.hs
index b3055fd4c..0bf6a3931 100644
--- a/Git/CheckAttr.hs
+++ b/Git/CheckAttr.hs
@@ -22,7 +22,7 @@ type Attr = String
 checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle
 checkAttrStart attrs repo = do
 	cwd <- getCurrentDirectory
-	h <- CoProcess.rawMode =<< gitCoProcessStart params repo
+	h <- CoProcess.rawMode =<< gitCoProcessStart True params repo
 	return (h, attrs, cwd)
   where
 	params =
diff --git a/Git/Command.hs b/Git/Command.hs
index e6cec16fb..648da985b 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -109,8 +109,10 @@ leaveZombie :: (a, IO Bool) -> a
 leaveZombie = fst
 
 {- Runs a git command as a coprocess. -}
-gitCoProcessStart :: [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle
-gitCoProcessStart params repo = CoProcess.start "git" (toCommand $ gitCommandLine params repo) (gitEnv repo)
+gitCoProcessStart :: Bool -> [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle
+gitCoProcessStart restartable params repo = CoProcess.start restartable "git"
+	(toCommand $ gitCommandLine params repo)
+	(gitEnv repo)
 
 gitCreateProcess :: [CommandParam] -> Repo -> CreateProcess
 gitCreateProcess params repo =
diff --git a/Git/HashObject.hs b/Git/HashObject.hs
index bf3ca7f8b..1991ea4a5 100644
--- a/Git/HashObject.hs
+++ b/Git/HashObject.hs
@@ -17,7 +17,7 @@ import qualified Utility.CoProcess as CoProcess
 type HashObjectHandle = CoProcess.CoProcessHandle
 
 hashObjectStart :: Repo -> IO HashObjectHandle
-hashObjectStart = CoProcess.rawMode <=< gitCoProcessStart
+hashObjectStart = CoProcess.rawMode <=< gitCoProcessStart True
 	[ Param "hash-object"
 	, Param "-w"
 	, Param "--stdin-paths"
diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs
index f72850fc5..534229d51 100644
--- a/Utility/CoProcess.hs
+++ b/Utility/CoProcess.hs
@@ -1,7 +1,7 @@
 {- Interface for running a shell command as a coprocess,
  - sending it queries and getting back results.
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -18,29 +18,72 @@ module Utility.CoProcess (
 
 import Common
 
-type CoProcessHandle = (ProcessHandle, Handle, Handle, CreateProcess)
+import Control.Concurrent.MVar
 
-start :: FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle
-start command params env = do
-	(from, to, _err, pid) <- runInteractiveProcess command params Nothing env
-	return (pid, to, from, proc command params)
+type CoProcessHandle = MVar CoProcessState
+
+data CoProcessState = CoProcessState
+	{ coProcessPid :: ProcessHandle
+	, coProcessTo :: Handle
+	, coProcessFrom :: Handle
+	, coProcessSpec :: CoProcessSpec
+	}
+
+data CoProcessSpec = CoProcessSpec
+	{ coProcessRestartable :: Bool
+	, coProcessCmd :: FilePath
+	, coProcessParams :: [String]
+	, coProcessEnv :: Maybe [(String, String)]
+	}
+
+start :: Bool -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle
+start restartable cmd params env = do
+	s <- start' $ CoProcessSpec restartable cmd params env
+	newMVar s
+
+start' :: CoProcessSpec -> IO CoProcessState
+start' s = do
+	(to, from, _err, pid) <- runInteractiveProcess (coProcessCmd s) (coProcessParams s) Nothing (coProcessEnv s)
+	return $ CoProcessState pid to from s
 
 stop :: CoProcessHandle -> IO ()
-stop (pid, from, to, p) = do
-	hClose to
-	hClose from
-	forceSuccessProcess p pid
+stop ch = do
+	s <- readMVar ch
+	hClose $ coProcessTo s
+	hClose $ coProcessFrom s
+	let p = proc (coProcessCmd $ coProcessSpec s) (coProcessParams $ coProcessSpec s)
+	forceSuccessProcess p (coProcessPid s)
 
+{- To handle a restartable process, any IO exception thrown by the send and
+ - receive actions are assumed to mean communication with the process
+ - failed, and the failed action is re-run with a new process. -}
 query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b
-query (_, from, to, _) send receive = do
-	_ <- send to
-	hFlush to
-	receive from
+query ch send receive = do
+	s <- readMVar ch
+	restartable s (send $ coProcessTo s) $ const $
+		restartable s (hFlush $ coProcessTo s) $ const $
+			restartable s (receive $ coProcessFrom s) $
+				return
+  where
+  	restartable s a cont
+		| coProcessRestartable (coProcessSpec s) =
+			maybe restart cont =<< catchMaybeIO a
+		| otherwise = cont =<< a
+	restart = do
+		s <- takeMVar ch
+		void $ catchMaybeIO $ do
+			hClose $ coProcessTo s
+			hClose $ coProcessFrom s
+		void $ waitForProcess $ coProcessPid s
+		s' <- start' (coProcessSpec s)
+		putMVar ch s'
+		query ch send receive
 
 rawMode :: CoProcessHandle -> IO CoProcessHandle
-rawMode ch@(_, from, to, _) = do
-	raw from
-	raw to
+rawMode ch = do
+	s <- readMVar ch
+	raw $ coProcessFrom s
+	raw $ coProcessTo s
 	return ch
   where
   	raw h = do
diff --git a/debian/changelog b/debian/changelog
index 2c40b472d..3d4f30378 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -21,6 +21,8 @@ git-annex (4.20130522) UNRELEASED; urgency=low
   * XMPP: Fix a file descriptor leak.
   * Android: Added an "Open WebApp" item to the terminal's menu.
     Should work for Android devices that cannot auto-open the webapp on start.
+  * Can now restart certain long-running git processes if they crash, and
+    continue working.
 
  -- Joey Hess <joeyh@debian.org>  Tue, 21 May 2013 18:22:46 -0400