diff options
| -rw-r--r-- | Assistant/Threads/XMPPClient.hs | 59 | ||||
| -rw-r--r-- | Assistant/XMPP.hs | 12 | ||||
| -rw-r--r-- | debian/changelog | 4 | ||||
| -rw-r--r-- | doc/design/assistant/blog/day_271__more_xmpp.mdwn | 31 | ||||
| -rw-r--r-- | doc/design/assistant/xmpp.mdwn | 2 |
5 files changed, 90 insertions, 18 deletions
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index b90a8ca10..c8c115e3a 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -28,11 +28,14 @@ import Logs.UUID import Network.Protocol.XMPP import Control.Concurrent +import Control.Concurrent.STM.TMVar +import Control.Concurrent.STM (atomically) import qualified Data.Text as T import qualified Data.Set as S import qualified Data.Map as M import qualified Git.Branch import Data.Time.Clock +import Control.Concurrent.Async xmppClientThread :: UrlRenderer -> NamedThread xmppClientThread urlrenderer = namedThread "XMPPClient" $ @@ -64,16 +67,16 @@ xmppClient urlrenderer d creds = - is not retained. -} liftAssistant $ updateBuddyList (const noBuddies) <<~ buddyList - e <- client + void client liftAssistant $ modifyDaemonStatus_ $ \s -> s { xmppClientID = Nothing } now <- getCurrentTime if diffUTCTime now starttime > 300 then do - liftAssistant $ debug ["connection lost; reconnecting", show e] + liftAssistant $ debug ["connection lost; reconnecting"] retry client now else do - liftAssistant $ debug ["connection failed; will retry", show e] + liftAssistant $ debug ["connection failed; will retry"] threadDelaySeconds (Seconds 300) retry client =<< getCurrentTime @@ -86,16 +89,43 @@ xmppClient urlrenderer d creds = { xmppClientID = Just $ xmppJID creds } debug ["connected", logJid selfjid] - xmppThread $ receivenotifications selfjid - forever $ do - a <- inAssistant $ relayNetMessage selfjid - a - - receivenotifications selfjid = forever $ do + lasttraffic <- liftIO $ atomically . newTMVar =<< getCurrentTime + + sender <- xmppSession $ sendnotifications selfjid + receiver <- xmppSession $ receivenotifications selfjid lasttraffic + pinger <- xmppSession $ sendpings selfjid lasttraffic + {- Run all 3 threads concurrently, until + - any of them throw an exception. + - Then kill all 3 threads, and rethrow the + - exception. + - + - If this thread gets an exception, the 3 threads + - will also be killed. -} + liftIO $ pinger `concurrently` sender `concurrently` receiver + + sendnotifications selfjid = forever $ do + a <- inAssistant $ relayNetMessage selfjid + a + receivenotifications selfjid lasttraffic = forever $ do l <- decodeStanza selfjid <$> getStanza + void $ liftIO $ atomically . swapTMVar lasttraffic =<< getCurrentTime inAssistant $ debug ["received:", show $ map logXMPPEvent l] mapM_ (handle selfjid) l + sendpings selfjid lasttraffic = forever $ do + putStanza pingstanza + + startping <- liftIO $ getCurrentTime + liftIO $ threadDelaySeconds (Seconds 120) + t <- liftIO $ atomically $ readTMVar lasttraffic + when (t < startping) $ do + inAssistant $ debug ["ping timeout"] + error "ping timeout" + where + {- XEP-0199 says that the server will respond with either + - a ping response or an error message. Either will + - cause traffic, so good enough. -} + pingstanza = xmppPing selfjid handle selfjid (PresenceMessage p) = do void $ inAssistant $ @@ -244,13 +274,12 @@ withOtherClient selfjid c a = case parseJID c of withClient :: ClientID -> (JID -> XMPP ()) -> XMPP () withClient c a = maybe noop a $ parseJID c -{- Runs a XMPP action in a separate thread, using a session to allow it - - to access the same XMPP client. -} -xmppThread :: XMPP () -> XMPP () -xmppThread a = do +{- Returns an IO action that runs a XMPP action in a separate thread, + - using a session to allow it to access the same XMPP client. -} +xmppSession :: XMPP () -> XMPP (IO ()) +xmppSession a = do s <- getSession - void $ liftIO $ forkIO $ - void $ runXMPP s a + return $ void $ runXMPP s a {- We only pull from one remote out of the set listed in the push - notification, as an optimisation. diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs index 0748c0581..ed28ac7d2 100644 --- a/Assistant/XMPP.hs +++ b/Assistant/XMPP.hs @@ -84,6 +84,18 @@ gitAnnexPresence = insertGitAnnexTag $ emptyPresence PresenceAvailable gitAnnexSignature :: Presence gitAnnexSignature = gitAnnexPresence $ Element gitAnnexTagName [] [] +{- XMPP client to server ping -} +xmppPing :: JID -> IQ +xmppPing selfjid = (emptyIQ IQGet) + { iqID = Just "c2s1" + , iqFrom = Just selfjid + , iqTo = Just $ JID Nothing (jidDomain selfjid) Nothing + , iqPayload = Just $ Element xmppPingTagName [] [] + } + +xmppPingTagName :: Name +xmppPingTagName = "{urn:xmpp}ping" + {- A message with a git-annex tag in it. -} gitAnnexMessage :: Element -> JID -> JID -> Message gitAnnexMessage elt tojid fromjid = (insertGitAnnexTag silentMessage elt) diff --git a/debian/changelog b/debian/changelog index d95c86be0..f2b1d6758 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,9 +1,11 @@ git-annex (4.20130522) UNRELEASED; urgency=low - * XMPP: Made much more robust. + * XMPP: Git push over 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. + * XMPP: Send pings and use them to detect when contact with the server + is lost. * hook special remote: Added combined hook program support. -- Joey Hess <joeyh@debian.org> Tue, 21 May 2013 18:22:46 -0400 diff --git a/doc/design/assistant/blog/day_271__more_xmpp.mdwn b/doc/design/assistant/blog/day_271__more_xmpp.mdwn new file mode 100644 index 000000000..14e734a2d --- /dev/null +++ b/doc/design/assistant/blog/day_271__more_xmpp.mdwn @@ -0,0 +1,31 @@ +Tobias has been busy again today, creating a [[/tips/flickrannex]] +special remote! Meanwhile, I'm thinking about providing a +[[more complete interface|/todo/support_for_writing_external_special_remotes]] +so that special remote programs not written in Haskell can do some of the +things the hook special remote's simplicity doesn't allow. + +Finally realized last night that the main problem with the XMPP push code +was an inversion of control. Reworked it so now there are two new threads, +XMPPSendpack and XMPPReceivePack, each with their own queue of push +initiation requests, that run the pushes. This is a lot easier to +understand, probably less buggy, and lets it apply some smarts to squash +duplicate actions and pick the best request to handle next. + +Also made the XMPP client send pings to detect when it has been disconnected +from the server. Currently every 120 seconds, though that may change. Testing +showed that without this, it did not notice (for at least 20 minutes) when +it lost routing to the server. Not sure why -- I'd think the TCP connections +should break and this throw an error -- but this will also handle any idle +disconnection problems that some XMPP servers might have. + +While writing that, I found myself writing this jem using +[async](http://hackage.haskell.org/package/async), which has a comment +much longer than the code, but basically we get 4 threads that are all +linked, so when any dies, all do. + +[[!format haskell """ +pinger `concurrently` sender `concurrently` receiver +"""]] + +Anyway, I need to run some long-running XMPP push tests to see if I've +really ironed out all the bugs. diff --git a/doc/design/assistant/xmpp.mdwn b/doc/design/assistant/xmpp.mdwn index bb7754ec6..8dadfaf97 100644 --- a/doc/design/assistant/xmpp.mdwn +++ b/doc/design/assistant/xmpp.mdwn @@ -4,8 +4,6 @@ who share a repository, that is stored in the [[cloud]]. ### TODO -* Prevent idle disconnection. Probably means sending or receiving pings, - but would prefer to avoid eg pinging every 60 seconds as some clients do. * Do git-annex clients sharing an account with regular clients cause confusing things to happen? See <http://git-annex.branchable.com/design/assistant/blog/day_114__xmpp/#comment-aaba579f92cb452caf26ac53071a6788> |