From 14d96b8e06933cc9d3e60b4f4db194ad5a54bcd0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 21 May 2013 00:59:38 -0400 Subject: [PATCH] XMPP: Be better at responding to CanPush messages when busy with something else. Observed: With 2 xmpp clients, one would sometimes stop responding to CanPush messages. Often it was in the middle of a receive-pack of its own (or was waiting for a failed one to time out). Now these are always immediately responded to, which is fine; the point of CanPush is to find out if there's another client out there that's interested in our push. Also, in queueNetPushMessage, queue push initiation messages when we're already running the side of the push they would initiate. Before, these messages were sent into the netMessagesPush channel, which was wrong. The xmpp send-pack and receive-pack code discarded such messages. This still doesn't make XMPP push 100% robust. In testing, I am seeing it sometimes try to run two send-packs, or two receive-packs at once to the same client (probably because the client sent two requests). Also, I'm seeing rather a lot of cases where it stalls out until it runs into the 120 second timeout and cancels a push. And finally, there seems to be a bug in runPush. I have logs that show it running its setup action, but never its cleanup action. How is this possible given its use of E.bracket? Either some exception is finding its way through, or the action somehow stalls forever. When this happens, one of the 2 clients stops syncing. --- Assistant/NetMessager.hs | 2 +- Assistant/Threads/XMPPClient.hs | 1 + Assistant/Types/NetMessager.hs | 7 +++++-- Assistant/XMPP/Git.hs | 13 ++++++++----- debian/changelog | 2 ++ 5 files changed, 17 insertions(+), 8 deletions(-) diff --git a/Assistant/NetMessager.hs b/Assistant/NetMessager.hs index 97d17af6e5..fd320b00bd 100644 --- a/Assistant/NetMessager.hs +++ b/Assistant/NetMessager.hs @@ -110,8 +110,8 @@ queueNetPushMessage m@(Pushing clientid stage) = do case v of Nothing -> return False (Just runningclientid) - | runningclientid == clientid -> queue nm | isPushInitiation stage -> defer nm + | runningclientid == clientid -> queue nm | otherwise -> discard where side = pushDestinationSide stage diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index 086494a749..dd1b2ac1fe 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -107,6 +107,7 @@ xmppClient urlrenderer d creds = handle selfjid (GotNetMessage (PairingNotification stage c u)) = maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c) handle _ (GotNetMessage m@(Pushing _ pushstage)) + | isPushNotice pushstage = inAssistant $ handlePushNotice m | isPushInitiation pushstage = inAssistant $ unlessM (queueNetPushMessage m) $ do let checker = checkCloudRepos urlrenderer diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs index 09a5580337..bc0bf3c223 100644 --- a/Assistant/Types/NetMessager.hs +++ b/Assistant/Types/NetMessager.hs @@ -85,13 +85,16 @@ logClientID c = T.concat [T.take 1 c, T.pack $ show $ T.length c] {- Things that initiate either side of a push, but do not actually send data. -} isPushInitiation :: PushStage -> Bool -isPushInitiation (CanPush _) = True isPushInitiation (PushRequest _) = True isPushInitiation (StartingPush _) = True isPushInitiation _ = False +isPushNotice :: PushStage -> Bool +isPushNotice (CanPush _) = True +isPushNotice _ = False + data PushSide = SendPack | ReceivePack - deriving (Eq, Ord) + deriving (Eq, Ord, Show) pushDestinationSide :: PushStage -> PushSide pushDestinationSide (CanPush _) = ReceivePack diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs index 93479014d4..7970f05060 100644 --- a/Assistant/XMPP/Git.hs +++ b/Assistant/XMPP/Git.hs @@ -287,10 +287,6 @@ xmppRemotes cid theiruuid = case baseJID <$> parseJID cid of knownuuid um r = Remote.uuid r == theiruuid || M.member theiruuid um handlePushInitiation :: (Remote -> Assistant ()) -> NetMessage -> Assistant () -handlePushInitiation _ (Pushing cid (CanPush theiruuid)) = - unlessM (null <$> xmppRemotes cid theiruuid) $ do - u <- liftAnnex getUUID - sendNetMessage $ Pushing cid (PushRequest u) handlePushInitiation checkcloudrepos (Pushing cid (PushRequest theiruuid)) = go =<< liftAnnex (inRepo Git.Branch.current) where @@ -317,8 +313,15 @@ handlePushInitiation checkcloudrepos (Pushing cid (StartingPush theiruuid)) = do mapM_ checkcloudrepos rs handlePushInitiation _ _ = noop +handlePushNotice :: NetMessage -> Assistant () +handlePushNotice (Pushing cid (CanPush theiruuid)) = + unlessM (null <$> xmppRemotes cid theiruuid) $ do + u <- liftAnnex getUUID + sendNetMessage $ Pushing cid (PushRequest u) +handlePushNotice _ = noop + handleDeferred :: (Remote -> Assistant ()) -> NetMessage -> Assistant () -handleDeferred = handlePushInitiation +handleDeferred checkcloudrepos m = handlePushInitiation checkcloudrepos m writeChunk :: Handle -> B.ByteString -> IO () writeChunk h b = do diff --git a/debian/changelog b/debian/changelog index 97e8a5a87b..7b84767277 100644 --- a/debian/changelog +++ b/debian/changelog @@ -23,6 +23,8 @@ git-annex (4.20130517) UNRELEASED; urgency=low * Linux standalone: Back to being built with glibc 2.13 for maximum portability. * XMPP: Ignore duplicate messages received when pushing. + * XMPP: Be better at responding to CanPush messages when busy with + something else. -- Joey Hess Fri, 17 May 2013 11:17:03 -0400