diff options
| -rw-r--r-- | Git/CatFile.hs | 2 | ||||
| -rw-r--r-- | Git/CheckAttr.hs | 2 | ||||
| -rw-r--r-- | Git/Command.hs | 6 | ||||
| -rw-r--r-- | Git/HashObject.hs | 2 | ||||
| -rw-r--r-- | Utility/CoProcess.hs | 77 | ||||
| -rw-r--r-- | debian/changelog | 2 |
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 |