finally merge the assistant into master

Progress bars still need to be done, otherwise it's fully working.
Although much work remains to hit all the use cases.

9 files changed, 100 insertions, 65 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..04b0723d0 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.Posix.Process (getAnyProcessStatus)
+import System.Process
 
 import Common
 import Git
@@ -29,7 +27,9 @@ gitCommandLine _ repo = assertLocal repo $ error "internal"
 {- Runs git in the specified repo. -}
 runBool :: String -> [CommandParam] -> Repo -> IO Bool
 runBool subcommand params repo = assertLocal repo $
-	boolSystem "git" $ gitCommandLine (Param subcommand : params) repo
+	boolSystemEnv "git"
+		(gitCommandLine (Param subcommand : params) repo)
+		(gitEnv repo)
 
 {- Runs git in the specified repo, throwing an error if it fails. -}
 run :: String -> [CommandParam] -> Repo -> IO ()
@@ -43,30 +43,28 @@ 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
+pipeRead params repo = assertLocal repo $
+	withHandle StdoutHandle createBackgroundProcess p $ \h -> do
+		fileEncoding h
+		hGetContents h
+	where
+		p  = (proc "git" $ toCommand $ gitCommandLine params repo)
+			{ env = gitEnv repo }
 
-{- 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 $
+	writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) 
+		(gitEnv repo) s
 
-{- 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 on a handle with an action. -}
+pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO ()
+pipeWrite params repo = withHandle StdinHandle createProcessSuccess p
+	where
+		p = (proc "git" $ toCommand $ gitCommandLine params repo)
+			{ env = gitEnv repo }
 
 {- 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..fb0c24bab 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, env)
 
 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,24 @@ 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
+					, env = gitEnv repo
+					}
+
+{- Gets the global git config, returning a dummy Repo containing it. -}
+global :: IO Repo
+global = do
+	repo <- Git.Construct.fromUnknown
+	withHandle StdoutHandle createProcessSuccess p $
+		hRead repo
+	where
+		params = ["config", "--null", "--list", "--global"]
+		p = (proc "git" params)
 
 {- Reads git config from a handle and populates a repo with it. -}
 hRead :: Repo -> Handle -> IO Repo
diff --git a/Git/Construct.hs b/Git/Construct.hs
index b809d7318..90bedbde1 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -225,6 +225,7 @@ newFrom l = return Repo
 	, fullconfig = M.empty
 	, remotes = []
 	, remoteName = Nothing
+	, gitEnv = Nothing
 	}
 
 
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/Index.hs b/Git/Index.hs
index aaf54e032..d6fa4ee6c 100644
--- a/Git/Index.hs
+++ b/Git/Index.hs
@@ -12,7 +12,10 @@ import System.Posix.Env (setEnv, unsetEnv, getEnv)
 {- Forces git to use the specified index file.
  -
  - Returns an action that will reset back to the default
- - index file. -}
+ - index file.
+ -
+ - Warning: Not thread safe.
+ -}
 override :: FilePath -> IO (IO ())
 override index = do
 	res <- getEnv var
diff --git a/Git/Queue.hs b/Git/Queue.hs
index ddcf13519..9f7a44882 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
@@ -149,10 +149,12 @@ 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 p $ \h -> do
+		fileEncoding h
+		hPutStr h $ join "\0" $ getFiles action
+		hClose h
 	where
-		params = toCommand $ gitCommandLine
+		p = (proc "xargs" params) { env = gitEnv repo }
+		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/Types.hs b/Git/Types.hs
index 0c37427c7..57e5ca6e2 100644
--- a/Git/Types.hs
+++ b/Git/Types.hs
@@ -27,15 +27,17 @@ data RepoLocation
 	| Unknown
 	deriving (Show, Eq)
 
-data Repo = Repo {
-	location :: RepoLocation,
-	config :: M.Map String String,
+data Repo = Repo
+	{ location :: RepoLocation
+	, config :: M.Map String String
 	-- a given git config key can actually have multiple values
-	fullconfig :: M.Map String [String],
-	remotes :: [Repo],
+	, fullconfig :: M.Map String [String]
+	, remotes :: [Repo]
 	-- remoteName holds the name used for this repo in remotes
-	remoteName :: Maybe String 
-} deriving (Show, Eq)
+	, remoteName :: Maybe String
+	-- alternate environment to use when running git commands
+	, gitEnv :: Maybe [(String, String)]
+	} deriving (Show, Eq)
 
 {- A git ref. Can be a sha1, or a branch or tag name. -}
 newtype Ref = Ref String
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index abdc4bcbe..69e5f1b3d 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,12 +34,10 @@ 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)
+streamUpdateIndex repo as = pipeWrite params repo $ \h -> do
 	fileEncoding h
 	forM_ as (stream h)
 	hClose h
-	forceSuccess p
 	where
 		params = map Param ["update-index", "-z", "--index-info"]
 		stream h a = a (streamer h)