1{- git-annex command 2 - 3 - Copyright 2011 Joachim Breitner <mail@joachim-breitner.de> 4 - Copyright 2011-2021 Joey Hess <id@joeyh.name> 5 - 6 - Licensed under the GNU AGPL version 3 or higher. 7 -} 8 9{-# LANGUAGE FlexibleContexts #-} 10{-# LANGUAGE OverloadedStrings #-} 11 12module Command.Sync ( 13 cmd, 14 CurrBranch, 15 mergeConfig, 16 merge, 17 prepMerge, 18 mergeLocal, 19 mergeRemote, 20 commitStaged, 21 commitMsg, 22 pushBranch, 23 updateBranch, 24 syncBranch, 25 updateBranches, 26 seekExportContent, 27 parseUnrelatedHistoriesOption, 28 SyncOptions(..), 29) where 30 31import Command 32import qualified Annex 33import qualified Annex.Branch 34import qualified Remote 35import qualified Types.Remote as Remote 36import Annex.Hook 37import qualified Git.Command 38import qualified Git.LsFiles as LsFiles 39import qualified Git.Branch 40import qualified Git.Merge 41import qualified Git.Types as Git 42import qualified Git.Ref 43import qualified Git 44import Git.FilePath 45import qualified Remote.Git 46import Config 47import Config.GitConfig 48import Annex.SpecialRemote.Config 49import Config.DynamicConfig 50import Annex.Path 51import Annex.Wanted 52import Annex.Content 53import Command.Get (getKey') 54import qualified Command.Move 55import qualified Command.Export 56import qualified Command.Import 57import Annex.Drop 58import Annex.UUID 59import Logs.UUID 60import Logs.Export 61import Logs.PreferredContent 62import Annex.AutoMerge 63import Annex.AdjustedBranch 64import Annex.AdjustedBranch.Merge 65import Annex.Ssh 66import Annex.BloomFilter 67import Annex.UpdateInstead 68import Annex.Export 69import Annex.TaggedPush 70import Annex.CurrentBranch 71import Annex.Import 72import Annex.CheckIgnore 73import Types.FileMatcher 74import qualified Database.Export as Export 75import Utility.Bloom 76import Utility.OptParse 77import Utility.Process.Transcript 78import Utility.Tuple 79 80import Control.Concurrent.MVar 81import qualified Data.Map as M 82import qualified Data.ByteString as S 83import Data.Char 84 85cmd :: Command 86cmd = withGlobalOptions [jobsOption] $ 87 command "sync" SectionCommon 88 "synchronize local repository with remotes" 89 (paramRepeating paramRemote) (seek <--< optParser) 90 91data SyncOptions = SyncOptions 92 { syncWith :: CmdParams 93 , onlyAnnexOption :: Bool 94 , notOnlyAnnexOption :: Bool 95 , commitOption :: Bool 96 , noCommitOption :: Bool 97 , messageOption :: Maybe String 98 , pullOption :: Bool 99 , pushOption :: Bool 100 , contentOption :: Bool 101 , noContentOption :: Bool 102 , contentOfOption :: [FilePath] 103 , cleanupOption :: Bool 104 , keyOptions :: Maybe KeyOptions 105 , resolveMergeOverride :: Bool 106 , allowUnrelatedHistories :: Bool 107 } 108 109instance Default SyncOptions where 110 def = SyncOptions 111 { syncWith = [] 112 , onlyAnnexOption = False 113 , notOnlyAnnexOption = False 114 , commitOption = False 115 , noCommitOption = False 116 , messageOption = Nothing 117 , pullOption = False 118 , pushOption = False 119 , contentOption = False 120 , noContentOption = False 121 , contentOfOption = [] 122 , cleanupOption = False 123 , keyOptions = Nothing 124 , resolveMergeOverride = False 125 , allowUnrelatedHistories = False 126 } 127 128optParser :: CmdParamsDesc -> Parser SyncOptions 129optParser desc = SyncOptions 130 <$> (many $ argument str 131 ( metavar desc 132 <> completeRemotes 133 )) 134 <*> switch 135 ( long "only-annex" 136 <> short 'a' 137 <> help "only sync git-annex branch and annexed file contents" 138 ) 139 <*> switch 140 ( long "not-only-annex" 141 <> help "sync git branches as well as annex" 142 ) 143 <*> switch 144 ( long "commit" 145 <> help "commit changes to git" 146 ) 147 <*> switch 148 ( long "no-commit" 149 <> help "avoid git commit" 150 ) 151 <*> optional (strOption 152 ( long "message" <> short 'm' <> metavar "MSG" 153 <> help "commit message" 154 )) 155 <*> invertableSwitch "pull" True 156 ( help "avoid git pulls from remotes" 157 ) 158 <*> invertableSwitch "push" True 159 ( help "avoid git pushes to remotes" 160 ) 161 <*> switch 162 ( long "content" 163 <> help "transfer annexed file contents" 164 ) 165 <*> switch 166 ( long "no-content" 167 <> help "do not transfer annexed file contents" 168 ) 169 <*> many (strOption 170 ( long "content-of" 171 <> short 'C' 172 <> help "transfer contents of annexed files in a given location" 173 <> metavar paramPath 174 )) 175 <*> switch 176 ( long "cleanup" 177 <> help "remove synced/ branches from previous sync" 178 ) 179 <*> optional parseAllOption 180 <*> invertableSwitch "resolvemerge" True 181 ( help "do not automatically resolve merge conflicts" 182 ) 183 <*> parseUnrelatedHistoriesOption 184 185parseUnrelatedHistoriesOption :: Parser Bool 186parseUnrelatedHistoriesOption = 187 invertableSwitch "allow-unrelated-histories" False 188 ( help "allow merging unrelated histories" 189 ) 190 191-- Since prepMerge changes the working directory, FilePath options 192-- have to be adjusted. 193instance DeferredParseClass SyncOptions where 194 finishParse v = SyncOptions 195 <$> pure (syncWith v) 196 <*> pure (onlyAnnexOption v) 197 <*> pure (notOnlyAnnexOption v) 198 <*> pure (commitOption v) 199 <*> pure (noCommitOption v) 200 <*> pure (messageOption v) 201 <*> pure (pullOption v) 202 <*> pure (pushOption v) 203 <*> pure (contentOption v) 204 <*> pure (noContentOption v) 205 <*> liftIO (mapM (fromRawFilePath <$$> absPath . toRawFilePath) (contentOfOption v)) 206 <*> pure (cleanupOption v) 207 <*> pure (keyOptions v) 208 <*> pure (resolveMergeOverride v) 209 <*> pure (allowUnrelatedHistories v) 210 211seek :: SyncOptions -> CommandSeek 212seek o = do 213 prepMerge 214 startConcurrency downloadStages (seek' o) 215 216seek' :: SyncOptions -> CommandSeek 217seek' o = do 218 let withbranch a = a =<< getCurrentBranch 219 220 remotes <- syncRemotes (syncWith o) 221 -- Remotes that are git repositories, not special remotes. 222 let gitremotes = filter (Remote.gitSyncableRemoteType . Remote.remotetype) remotes 223 -- Remotes that contain annex object content. 224 contentremotes <- filter (\r -> Remote.uuid r /= NoUUID) 225 <$> filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) remotes 226 227 if cleanupOption o 228 then do 229 commandAction (withbranch cleanupLocal) 230 mapM_ (commandAction . withbranch . cleanupRemote) gitremotes 231 else do 232 mc <- mergeConfig (allowUnrelatedHistories o) 233 234 -- Syncing involves many actions, any of which 235 -- can independently fail, without preventing 236 -- the others from running. 237 -- These actions cannot be run concurrently. 238 mapM_ includeCommandAction $ concat 239 [ [ commit o ] 240 , [ withbranch (mergeLocal mc o) ] 241 , map (withbranch . pullRemote o mc) gitremotes 242 , [ mergeAnnex ] 243 ] 244 245 content <- shouldSyncContent o 246 247 forM_ (filter isImport contentremotes) $ 248 withbranch . importRemote content o 249 forM_ (filter isThirdPartyPopulated contentremotes) $ 250 pullThirdPartyPopulated o 251 252 when content $ do 253 -- Send content to any exports before other 254 -- repositories, in case that lets content 255 -- be dropped from other repositories. 256 exportedcontent <- withbranch $ 257 seekExportContent (Just o) 258 (filter isExport contentremotes) 259 260 -- Sync content with remotes, but not with 261 -- export or import remotes, which handle content 262 -- syncing as part of export and import. 263 syncedcontent <- withbranch $ 264 seekSyncContent o $ filter 265 (\r -> not (isExport r || isImport r)) 266 contentremotes 267 268 -- Transferring content can take a while, 269 -- and other changes can be pushed to the 270 -- git-annex branch on the remotes in the 271 -- meantime, so pull and merge again to 272 -- avoid our push overwriting those changes. 273 when (syncedcontent || exportedcontent) $ do 274 mapM_ includeCommandAction $ concat 275 [ map (withbranch . pullRemote o mc) gitremotes 276 , [ commitAnnex, mergeAnnex ] 277 ] 278 279 void $ includeCommandAction $ withbranch $ pushLocal o 280 -- Pushes to remotes can run concurrently. 281 mapM_ (commandAction . withbranch . pushRemote o) gitremotes 282 283{- Merging may delete the current directory, so go to the top 284 - of the repo. This also means that sync always acts on all files in the 285 - repository, not just on a subdirectory. -} 286prepMerge :: Annex () 287prepMerge = Annex.changeDirectory . fromRawFilePath =<< fromRepo Git.repoPath 288 289mergeConfig :: Bool -> Annex [Git.Merge.MergeConfig] 290mergeConfig mergeunrelated = do 291 quiet <- commandProgressDisabled 292 return $ catMaybes 293 [ Just Git.Merge.MergeNonInteractive 294 , if mergeunrelated 295 then Just Git.Merge.MergeUnrelatedHistories 296 else Nothing 297 , if quiet 298 then Just Git.Merge.MergeQuiet 299 else Nothing 300 ] 301 302merge :: CurrBranch -> [Git.Merge.MergeConfig] -> SyncOptions -> Git.Branch.CommitMode -> Git.Branch -> Annex Bool 303merge currbranch mergeconfig o commitmode tomerge = do 304 canresolvemerge <- if resolveMergeOverride o 305 then getGitConfigVal annexResolveMerge 306 else return False 307 case currbranch of 308 (Just b, Just adj) -> mergeToAdjustedBranch tomerge (b, adj) mergeconfig canresolvemerge commitmode 309 (b, _) -> autoMergeFrom tomerge b mergeconfig commitmode canresolvemerge 310 311syncBranch :: Git.Branch -> Git.Branch 312syncBranch = Git.Ref.underBase "refs/heads/synced" . fromAdjustedBranch 313 314remoteBranch :: Remote -> Git.Ref -> Git.Ref 315remoteBranch remote = Git.Ref.underBase $ "refs/remotes/" ++ Remote.name remote 316 317-- Do automatic initialization of remotes when possible when getting remote 318-- list. 319syncRemotes :: [String] -> Annex [Remote] 320syncRemotes ps = do 321 remotelist <- Remote.remoteList' True 322 available <- filterM (liftIO . getDynamicConfig . remoteAnnexSync . Remote.gitconfig) remotelist 323 syncRemotes' ps available 324 325syncRemotes' :: [String] -> [Remote] -> Annex [Remote] 326syncRemotes' ps available = 327 ifM (Annex.getState Annex.fast) ( fastest <$> wanted , wanted ) 328 where 329 wanted 330 | null ps = filterM good (concat $ Remote.byCost available) 331 | otherwise = listed 332 333 listed = concat <$> mapM Remote.byNameOrGroup ps 334 335 good r 336 | Remote.gitSyncableRemoteType (Remote.remotetype r) = 337 Remote.Git.repoAvail =<< Remote.getRepo r 338 | otherwise = return True 339 340 fastest = fromMaybe [] . headMaybe . Remote.byCost 341 342commit :: SyncOptions -> CommandStart 343commit o = stopUnless shouldcommit $ starting "commit" ai si $ do 344 commitmessage <- maybe commitMsg return (messageOption o) 345 Annex.Branch.commit =<< Annex.Branch.commitMessage 346 next $ do 347 showOutput 348 let cmode = Git.Branch.ManualCommit 349 cquiet <- Git.Branch.CommitQuiet <$> commandProgressDisabled 350 void $ inRepo $ Git.Branch.commitCommand cmode cquiet 351 [ Param "-a" 352 , Param "-m" 353 , Param commitmessage 354 ] 355 return True 356 where 357 shouldcommit = notOnlyAnnex o <&&> 358 ( pure (commitOption o) 359 <||> (pure (not (noCommitOption o)) <&&> getGitConfigVal annexAutoCommit) 360 ) 361 ai = ActionItemOther Nothing 362 si = SeekInput [] 363 364commitMsg :: Annex String 365commitMsg = do 366 u <- getUUID 367 m <- uuidDescMap 368 return $ "git-annex in " ++ maybe "unknown" fromUUIDDesc (M.lookup u m) 369 370commitStaged :: Git.Branch.CommitMode -> String -> Annex Bool 371commitStaged commitmode commitmessage = do 372 runAnnexHook preCommitAnnexHook 373 mb <- inRepo Git.Branch.currentUnsafe 374 let (getparent, branch) = case mb of 375 Just b -> (Git.Ref.sha b, b) 376 Nothing -> (Git.Ref.headSha, Git.Ref.headRef) 377 parents <- maybeToList <$> inRepo getparent 378 void $ inRepo $ Git.Branch.commit commitmode False commitmessage branch parents 379 return True 380 381mergeLocal :: [Git.Merge.MergeConfig] -> SyncOptions -> CurrBranch -> CommandStart 382mergeLocal mergeconfig o currbranch = stopUnless (notOnlyAnnex o) $ 383 mergeLocal' mergeconfig o currbranch 384 385mergeLocal' :: [Git.Merge.MergeConfig] -> SyncOptions -> CurrBranch -> CommandStart 386mergeLocal' mergeconfig o currbranch@(Just branch, _) = 387 needMerge currbranch branch >>= \case 388 Nothing -> stop 389 Just syncbranch -> do 390 let ai = ActionItemOther (Just $ Git.Ref.describe syncbranch) 391 let si = SeekInput [] 392 starting "merge" ai si $ 393 next $ merge currbranch mergeconfig o Git.Branch.ManualCommit syncbranch 394mergeLocal' _ _ currbranch@(Nothing, _) = inRepo Git.Branch.currentUnsafe >>= \case 395 Just branch -> needMerge currbranch branch >>= \case 396 Nothing -> stop 397 Just syncbranch -> do 398 let ai = ActionItemOther (Just $ Git.Ref.describe syncbranch) 399 let si = SeekInput [] 400 starting "merge" ai si $ do 401 warning $ "There are no commits yet to branch " ++ Git.fromRef branch ++ ", so cannot merge " ++ Git.fromRef syncbranch ++ " into it." 402 next $ return False 403 Nothing -> stop 404 405-- Returns the branch that should be merged, if any. 406needMerge :: CurrBranch -> Git.Branch -> Annex (Maybe Git.Branch) 407needMerge currbranch headbranch = ifM (allM id checks) 408 ( return (Just syncbranch) 409 , return Nothing 410 ) 411 where 412 syncbranch = syncBranch headbranch 413 checks = case currbranch of 414 (Just _, madj) -> 415 let branch' = maybe headbranch (adjBranch . originalToAdjusted headbranch) madj 416 in 417 [ not <$> isBareRepo 418 , inRepo (Git.Ref.exists syncbranch) 419 , inRepo (Git.Branch.changed branch' syncbranch) 420 ] 421 (Nothing, _) -> 422 [ not <$> isBareRepo 423 , inRepo (Git.Ref.exists syncbranch) 424 ] 425 426pushLocal :: SyncOptions -> CurrBranch -> CommandStart 427pushLocal o b = stopUnless (notOnlyAnnex o) $ do 428 updateBranches b 429 stop 430 431updateBranches :: CurrBranch -> Annex () 432updateBranches (Nothing, _) = noop 433updateBranches (Just branch, madj) = do 434 -- When in an adjusted branch, propigate any changes made to it 435 -- back to the original branch. The adjusted branch may also need 436 -- to be updated, if the adjustment is not stable, and the usual 437 -- configuration does not update it. 438 case madj of 439 Nothing -> noop 440 Just adj -> do 441 let origbranch = branch 442 propigateAdjustedCommits origbranch adj 443 unless (adjustmentIsStable adj) $ 444 annexAdjustedBranchRefresh <$> Annex.getGitConfig >>= \case 445 0 -> adjustedBranchRefreshFull adj origbranch 446 _ -> return () 447 448 -- Update the sync branch to match the new state of the branch 449 inRepo $ updateBranch (syncBranch branch) branch 450 451updateBranch :: Git.Branch -> Git.Branch -> Git.Repo -> IO () 452updateBranch syncbranch updateto g = 453 unlessM go $ giveup $ "failed to update " ++ Git.fromRef syncbranch 454 where 455 go = Git.Command.runBool 456 [ Param "branch" 457 , Param "-f" 458 , Param $ Git.fromRef $ Git.Ref.base syncbranch 459 , Param $ Git.fromRef $ updateto 460 ] g 461 462pullRemote :: SyncOptions -> [Git.Merge.MergeConfig] -> Remote -> CurrBranch -> CommandStart 463pullRemote o mergeconfig remote branch = stopUnless (pure $ pullOption o && wantpull) $ 464 starting "pull" ai si $ do 465 showOutput 466 ifM (onlyAnnex o) 467 ( do 468 void $ fetch $ map Git.fromRef 469 [ Annex.Branch.name 470 , syncBranch $ Annex.Branch.name 471 ] 472 next $ return True 473 , ifM (fetch []) 474 ( next $ mergeRemote remote branch mergeconfig o 475 , next $ return True 476 ) 477 ) 478 where 479 fetch bs = do 480 repo <- Remote.getRepo remote 481 ms <- Annex.getState Annex.output 482 inRepoWithSshOptionsTo repo (Remote.gitconfig remote) $ 483 Git.Command.runBool $ catMaybes 484 [ Just $ Param "fetch" 485 , if commandProgressDisabled' ms 486 then Just $ Param "--quiet" 487 else Nothing 488 , Just $ Param $ Remote.name remote 489 ] ++ map Param bs 490 wantpull = remoteAnnexPull (Remote.gitconfig remote) 491 ai = ActionItemOther (Just (Remote.name remote)) 492 si = SeekInput [] 493 494importRemote :: Bool -> SyncOptions -> Remote -> CurrBranch -> CommandSeek 495importRemote importcontent o remote currbranch 496 | not (pullOption o) || not wantpull = noop 497 | otherwise = case remoteAnnexTrackingBranch (Remote.gitconfig remote) of 498 Nothing -> noop 499 Just tb -> do 500 let (b, p) = separate' (== (fromIntegral (ord ':'))) (Git.fromRef' tb) 501 let branch = Git.Ref b 502 let subdir = if S.null p 503 then Nothing 504 else Just (asTopFilePath p) 505 if canImportKeys remote importcontent 506 then do 507 Command.Import.seekRemote remote branch subdir importcontent (CheckGitIgnore True) 508 -- Importing generates a branch 509 -- that is not initially connected 510 -- to the current branch, so allow 511 -- merging unrelated histories when 512 -- mergeing it. 513 mc <- mergeConfig True 514 void $ mergeRemote remote currbranch mc o 515 else warning $ "Cannot import from " ++ Remote.name remote ++ " when not syncing content." 516 where 517 wantpull = remoteAnnexPull (Remote.gitconfig remote) 518 519{- Handle a remote that is populated by a third party, by listing 520 - the contents of the remote, and then adding only the files on it that 521 - importKey identifies to a tree. The tree is only used to keep track 522 - of where keys are located on the remote, no remote tracking branch is 523 - updated, because the filenames are the names of annex object files, 524 - not suitable for a tracking branch. Does not transfer any content. -} 525pullThirdPartyPopulated :: SyncOptions -> Remote -> CommandSeek 526pullThirdPartyPopulated o remote 527 | not (pullOption o) || not wantpull = noop 528 | not (canImportKeys remote False) = noop 529 | otherwise = void $ includeCommandAction $ starting "list" ai si $ 530 Command.Import.listContents' remote ImportTree (CheckGitIgnore False) go 531 where 532 go (Just importable) = importKeys remote ImportTree False True importable >>= \case 533 Just importablekeys -> do 534 (_imported, updatestate) <- recordImportTree remote ImportTree importablekeys 535 next $ do 536 updatestate 537 return True 538 Nothing -> next $ return False 539 go Nothing = next $ return True -- unchanged from before 540 541 ai = ActionItemOther (Just (Remote.name remote)) 542 si = SeekInput [] 543 544 wantpull = remoteAnnexPull (Remote.gitconfig remote) 545 546{- The remote probably has both a master and a synced/master branch. 547 - Which to merge from? Well, the master has whatever latest changes 548 - were committed (or pushed changes, if this is a bare remote), 549 - while the synced/master may have changes that some 550 - other remote synced to this remote. So, merge them both. -} 551mergeRemote :: Remote -> CurrBranch -> [Git.Merge.MergeConfig] -> SyncOptions -> CommandCleanup 552mergeRemote remote currbranch mergeconfig o = ifM isBareRepo 553 ( return True 554 , case currbranch of 555 (Nothing, _) -> do 556 branch <- inRepo Git.Branch.currentUnsafe 557 mergelisted (pure (branchlist branch)) 558 (Just branch, _) -> do 559 inRepo $ updateBranch (syncBranch branch) branch 560 mergelisted (tomerge (branchlist (Just branch))) 561 ) 562 where 563 mergelisted getlist = and <$> 564 (mapM (merge currbranch mergeconfig o Git.Branch.ManualCommit . remoteBranch remote) =<< getlist) 565 tomerge = filterM (changed remote) 566 branchlist Nothing = [] 567 branchlist (Just branch) = [fromAdjustedBranch branch, syncBranch branch] 568 569pushRemote :: SyncOptions -> Remote -> CurrBranch -> CommandStart 570pushRemote _o _remote (Nothing, _) = stop 571pushRemote o remote (Just branch, _) = do 572 onlyannex <- onlyAnnex o 573 let mainbranch = if onlyannex then Nothing else Just branch 574 stopUnless (pure (pushOption o) <&&> needpush mainbranch) $ 575 starting "push" ai si $ next $ do 576 repo <- Remote.getRepo remote 577 showOutput 578 ms <- Annex.getState Annex.output 579 ok <- inRepoWithSshOptionsTo repo gc $ 580 pushBranch remote mainbranch ms 581 if ok 582 then postpushupdate repo 583 else do 584 warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ] 585 return ok 586 where 587 ai = ActionItemOther (Just (Remote.name remote)) 588 si = SeekInput [] 589 gc = Remote.gitconfig remote 590 needpush mainbranch 591 | remoteAnnexReadOnly gc = return False 592 | not (remoteAnnexPush gc) = return False 593 | otherwise = anyM (newer remote) $ catMaybes 594 [ syncBranch <$> mainbranch 595 , Just (Annex.Branch.name) 596 ] 597 -- Older remotes on crippled filesystems may not have a 598 -- post-receive hook set up, so when updateInstead emulation 599 -- is needed, run post-receive manually. 600 postpushupdate repo = case Git.repoWorkTree repo of 601 Nothing -> return True 602 Just wt -> ifM needemulation 603 ( gitAnnexChildProcess "post-receive" [] 604 (\cp -> cp { cwd = Just (fromRawFilePath wt) }) 605 (\_ _ _ pid -> waitForProcess pid >>= return . \case 606 ExitSuccess -> True 607 _ -> False 608 ) 609 , return True 610 ) 611 where 612 needemulation = Remote.Git.onLocalRepo repo $ 613 (annexCrippledFileSystem <$> Annex.getGitConfig) 614 <&&> 615 needUpdateInsteadEmulation 616 617{- Pushes a regular branch like master to a remote. Also pushes the git-annex 618 - branch. 619 - 620 - If the remote is a bare git repository, it's best to push the regular 621 - branch directly to it, so that cloning/pulling will get it. 622 - On the other hand, if it's not bare, pushing to the checked out branch 623 - will generally fail (except with receive.denyCurrentBranch=updateInstead), 624 - and this is why we push to its syncBranch. 625 - 626 - Git offers no way to tell if a remote is bare or not, so both methods 627 - are tried. 628 - 629 - The direct push is likely to spew an ugly error message, so its stderr is 630 - often elided. Since git progress display goes to stderr too, the 631 - sync push is done first, and actually sends the data. Then the 632 - direct push is tried, with stderr discarded, to update the branch ref 633 - on the remote. 634 - 635 - The sync push first sends the synced/master branch, 636 - and then forces the update of the remote synced/git-annex branch. 637 - 638 - Since some providers like github may treat the first branch sent 639 - as the default branch, it's better to make that be synced/master than 640 - synced/git-annex. (Although neither is ideal, it's the best that 641 - can be managed given the constraints on order.) 642 - 643 - The forcing is necessary if a transition has rewritten the git-annex branch. 644 - Normally any changes to the git-annex branch get pulled and merged before 645 - this push, so this forcing is unlikely to overwrite new data pushed 646 - in from another repository that is also syncing. 647 - 648 - But overwriting of data on synced/git-annex can happen, in a race. 649 - The only difference caused by using a forced push in that case is that 650 - the last repository to push wins the race, rather than the first to push. 651 -} 652pushBranch :: Remote -> Maybe Git.Branch -> MessageState -> Git.Repo -> IO Bool 653pushBranch remote mbranch ms g = directpush `after` annexpush `after` syncpush 654 where 655 syncpush = flip Git.Command.runBool g $ pushparams $ catMaybes 656 [ (refspec . fromAdjustedBranch) <$> mbranch 657 , Just $ Git.Branch.forcePush $ refspec Annex.Branch.name 658 ] 659 annexpush = void $ tryIO $ flip Git.Command.runQuiet g $ pushparams 660 [ Git.fromRef $ Git.Ref.base $ Annex.Branch.name ] 661 directpush = case mbranch of 662 Nothing -> noop 663 -- Git prints out an error message when this fails. 664 -- In the default configuration of receive.denyCurrentBranch, 665 -- the error message mentions that config setting 666 -- (and should even if it is localized), and is quite long, 667 -- and the user was not intending to update the checked out 668 -- branch, so in that case, avoid displaying the error 669 -- message. Do display other error messages though, 670 -- including the error displayed when 671 -- receive.denyCurrentBranch=updateInstead -- the user 672 -- will want to see that one. 673 Just branch -> do 674 let p = flip Git.Command.gitCreateProcess g $ pushparams 675 [ Git.fromRef $ Git.Ref.base $ fromAdjustedBranch branch ] 676 (transcript, ok) <- processTranscript' p Nothing 677 when (not ok && not ("denyCurrentBranch" `isInfixOf` transcript)) $ 678 hPutStr stderr transcript 679 pushparams branches = catMaybes 680 [ Just $ Param "push" 681 , if commandProgressDisabled' ms 682 then Just $ Param "--quiet" 683 else Nothing 684 , Just $ Param $ Remote.name remote 685 ] ++ map Param branches 686 refspec b = concat 687 [ Git.fromRef $ Git.Ref.base b 688 , ":" 689 , Git.fromRef $ Git.Ref.base $ syncBranch b 690 ] 691 692commitAnnex :: CommandStart 693commitAnnex = do 694 Annex.Branch.commit =<< Annex.Branch.commitMessage 695 stop 696 697mergeAnnex :: CommandStart 698mergeAnnex = do 699 void Annex.Branch.forceUpdate 700 stop 701 702changed :: Remote -> Git.Ref -> Annex Bool 703changed remote b = do 704 let r = remoteBranch remote b 705 ifM (inRepo $ Git.Ref.exists r) 706 ( inRepo $ Git.Branch.changed b r 707 , return False 708 ) 709 710newer :: Remote -> Git.Ref -> Annex Bool 711newer remote b = do 712 let r = remoteBranch remote b 713 ifM (inRepo $ Git.Ref.exists r) 714 ( inRepo $ Git.Branch.changed r b 715 , return True 716 ) 717 718{- Without --all, only looks at files in the work tree. 719 - (Or, when in an ajusted branch where some files are hidden, at files in 720 - the original branch.) 721 - 722 - With --all, when preferred content expressions look at filenames, 723 - makes a first pass over the files in the work tree so those preferred 724 - content expressions will match. The second pass is over all keys, 725 - and only preferred content expressions that don't look at filenames 726 - will match. 727 - 728 - Returns true if any file transfers were made. 729 - 730 - When concurrency is enabled, files are processed concurrently. 731 -} 732seekSyncContent :: SyncOptions -> [Remote] -> CurrBranch -> Annex Bool 733seekSyncContent _ [] _ = return False 734seekSyncContent o rs currbranch = do 735 mvar <- liftIO newEmptyMVar 736 bloom <- case keyOptions o of 737 Just WantAllKeys -> ifM preferredcontentmatchesfilenames 738 ( Just <$> genBloomFilter (seekworktree mvar (WorkTreeItems [])) 739 , pure Nothing 740 ) 741 _ -> case currbranch of 742 (Just origbranch, Just adj) | adjustmentHidesFiles adj -> do 743 l <- workTreeItems' (AllowHidden True) ww (contentOfOption o) 744 seekincludinghidden origbranch mvar l (const noop) 745 pure Nothing 746 _ -> do 747 l <- workTreeItems ww (contentOfOption o) 748 seekworktree mvar l (const noop) 749 pure Nothing 750 waitForAllRunningCommandActions 751 withKeyOptions' (keyOptions o) False 752 (return (const (commandAction . gokey mvar bloom))) 753 (const noop) 754 (WorkTreeItems []) 755 waitForAllRunningCommandActions 756 liftIO $ not <$> isEmptyMVar mvar 757 where 758 seekworktree mvar l bloomfeeder = do 759 let seeker = AnnexedFileSeeker 760 { startAction = gofile bloomfeeder mvar 761 , checkContentPresent = Nothing 762 , usesLocationLog = True 763 } 764 seekFilteredKeys seeker $ 765 seekHelper fst3 ww LsFiles.inRepoDetails l 766 767 seekincludinghidden origbranch mvar l bloomfeeder = 768 seekFiltered (const (pure True)) (\(si, f) -> ifAnnexed f (commandAction . gofile bloomfeeder mvar si f) noop) $ 769 seekHelper id ww (LsFiles.inRepoOrBranch origbranch) l 770 771 ww = WarnUnmatchLsFiles 772 773 gofile bloom mvar _ f k = 774 go (Right bloom) mvar (AssociatedFile (Just f)) k 775 776 gokey mvar bloom (_, k, _) = 777 go (Left bloom) mvar (AssociatedFile Nothing) k 778 779 go ebloom mvar af k = do 780 let ai = OnlyActionOn k (ActionItemKey k) 781 startingNoMessage ai $ do 782 whenM (syncFile ebloom rs af k) $ 783 void $ liftIO $ tryPutMVar mvar () 784 next $ return True 785 786 preferredcontentmatchesfilenames = 787 preferredcontentmatchesfilenames' Nothing 788 <||> anyM (preferredcontentmatchesfilenames' . Just . Remote.uuid) rs 789 preferredcontentmatchesfilenames' = 790 introspectPreferredRequiredContent matchNeedsFileName 791 792{- If it's preferred content, and we don't have it, get it from one of the 793 - listed remotes (preferring the cheaper earlier ones). 794 - 795 - Send it to each remote that doesn't have it, and for which it's 796 - preferred content. 797 - 798 - Drop it locally if it's not preferred content (honoring numcopies). 799 - 800 - Drop it from each remote that has it, where it's not preferred content 801 - (honoring numcopies). 802 - 803 - Returns True if any file transfers were made. 804 -} 805syncFile :: Either (Maybe (Bloom Key)) (Key -> Annex ()) -> [Remote] -> AssociatedFile -> Key -> Annex Bool 806syncFile ebloom rs af k = do 807 inhere <- inAnnex k 808 locs <- map Remote.uuid <$> Remote.keyPossibilities k 809 let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs 810 811 got <- anyM id =<< handleget have inhere 812 putrs <- handleput lack 813 814 u <- getUUID 815 let locs' = concat [if inhere || got then [u] else [], putrs, locs] 816 817 -- To handle --all, a bloom filter is populated with all the keys 818 -- of files in the working tree in the first pass. On the second 819 -- pass, avoid dropping keys that were seen in the first pass, which 820 -- would happen otherwise when preferred content matches on the 821 -- filename, which is not available in the second pass. 822 -- (When the preferred content expressions do not match on 823 -- filenames, the first pass is skipped for speed.) 824 -- 825 -- When there's a false positive in the bloom filter, the result 826 -- is keeping a key that preferred content doesn't really want. 827 seenbloom <- case ebloom of 828 Left Nothing -> pure False 829 Left (Just bloom) -> pure (elemB k bloom) 830 Right bloomfeeder -> bloomfeeder k >> return False 831 unless seenbloom $ 832 -- Using callCommandAction rather than 833 -- includeCommandAction for drops, 834 -- because a failure to drop does not mean 835 -- the sync failed. 836 handleDropsFrom locs' rs "unwanted" True k af si [] 837 callCommandAction 838 839 return (got || not (null putrs)) 840 where 841 wantget have inhere = allM id 842 [ pure (not $ null have) 843 , pure (not inhere) 844 , wantGet True (Just k) af 845 ] 846 handleget have inhere = ifM (wantget have inhere) 847 ( return [ get have ] 848 , return [] 849 ) 850 get have = includeCommandAction $ starting "get" ai si $ 851 stopUnless (getKey' k af have) $ 852 next $ return True 853 854 wantput r 855 | Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False 856 | isThirdPartyPopulated r = return False 857 | otherwise = wantSend True (Just k) af (Remote.uuid r) 858 handleput lack = catMaybes <$> ifM (inAnnex k) 859 ( forM lack $ \r -> 860 ifM (wantput r <&&> put r) 861 ( return (Just (Remote.uuid r)) 862 , return Nothing 863 ) 864 , return [] 865 ) 866 put dest = includeCommandAction $ 867 Command.Move.toStart' dest Command.Move.RemoveNever af k ai si 868 869 ai = mkActionItem (k, af) 870 si = SeekInput [] 871 872{- When a remote has an annex-tracking-branch configuration, change the export 873 - to contain the current content of the branch. Otherwise, transfer any files 874 - that were part of an export but are not in the remote yet. 875 - 876 - Returns True if any file transfers were made. 877 -} 878seekExportContent :: Maybe SyncOptions -> [Remote] -> CurrBranch -> Annex Bool 879seekExportContent o rs (currbranch, _) = or <$> forM rs go 880 where 881 go r 882 | not (maybe True pullOption o) = return False 883 | not (remoteAnnexPush (Remote.gitconfig r)) = return False 884 | otherwise = bracket 885 (Export.openDb (Remote.uuid r)) 886 Export.closeDb 887 (\db -> Export.writeLockDbWhile db (go' r db)) 888 go' r db = case remoteAnnexTrackingBranch (Remote.gitconfig r) of 889 Nothing -> nontracking r db 890 Just b -> do 891 mtree <- inRepo $ Git.Ref.tree b 892 mtbcommitsha <- Command.Export.getExportCommit r b 893 case (mtree, mtbcommitsha) of 894 (Just tree, Just _) -> do 895 filteredtree <- Command.Export.filterExport r tree 896 Command.Export.changeExport r db filteredtree 897 Command.Export.fillExport r db filteredtree mtbcommitsha 898 _ -> nontracking r db 899 900 nontracking r db = do 901 exported <- getExport (Remote.uuid r) 902 maybe noop (warnnontracking r exported) currbranch 903 nontrackingfillexport r db (exportedTreeishes exported) Nothing 904 905 warnnontracking r exported currb = inRepo (Git.Ref.tree currb) >>= \case 906 Just currt | not (any (== currt) (exportedTreeishes exported)) -> 907 showLongNote $ unwords 908 [ "Not updating export to " ++ Remote.name r 909 , "to reflect changes to the tree, because export" 910 , "tracking is not enabled. " 911 , "(Set " ++ gitconfig ++ " to enable it.)" 912 ] 913 _ -> noop 914 where 915 gitconfig = show (remoteAnnexConfig r "tracking-branch") 916 917 nontrackingfillexport _ _ [] _ = return False 918 nontrackingfillexport r db (tree:[]) mtbcommitsha = do 919 -- The tree was already filtered when it was exported, so 920 -- does not need be be filtered again now, when we're only 921 -- filling in any files that did not get transferred. 922 let filteredtree = Command.Export.ExportFiltered tree 923 Command.Export.fillExport r db filteredtree mtbcommitsha 924 nontrackingfillexport r _ _ _ = do 925 warnExportImportConflict r 926 return False 927 928cleanupLocal :: CurrBranch -> CommandStart 929cleanupLocal (Nothing, _) = stop 930cleanupLocal (Just currb, _) = starting "cleanup" ai si $ next $ do 931 delbranch $ syncBranch currb 932 delbranch $ syncBranch $ Git.Ref.base $ Annex.Branch.name 933 mapM_ (\(s,r) -> inRepo $ Git.Ref.delete s r) =<< listTaggedBranches 934 return True 935 where 936 delbranch b = whenM (inRepo $ Git.Ref.exists $ Git.Ref.branchRef b) $ 937 inRepo $ Git.Branch.delete b 938 ai = ActionItemOther (Just "local") 939 si = SeekInput [] 940 941cleanupRemote :: Remote -> CurrBranch -> CommandStart 942cleanupRemote _ (Nothing, _) = stop 943cleanupRemote remote (Just b, _) = 944 starting "cleanup" ai si $ 945 next $ inRepo $ Git.Command.runBool 946 [ Param "push" 947 , Param "--quiet" 948 , Param "--delete" 949 , Param $ Remote.name remote 950 , Param $ Git.fromRef $ syncBranch b 951 , Param $ Git.fromRef $ syncBranch $ 952 Git.Ref.base $ Annex.Branch.name 953 ] 954 where 955 ai = ActionItemOther (Just (Remote.name remote)) 956 si = SeekInput [] 957 958shouldSyncContent :: SyncOptions -> Annex Bool 959shouldSyncContent o 960 | noContentOption o = pure False 961 | contentOption o || not (null (contentOfOption o)) = pure True 962 | otherwise = getGitConfigVal annexSyncContent <||> onlyAnnex o 963 964notOnlyAnnex :: SyncOptions -> Annex Bool 965notOnlyAnnex o = not <$> onlyAnnex o 966 967onlyAnnex :: SyncOptions -> Annex Bool 968onlyAnnex o 969 | notOnlyAnnexOption o = pure False 970 | onlyAnnexOption o = pure True 971 | otherwise = getGitConfigVal annexSyncOnlyAnnex 972 973isExport :: Remote -> Bool 974isExport = exportTree . Remote.config 975 976isImport :: Remote -> Bool 977isImport = importTree . Remote.config 978 979isThirdPartyPopulated :: Remote -> Bool 980isThirdPartyPopulated = Remote.thirdPartyPopulated . Remote.remotetype 981