diff options
Diffstat (limited to 'Git')
| -rw-r--r-- | Git/Branch.hs | 39 | ||||
| -rw-r--r-- | Git/Command.hs | 40 | ||||
| -rw-r--r-- | Git/Config.hs | 11 | ||||
| -rw-r--r-- | Git/HashObject.hs | 8 | ||||
| -rw-r--r-- | Git/Queue.hs | 12 | ||||
| -rw-r--r-- | Git/UpdateIndex.hs | 14 |
6 files changed, 64 insertions, 60 deletions
diff --git a/Git/Branch.hs b/Git/Branch.hs index 6edc1c306..f73ae5e2a 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE BangPatterns #-} + module Git.Branch where import Common @@ -12,13 +14,32 @@ import Git import Git.Sha import Git.Command -{- The currently checked out branch. -} +{- The currently checked out branch. + - + - In a just initialized git repo before the first commit, + - symbolic-ref will show the master branch, even though that + - branch is not created yet. So, this also looks at show-ref HEAD + - to double-check. + -} current :: Repo -> IO (Maybe Git.Ref) -current r = parse <$> pipeRead [Param "symbolic-ref", Param "HEAD"] r +current r = do + v <- currentUnsafe r + case v of + Nothing -> return Nothing + Just branch -> + ifM (null <$> pipeRead [Param "show-ref", Param $ show branch] r) + ( return Nothing + , return v + ) + +{- The current branch, which may not really exist yet. -} +currentUnsafe :: Repo -> IO (Maybe Git.Ref) +currentUnsafe r = parse . firstLine + <$> pipeRead [Param "symbolic-ref", Param "HEAD"] r where - parse v - | null v = Nothing - | otherwise = Just $ Git.Ref $ firstLine v + parse l + | null l = Nothing + | otherwise = Just $ Git.Ref l {- Checks if the second branch has any commits not present on the first - branch. -} @@ -73,12 +94,10 @@ commit :: String -> Branch -> [Ref] -> Repo -> IO Sha commit message branch parentrefs repo = do tree <- getSha "write-tree" $ pipeRead [Param "write-tree"] repo - sha <- getSha "commit-tree" $ - ignorehandle $ pipeWriteRead - (map Param $ ["commit-tree", show tree] ++ ps) - message repo + sha <- getSha "commit-tree" $ pipeWriteRead + (map Param $ ["commit-tree", show tree] ++ ps) + message repo run "update-ref" [Param $ show branch, Param $ show sha] repo return sha where - ignorehandle a = snd <$> a ps = concatMap (\r -> ["-p", show r]) parentrefs diff --git a/Git/Command.hs b/Git/Command.hs index 35f0838ba..cd6c98d33 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -7,10 +7,7 @@ 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.Posix.Process (getAnyProcessStatus) import Common import Git @@ -43,30 +40,19 @@ run subcommand params repo = assertLocal repo $ - result unless reap is called. -} pipeRead :: [CommandParam] -> Repo -> IO String -pipeRead params repo = assertLocal repo $ do - (_, h) <- hPipeFrom "git" $ toCommand $ gitCommandLine params repo - 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 +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. - - You should call either getProcessStatus or forceSuccess on the PipeHandle. -} -pipeWriteRead :: [CommandParam] -> String -> Repo -> IO (PipeHandle, 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 <- hGetContents from - return (p, c) +{- 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 $ + writeReadProcess "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..c82d6bb1b 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 (cwd) 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,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 = bracketCd d $ - pOpen ReadFromPipe "git" ["config", "--null", "--list"] $ - hRead repo + 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 diff --git a/Git/HashObject.hs b/Git/HashObject.hs index 9f37de5ba..c90c9ec3d 100644 --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -38,11 +38,9 @@ hashFile h file = CoProcess.query h send receive {- Injects some content into git, returning its Sha. -} hashObject :: ObjectType -> String -> Repo -> IO Sha hashObject objtype content repo = getSha subcmd $ do - (h, s) <- pipeWriteRead (map Param params) content repo - length s `seq` do - forceSuccess h - reap -- XXX unsure why this is needed - return s + s <- pipeWriteRead (map Param params) content repo + reap -- XXX unsure why this is needed, of if it is anymore + return s where subcmd = "hash-object" params = [subcmd, "-t", show objtype, "-w", "--stdin"] diff --git a/Git/Queue.hs b/Git/Queue.hs index ddcf13519..f515ad104 100644 --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -19,7 +19,6 @@ module Git.Queue ( import qualified Data.Map as M import System.IO -import System.Cmd.Utils import Data.String.Utils import Utility.SafeCommand @@ -149,10 +148,11 @@ 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 + withHandle StdinHandle createProcessSuccess (proc "xargs" params) $ \h -> do + fileEncoding h + hPutStr h $ join "\0" $ getFiles action + hClose h 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/UpdateIndex.hs b/Git/UpdateIndex.hs index abdc4bcbe..929448729 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -17,8 +17,6 @@ module Git.UpdateIndex ( stageSymlink ) where -import System.Cmd.Utils - import Common import Git import Git.Types @@ -36,13 +34,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) - fileEncoding h - forM_ as (stream h) - hClose h - forceSuccess p +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"] stream h a = a (streamer h) streamer h s = do |