From b6ebb173e7b5d4d07577cb2918e7d1a24fbc1f60 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 21 May 2013 18:24:29 -0400 Subject: 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. --- Annex/Branch.hs | 2 +- Assistant/Sync.hs | 8 ++++++-- Assistant/Types/NetMessager.hs | 9 +++++---- Assistant/XMPP.hs | 18 +++++++++++++----- Assistant/XMPP/Git.hs | 21 +++++++++++++++++++-- Git/Branch.hs | 3 ++- Git/DiffTree.hs | 5 ++++- Git/Ref.hs | 21 ++++++++++++--------- Git/Types.hs | 2 +- debian/changelog | 9 +++++++++ doc/design/assistant/xmpp.mdwn | 6 +++++- 11 files changed, 77 insertions(+), 27 deletions(-) diff --git a/Annex/Branch.hs b/Annex/Branch.hs index 6578471bc..1c260ff7e 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -65,7 +65,7 @@ hasSibling = not . null <$> siblingBranches {- List of git-annex (refs, branches), including the main one and any - from remotes. Duplicate refs are filtered out. -} siblingBranches :: Annex [(Git.Ref, Git.Branch)] -siblingBranches = inRepo $ Git.Ref.matchingUniq name +siblingBranches = inRepo $ Git.Ref.matchingUniq [name] {- Creates the branch, if it does not already exist. -} create :: Annex () diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index 1b9de1656..cff4f95e0 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -20,6 +20,7 @@ import Utility.Parallel import qualified Git import qualified Git.Branch import qualified Git.Command +import qualified Git.Ref import qualified Remote import qualified Types.Remote as Remote import qualified Annex.Branch @@ -112,8 +113,11 @@ pushToRemotes' now notifypushes remotes = do <*> getUUID let (xmppremotes, normalremotes) = partition isXMPPRemote remotes ret <- go True branch g u normalremotes - forM_ xmppremotes $ \r -> - sendNetMessage $ Pushing (getXMPPClientID r) (CanPush u) + unless (null xmppremotes) $ do + shas <- liftAnnex $ map fst <$> + inRepo (Git.Ref.matching [Annex.Branch.fullname, Git.Ref.headRef]) + forM_ xmppremotes $ \r -> sendNetMessage $ + Pushing (getXMPPClientID r) (CanPush u shas) return ret where go _ Nothing _ _ _ = return [] -- no branch, so nothing to do diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs index 2c9de253f..cfcbe2aa3 100644 --- a/Assistant/Types/NetMessager.hs +++ b/Assistant/Types/NetMessager.hs @@ -9,6 +9,7 @@ module Assistant.Types.NetMessager where import Common.Annex import Assistant.Pairing +import Git.Types import Control.Concurrent.STM import Control.Concurrent.MSampleVar @@ -38,7 +39,7 @@ type ClientID = Text data PushStage -- indicates that we have data to push over the out of band network - = CanPush UUID + = CanPush UUID [Sha] -- request that a git push be sent over the out of band network | PushRequest UUID -- indicates that a push is starting @@ -59,7 +60,7 @@ type SequenceNum = Int {- NetMessages that are important (and small), and should be stored to be - resent when new clients are seen. -} isImportantNetMessage :: NetMessage -> Maybe ClientID -isImportantNetMessage (Pushing c (CanPush _)) = Just c +isImportantNetMessage (Pushing c (CanPush _ _)) = Just c isImportantNetMessage (Pushing c (PushRequest _)) = Just c isImportantNetMessage _ = Nothing @@ -91,14 +92,14 @@ isPushInitiation (StartingPush _) = True isPushInitiation _ = False isPushNotice :: PushStage -> Bool -isPushNotice (CanPush _) = True +isPushNotice (CanPush _ _) = True isPushNotice _ = False data PushSide = SendPack | ReceivePack deriving (Eq, Ord, Show) pushDestinationSide :: PushStage -> PushSide -pushDestinationSide (CanPush _) = ReceivePack +pushDestinationSide (CanPush _ _) = ReceivePack pushDestinationSide (PushRequest _) = SendPack pushDestinationSide (StartingPush _) = ReceivePack pushDestinationSide (ReceivePackOutput _ _) = SendPack diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs index fbc351931..0748c0581 100644 --- a/Assistant/XMPP.hs +++ b/Assistant/XMPP.hs @@ -1,6 +1,6 @@ {- core xmpp support - - - Copyright 2012 Joey Hess + - Copyright 2012-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -12,6 +12,7 @@ module Assistant.XMPP where import Assistant.Common import Assistant.Types.NetMessager import Assistant.Pairing +import Git.Sha (extractSha) import Network.Protocol.XMPP hiding (Node) import Data.Text (Text) @@ -131,8 +132,9 @@ decodePairingNotification m = parse . words . T.unpack . tagValue pushMessage :: PushStage -> JID -> JID -> Message pushMessage = gitAnnexMessage . encode where - encode (CanPush u) = - gitAnnexTag canPushAttr $ T.pack $ fromUUID u + encode (CanPush u shas) = + gitAnnexTag canPushAttr $ T.pack $ unwords $ + fromUUID u : map show shas encode (PushRequest u) = gitAnnexTag pushRequestAttr $ T.pack $ fromUUID u encode (StartingPush u) = @@ -160,7 +162,7 @@ decodeMessage m = decode =<< gitAnnexTagInfo m , receivePackDoneAttr ] [ decodePairingNotification - , pushdecoder $ gen CanPush + , pushdecoder $ shasgen CanPush , pushdecoder $ gen PushRequest , pushdecoder $ gen StartingPush , pushdecoder $ seqgen ReceivePackOutput @@ -172,11 +174,14 @@ decodeMessage m = decode =<< gitAnnexTagInfo m pushdecoder a m' i = Pushing <$> (formatJID <$> messageFrom m') <*> a i - gen c = Just . c . toUUID . T.unpack . tagValue + gen c i = c . toUUID <$> headMaybe (words (T.unpack (tagValue i))) seqgen c i = do packet <- decodeTagContent $ tagElement i let seqnum = fromMaybe 0 $ readish $ T.unpack $ tagValue i return $ c seqnum packet + shasgen c i = do + let (u:shas) = words $ T.unpack $ tagValue i + return $ c (toUUID u) (mapMaybe extractSha shas) decodeExitCode :: Int -> ExitCode decodeExitCode 0 = ExitSuccess @@ -245,3 +250,6 @@ sendPackAttr = "sp" receivePackDoneAttr :: Name receivePackDoneAttr = "rpdone" + +shasAttr :: Name +shasAttr = "shas" 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 () diff --git a/Git/Branch.hs b/Git/Branch.hs index 41ae2559e..d4a684016 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -13,6 +13,7 @@ import Common import Git import Git.Sha import Git.Command +import Git.Ref (headRef) {- The currently checked out branch. - @@ -35,7 +36,7 @@ current r = do {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Git.Ref) currentUnsafe r = parse . firstLine - <$> pipeReadStrict [Param "symbolic-ref", Param "HEAD"] r + <$> pipeReadStrict [Param "symbolic-ref", Param $ show headRef] r where parse l | null l = Nothing diff --git a/Git/DiffTree.hs b/Git/DiffTree.hs index f122a4fb5..cf8a37600 100644 --- a/Git/DiffTree.hs +++ b/Git/DiffTree.hs @@ -46,7 +46,10 @@ diffTreeRecursive src dst = getdiff (Param "diff-tree") diffIndex :: Repo -> IO ([DiffTreeItem], IO Bool) diffIndex repo = do ifM (Git.Ref.headExists repo) - ( getdiff (Param "diff-index") [Param "--cached", Param "HEAD"] repo + ( getdiff (Param "diff-index") + [ Param "--cached" + , Param $ show Git.Ref.headRef + ] repo , return ([], return True) ) diff --git a/Git/Ref.hs b/Git/Ref.hs index c98802cb7..d6e31897c 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -1,6 +1,6 @@ {- git ref stuff - - - Copyright 2011 Joey Hess + - Copyright 2011-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -13,6 +13,9 @@ import Git.Command import Data.Char (chr) +headRef :: Ref +headRef = Ref "HEAD" + {- Converts a fully qualified git ref into a user-visible string. -} describe :: Ref -> String describe = show . base @@ -54,18 +57,18 @@ sha branch repo = process <$> showref repo process [] = Nothing process s = Just $ Ref $ firstLine s -{- List of (refs, branches) matching a given ref spec. -} -matching :: Ref -> Repo -> IO [(Ref, Branch)] -matching ref repo = map gen . lines <$> - pipeReadStrict [Param "show-ref", Param $ show ref] repo +{- List of (shas, branches) matching a given ref or refs. -} +matching :: [Ref] -> Repo -> IO [(Sha, Branch)] +matching refs repo = map gen . lines <$> + pipeReadStrict (Param "show-ref" : map (Param . show) refs) repo where gen l = let (r, b) = separate (== ' ') l in (Ref r, Ref b) -{- List of (refs, branches) matching a given ref spec. - - Duplicate refs are filtered out. -} -matchingUniq :: Ref -> Repo -> IO [(Ref, Branch)] -matchingUniq ref repo = nubBy uniqref <$> matching ref repo +{- List of (shas, branches) matching a given ref spec. + - Duplicate shas are filtered out. -} +matchingUniq :: [Ref] -> Repo -> IO [(Sha, Branch)] +matchingUniq refs repo = nubBy uniqref <$> matching refs repo where uniqref (a, _) (b, _) = a == b diff --git a/Git/Types.hs b/Git/Types.hs index 57e5ca6e2..4765aad6c 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -41,7 +41,7 @@ data Repo = Repo {- A git ref. Can be a sha1, or a branch or tag name. -} newtype Ref = Ref String - deriving (Eq) + deriving (Eq, Ord) instance Show Ref where show (Ref v) = v diff --git a/debian/changelog b/debian/changelog index 02a246e37..327128b22 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,12 @@ +git-annex (4.20130522) UNRELEASED; urgency=low + + * XMPP: Made much more robust. + * 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. + + -- Joey Hess Tue, 21 May 2013 18:22:46 -0400 + git-annex (4.20130521) unstable; urgency=low * Sanitize debian changelog version before putting it into cabal file. diff --git a/doc/design/assistant/xmpp.mdwn b/doc/design/assistant/xmpp.mdwn index 5ee8bc508..f6c7d4dc8 100644 --- a/doc/design/assistant/xmpp.mdwn +++ b/doc/design/assistant/xmpp.mdwn @@ -66,7 +66,11 @@ containing: To indicate that we could push over XMPP, a chat message is sent, to each known client of each XMPP remote. - + + +The shas are omitted by old clients. If present, they are the git shas of +the head and git-annex branches that are available to be pushed. This lets +the receiver check if it's already got them. To request that a remote push to us, a chat message can be sent. -- cgit v1.2.3