summaryrefslogtreecommitdiff
path: root/Assistant/XMPP/Git.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2013-05-21 18:24:29 -0400
committerGravatar Joey Hess <joey@kitenet.net>2013-05-21 18:24:29 -0400
commitb6ebb173e7b5d4d07577cb2918e7d1a24fbc1f60 (patch)
tree8c994e00b091c448d80737aa99bbc181701eee04 /Assistant/XMPP/Git.hs
parent14f2a42ca4131a7a51a9e10a94521639b971bccd (diff)
XMPP: Avoid redundant and unncessary pushes. Note that this breaks compatibility with previous versions of git-annex, which will refuse to accept any XMPP pushes from this version.
Diffstat (limited to 'Assistant/XMPP/Git.hs')
-rw-r--r--Assistant/XMPP/Git.hs21
1 files changed, 19 insertions, 2 deletions
diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs
index 98c70cf41..c314042e6 100644
--- a/Assistant/XMPP/Git.hs
+++ b/Assistant/XMPP/Git.hs
@@ -23,6 +23,7 @@ import qualified Annex.Branch
import Annex.UUID
import Logs.UUID
import Annex.TaggedPush
+import Annex.CatFile
import Config
import Git
import qualified Git.Branch
@@ -311,11 +312,27 @@ handlePushInitiation checkcloudrepos (Pushing cid (StartingPush theiruuid)) = do
mapM_ checkcloudrepos rs
handlePushInitiation _ _ = noop
+{- Check if any of the shas that can be pushed are ones we do not
+ - have.
+ -
+ - (Older clients send no shas, so when there are none, always
+ - request a push.)
+ -}
handlePushNotice :: NetMessage -> Assistant ()
-handlePushNotice (Pushing cid (CanPush theiruuid)) =
- unlessM (null <$> xmppRemotes cid theiruuid) $ do
+handlePushNotice (Pushing cid (CanPush theiruuid shas)) =
+ unlessM (null <$> xmppRemotes cid theiruuid) $
+ if null shas
+ then go
+ else ifM (haveall shas)
+ ( debug ["ignoring CanPush with known shas"]
+ , go
+ )
+ where
+ go = do
u <- liftAnnex getUUID
sendNetMessage $ Pushing cid (PushRequest u)
+ haveall l = liftAnnex $ not <$> anyM donthave l
+ donthave sha = isNothing <$> catObjectDetails sha
handlePushNotice _ = noop
writeChunk :: Handle -> B.ByteString -> IO ()