diff options
| author |  Joey Hess <joey@kitenet.net> | 2012-11-09 16:04:55 -0400 |
|---|---|---|
| committer | Joey Hess <joey@kitenet.net> | 2012-11-09 16:04:55 -0400 |
| commit | 5c928715e72b94c4fae601aebbe23fe5cd2436e3 (patch) | |
| tree | 1d93ceb12be3ca12dcc7e169981f6bb8fd700650 | |
| parent | bea266e2c14163cac86a19b3f6b5ba834d9a0793 (diff) | |
run xmpp push actions in separate thread from xmpp client
Took me a while to figure out why the xmpp client was not receiving git xmpp
push messages after a push started.
| -rw-r--r-- | Assistant/Threads/XMPPClient.hs | 13 | ||||
| -rw-r--r-- | Assistant/XMPP/Git.hs | 20 |
2 files changed, 15 insertions, 18 deletions
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index 32353fdc4..bb9293b90 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -96,17 +96,18 @@ xmppClient urlrenderer d = do handle _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us handle selfjid (GotNetMessage (PairingNotification stage c u)) = maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c) - handle _ (GotNetMessage m@(CanPush _)) = inAssistant $ - unlessM (queueNetPushMessage m) $ void $ handlePushMessage m - handle _ (GotNetMessage m@(PushRequest _)) = inAssistant $ - unlessM (queueNetPushMessage m) $ void $ handlePushMessage m - handle _ (GotNetMessage m@(StartingPush _)) = inAssistant $ - unlessM (queueNetPushMessage m) $ void $ handlePushMessage m + handle _ (GotNetMessage m@(CanPush _)) = handlepushmsg m + handle _ (GotNetMessage m@(PushRequest _)) = handlepushmsg m + handle _ (GotNetMessage m@(StartingPush _)) = handlepushmsg m handle _ (GotNetMessage m) = void $ inAssistant $ queueNetPushMessage m handle _ (Ignorable _) = noop handle _ (Unknown _) = noop handle _ (ProtocolError _) = noop + handlepushmsg m = inAssistant $ + unlessM (queueNetPushMessage m) $ + void $ forkIO <~> handlePushMessage m + data XMPPEvent = GotNetMessage NetMessage | PresenceMessage Presence diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs index 11b5dd907..a224adb3d 100644 --- a/Assistant/XMPP/Git.hs +++ b/Assistant/XMPP/Git.hs @@ -224,24 +224,20 @@ xmppRemotes cid = case baseJID <$> parseJID cid of return $ repoIsUrl r && repoLocation r == "xmpp::" ++ want handleDeferred :: NetMessage -> Assistant () -handleDeferred = void . handlePushMessage +handleDeferred = handlePushMessage -handlePushMessage :: NetMessage -> Assistant Bool +handlePushMessage :: NetMessage -> Assistant () handlePushMessage (CanPush cid) = do rs <- xmppRemotes cid - if null rs - then return False - else do - sendNetMessage $ PushRequest cid - return True + unless (null rs) $ + sendNetMessage $ PushRequest cid handlePushMessage (PushRequest cid) = do rs <- xmppRemotes cid current <- liftAnnex $ inRepo Git.Branch.current let refs = catMaybes [current, Just Annex.Branch.fullname] - any id <$> (forM rs $ \r -> xmppPush cid r refs) + forM_ rs $ \r -> xmppPush cid r refs handlePushMessage (StartingPush cid) = do rs <- xmppRemotes cid - if null rs - then return False - else xmppReceivePack cid -handlePushMessage _ = return False + unless (null rs) $ + void $ xmppReceivePack cid +handlePushMessage _ = noop |