aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Annex/Branch.hs34
-rw-r--r--Git/Command.hs18
-rw-r--r--Git/Config.hs7
-rw-r--r--Git/Construct.hs1
-rw-r--r--Git/Index.hs5
-rw-r--r--Git/Queue.hs4
-rw-r--r--Git/Types.hs16
-rw-r--r--Git/UpdateIndex.hs10
-rw-r--r--Utility/Process.hs71
9 files changed, 108 insertions, 58 deletions
diff --git a/Annex/Branch.hs b/Annex/Branch.hs
index a832efada..f36f1c57b 100644
--- a/Annex/Branch.hs
+++ b/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
- checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do
- unless bootstrapping create
- liftIO $ createDirectoryIfMissing True $ takeDirectory f
- unless bootstrapping $ inRepo genIndex
- a
+ 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
+ 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,12 +343,13 @@ stageJournal :: Annex ()
stageJournal = do
showStoringStateAction
fs <- getJournalFiles
- g <- gitRepo
- withIndex $ liftIO $ do
- h <- hashObjectStart g
- Git.UpdateIndex.streamUpdateIndex g
- [genstream (gitAnnexJournalDir g) h fs]
- hashObjectStop h
+ withIndex $ do
+ g <- gitRepo
+ liftIO $ do
+ h <- hashObjectStart g
+ Git.UpdateIndex.streamUpdateIndex g
+ [genstream (gitAnnexJournalDir g) h fs]
+ hashObjectStop h
where
genstream dir h fs streamer = forM_ fs $ \file -> do
let path = dir </> file
diff --git a/Git/Command.hs b/Git/Command.hs
index cd6c98d33..04b0723d0 100644
--- a/Git/Command.hs
+++ b/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. -}
diff --git a/Git/Config.hs b/Git/Config.hs
index 0a720c1c0..fb0c24bab 100644
--- a/Git/Config.hs
+++ b/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
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/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 f515ad104..9f7a44882 100644
--- a/Git/Queue.hs
+++ b/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
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 929448729..69e5f1b3d 100644
--- a/Git/UpdateIndex.hs
+++ b/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
diff --git a/Utility/Process.hs b/Utility/Process.hs
index 5c29bbdfb..e5de96ae9 100644
--- a/Utility/Process.hs
+++ b/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
- - not mess with stdin. -}
+{- Normally, when reading from a process, it does not need to be fed any
+ - 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 []
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-27 21:21:07 +0000