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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
|
{- git-annex automatic merge conflict resolution
-
- Copyright 2012-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.AutoMerge (autoMergeFrom) where
import Common.Annex
import qualified Annex.Queue
import Annex.Direct
import Annex.CatFile
import Annex.Link
import qualified Git.LsFiles as LsFiles
import qualified Git.UpdateIndex as UpdateIndex
import qualified Git.Merge
import qualified Git.Ref
import qualified Git
import qualified Git.Branch
import Git.Types (BlobType(..))
import Config
import Annex.ReplaceFile
import Git.FileMode
import Annex.VariantFile
import qualified Data.Set as S
{- Merges from a branch into the current branch
- (which may not exist yet),
- with automatic merge conflict resolution.
-
- Callers should use Git.Branch.changed first, to make sure that
- there are changed from the current branch to the branch being merged in.
-}
autoMergeFrom :: Git.Ref -> (Maybe Git.Ref) -> Git.Branch.CommitMode -> Annex Bool
autoMergeFrom branch currbranch commitmode = do
showOutput
case currbranch of
Nothing -> go Nothing
Just b -> go =<< inRepo (Git.Ref.sha b)
where
go old = ifM isDirect
( mergeDirect currbranch old branch (resolveMerge old branch) commitmode
, inRepo (Git.Merge.mergeNonInteractive branch commitmode)
<||> (resolveMerge old branch <&&> commitResolvedMerge commitmode)
)
{- Resolves a conflicted merge. It's important that any conflicts be
- resolved in a way that itself avoids later merge conflicts, since
- multiple repositories may be doing this concurrently.
-
- Only merge conflicts where at least one side is an annexed file
- is resolved.
-
- This uses the Keys pointed to by the files to construct new
- filenames. So when both sides modified annexed file foo,
- it will be deleted, and replaced with files foo.variant-A and
- foo.variant-B.
-
- On the other hand, when one side deleted foo, and the other modified it,
- it will be deleted, and the modified version stored as file
- foo.variant-A (or B).
-
- It's also possible that one side has foo as an annexed file, and
- the other as a directory or non-annexed file. The annexed file
- is renamed to resolve the merge, and the other object is preserved as-is.
-
- In indirect mode, the merge is resolved in the work tree and files
- staged, to clean up from a conflicted merge that was run in the work
- tree.
-
- In direct mode, the work tree is not touched here; files are staged to
- the index, and written to the gitAnnexMergeDir, for later handling by
- the direct mode merge code.
-}
resolveMerge :: Maybe Git.Ref -> Git.Ref -> Annex Bool
resolveMerge us them = do
top <- fromRepo Git.repoPath
(fs, cleanup) <- inRepo (LsFiles.unmerged [top])
mergedfs <- catMaybes <$> mapM (resolveMerge' us them) fs
let merged = not (null mergedfs)
void $ liftIO cleanup
unlessM isDirect $ do
(deleted, cleanup2) <- inRepo (LsFiles.deleted [top])
unless (null deleted) $
Annex.Queue.addCommand "rm" [Params "--quiet -f --"] deleted
void $ liftIO cleanup2
when merged $ do
unlessM isDirect $
cleanConflictCruft mergedfs top
Annex.Queue.flush
showLongNote "Merge conflict was automatically resolved; you may want to examine the result."
return merged
resolveMerge' :: Maybe Git.Ref -> Git.Ref -> LsFiles.Unmerged -> Annex (Maybe FilePath)
resolveMerge' Nothing _ _ = return Nothing
resolveMerge' (Just us) them u = do
kus <- getkey LsFiles.valUs LsFiles.valUs
kthem <- getkey LsFiles.valThem LsFiles.valThem
case (kus, kthem) of
-- Both sides of conflict are annexed files
(Just keyUs, Just keyThem)
| keyUs /= keyThem -> resolveby $ do
makelink keyUs
makelink keyThem
| otherwise -> resolveby $
makelink keyUs
-- Our side is annexed file, other side is not.
(Just keyUs, Nothing) -> resolveby $ do
graftin them file LsFiles.valThem LsFiles.valThem
makelink keyUs
-- Our side is not annexed file, other side is.
(Nothing, Just keyThem) -> resolveby $ do
graftin us file LsFiles.valUs LsFiles.valUs
makelink keyThem
-- Neither side is annexed file; cannot resolve.
(Nothing, Nothing) -> return Nothing
where
file = LsFiles.unmergedFile u
getkey select select'
| select (LsFiles.unmergedBlobType u) == Just SymlinkBlob =
case select' (LsFiles.unmergedSha u) of
Nothing -> return Nothing
Just sha -> catKey sha symLinkMode
| otherwise = return Nothing
makelink key = do
let dest = variantFile file key
l <- inRepo $ gitAnnexLink dest key
replacewithlink dest l
stageSymlink dest =<< hashSymlink l
replacewithlink file link = ifM isDirect
( do
d <- fromRepo gitAnnexMergeDir
replaceFile (d </> file) $ makeGitLink link
, replaceFile file $ makeGitLink link
)
{- Stage a graft of a directory or file from a branch.
-
- When there is a conflicted merge where one side is a directory
- or file, and the other side is a symlink, git merge always
- updates the work tree to contain the non-symlink. So, the
- directory or file will already be in the work tree correctly,
- and they just need to be staged into place. Do so by copying the
- index. (Note that this is also better than calling git-add
- because on a crippled filesystem, it preserves any symlink
- bits.)
-
- It's also possible for the branch to have a symlink in it,
- which is not a git-annex symlink. In this special case,
- git merge does not update the work tree to contain the symlink
- from the branch, so we have to do so manually.
-}
graftin b item select select' = do
Annex.Queue.addUpdateIndex
=<< fromRepo (UpdateIndex.lsSubTree b item)
when (select (LsFiles.unmergedBlobType u) == Just SymlinkBlob) $
case select' (LsFiles.unmergedSha u) of
Nothing -> noop
Just sha -> do
link <- catLink True sha
replacewithlink item link
resolveby a = do
{- Remove conflicted file from index so merge can be resolved. -}
Annex.Queue.addCommand "rm" [Params "--quiet -f --cached --"] [file]
void a
return (Just file)
{- git-merge moves conflicting files away to files
- named something like f~HEAD or f~branch, but the
- exact name chosen can vary. Once the conflict is resolved,
- this cruft can be deleted. To avoid deleting legitimate
- files that look like this, only delete files that are
- A) not staged in git and B) look like git-annex symlinks.
-}
cleanConflictCruft :: [FilePath] -> FilePath -> Annex ()
cleanConflictCruft resolvedfs top = do
(fs, cleanup) <- inRepo $ LsFiles.notInRepo False [top]
mapM_ clean fs
void $ liftIO cleanup
where
clean f
| matchesresolved f = whenM (isJust <$> isAnnexLink f) $
liftIO $ nukeFile f
| otherwise = noop
s = S.fromList resolvedfs
matchesresolved f = S.member (base f) s
base f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f
commitResolvedMerge :: Git.Branch.CommitMode -> Annex Bool
commitResolvedMerge commitmode = inRepo $ Git.Branch.commitCommand commitmode
[ Param "--no-verify"
, Param "-m"
, Param "git-annex automatic merge conflict fix"
]
|
