diff options
Diffstat (limited to 'Assistant')
-rw-r--r-- | Assistant/Threads/XMPPClient.hs | 59 | ||||
-rw-r--r-- | Assistant/XMPP.hs | 12 |
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) |