2014-02-18 21:38:23 +00:00
|
|
|
{- Using other git index files
|
|
|
|
-
|
2015-01-21 16:50:09 +00:00
|
|
|
- Copyright 2014 Joey Hess <id@joeyh.name>
|
2014-02-18 21:38:23 +00:00
|
|
|
-
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
-}
|
|
|
|
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
|
|
|
|
module Annex.Index (
|
|
|
|
withIndexFile,
|
2014-04-12 19:59:34 +00:00
|
|
|
addGitEnv,
|
2014-02-18 21:38:23 +00:00
|
|
|
) where
|
|
|
|
|
|
|
|
import qualified Control.Exception as E
|
|
|
|
|
2016-01-20 20:36:33 +00:00
|
|
|
import Annex.Common
|
2014-02-18 21:38:23 +00:00
|
|
|
import Git.Types
|
|
|
|
import qualified Annex
|
|
|
|
import Utility.Env
|
|
|
|
|
|
|
|
{- Runs an action using a different git index file. -}
|
|
|
|
withIndexFile :: FilePath -> Annex a -> Annex a
|
|
|
|
withIndexFile f a = do
|
|
|
|
g <- gitRepo
|
2014-04-12 19:59:34 +00:00
|
|
|
g' <- liftIO $ addGitEnv g "GIT_INDEX_FILE" f
|
2014-02-18 21:38:23 +00:00
|
|
|
|
unify exception handling into Utility.Exception
Removed old extensible-exceptions, only needed for very old ghc.
Made webdav use Utility.Exception, to work after some changes in DAV's
exception handling.
Removed Annex.Exception. Mostly this was trivial, but note that
tryAnnex is replaced with tryNonAsync and catchAnnex replaced with
catchNonAsync. In theory that could be a behavior change, since the former
caught all exceptions, and the latter don't catch async exceptions.
However, in practice, nothing in the Annex monad uses async exceptions.
Grepping for throwTo and killThread only find stuff in the assistant,
which does not seem related.
Command.Add.undo is changed to accept a SomeException, and things
that use it for rollback now catch non-async exceptions, rather than
only IOExceptions.
2014-08-08 01:55:44 +00:00
|
|
|
r <- tryNonAsync $ do
|
2014-02-18 21:38:23 +00:00
|
|
|
Annex.changeState $ \s -> s { Annex.repo = g' }
|
|
|
|
a
|
|
|
|
Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} }
|
|
|
|
either E.throw return r
|
2014-04-12 19:59:34 +00:00
|
|
|
|
|
|
|
addGitEnv :: Repo -> String -> String -> IO Repo
|
|
|
|
addGitEnv g var val = do
|
|
|
|
e <- maybe copyenv return (gitEnv g)
|
|
|
|
let e' = addEntry var val e
|
|
|
|
return $ g { gitEnv = Just e' }
|
|
|
|
where
|
|
|
|
copyenv = 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
|
|
|
|
liftIO $ catMaybes <$> forM keyenv getEnvPair
|
|
|
|
#else
|
|
|
|
liftIO getEnvironment
|
|
|
|
#endif
|