1{- git-annex automatic merge conflict resolution 2 - 3 - Copyright 2012-2020 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8{-# LANGUAGE OverloadedStrings #-} 9 10module Annex.AutoMerge 11 ( autoMergeFrom 12 , autoMergeFrom' 13 , resolveMerge 14 , commitResolvedMerge 15 ) where 16 17import Annex.Common 18import qualified Annex 19import qualified Annex.Queue 20import Annex.CatFile 21import Annex.Link 22import Annex.Content 23import qualified Git.LsFiles as LsFiles 24import qualified Git.UpdateIndex as UpdateIndex 25import qualified Git.Merge 26import qualified Git.Ref 27import qualified Git 28import qualified Git.Branch 29import Git.Types (TreeItemType(..), fromTreeItemType) 30import Git.FilePath 31import Annex.ReplaceFile 32import Annex.VariantFile 33import qualified Database.Keys 34import Annex.InodeSentinal 35import Utility.InodeCache 36import Utility.FileMode 37import qualified Utility.RawFilePath as R 38 39import qualified Data.Set as S 40import qualified Data.Map as M 41import qualified Data.ByteString.Lazy as L 42 43{- Merges from a branch into the current branch (which may not exist yet), 44 - with automatic merge conflict resolution. 45 - 46 - Callers should use Git.Branch.changed first, to make sure that 47 - there are changes from the current branch to the branch being merged in. 48 -} 49autoMergeFrom :: Git.Ref -> Maybe Git.Ref -> [Git.Merge.MergeConfig] -> Git.Branch.CommitMode -> Bool -> Annex Bool 50autoMergeFrom branch currbranch mergeconfig commitmode canresolvemerge = 51 autoMergeFrom' branch currbranch mergeconfig commitmode canresolvemerge resolvemerge 52 where 53 resolvemerge old 54 | canresolvemerge = resolveMerge old branch False 55 | otherwise = return False 56 57autoMergeFrom' :: Git.Ref -> Maybe Git.Ref -> [Git.Merge.MergeConfig] -> Git.Branch.CommitMode -> Bool -> (Maybe Git.Ref -> Annex Bool) -> Annex Bool 58autoMergeFrom' branch currbranch mergeconfig commitmode willresolvemerge toresolvemerge = do 59 showOutput 60 case currbranch of 61 Nothing -> go Nothing 62 Just b -> go =<< inRepo (Git.Ref.sha b) 63 where 64 go old = do 65 -- merge.directoryRenames=conflict plus automatic 66 -- merge conflict resolution results in files in a 67 -- "renamed" directory getting variant names, 68 -- so is not a great combination. If the user has 69 -- explicitly set it, use it, but otherwise when 70 -- merge conflicts will be resolved, override 71 -- to merge.directoryRenames=false. 72 overridedirectoryrenames <- if willresolvemerge 73 then isNothing . mergeDirectoryRenames 74 <$> Annex.getGitConfig 75 else pure False 76 let f r 77 | overridedirectoryrenames = r 78 { Git.gitGlobalOpts = 79 Param "-c" 80 : Param "merge.directoryRenames=false" 81 : Git.gitGlobalOpts r 82 } 83 | otherwise = r 84 r <- inRepo (Git.Merge.merge branch mergeconfig commitmode . f) 85 <||> (toresolvemerge old <&&> commitResolvedMerge commitmode) 86 -- Merging can cause new associated files to appear 87 -- and the smudge filter will add them to the database. 88 -- To ensure that this process sees those changes, 89 -- close the database if it was open. 90 Database.Keys.closeDb 91 return r 92 93{- Resolves a conflicted merge. It's important that any conflicts be 94 - resolved in a way that itself avoids later merge conflicts, since 95 - multiple repositories may be doing this concurrently. 96 - 97 - Only merge conflicts where at least one side is an annexed file 98 - is resolved. 99 - 100 - This uses the Keys pointed to by the files to construct new 101 - filenames. So when both sides modified annexed file foo, 102 - it will be deleted, and replaced with files foo.variant-A and 103 - foo.variant-B. 104 - 105 - On the other hand, when one side deleted foo, and the other modified it, 106 - it will be deleted, and the modified version stored as file 107 - foo.variant-A (or B). 108 - 109 - It's also possible that one side has foo as an annexed file, and 110 - the other as a directory or non-annexed file. The annexed file 111 - is renamed to resolve the merge, and the other object is preserved as-is. 112 - 113 - The merge is resolved in the work tree and files 114 - staged, to clean up from a conflicted merge that was run in the work 115 - tree. 116 - 117 - This is complicated by needing to support merges run in an overlay 118 - work tree, in which case the CWD won't be within the work tree. 119 - In this mode, there is no need to update the work tree at all, 120 - as the overlay work tree will get deleted. 121 - 122 - Unlocked files remain unlocked after merging, and locked files 123 - remain locked. When the merge conflict is between a locked and unlocked 124 - file, that otherwise point to the same content, the unlocked mode wins. 125 - This is done because only unlocked files work in filesystems that don't 126 - support symlinks. 127 - 128 - Returns false when there are no merge conflicts to resolve. 129 - A git merge can fail for other reasons, and this allows detecting 130 - such failures. 131 -} 132resolveMerge :: Maybe Git.Ref -> Git.Ref -> Bool -> Annex Bool 133resolveMerge us them inoverlay = do 134 top <- if inoverlay 135 then pure "." 136 else fromRepo Git.repoPath 137 (fs, cleanup) <- inRepo (LsFiles.unmerged [top]) 138 srcmap <- if inoverlay 139 then pure M.empty 140 else inodeMap $ pure (map LsFiles.unmergedFile fs, return True) 141 (mergedks, mergedfs) <- unzip <$> mapM (resolveMerge' srcmap us them inoverlay) fs 142 let mergedks' = concat mergedks 143 let mergedfs' = catMaybes mergedfs 144 let merged = not (null mergedfs') 145 void $ liftIO cleanup 146 147 unless inoverlay $ do 148 (deleted, cleanup2) <- inRepo (LsFiles.deleted [] [top]) 149 unless (null deleted) $ 150 Annex.Queue.addCommand [] "rm" 151 [Param "--quiet", Param "-f", Param "--"] 152 (map fromRawFilePath deleted) 153 void $ liftIO cleanup2 154 155 when merged $ do 156 Annex.Queue.flush 157 unless inoverlay $ do 158 unstagedmap <- inodeMap $ inRepo $ 159 LsFiles.notInRepo [] False [top] 160 cleanConflictCruft mergedks' mergedfs' unstagedmap 161 showLongNote "Merge conflict was automatically resolved; you may want to examine the result." 162 return merged 163 164resolveMerge' :: InodeMap -> Maybe Git.Ref -> Git.Ref -> Bool -> LsFiles.Unmerged -> Annex ([Key], Maybe FilePath) 165resolveMerge' _ Nothing _ _ _ = return ([], Nothing) 166resolveMerge' unstagedmap (Just us) them inoverlay u = do 167 kus <- getkey LsFiles.valUs 168 kthem <- getkey LsFiles.valThem 169 case (kus, kthem) of 170 -- Both sides of conflict are annexed files 171 (Just keyUs, Just keyThem) 172 | keyUs /= keyThem -> resolveby [keyUs, keyThem] $ do 173 makevariantannexlink keyUs LsFiles.valUs 174 makevariantannexlink keyThem LsFiles.valThem 175 -- cleanConflictCruft can't handle unlocked 176 -- files, so delete here. 177 unless inoverlay $ 178 unless (islocked LsFiles.valUs) $ 179 liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath file) 180 | otherwise -> do 181 -- Only resolve using symlink when both 182 -- were locked, otherwise use unlocked 183 -- pointer. 184 -- In either case, keep original filename. 185 if islocked LsFiles.valUs && islocked LsFiles.valThem 186 then makesymlink keyUs file 187 else makepointer keyUs file (combinedmodes) 188 return ([keyUs, keyThem], Just file) 189 -- Our side is annexed file, other side is not. 190 -- Make the annexed file into a variant file and graft in the 191 -- other file/directory as it was. 192 (Just keyUs, Nothing) -> resolveby [keyUs] $ do 193 graftin them file LsFiles.valThem LsFiles.valThem LsFiles.valUs 194 makevariantannexlink keyUs LsFiles.valUs 195 -- Our side is not annexed file, other side is. 196 (Nothing, Just keyThem) -> resolveby [keyThem] $ do 197 graftin us file LsFiles.valUs LsFiles.valUs LsFiles.valThem 198 makevariantannexlink keyThem LsFiles.valThem 199 -- Neither side is annexed file; cannot resolve. 200 (Nothing, Nothing) -> return ([], Nothing) 201 where 202 file = fromRawFilePath $ LsFiles.unmergedFile u 203 204 getkey select = 205 case select (LsFiles.unmergedSha u) of 206 Just sha -> catKey sha 207 Nothing -> pure Nothing 208 209 islocked select = select (LsFiles.unmergedTreeItemType u) == Just TreeSymlink 210 211 combinedmodes = case catMaybes [ourmode, theirmode] of 212 [] -> Nothing 213 l -> Just (combineModes l) 214 where 215 ourmode = fromTreeItemType 216 <$> LsFiles.valUs (LsFiles.unmergedTreeItemType u) 217 theirmode = fromTreeItemType 218 <$> LsFiles.valThem (LsFiles.unmergedTreeItemType u) 219 220 makevariantannexlink key select 221 | islocked select = makesymlink key dest 222 | otherwise = makepointer key dest destmode 223 where 224 dest = variantFile file key 225 destmode = fromTreeItemType <$> select (LsFiles.unmergedTreeItemType u) 226 227 stagefile :: FilePath -> Annex FilePath 228 stagefile f 229 | inoverlay = (</> f) . fromRawFilePath <$> fromRepo Git.repoPath 230 | otherwise = pure f 231 232 makesymlink key dest = do 233 l <- calcRepo $ gitAnnexLink (toRawFilePath dest) key 234 unless inoverlay $ replacewithsymlink dest l 235 dest' <- toRawFilePath <$> stagefile dest 236 stageSymlink dest' =<< hashSymlink l 237 238 replacewithsymlink dest link = replaceWorkTreeFile dest $ 239 makeGitLink link . toRawFilePath 240 241 makepointer key dest destmode = do 242 unless inoverlay $ 243 unlessM (reuseOldFile unstagedmap key file dest) $ 244 linkFromAnnex key (toRawFilePath dest) destmode >>= \case 245 LinkAnnexFailed -> liftIO $ 246 writePointerFile (toRawFilePath dest) key destmode 247 _ -> noop 248 dest' <- toRawFilePath <$> stagefile dest 249 stagePointerFile dest' destmode =<< hashPointerFile key 250 unless inoverlay $ 251 Database.Keys.addAssociatedFile key 252 =<< inRepo (toTopFilePath (toRawFilePath dest)) 253 254 {- Stage a graft of a directory or file from a branch 255 - and update the work tree. -} 256 graftin b item selectwant selectwant' selectunwant = do 257 Annex.Queue.addUpdateIndex 258 =<< fromRepo (UpdateIndex.lsSubTree b item) 259 260 -- Update the work tree to reflect the graft. 261 unless inoverlay $ case (selectwant (LsFiles.unmergedTreeItemType u), selectunwant (LsFiles.unmergedTreeItemType u)) of 262 -- Symlinks are never left in work tree when 263 -- there's a conflict with anything else. 264 -- So, when grafting in a symlink, we must create it: 265 (Just TreeSymlink, _) -> do 266 case selectwant' (LsFiles.unmergedSha u) of 267 Nothing -> noop 268 Just sha -> do 269 link <- catSymLinkTarget sha 270 replacewithsymlink item link 271 -- And when grafting in anything else vs a symlink, 272 -- the work tree already contains what we want. 273 (_, Just TreeSymlink) -> noop 274 _ -> ifM (liftIO $ doesDirectoryExist item) 275 -- a conflict between a file and a directory 276 -- leaves the directory, so since a directory 277 -- is there, it must be what was wanted 278 ( noop 279 -- probably a file with conflict markers is 280 -- in the work tree; replace with grafted 281 -- file content 282 , case selectwant' (LsFiles.unmergedSha u) of 283 Nothing -> noop 284 Just sha -> replaceWorkTreeFile item $ \tmp -> do 285 c <- catObject sha 286 liftIO $ L.writeFile tmp c 287 ) 288 289 resolveby ks a = do 290 {- Remove conflicted file from index so merge can be resolved. -} 291 Annex.Queue.addCommand [] "rm" 292 [ Param "--quiet" 293 , Param "-f" 294 , Param "--cached" 295 , Param "--" 296 ] 297 [file] 298 void a 299 return (ks, Just file) 300 301{- git-merge moves conflicting files away to files 302 - named something like f~HEAD or f~branch or just f, but the 303 - exact name chosen can vary. Once the conflict is resolved, 304 - this cruft can be deleted. To avoid deleting legitimate 305 - files that look like this, only delete files that are 306 - A) not staged in git and 307 - B) have a name related to the merged files and 308 - C) are pointers to or have the content of keys that were involved 309 - in the merge. 310 -} 311cleanConflictCruft :: [Key] -> [FilePath] -> InodeMap -> Annex () 312cleanConflictCruft resolvedks resolvedfs unstagedmap = do 313 is <- S.fromList . map (inodeCacheToKey Strongly) . concat 314 <$> mapM Database.Keys.getInodeCaches resolvedks 315 forM_ (M.toList unstagedmap) $ \(i, f) -> 316 whenM (matchesresolved is i f) $ 317 liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) 318 where 319 fs = S.fromList resolvedfs 320 ks = S.fromList resolvedks 321 inks = maybe False (flip S.member ks) 322 matchesresolved is i f 323 | S.member f fs || S.member (conflictCruftBase f) fs = anyM id 324 [ pure $ either (const False) (`S.member` is) i 325 , inks <$> isAnnexLink (toRawFilePath f) 326 , inks <$> liftIO (isPointerFile (toRawFilePath f)) 327 ] 328 | otherwise = return False 329 330conflictCruftBase :: FilePath -> FilePath 331conflictCruftBase f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f 332 333{- When possible, reuse an existing file from the srcmap as the 334 - content of a worktree file in the resolved merge. It must have the 335 - same name as the origfile, or a name that git would use for conflict 336 - cruft. And, its inode cache must be a known one for the key. -} 337reuseOldFile :: InodeMap -> Key -> FilePath -> FilePath -> Annex Bool 338reuseOldFile srcmap key origfile destfile = do 339 is <- map (inodeCacheToKey Strongly) 340 <$> Database.Keys.getInodeCaches key 341 liftIO $ go $ mapMaybe (\i -> M.lookup (Right i) srcmap) is 342 where 343 go [] = return False 344 go (f:fs) 345 | f == origfile || conflictCruftBase f == origfile = 346 ifM (doesFileExist f) 347 ( do 348 renameFile f destfile 349 return True 350 , go fs 351 ) 352 | otherwise = go fs 353 354commitResolvedMerge :: Git.Branch.CommitMode -> Annex Bool 355commitResolvedMerge commitmode = do 356 commitquiet <- Git.Branch.CommitQuiet <$> commandProgressDisabled 357 inRepo $ Git.Branch.commitCommand commitmode commitquiet 358 [ Param "--no-verify" 359 , Param "-m" 360 , Param "git-annex automatic merge conflict fix" 361 ] 362 363type InodeMap = M.Map (Either FilePath InodeCacheKey) FilePath 364 365inodeMap :: Annex ([RawFilePath], IO Bool) -> Annex InodeMap 366inodeMap getfiles = do 367 (fs, cleanup) <- getfiles 368 fsis <- forM fs $ \f -> do 369 s <- liftIO $ R.getSymbolicLinkStatus f 370 let f' = fromRawFilePath f 371 if isSymbolicLink s 372 then pure $ Just (Left f', f') 373 else withTSDelta (\d -> liftIO $ toInodeCache d f s) 374 >>= return . \case 375 Just i -> Just (Right (inodeCacheToKey Strongly i), f') 376 Nothing -> Nothing 377 void $ liftIO cleanup 378 return $ M.fromList $ catMaybes fsis 379