1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
{- git-annex repository fixups
-
- Copyright 2013-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.Fixup where
import Git.Types
import Git.Config
import Types.GitConfig
import qualified Git.BuildVersion
import Utility.Path
import Utility.SafeCommand
import Utility.Directory
import Utility.Exception
import Utility.Monad
import Utility.PartialPrelude
import System.IO
import System.FilePath
import System.PosixCompat.Files
import Data.List
import Control.Monad
import Control.Monad.IfElse
import qualified Data.Map as M
import Control.Applicative
import Prelude
fixupRepo :: Repo -> GitConfig -> IO Repo
fixupRepo r c = do
let r' = disableWildcardExpansion r
r'' <- fixupUnusualRepos r' c
if annexDirect c
then return (fixupDirect r'')
else return r''
{- Disable git's built-in wildcard expansion, which is not wanted
- when using it as plumbing by git-annex. -}
disableWildcardExpansion :: Repo -> Repo
disableWildcardExpansion r
| Git.BuildVersion.older "1.8.1" = r
| otherwise = r
{ gitGlobalOpts = gitGlobalOpts r ++ [Param "--literal-pathspecs"] }
{- 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. -}
fixupDirect :: Repo -> Repo
fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) = do
r
{ location = l { worktree = Just (parentDir d) }
, gitGlobalOpts = gitGlobalOpts r ++
[ Param "-c"
, Param $ coreBare ++ "=" ++ boolConfig False
]
}
fixupDirect r = r
{- Submodules have their gitdir containing ".git/modules/", and
- have core.worktree set, and also have a .git file in the top
- 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
- 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.
-
- 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.
-
- When the filesystem doesn't support symlinks, we cannot make .git
- into a symlink. But we don't need too, since the repo will use direct
- mode.
-}
fixupUnusualRepos :: Repo -> GitConfig -> IO Repo
fixupUnusualRepos r@(Repo { location = l@(Local { worktree = Just w, gitdir = d }) }) c
| needsSubmoduleFixup r = 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)
}
| otherwise = ifM (needsGitLinkFixup r)
( 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
)
where
dotgit = w </> ".git"
replacedotgit = whenM (doesFileExist dotgit) $ do
linktarget <- relPathDirToFile w d
nukeFile dotgit
createSymbolicLink linktarget dotgit
unsetcoreworktree =
maybe (error "unset core.worktree failed") (\_ -> return ())
=<< Git.Config.unset "core.worktree" r
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
fixupUnusualRepos r _ = return r
needsSubmoduleFixup :: Repo -> Bool
needsSubmoduleFixup (Repo { location = (Local { worktree = Just _, gitdir = d }) }) =
(".git" </> "modules") `isInfixOf` d
needsSubmoduleFixup _ = False
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
|
