XMPP: Send pings and use them to detect when contact with the server is lost.

I noticed that when my modem hung up and redialed, my xmpp client was left
sending messages into the void. This will also handle any idle
disconnection issues.

2 files changed, 56 insertions, 15 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)