91c4dcfc69
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.
93 lines
2.4 KiB
Haskell
93 lines
2.4 KiB
Haskell
{- Interface for running a shell command as a coprocess,
|
|
- sending it queries and getting back results.
|
|
-
|
|
- Copyright 2012-2013 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Utility.CoProcess (
|
|
CoProcessHandle,
|
|
start,
|
|
stop,
|
|
query,
|
|
rawMode
|
|
) where
|
|
|
|
import Common
|
|
|
|
import Control.Concurrent.MVar
|
|
|
|
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 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 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 = do
|
|
s <- readMVar ch
|
|
raw $ coProcessFrom s
|
|
raw $ coProcessTo s
|
|
return ch
|
|
where
|
|
raw h = do
|
|
fileEncoding h
|
|
#ifdef __WINDOWS__
|
|
hSetNewlineMode h noNewlineTranslation
|
|
#endif
|