add back debug logging

Make Utility.Process wrap the parts of System.Process that I use,
and add debug logging to them.

Also wrote some higher-level code that allows running an action
with handles to a processes stdin or stdout (or both), and checking
its exit status, all in a single function call.

As a bonus, the debug logging now indicates whether the process
is being run to read from it, feed it data, chat with it (writing and
reading), or just call it for its side effect.
This commit is contained in:
Joey Hess 2012-07-19 00:43:36 -04:00
parent 549f861999
commit 1db7d27a45
17 changed files with 251 additions and 126 deletions

View file

@ -7,7 +7,6 @@
module Git.Command where
import System.Process
import System.Posix.Process (getAnyProcessStatus)
import Common
@ -41,12 +40,12 @@ run subcommand params repo = assertLocal repo $
- result unless reap is called.
-}
pipeRead :: [CommandParam] -> Repo -> IO String
pipeRead params repo = assertLocal repo $ do
(_, Just h, _, _) <- createProcess
(proc "git" $ toCommand $ gitCommandLine params repo)
{ std_out = CreatePipe }
fileEncoding h
hGetContents h
pipeRead params repo = assertLocal repo $
withHandle StdoutHandle createBackgroundProcess p $ \h -> do
fileEncoding h
hGetContents h
where
p = proc "git" $ toCommand $ gitCommandLine params repo
{- Runs a git subcommand, feeding it input, and returning its output,
- which is expected to be fairly small, since it's all read into memory

View file

@ -9,7 +9,7 @@ module Git.Config where
import qualified Data.Map as M
import Data.Char
import System.Process
import System.Process (cwd)
import Common
import Git
@ -48,14 +48,11 @@ read' repo = go repo
go Repo { location = Local { gitdir = d } } = git_config d
go Repo { location = LocalUnknown d } = git_config d
go _ = assertLocal repo $ error "internal"
git_config d = do
(_, Just h, _, pid)
<- createProcess (proc "git" params)
{ std_out = CreatePipe, cwd = Just d }
repo' <- hRead repo h
forceSuccessProcess pid "git" params
return repo'
params = ["config", "--null", "--list"]
git_config d = withHandle StdoutHandle createProcessSuccess p $
hRead repo
where
params = ["config", "--null", "--list"]
p = (proc "git" params) { cwd = Just d }
{- Reads git config from a handle and populates a repo with it. -}
hRead :: Repo -> Handle -> IO Repo

View file

@ -19,7 +19,6 @@ module Git.Queue (
import qualified Data.Map as M
import System.IO
import System.Process
import Data.String.Utils
import Utility.SafeCommand
@ -148,13 +147,11 @@ runAction :: Repo -> Action -> IO ()
runAction repo (UpdateIndexAction streamers) =
-- list is stored in reverse order
Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers
runAction repo action@(CommandAction {}) = do
(Just h, _, _, pid) <- createProcess (proc "xargs" params)
{ std_in = CreatePipe }
fileEncoding h
hPutStr h $ join "\0" $ getFiles action
hClose h
forceSuccessProcess pid "xargs" params
runAction repo action@(CommandAction {}) =
withHandle StdinHandle createProcessSuccess (proc "xargs" params) $ \h -> do
fileEncoding h
hPutStr h $ join "\0" $ getFiles action
hClose h
where
params = "-0":"git":baseparams
baseparams = toCommand $ gitCommandLine

View file

@ -17,8 +17,6 @@ module Git.UpdateIndex (
stageSymlink
) where
import System.Process
import Common
import Git
import Git.Types
@ -36,12 +34,11 @@ pureStreamer !s = \streamer -> streamer s
{- Streams content into update-index from a list of Streamers. -}
streamUpdateIndex :: Repo -> [Streamer] -> IO ()
streamUpdateIndex repo as = do
(Just h, _, _, p) <- createProcess (proc "git" ps) { std_in = CreatePipe }
fileEncoding h
forM_ as (stream h)
hClose h
forceSuccessProcess p "git" ps
streamUpdateIndex repo as =
withHandle StdinHandle createProcessSuccess (proc "git" ps) $ \h -> do
fileEncoding h
forM_ as (stream h)
hClose h
where
ps = toCommand $ gitCommandLine params repo
params = map Param ["update-index", "-z", "--index-info"]