thread safe git-annex index file use

Annex/Branch.hs

@@ -25,7 +25,6 @@ module Annex.Branch (
 import qualified Data.ByteString.Lazy.Char8 as L
 
 import Common.Annex
-import Annex.Exception
 import Annex.BranchState
 import Annex.Journal
 import qualified Git
@@ -37,9 +36,9 @@ import qualified Git.UpdateIndex
 import Git.HashObject
 import Git.Types
 import Git.FilePath
-import qualified Git.Index
 import Annex.CatFile
 import Annex.Perms
+import qualified Annex
 
 {- Name of the branch that is used to store git-annex's information. -}
 name :: Git.Ref
@@ -280,12 +279,18 @@ withIndex = withIndex' False
 withIndex' :: Bool -> Annex a -> Annex a
 withIndex' bootstrapping a = do
 	f <- fromRepo gitAnnexIndex
-	bracketIO (Git.Index.override f) id $ do
+	g <- gitRepo
+	let g' = g { gitEnv = Just [("GIT_INDEX_FILE", f)] }
+
+	Annex.changeState $ \s -> s { Annex.repo = g' }
 	checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do
 		unless bootstrapping create
 		liftIO $ createDirectoryIfMissing True $ takeDirectory f
 		unless bootstrapping $ inRepo genIndex
-		a
+	r <- a
+	Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} }
+
+	return r
 
 {- Runs an action using the branch's index file, first making sure that
  - the branch and index are up-to-date. -}
@@ -338,8 +343,9 @@ stageJournal :: Annex ()
 stageJournal = do
 	showStoringStateAction
 	fs <- getJournalFiles
+	withIndex $ do
 		g <- gitRepo
-	withIndex $ liftIO $ do
+		liftIO $ do
 			h <- hashObjectStart g
 			Git.UpdateIndex.streamUpdateIndex g
 				[genstream (gitAnnexJournalDir g) h fs]

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 {
+data Repo = Repo
-	location :: RepoLocation,
+	{ location :: RepoLocation
-	config :: M.Map String String,
+	, config :: M.Map String String
 	-- a given git config key can actually have multiple values
-	fullconfig :: M.Map String [String],
+	, fullconfig :: M.Map String [String]
-	remotes :: [Repo],
+	, remotes :: [Repo]
 	-- remoteName holds the name used for this repo in remotes
-	remoteName :: Maybe String 
+	, remoteName :: Maybe String
-} deriving (Show, Eq)
+	-- 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 =
+streamUpdateIndex repo as = pipeWrite params repo $ \h -> do
-	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

Utility/Process.hs

@@ -12,7 +12,9 @@ module Utility.Process (
 	module X,
 	CreateProcess,
 	StdHandle(..),
+	readProcess,
 	readProcessEnv,
+	writeReadProcessEnv,
 	forceSuccessProcess,
 	checkSuccessProcess,
 	createProcessSuccess,
@@ -22,8 +24,6 @@ module Utility.Process (
 	withBothHandles,
 	createProcess,
 	runInteractiveProcess,
-	writeReadProcess,
-	readProcess
 ) where
 
 import qualified System.Process
@@ -32,6 +32,9 @@ import System.Process hiding (createProcess, runInteractiveProcess, readProcess)
 import System.Exit
 import System.IO
 import System.Log.Logger
+import Control.Concurrent
+import qualified Control.Exception as E
+import Control.Monad
 
 import Utility.Misc
 
@@ -40,8 +43,11 @@ type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Hand
 data StdHandle = StdinHandle | StdoutHandle | StderrHandle
 	deriving (Eq)
 
-{- Like readProcess, but allows specifying the environment, and does
+{- Normally, when reading from a process, it does not need to be fed any
- - not mess with stdin. -}
+ - standard input. -}
+readProcess :: FilePath	-> [String] -> IO String
+readProcess cmd args = readProcessEnv cmd args Nothing
+
 readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String
 readProcessEnv cmd args environ =
 	withHandle StdoutHandle createProcessSuccess p $ \h -> do
@@ -54,6 +60,43 @@ readProcessEnv cmd args environ =
 			, env = environ
 			}
 
+{- Writes stdout to a process, returns its output, and also allows specifying
+ - the environment. -}
+writeReadProcessEnv
+	:: FilePath
+	-> [String]
+	-> Maybe [(String, String)]
+	-> String	
+	-> IO String
+writeReadProcessEnv cmd args environ input = do
+	(Just inh, Just outh, _, pid) <- createProcess p
+
+	-- fork off a thread to start consuming the output
+	output  <- hGetContents outh
+	outMVar <- newEmptyMVar
+	_ <- forkIO $ E.evaluate (length output) >> putMVar outMVar ()
+
+	-- now write and flush any input
+	when (not (null input)) $ do hPutStr inh input; hFlush inh
+	hClose inh -- done with stdin
+
+	-- wait on the output
+	takeMVar outMVar
+	hClose outh
+
+	-- wait on the process
+	forceSuccessProcess p pid
+
+	return output
+
+	where
+		p = (proc cmd args)
+			{ std_in = CreatePipe
+			, std_out = CreatePipe
+			, std_err = Inherit
+			, env = environ
+			}
+
 {- Waits for a ProcessHandle, and throws an exception if the process
  - did not exit successfully. -}
 forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO ()
@@ -192,23 +235,3 @@ runInteractiveProcess f args c e = do
 			, std_err = CreatePipe
 			}
 	System.Process.runInteractiveProcess f args c e
-
-{- I think this is a more descriptive name than System.Process.readProcess. -}
-writeReadProcess
-	:: FilePath	
-	-> [String]	
-	-> String	
-	-> IO String
-writeReadProcess f args input = do
-	debugProcess $ (proc f args) { std_out = CreatePipe, std_in = CreatePipe }
-	System.Process.readProcess f args input
-
-{- Normally, when reading from a process, it does not need to be fed any
- - input. -}
-readProcess
-	:: FilePath	
-	-> [String]	
-	-> IO String
-readProcess f args = do
-	debugProcess $ (proc f args) { std_out = CreatePipe }
-	System.Process.readProcess f args []