From d1da9cf221aeea5c7ac8a313a18b559791a04f12 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 18 Jul 2012 15:30:26 -0400 Subject: switch from System.Cmd.Utils to System.Process Test suite now passes with -threaded! I traced back all the hangs with -threaded to System.Cmd.Utils. It seems it's just crappy/unsafe/outdated, and should not be used. System.Process seems to be the cool new thing, so converted all the code to use it instead. In the process, --debug stopped printing commands it runs. I may try to bring that back later. Note that even SafeSystem was switched to use System.Process. Since that was a modified version of code from System.Cmd.Utils, it needed to be converted too. I also got rid of nearly all calls to forkProcess, and all calls to executeFile, which I'm also doubtful about working well with -threaded. --- Git/Branch.hs | 2 -- Git/CatFile.hs | 12 +----------- Git/CheckAttr.hs | 4 ---- Git/Command.hs | 29 +++++++---------------------- Git/Config.hs | 14 ++++++++++---- Git/Queue.hs | 17 ++++++++++------- Git/Ref.hs | 5 +---- Git/UpdateIndex.hs | 7 ++++--- 8 files changed, 33 insertions(+), 57 deletions(-) (limited to 'Git') diff --git a/Git/Branch.hs b/Git/Branch.hs index 6f3d25186..4d239d8fc 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -76,9 +76,7 @@ commit message branch parentrefs repo = do sha <- getSha "commit-tree" $ pipeWriteRead (map Param $ ["commit-tree", show tree] ++ ps) message repo - print ("got", sha) run "update-ref" [Param $ show branch, Param $ show sha] repo - print ("update-ref done", sha) return sha where ps = concatMap (\r -> ["-p", show r]) parentrefs diff --git a/Git/CatFile.hs b/Git/CatFile.hs index e8f362685..e667b2087 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -50,16 +50,11 @@ catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha)) catObjectDetails h object = CoProcess.query h send receive where send to = do - putStrLn "catObjectDetails send start" fileEncoding to hPutStrLn to $ show object - putStrLn $ "catObjectDetails send done " ++ show object receive from = do - putStrLn "catObjectDetails read header start" fileEncoding from - putStrLn "catObjectDetails read header start2" header <- hGetLine from - putStrLn "catObjectDetails read header done" case words header of [sha, objtype, size] | length sha == shaSize && @@ -72,14 +67,9 @@ catObjectDetails h object = CoProcess.query h send receive | header == show object ++ " missing" -> dne | otherwise -> error $ "unknown response from git cat-file " ++ show (header, object) readcontent bytes from sha = do - putStrLn "readcontent start" content <- S.hGet from bytes - putStrLn "readcontent end" c <- hGetChar from - putStrLn "readcontent newline read" when (c /= '\n') $ error "missing newline from git cat-file" return $ Just (L.fromChunks [content], Ref sha) - dne = do - putStrLn "dne" - return Nothing + dne = return Nothing diff --git a/Git/CheckAttr.hs b/Git/CheckAttr.hs index 7636ea641..6b321f8b8 100644 --- a/Git/CheckAttr.hs +++ b/Git/CheckAttr.hs @@ -44,15 +44,11 @@ checkAttr (h, attrs, cwd) want file = do _ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file where send to = do - putStrLn "checkAttr send start" fileEncoding to hPutStr to $ file' ++ "\0" - putStrLn "checkAttr send end" receive from = forM attrs $ \attr -> do - putStrLn "checkAttr receive start" fileEncoding from l <- hGetLine from - putStrLn "checkAttr receive end" return (attr, attrvalue attr l) {- Before git 1.7.7, git check-attr worked best with - absolute filenames; using them worked around some bugs diff --git a/Git/Command.hs b/Git/Command.hs index 9a09300e2..038824f26 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -7,10 +7,8 @@ module Git.Command where -import qualified Data.Text.Lazy as L -import qualified Data.Text.Lazy.IO as L -import Control.Concurrent -import Control.Exception (finally) +import System.Process +import System.Posix.Process (getAnyProcessStatus) import Common import Git @@ -44,31 +42,18 @@ run subcommand params repo = assertLocal repo $ -} pipeRead :: [CommandParam] -> Repo -> IO String pipeRead params repo = assertLocal repo $ do - (_, h) <- hPipeFrom "git" $ toCommand $ gitCommandLine params repo + (_, Just h, _, _) <- createProcess + (proc "git" $ toCommand $ gitCommandLine params repo) + { std_out = CreatePipe } fileEncoding h hGetContents h -{- Runs a git subcommand, feeding it input. - - You should call either getProcessStatus or forceSuccess on the PipeHandle. -} -pipeWrite :: [CommandParam] -> L.Text -> Repo -> IO PipeHandle -pipeWrite params s repo = assertLocal repo $ do - (p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo) - L.hPutStr h s - hClose h - return p - {- 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 - strictly. -} pipeWriteRead :: [CommandParam] -> String -> Repo -> IO String -pipeWriteRead params s repo = assertLocal repo $ do - (p, from, to) <- hPipeBoth "git" (toCommand $ gitCommandLine params repo) - fileEncoding to - fileEncoding from - _ <- forkIO $ finally (hPutStr to s) (hClose to) - c <- hGetContentsStrict from - forceSuccess p - return c +pipeWriteRead params s repo = assertLocal repo $ + readProcess "git" (toCommand $ gitCommandLine params repo) s {- Reads null terminated output of a git command (as enabled by the -z - parameter), and splits it. -} diff --git a/Git/Config.hs b/Git/Config.hs index c9e4f9a2d..234750113 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -9,6 +9,7 @@ module Git.Config where import qualified Data.Map as M import Data.Char +import System.Process import Common import Git @@ -39,7 +40,7 @@ reRead :: Repo -> IO Repo reRead = read' {- Cannot use pipeRead because it relies on the config having been already - - read. Instead, chdir to the repo. + - read. Instead, chdir to the repo and run git config. -} read' :: Repo -> IO Repo read' repo = go repo @@ -47,9 +48,14 @@ 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 = bracketCd d $ - pOpen ReadFromPipe "git" ["config", "--null", "--list"] $ - hRead repo + 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"] {- Reads git config from a handle and populates a repo with it. -} hRead :: Repo -> Handle -> IO Repo diff --git a/Git/Queue.hs b/Git/Queue.hs index ddcf13519..4e6f05c2e 100644 --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -19,7 +19,7 @@ module Git.Queue ( import qualified Data.Map as M import System.IO -import System.Cmd.Utils +import System.Process import Data.String.Utils import Utility.SafeCommand @@ -148,11 +148,14 @@ runAction :: Repo -> Action -> IO () runAction repo (UpdateIndexAction streamers) = -- list is stored in reverse order Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers -runAction repo action@(CommandAction {}) = - pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs +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 where - params = toCommand $ gitCommandLine + params = "-0":"git":baseparams + baseparams = toCommand $ gitCommandLine (Param (getSubcommand action):getParams action) repo - feedxargs h = do - fileEncoding h - hPutStr h $ join "\0" $ getFiles action diff --git a/Git/Ref.hs b/Git/Ref.hs index 3052d0a6e..ee2f02187 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -40,10 +40,7 @@ exists ref = runBool "show-ref" {- Get the sha of a fully qualified git ref, if it exists. -} sha :: Branch -> Repo -> IO (Maybe Sha) -sha branch repo = do - r <- process <$> showref repo - print r - return r +sha branch repo = process <$> showref repo where showref = pipeRead [Param "show-ref", Param "--hash", -- get the hash diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index abdc4bcbe..6de0c3ada 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -17,7 +17,7 @@ module Git.UpdateIndex ( stageSymlink ) where -import System.Cmd.Utils +import System.Process import Common import Git @@ -37,12 +37,13 @@ pureStreamer !s = \streamer -> streamer s {- Streams content into update-index from a list of Streamers. -} streamUpdateIndex :: Repo -> [Streamer] -> IO () streamUpdateIndex repo as = do - (p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo) + (Just h, _, _, p) <- createProcess (proc "git" ps) { std_in = CreatePipe } fileEncoding h forM_ as (stream h) hClose h - forceSuccess p + forceSuccessProcess p "git" ps where + ps = toCommand $ gitCommandLine params repo params = map Param ["update-index", "-z", "--index-info"] stream h a = a (streamer h) streamer h s = do -- cgit v1.2.3