thread safe git-annex index file use

Git/Command.hs

@@ -8,6 +8,7 @@
 module Git.Command where
 
 import System.Posix.Process (getAnyProcessStatus)
+import System.Process
 
 import Common
 import Git
@@ -26,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 ()
@@ -45,14 +48,23 @@ pipeRead params repo = assertLocal repo $
 		fileEncoding h
 		hGetContents h
 	where
-		p  = proc "git" $ toCommand $ gitCommandLine params repo
+		p  = (proc "git" $ toCommand $ gitCommandLine params repo)
+			{ env = gitEnv 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
  - strictly. -}
 pipeWriteRead :: [CommandParam] -> String -> Repo -> IO String
 pipeWriteRead params s repo = assertLocal repo $
-	writeReadProcess "git" (toCommand $ gitCommandLine params repo) s
+	writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) 
+		(gitEnv repo) s
+
+{- 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. -}

Git/Config.hs

@@ -9,7 +9,7 @@ module Git.Config where
 
 import qualified Data.Map as M
 import Data.Char
-import System.Process (cwd)
+import System.Process (cwd, env)
 
 import Common
 import Git
@@ -52,7 +52,10 @@ read' repo = go repo
 			hRead repo
 			where
 				params = ["config", "--null", "--list"]
-				p = (proc "git" params) { cwd = Just d }
+				p = (proc "git" params)
+					{ cwd = Just d
+					, env = gitEnv repo
+					}
 
 {- Gets the global git config, returning a dummy Repo containing it. -}
 global :: IO Repo

Git/Construct.hs

@@ -225,6 +225,7 @@ newFrom l = return Repo
 	, fullconfig = M.empty
 	, remotes = []
 	, remoteName = Nothing
+	, gitEnv = Nothing
 	}
 
 

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

Git/Queue.hs

@@ -19,6 +19,7 @@ module Git.Queue (
 
 import qualified Data.Map as M
 import System.IO
+import System.Process
 import Data.String.Utils
 
 import Utility.SafeCommand
@@ -148,11 +149,12 @@ runAction repo (UpdateIndexAction streamers) =
 	-- list is stored in reverse order
 	Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers
 runAction repo action@(CommandAction {}) =
-	withHandle StdinHandle createProcessSuccess (proc "xargs" params) $ \h -> do
+	withHandle StdinHandle createProcessSuccess p $ \h -> do
 		fileEncoding h
 		hPutStr h $ join "\0" $ getFiles action
 		hClose h
 	where
+		p = (proc "xargs" params) { env = gitEnv repo }
 		params = "-0":"git":baseparams
 		baseparams = toCommand $ gitCommandLine
 			(Param (getSubcommand action):getParams action) repo

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

Git/UpdateIndex.hs

@@ -34,13 +34,11 @@ pureStreamer !s = \streamer -> streamer s
 
 {- Streams content into update-index from a list of Streamers. -}
 streamUpdateIndex :: Repo -> [Streamer] -> IO ()
-streamUpdateIndex repo as =
-	withHandle StdinHandle createProcessSuccess (proc "git" ps) $ \h -> do
-		fileEncoding h
-		forM_ as (stream h)
-		hClose h
+streamUpdateIndex repo as = pipeWrite params repo $ \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