git-annex/Command/Sync.hs

364 lines
11 KiB
Haskell
Raw Normal View History

{- git-annex command
-
2011-12-30 20:24:30 +00:00
- Copyright 2011 Joachim Breitner <mail@joachim-breitner.de>
- Copyright 2011,2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Command.Sync where
import Common.Annex
import Command
import qualified Remote
import qualified Annex
import qualified Annex.Branch
import qualified Annex.Queue
2012-12-12 23:20:38 +00:00
import Annex.Direct
import Annex.CatFile
fully support core.symlinks=false in all relevant symlink handling code Refactored annex link code into nice clean new library. Audited and dealt with calls to createSymbolicLink. Remaining calls are all safe, because: Annex/Link.hs: ( liftIO $ createSymbolicLink linktarget file only when core.symlinks=true Assistant/WebApp/Configurators/Local.hs: createSymbolicLink link link test if symlinks can be made Command/Fix.hs: liftIO $ createSymbolicLink link file command only works in indirect mode Command/FromKey.hs: liftIO $ createSymbolicLink link file command only works in indirect mode Command/Indirect.hs: liftIO $ createSymbolicLink l f refuses to run if core.symlinks=false Init.hs: createSymbolicLink f f2 test if symlinks can be made Remote/Directory.hs: go [file] = catchBoolIO $ createSymbolicLink file f >> return True fast key linking; catches failure to make symlink and falls back to copy Remote/Git.hs: liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True ditto Upgrade/V1.hs: liftIO $ createSymbolicLink link f v1 repos could not be on a filesystem w/o symlinks Audited and dealt with calls to readSymbolicLink. Remaining calls are all safe, because: Annex/Link.hs: ( liftIO $ catchMaybeIO $ readSymbolicLink file only when core.symlinks=true Assistant/Threads/Watcher.hs: ifM ((==) (Just link) <$> liftIO (catchMaybeIO $ readSymbolicLink file)) code that fixes real symlinks when inotify sees them It's ok to not fix psdueo-symlinks. Assistant/Threads/Watcher.hs: mlink <- liftIO (catchMaybeIO $ readSymbolicLink file) ditto Command/Fix.hs: stopUnless ((/=) (Just link) <$> liftIO (catchMaybeIO $ readSymbolicLink file)) $ do command only works in indirect mode Upgrade/V1.hs: getsymlink = takeFileName <$> readSymbolicLink file v1 repos could not be on a filesystem w/o symlinks Audited and dealt with calls to isSymbolicLink. (Typically used with getSymbolicLinkStatus, but that is just used because getFileStatus is not as robust; it also works on pseudolinks.) Remaining calls are all safe, because: Assistant/Threads/SanityChecker.hs: | isSymbolicLink s -> addsymlink file ms only handles staging of symlinks that were somehow not staged (might need to be updated to support pseudolinks, but this is only a belt-and-suspenders check anyway, and I've never seen the code run) Command/Add.hs: if isSymbolicLink s || not (isRegularFile s) avoids adding symlinks to the annex, so not relevant Command/Indirect.hs: | isSymbolicLink s -> void $ flip whenAnnexed f $ only allowed on systems that support symlinks Command/Indirect.hs: whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do ditto Seek.hs:notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f used to find unlocked files, only relevant in indirect mode Utility/FSEvents.hs: | Files.isSymbolicLink s = runhook addSymlinkHook $ Just s Utility/FSEvents.hs: | Files.isSymbolicLink s -> Utility/INotify.hs: | Files.isSymbolicLink s -> Utility/INotify.hs: checkfiletype Files.isSymbolicLink addSymlinkHook f Utility/Kqueue.hs: | Files.isSymbolicLink s = callhook addSymlinkHook (Just s) change all above are lower-level, not relevant Audited and dealt with calls to isSymLink. Remaining calls are all safe, because: Annex/Direct.hs: | isSymLink (getmode item) = This is looking at git diff-tree objects, not files on disk Command/Unused.hs: | isSymLink (LsTree.mode l) = do This is looking at git ls-tree, not file on disk Utility/FileMode.hs:isSymLink :: FileMode -> Bool Utility/FileMode.hs:isSymLink = checkMode symbolicLinkMode low-level Done!!
2013-02-17 19:05:55 +00:00
import Annex.Link
2011-12-14 19:56:11 +00:00
import qualified Git.Command
import qualified Git.LsFiles as LsFiles
import qualified Git.Merge
import qualified Git.Branch
import qualified Git.Ref
import qualified Git
import Git.Types (BlobType(..))
import qualified Types.Remote
import qualified Remote.Git
import Types.Key
import Config
import Annex.ReplaceFile
import Data.Hash.MD5
def :: [Command]
def = [command "sync" (paramOptional (paramRepeating paramRemote))
[seek] SectionCommon "synchronize local repository with remotes"]
2011-12-31 06:18:16 +00:00
-- syncing involves several operations, any of which can independently fail
seek :: CommandSeek
seek rs = do
branch <- fromMaybe nobranch <$> inRepo Git.Branch.current
remotes <- syncRemotes rs
2012-02-16 04:41:30 +00:00
return $ concat
2011-12-30 21:54:09 +00:00
[ [ commit ]
, [ mergeLocal branch ]
, [ pullRemote remote branch | remote <- remotes ]
2011-12-30 21:54:09 +00:00
, [ mergeAnnex ]
, [ pushLocal branch ]
, [ pushRemote remote branch | remote <- remotes ]
2011-12-30 21:54:09 +00:00
]
2012-11-12 05:05:04 +00:00
where
nobranch = error "no branch is checked out"
2011-12-30 20:24:30 +00:00
syncBranch :: Git.Ref -> Git.Ref
syncBranch = Git.Ref.under "refs/heads/synced/"
2011-12-31 08:11:39 +00:00
remoteBranch :: Remote -> Git.Ref -> Git.Ref
2011-12-31 07:01:18 +00:00
remoteBranch remote = Git.Ref.under $ "refs/remotes/" ++ Remote.name remote
2011-12-31 08:11:39 +00:00
syncRemotes :: [String] -> Annex [Remote]
syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
2012-11-12 05:05:04 +00:00
where
pickfast = (++) <$> listed <*> (good =<< fastest <$> available)
wanted
| null rs = good =<< concat . Remote.byCost <$> available
| otherwise = listed
listed = do
l <- catMaybes <$> mapM (Remote.byName . Just) rs
let s = filter Remote.specialRemote l
unless (null s) $
error $ "cannot sync special remotes: " ++
unwords (map Types.Remote.name s)
return l
available = filter (not . Remote.specialRemote)
. filter (remoteAnnexSync . Types.Remote.gitconfig)
<$> Remote.remoteList
2012-11-12 05:05:04 +00:00
good = filterM $ Remote.Git.repoAvail . Types.Remote.repo
fastest = fromMaybe [] . headMaybe . Remote.byCost
2011-12-10 16:21:22 +00:00
commit :: CommandStart
2012-12-12 23:20:38 +00:00
commit = next $ next $ do
ifM isDirect
( do
void $ stageDirect
runcommit []
2012-12-12 23:20:38 +00:00
, runcommit [Param "-a"]
)
where
runcommit ps = do
showStart "commit" ""
2011-12-10 16:21:22 +00:00
showOutput
2012-12-13 19:58:38 +00:00
Annex.Branch.commit "update"
2011-12-10 16:21:22 +00:00
-- Commit will fail when the tree is clean, so ignore failure.
let params = (Param "commit") : ps ++
2012-12-12 23:20:38 +00:00
[Param "-m", Param "git-annex automatic sync"]
_ <- inRepo $ tryIO . Git.Command.runQuiet params
2011-12-10 16:21:22 +00:00
return True
mergeLocal :: Git.Ref -> CommandStart
mergeLocal branch = go =<< needmerge
2012-11-12 05:05:04 +00:00
where
syncbranch = syncBranch branch
needmerge = ifM isBareRepo
( return False
, do
unlessM (inRepo $ Git.Ref.exists syncbranch) $
inRepo $ updateBranch syncbranch
inRepo $ Git.Branch.changed branch syncbranch
)
2012-11-12 05:05:04 +00:00
go False = stop
go True = do
showStart "merge" $ Git.Ref.describe syncbranch
next $ next $ mergeFrom syncbranch
pushLocal :: Git.Ref -> CommandStart
pushLocal branch = do
inRepo $ updateBranch $ syncBranch branch
stop
2011-12-30 22:52:24 +00:00
updateBranch :: Git.Ref -> Git.Repo -> IO ()
updateBranch syncbranch g =
2011-12-30 22:52:24 +00:00
unlessM go $ error $ "failed to update " ++ show syncbranch
2012-11-12 05:05:04 +00:00
where
go = Git.Command.runBool
[ Param "branch"
, Param "-f"
2012-11-12 05:05:04 +00:00
, Param $ show $ Git.Ref.base syncbranch
] g
2011-12-30 21:38:38 +00:00
2011-12-31 08:11:39 +00:00
pullRemote :: Remote -> Git.Ref -> CommandStart
pullRemote remote branch = do
showStart "pull" (Remote.name remote)
2011-12-30 21:38:38 +00:00
next $ do
showOutput
stopUnless fetch $
next $ mergeRemote remote (Just branch)
2012-11-12 05:05:04 +00:00
where
fetch = inRepo $ Git.Command.runBool
[Param "fetch", Param $ Remote.name remote]
{- The remote probably has both a master and a synced/master branch.
- Which to merge from? Well, the master has whatever latest changes
- were committed (or pushed changes, if this is a bare remote),
- while the synced/master may have changes that some
- other remote synced to this remote. So, merge them both. -}
mergeRemote :: Remote -> (Maybe Git.Ref) -> CommandCleanup
mergeRemote remote b = case b of
Nothing -> do
branch <- inRepo Git.Branch.currentUnsafe
all id <$> (mapM merge $ branchlist branch)
2012-12-12 23:20:38 +00:00
Just _ -> all id <$> (mapM merge =<< tomerge (branchlist b))
2012-11-12 05:05:04 +00:00
where
merge = mergeFrom . remoteBranch remote
tomerge branches = filterM (changed remote) branches
branchlist Nothing = []
branchlist (Just branch) = [branch, syncBranch branch]
2011-12-31 08:11:39 +00:00
pushRemote :: Remote -> Git.Ref -> CommandStart
pushRemote remote branch = go =<< needpush
2012-11-12 05:05:04 +00:00
where
needpush = anyM (newer remote) [syncBranch branch, Annex.Branch.name]
go False = stop
go True = do
showStart "push" (Remote.name remote)
next $ next $ do
showOutput
inRepo $ pushBranch remote branch
{- Pushes a regular branch like master to a remote. Also pushes the git-annex
- branch.
-
- If the remote is a bare git repository, it's best to push the regular
- branch directly to it, so that cloning/pulling will get it.
- On the other hand, if it's not bare, pushing to the checked out branch
- will fail, and this is why we push to its syncBranch.
-
- Git offers no way to tell if a remote is bare or not, so both methods
- are tried.
-
- The direct push is likely to spew an ugly error message, so stderr is
- elided. Since git progress display goes to stderr too, the sync push
- is done first, and actually sends the data. Then the direct push is
- tried, with stderr discarded, to update the branch ref on the remote.
-
- The sync push forces the update of the remote synced/git-annex branch.
- This is necessary if a transition has rewritten the git-annex branch.
- Normally any changes to the git-annex branch get pulled and merged before
- this push, so this forcing is unlikely to overwrite new data pushed
- in from another repository that is also syncing.
-
- But overwriting of data on synced/git-annex can happen, in a race.
- The only difference caused by using a forced push in that case is that
- the last repository to push wins the race, rather than the first to push.
-}
pushBranch :: Remote -> Git.Ref -> Git.Repo -> IO Bool
pushBranch remote branch g = tryIO (directpush g) `after` syncpush g
where
syncpush = Git.Command.runBool $ pushparams
[ Git.Branch.forcePush $ refspec Annex.Branch.name
, refspec branch
]
directpush = Git.Command.runQuiet $ pushparams
[show $ Git.Ref.base branch]
pushparams branches =
[ Param "push"
, Param $ Remote.name remote
] ++ map Param branches
2012-11-12 05:05:04 +00:00
refspec b = concat
[ show $ Git.Ref.base b
, ":"
, show $ Git.Ref.base $ syncBranch b
]
mergeAnnex :: CommandStart
2011-12-30 21:38:38 +00:00
mergeAnnex = do
void $ Annex.Branch.forceUpdate
2011-12-30 21:38:38 +00:00
stop
2011-12-31 06:18:16 +00:00
{- Merges from a branch into the current branch. -}
mergeFrom :: Git.Ref -> Annex Bool
mergeFrom branch = do
showOutput
ifM isDirect
( maybe go godirect =<< inRepo Git.Branch.current
, go
)
where
go = runmerge $ inRepo $ Git.Merge.mergeNonInteractive branch
godirect currbranch = do
old <- inRepo $ Git.Ref.sha currbranch
d <- fromRepo gitAnnexMergeDir
r <- runmerge $ inRepo $ mergeDirect d branch
new <- inRepo $ Git.Ref.sha currbranch
case (old, new) of
(Just oldsha, Just newsha) ->
mergeDirectCleanup d oldsha newsha
_ -> noop
return r
runmerge a = ifM (a)
( return True
, resolveMerge
)
{- 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 annexed files are resolved; other files are left for the user to
- handle.
-
- This uses the Keys pointed to by the files to construct new
- filenames. So when both sides modified file foo,
- it will be deleted, and replaced with files foo.KEYA and foo.KEYB.
-
- 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.KEYA (or KEYB).
-}
resolveMerge :: Annex Bool
resolveMerge = do
top <- fromRepo Git.repoPath
(fs, cleanup) <- inRepo (LsFiles.unmerged [top])
merged <- all id <$> mapM resolveMerge' fs
void $ liftIO cleanup
(deleted, cleanup2) <- inRepo (LsFiles.deleted [top])
2013-02-05 19:11:05 +00:00
unless (null deleted) $
Annex.Queue.addCommand "rm" [Params "--quiet -f --"] deleted
void $ liftIO cleanup2
when merged $ do
Annex.Queue.flush
void $ inRepo $ Git.Command.runBool
[ Param "commit"
, Param "-m"
, Param "git-annex automatic merge conflict fix"
]
return merged
resolveMerge' :: LsFiles.Unmerged -> Annex Bool
resolveMerge' u
| issymlink LsFiles.valUs && issymlink LsFiles.valThem =
withKey LsFiles.valUs $ \keyUs ->
withKey LsFiles.valThem $ \keyThem -> do
ifM isDirect
( maybe noop (\k -> removeDirect k file) keyUs
, liftIO $ nukeFile file
)
Annex.Queue.addCommand "rm" [Params "--quiet -f --"] [file]
go keyUs keyThem
| otherwise = return False
2012-11-12 05:05:04 +00:00
where
go keyUs keyThem
| keyUs == keyThem = do
makelink keyUs
return True
| otherwise = do
makelink keyUs
makelink keyThem
return True
file = LsFiles.unmergedFile u
issymlink select = any (select (LsFiles.unmergedBlobType u) ==)
[Just SymlinkBlob, Nothing]
makelink (Just key) = do
let dest = mergeFile file key
l <- inRepo $ gitAnnexLink dest key
replaceFile dest $ makeAnnexLink l
stageSymlink dest =<< hashSymlink l
whenM (isDirect) $
toDirect key dest
2012-11-12 05:05:04 +00:00
makelink _ = noop
withKey select a = do
let msha = select $ LsFiles.unmergedSha u
case msha of
Nothing -> a Nothing
Just sha -> do
2012-12-12 23:20:38 +00:00
key <- catKey sha
2012-11-12 05:05:04 +00:00
maybe (return False) (a . Just) key
{- The filename to use when resolving a conflicted merge of a file,
- that points to a key.
-
- Something derived from the key needs to be included in the filename,
- but rather than exposing the whole key to the user, a very weak hash
- is used. There is a very real, although still unlikely, chance of
- conflicts using this hash.
-
- In the event that there is a conflict with the filename generated
- for some other key, that conflict will itself be handled by the
- conflicted merge resolution code. That case is detected, and the full
- key is used in the filename.
-}
mergeFile :: FilePath -> Key -> FilePath
mergeFile file key
| doubleconflict = go $ key2file key
| otherwise = go $ shortHash $ key2file key
2012-11-12 05:05:04 +00:00
where
varmarker = ".variant-"
doubleconflict = varmarker `isInfixOf` file
2012-11-12 05:05:04 +00:00
go v = takeDirectory file
</> dropExtension (takeFileName file)
++ varmarker ++ v
++ takeExtension file
shortHash :: String -> String
2012-09-13 23:14:00 +00:00
shortHash = take 4 . md5s . md5FilePath
2011-12-31 07:01:18 +00:00
2011-12-31 08:11:39 +00:00
changed :: Remote -> Git.Ref -> Annex Bool
2011-12-31 07:01:18 +00:00
changed remote b = do
let r = remoteBranch remote b
ifM (inRepo $ Git.Ref.exists r)
( inRepo $ Git.Branch.changed b r
, return False
)
2011-12-31 07:01:18 +00:00
2011-12-31 08:11:39 +00:00
newer :: Remote -> Git.Ref -> Annex Bool
2011-12-31 07:01:18 +00:00
newer remote b = do
let r = remoteBranch remote b
ifM (inRepo $ Git.Ref.exists r)
( inRepo $ Git.Branch.changed r b
, return True
)