git-annex-8.20200720: Annex/GitOverlay.hs

{- Temporarily changing the files git uses.
 -
 - Copyright 2014-2020 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Annex.GitOverlay (
	module Annex.GitOverlay,
	AltIndexFile(..),
) where

import qualified Control.Exception as E

import Annex.Common
import Types.IndexFiles
import Git
import Git.Types
import Git.Index
import Git.Env
import qualified Annex
import qualified Annex.Queue
#ifndef mingw32_HOST_OS
import qualified Utility.LockFile.PidLock as PidF
import qualified Utility.LockPool.PidLock as PidP
import Utility.LockPool (dropLock)
import Utility.Env
import Config
#endif

{- Runs an action using a different git index file. -}
withIndexFile :: AltIndexFile -> (FilePath -> Annex a) -> Annex a
withIndexFile i = withAltRepo usecachedgitenv restoregitenv
  where
	-- This is an optimisation. Since withIndexFile is run repeatedly,
	-- typically with the same file, and addGitEnv uses the slow
	-- getEnvironment when gitEnv is Nothing, and has to do a
	-- nontrivial amount of work, we cache the modified environment
	-- the first time, and reuse it in subsequent calls for the same
	-- index file.
	--
	-- (This could be done at another level; eg when creating the
	-- Git object in the first place, but it's more efficient to let
	-- the environment be inherited in all calls to git where it
	-- does not need to be modified.)
	--
	-- Also, the use of AltIndexFile avoids needing to construct
	-- the FilePath each time, which saves enough time to be worth the
	-- added complication.
	usecachedgitenv g = case gitEnv g of
		Nothing -> Annex.withState $ \s -> case Annex.cachedgitenv s of
			Just (cachedi, cachedf, cachede) | i == cachedi ->
				return (s, (g { gitEnv = Just cachede }, cachedf))
			_ -> do
				r@(g', f) <- addindex g
				let cache = (,,)
					<$> Just i
					<*> Just f
					<*> gitEnv g'
				return (s { Annex.cachedgitenv = cache }, r)
		Just _ -> liftIO $ addindex g
	
	addindex g = do
		f <- indexEnvVal $ case i of
			AnnexIndexFile -> gitAnnexIndex g
			ViewIndexFile -> gitAnnexViewIndex g
		g' <- addGitEnv g indexEnv f
		return (g', f)
	
	restoregitenv g g' = g' { gitEnv = gitEnv g }

{- Runs an action using a different git work tree.
 -
 - Smudge and clean filters are disabled in this work tree. -}
withWorkTree :: FilePath -> Annex a -> Annex a
withWorkTree d a = withAltRepo
	(\g -> return $ (g { location = modlocation (location g), gitGlobalOpts = gitGlobalOpts g ++ disableSmudgeConfig }, ()))
	(\g g' -> g' { location = location g, gitGlobalOpts = gitGlobalOpts g })
	(const a)
  where
	modlocation l@(Local {}) = l { worktree = Just (toRawFilePath d) }
	modlocation _ = error "withWorkTree of non-local git repo"
	disableSmudgeConfig = map Param
		[ "-c", "filter.annex.smudge="
		, "-c", "filter.annex.clean="
		]

{- Runs an action with the git index file and HEAD, and a few other
 - files that are related to the work tree coming from an overlay
 - directory other than the usual. This is done by pointing
 - GIT_COMMON_DIR at the regular git directory, and GIT_DIR at the
 - overlay directory.
 -
 - Needs git 2.2.0 or newer.
 -}
withWorkTreeRelated :: FilePath -> Annex a -> Annex a
withWorkTreeRelated d a = withAltRepo modrepo unmodrepo (const a)
  where
	modrepo g = liftIO $ do
		g' <- addGitEnv g "GIT_COMMON_DIR"
			=<< absPath (fromRawFilePath (localGitDir g))
		g'' <- addGitEnv g' "GIT_DIR" d
		return (g'' { gitEnvOverridesGitDir = True }, ())
	unmodrepo g g' = g'
		{ gitEnv = gitEnv g
		, gitEnvOverridesGitDir = gitEnvOverridesGitDir g
		}

withAltRepo 
	:: (Repo -> Annex (Repo, t))
	-- ^ modify Repo
	-> (Repo -> Repo -> Repo)
	-- ^ undo modifications; first Repo is the original and second
	-- is the one after running the action.
	-> (t -> Annex a)
	-> Annex a
withAltRepo modrepo unmodrepo a = do
	g <- gitRepo
	(g', t) <- modrepo g
	q <- Annex.Queue.get
	v <- tryNonAsync $ do
		Annex.changeState $ \s -> s
			{ Annex.repo = g'
			-- Start a separate queue for any changes made
			-- with the modified repo.
			, Annex.repoqueue = Nothing
			}
		a t
	void $ tryNonAsync Annex.Queue.flush
	Annex.changeState $ \s -> s
		{ Annex.repo = unmodrepo g (Annex.repo s)
		, Annex.repoqueue = Just q
		}
	either E.throw return v

{- Wrap around actions that may run a git-annex child process.
 -
 - When pid locking is in use, this tries to take the pid lock, and if
 - successful, holds it while running the child process. The action
 - is run with the Annex monad modified so git commands are run with
 - an env var set, which prevents child git annex processes from t
 - rying to take the pid lock themselves.
 -
 - This way, any locking the parent does will not get in the way of
 - the child. The child is assumed to not do any locking that conflicts
 - with the parent, but if it did happen to do that, it would be noticed
 - when git-annex is used without pid locking.
 -}
runsGitAnnexChildProcess :: Annex a -> Annex a
#ifndef mingw32_HOST_OS
runsGitAnnexChildProcess a = pidLockFile >>= \case
	Nothing -> a
	Just pidlock -> bracket (setup pidlock) cleanup (go pidlock)
  where
	setup pidlock = liftIO $ PidP.tryLock pidlock
	
	cleanup (Just h) = liftIO $ dropLock h
	cleanup Nothing = return ()
	
	go _ Nothing = a
	go pidlock (Just _h) = do
		v <- liftIO $ PidF.pidLockEnv pidlock
		let addenv g = do
			g' <- liftIO $ addGitEnv g v "1"
			return (g', ())
		let rmenv oldg g
			| any (\(k, _) -> k == v) (fromMaybe [] (Git.gitEnv oldg)) = g
			| otherwise = 
				let e' = case Git.gitEnv g of
					Just e -> Just (delEntry v e)
					Nothing -> Nothing
				in g { Git.gitEnv = e' }
		withAltRepo addenv rmenv (const a)
#else
runsGitAnnexChildProcess a = a
#endif

runsGitAnnexChildProcess' :: Git.Repo -> (Git.Repo -> IO a) -> Annex a
#ifndef mingw32_HOST_OS
runsGitAnnexChildProcess' r a = pidLockFile >>= \case
	Nothing -> liftIO $ a r
	Just pidlock -> liftIO $ bracket (setup pidlock) cleanup (go pidlock)
  where
	setup pidlock = PidP.tryLock pidlock
	
	cleanup (Just h) = dropLock h
	cleanup Nothing = return ()
	
	go _ Nothing = a r
	go pidlock (Just _h) = do
		v <- PidF.pidLockEnv pidlock
		r' <- addGitEnv r v "1"
		a r'
#else
runsGitAnnexChildProcess' r a = liftIO $ a r
#endif