1cd02762bf
Speeds up commands like "git-annex find --in remote" by over 50%. Profiling showed that adjustGitEnv was 21% of the time and 37% of the allocations of that command. It copied the environment each time with getEnvironment. The only repeated use of adjustGitEnv is in withIndexFile, which tends to be run at least once per file. So, it was optimised by keeping a cache of the environment, which can be reused. There could be other better ways to optimise this. Maybe get the while environment once at startup. But, then it would have to be serialized back out each time running a child process, so I doubt that would be a net win. It might be better to cache a version of the environment that is pre-modified to use .git-annex/index. But, profiling doesn't show that modifying the enviroment is taking any significant time.
69 lines
2.2 KiB
Haskell
69 lines
2.2 KiB
Haskell
{- Adjusting the environment while running git commands.
|
|
-
|
|
- Copyright 2014-2016 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Git.Env where
|
|
|
|
import Common
|
|
import Git
|
|
import Git.Types
|
|
import Utility.Env
|
|
|
|
{- Adjusts the gitEnv of a Repo. Copies the system environment if the repo
|
|
- does not have any gitEnv yet. -}
|
|
adjustGitEnv :: Repo -> ([(String, String)] -> [(String, String)]) -> IO Repo
|
|
adjustGitEnv g adj = do
|
|
e <- maybe copyGitEnv return (gitEnv g)
|
|
let e' = adj e
|
|
return $ g { gitEnv = Just e' }
|
|
where
|
|
|
|
{- Copies the current environment, so it can be adjusted when running a git
|
|
- command. -}
|
|
copyGitEnv :: IO [(String, String)]
|
|
copyGitEnv = do
|
|
#ifdef __ANDROID__
|
|
{- This should not be necessary on Android, but there is some
|
|
- weird getEnvironment breakage. See
|
|
- https://github.com/neurocyte/ghc-android/issues/7
|
|
- Use getEnv to get some key environment variables that
|
|
- git expects to have. -}
|
|
let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME"
|
|
let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k
|
|
catMaybes <$> forM keyenv getEnvPair
|
|
#else
|
|
getEnvironment
|
|
#endif
|
|
|
|
addGitEnv :: Repo -> String -> String -> IO Repo
|
|
addGitEnv g var val = adjustGitEnv g (addEntry var val)
|
|
|
|
{- Environment variables to use when running a command.
|
|
- Includes GIT_DIR pointing at the repo, and GIT_WORK_TREE when the repo
|
|
- is not bare. Also includes anything added to the Repo's gitEnv,
|
|
- and a copy of the rest of the system environment. -}
|
|
propGitEnv :: Repo -> IO [(String, String)]
|
|
propGitEnv g = do
|
|
g' <- addGitEnv g "GIT_DIR" (localGitDir g)
|
|
g'' <- maybe (pure g') (addGitEnv g' "GIT_WORK_TREE") (repoWorkTree g)
|
|
return $ fromMaybe [] (gitEnv g'')
|
|
|
|
{- Use with any action that makes a commit to set metadata. -}
|
|
commitWithMetaData :: CommitMetaData -> CommitMetaData -> (Repo -> IO a) -> Repo -> IO a
|
|
commitWithMetaData authormetadata committermetadata a g =
|
|
a =<< adjustGitEnv g adj
|
|
where
|
|
adj = mkadj "AUTHOR" authormetadata
|
|
. mkadj "COMMITTER" committermetadata
|
|
mkadj p md = go "NAME" commitName
|
|
. go "EMAIL" commitEmail
|
|
. go "DATE" commitDate
|
|
where
|
|
go s getv = case getv md of
|
|
Nothing -> id
|
|
Just v -> addEntry ("GIT_" ++ p ++ "_" ++ s) v
|