2015-03-02 20:43:44 +00:00
|
|
|
{- git-annex repository fixups
|
|
|
|
-
|
2019-02-05 18:43:23 +00:00
|
|
|
- Copyright 2013-2019 Joey Hess <id@joeyh.name>
|
2015-03-02 20:43:44 +00:00
|
|
|
-
|
2019-03-13 19:48:14 +00:00
|
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
2015-03-02 20:43:44 +00:00
|
|
|
-}
|
|
|
|
|
|
|
|
module Annex.Fixup where
|
|
|
|
|
|
|
|
import Git.Types
|
|
|
|
import Git.Config
|
|
|
|
import Types.GitConfig
|
2019-02-05 18:43:23 +00:00
|
|
|
import Config.Files
|
2019-02-08 17:20:24 +00:00
|
|
|
import qualified Git
|
2015-04-06 17:46:11 +00:00
|
|
|
import qualified Git.BuildVersion
|
2015-03-02 20:43:44 +00:00
|
|
|
import Utility.Path
|
|
|
|
import Utility.SafeCommand
|
|
|
|
import Utility.Directory
|
|
|
|
import Utility.Exception
|
2018-07-18 18:25:03 +00:00
|
|
|
import Utility.Monad
|
|
|
|
import Utility.PartialPrelude
|
2015-03-02 20:43:44 +00:00
|
|
|
|
|
|
|
import System.IO
|
|
|
|
import System.FilePath
|
2017-11-14 18:00:24 +00:00
|
|
|
import System.PosixCompat.Files
|
2015-03-02 20:43:44 +00:00
|
|
|
import Data.List
|
2019-02-05 18:43:23 +00:00
|
|
|
import Data.Maybe
|
2015-03-02 20:43:44 +00:00
|
|
|
import Control.Monad
|
|
|
|
import Control.Monad.IfElse
|
|
|
|
import qualified Data.Map as M
|
2018-07-19 17:27:29 +00:00
|
|
|
import Control.Applicative
|
|
|
|
import Prelude
|
2015-03-02 20:43:44 +00:00
|
|
|
|
|
|
|
fixupRepo :: Repo -> GitConfig -> IO Repo
|
|
|
|
fixupRepo r c = do
|
2015-03-30 23:55:35 +00:00
|
|
|
let r' = disableWildcardExpansion r
|
2018-07-18 18:25:03 +00:00
|
|
|
r'' <- fixupUnusualRepos r' c
|
2015-03-02 20:43:44 +00:00
|
|
|
if annexDirect c
|
2018-01-09 19:36:56 +00:00
|
|
|
then return (fixupDirect r'')
|
2015-03-30 23:44:13 +00:00
|
|
|
else return r''
|
2015-03-02 20:43:44 +00:00
|
|
|
|
2015-03-30 23:55:35 +00:00
|
|
|
{- Disable git's built-in wildcard expansion, which is not wanted
|
|
|
|
- when using it as plumbing by git-annex. -}
|
|
|
|
disableWildcardExpansion :: Repo -> Repo
|
2015-04-06 17:46:11 +00:00
|
|
|
disableWildcardExpansion r
|
|
|
|
| Git.BuildVersion.older "1.8.1" = r
|
|
|
|
| otherwise = r
|
|
|
|
{ gitGlobalOpts = gitGlobalOpts r ++ [Param "--literal-pathspecs"] }
|
2015-03-30 23:55:35 +00:00
|
|
|
|
2015-03-02 20:43:44 +00:00
|
|
|
{- Direct mode repos have core.bare=true, but are not really bare.
|
|
|
|
- Fix up the Repo to be a non-bare repo, and arrange for git commands
|
|
|
|
- run by git-annex to be passed parameters that override this setting. -}
|
2018-01-09 19:36:56 +00:00
|
|
|
fixupDirect :: Repo -> Repo
|
2015-03-02 20:43:44 +00:00
|
|
|
fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) = do
|
2018-01-09 19:36:56 +00:00
|
|
|
r
|
2015-03-02 20:43:44 +00:00
|
|
|
{ location = l { worktree = Just (parentDir d) }
|
|
|
|
, gitGlobalOpts = gitGlobalOpts r ++
|
|
|
|
[ Param "-c"
|
|
|
|
, Param $ coreBare ++ "=" ++ boolConfig False
|
|
|
|
]
|
|
|
|
}
|
2018-01-09 19:36:56 +00:00
|
|
|
fixupDirect r = r
|
2015-03-02 20:43:44 +00:00
|
|
|
|
|
|
|
{- Submodules have their gitdir containing ".git/modules/", and
|
|
|
|
- have core.worktree set, and also have a .git file in the top
|
2018-07-18 18:25:03 +00:00
|
|
|
- of the repo. We need to unset core.worktree, and change the .git
|
|
|
|
- file into a symlink to the git directory. This way, annex symlinks will be
|
2015-03-02 20:43:44 +00:00
|
|
|
- of the usual .git/annex/object form, and will consistently work
|
|
|
|
- whether a repo is used as a submodule or not, and wheverever the
|
|
|
|
- submodule is mounted.
|
|
|
|
-
|
2018-07-18 18:25:03 +00:00
|
|
|
- git-worktree directories have a .git file.
|
|
|
|
- That needs to be converted to a symlink, and .git/annex made a symlink
|
|
|
|
- to the main repository's git-annex directory.
|
|
|
|
- The worktree shares git config with the main repository, so the same
|
|
|
|
- annex uuid and other configuration will be used in the worktree as in
|
|
|
|
- the main repository.
|
|
|
|
-
|
|
|
|
- git clone or init with --separate-git-dir similarly makes a .git file,
|
|
|
|
- which in that case points to a different git directory. It's
|
|
|
|
- also converted to a symlink so links to .git/annex will work.
|
|
|
|
-
|
2015-03-02 20:43:44 +00:00
|
|
|
- When the filesystem doesn't support symlinks, we cannot make .git
|
2015-03-04 20:08:41 +00:00
|
|
|
- into a symlink. But we don't need too, since the repo will use direct
|
2018-07-18 18:25:03 +00:00
|
|
|
- mode.
|
2019-02-05 18:43:23 +00:00
|
|
|
-
|
|
|
|
- Before making any changes, check if there's a .noannex file
|
|
|
|
- in the repo. If that file will prevent git-annex from being used,
|
|
|
|
- there's no need to fix up the repository.
|
2015-03-02 20:43:44 +00:00
|
|
|
-}
|
2018-07-18 18:25:03 +00:00
|
|
|
fixupUnusualRepos :: Repo -> GitConfig -> IO Repo
|
|
|
|
fixupUnusualRepos r@(Repo { location = l@(Local { worktree = Just w, gitdir = d }) }) c
|
2019-02-05 18:43:23 +00:00
|
|
|
| needsSubmoduleFixup r = ifM notnoannex
|
|
|
|
( do
|
|
|
|
when (coreSymlinks c) $
|
|
|
|
(replacedotgit >> unsetcoreworktree)
|
|
|
|
`catchNonAsync` \_e -> hPutStrLn stderr
|
|
|
|
"warning: unable to convert submodule to form that will work with git-annex"
|
|
|
|
return $ r'
|
|
|
|
{ config = M.delete "core.worktree" (config r)
|
|
|
|
}
|
|
|
|
, return r
|
|
|
|
)
|
|
|
|
| otherwise = ifM (needsGitLinkFixup r <&&> notnoannex)
|
2018-07-18 18:25:03 +00:00
|
|
|
( do
|
|
|
|
when (coreSymlinks c) $
|
|
|
|
(replacedotgit >> worktreefixup)
|
|
|
|
`catchNonAsync` \_e -> hPutStrLn stderr
|
|
|
|
"warning: unable to convert .git file to symlink that will work with git-annex"
|
|
|
|
return r'
|
|
|
|
, return r
|
|
|
|
)
|
2015-03-02 20:43:44 +00:00
|
|
|
where
|
|
|
|
dotgit = w </> ".git"
|
2018-07-18 18:25:03 +00:00
|
|
|
|
2015-03-02 20:43:44 +00:00
|
|
|
replacedotgit = whenM (doesFileExist dotgit) $ do
|
2016-02-08 19:41:19 +00:00
|
|
|
linktarget <- relPathDirToFile w d
|
2015-03-02 20:43:44 +00:00
|
|
|
nukeFile dotgit
|
2016-02-08 19:41:19 +00:00
|
|
|
createSymbolicLink linktarget dotgit
|
2018-07-18 18:25:03 +00:00
|
|
|
|
|
|
|
unsetcoreworktree =
|
2015-03-02 20:43:44 +00:00
|
|
|
maybe (error "unset core.worktree failed") (\_ -> return ())
|
|
|
|
=<< Git.Config.unset "core.worktree" r
|
2018-07-18 18:25:03 +00:00
|
|
|
|
|
|
|
worktreefixup =
|
|
|
|
-- git-worktree sets up a "commondir" file that contains
|
|
|
|
-- the path to the main git directory.
|
|
|
|
-- Using --separate-git-dir does not.
|
|
|
|
catchDefaultIO Nothing (headMaybe . lines <$> readFile (d </> "commondir")) >>= \case
|
|
|
|
Just gd -> do
|
|
|
|
-- Make the worktree's git directory
|
|
|
|
-- contain an annex symlink to the main
|
|
|
|
-- repository's annex directory.
|
|
|
|
let linktarget = gd </> "annex"
|
|
|
|
createSymbolicLink linktarget (dotgit </> "annex")
|
|
|
|
Nothing -> return ()
|
|
|
|
|
|
|
|
-- Repo adjusted, so that symlinks to objects that get checked
|
|
|
|
-- in will have the usual path, rather than pointing off to the
|
|
|
|
-- real .git directory.
|
|
|
|
r'
|
|
|
|
| coreSymlinks c = r { location = l { gitdir = dotgit } }
|
|
|
|
| otherwise = r
|
2019-02-05 18:43:23 +00:00
|
|
|
|
2019-02-08 17:20:24 +00:00
|
|
|
notnoannex = isNothing <$> noAnnexFileContent (Git.repoWorkTree r)
|
2018-07-18 18:25:03 +00:00
|
|
|
fixupUnusualRepos r _ = return r
|
2015-03-04 20:08:41 +00:00
|
|
|
|
|
|
|
needsSubmoduleFixup :: Repo -> Bool
|
|
|
|
needsSubmoduleFixup (Repo { location = (Local { worktree = Just _, gitdir = d }) }) =
|
|
|
|
(".git" </> "modules") `isInfixOf` d
|
|
|
|
needsSubmoduleFixup _ = False
|
2018-07-18 18:25:03 +00:00
|
|
|
|
|
|
|
needsGitLinkFixup :: Repo -> IO Bool
|
|
|
|
needsGitLinkFixup (Repo { location = (Local { worktree = Just wt, gitdir = d }) })
|
|
|
|
-- Optimization: Avoid statting .git in the common case; only
|
|
|
|
-- when the gitdir is not in the usual place inside the worktree
|
|
|
|
-- might .git be a file.
|
|
|
|
| wt </> ".git" == d = return False
|
|
|
|
| otherwise = doesFileExist (wt </> ".git")
|
|
|
|
needsGitLinkFixup _ = return False
|