diff options
author | Joey Hess <joeyh@debian.org> | 2013-11-22 11:16:03 -0400 |
---|---|---|
committer | Joey Hess <joeyh@debian.org> | 2013-11-22 11:16:03 -0400 |
commit | 7e592e1d6ed5e0b25b37215da7558c6324688d6f (patch) | |
tree | 75a86ff02e9311bcff817f2dcfe9b0a6ca1b5708 /Utility/CoProcess.hs | |
download | git-repair-7e592e1d6ed5e0b25b37215da7558c6324688d6f.tar.gz |
git-repair (1.20131122) unstable; urgency=low
* Added test mode, which can be used to randomly corrupt test
repositories, in reproducible ways, which allows easy
corruption-driven-development.
* Improve repair code in the case where the index file is corrupt,
and this hides other problems.
* Write a dummy .git/HEAD if the file is missing or corrupt, as
git otherwise will not treat the repository as a git repo.
* Improve fsck code to find badly corrupted objects that crash git fsck
before it can complain about them.
* Fixed crashes on bad file encodings.
* Can now run 10000 tests (git-repair --test -n 10000 --force)
with 0 failures.
# imported from the archive
Diffstat (limited to 'Utility/CoProcess.hs')
-rw-r--r-- | Utility/CoProcess.hs | 93 |
1 files changed, 93 insertions, 0 deletions
diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs new file mode 100644 index 0000000..710d2af --- /dev/null +++ b/Utility/CoProcess.hs @@ -0,0 +1,93 @@ +{- 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 + (pid, from, to) <- startInteractiveProcess (coProcessCmd s) (coProcessParams s) (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 mingw32_HOST_OS + hSetNewlineMode h noNewlineTranslation +#endif |