diff options
Diffstat (limited to 'Assistant/Threads/XMPPClient.hs')
| -rw-r--r-- | Assistant/Threads/XMPPClient.hs | 59 |
1 files changed, 44 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. |