From e1e873eb6aca89d47231a4af5d0652efc3d8a561 Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 11 Nov 2013 19:33:05 -0500 Subject: More ping work --- Presence/XMPP.hs | 104 +++++++++++++++++++++++++++++++++++--------------- Presence/XMPPTypes.hs | 1 + 2 files changed, 75 insertions(+), 30 deletions(-) diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs index 8589999b..498106b9 100644 --- a/Presence/XMPP.hs +++ b/Presence/XMPP.hs @@ -30,6 +30,7 @@ import Data.Maybe (catMaybes) import Data.HList import Network.Socket ( Family ) import Control.Concurrent.STM +import Control.Concurrent.STM.Delay import Data.Conduit import Data.Maybe import Data.ByteString (ByteString) @@ -888,6 +889,7 @@ peerRejectsSubscription session stanza = do handlePeerIQGet :: (JabberPeerSession session, MonadIO m) => session -> XML.Event -> NestingXML o m () handlePeerIQGet session tag = do + -- TODO: Pings should not require an id field. withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do whenJust nextElement $ \child -> do let unhandledGet req = do @@ -925,6 +927,8 @@ fromPeer session = doNestingXML $ do whenJust nextElement $ \stanza -> do stanza_lvl <- nesting + liftIO $ sendPeerMessage session ActivityBump -- reset ping timer + let unhandledStanza = do xs <- gatherElement stanza Seq.empty prettyPrint "P: " (toList xs) @@ -983,6 +987,7 @@ instance CommandCache CachedMessages where updateCache (OutBoundMessage msg) cache = cache -- TODO updateCache (Pong _ _ _) cache = cache -- pings are not cached updateCache (Unsupported _ _ _ _) cache = cache -- error messages are not cached + updateCache ActivityBump cache = cache instance ThreadChannelCommand OutBoundMessage where isQuitCommand Disconnect = True @@ -1007,14 +1012,23 @@ goodbyePeer = , EventEndDocument ] -presenceStanza sock fromjid tojid typ = do +peerJidTextLocal sock jid = do addr <- getSocketName sock - let jidstr jid = toStrict . L.decodeUtf8 - $ name jid <$++> "@" + return . toStrict . L.decodeUtf8 + $ name jid <$++> "@" + showPeer (RemotePeer addr) + <++?> "/" <++$> resource jid + +peerJidTextRemote sock jid = do + addr <- getPeerName sock + return . toStrict . L.decodeUtf8 + $ name jid <$++> "@" showPeer (RemotePeer addr) <++?> "/" <++$> resource jid - from = jidstr fromjid - to = toStrict . L.decodeUtf8 + +presenceStanza sock fromjid tojid typ = do + from <- peerJidTextLocal sock fromjid + let to = toStrict . L.decodeUtf8 $ name tojid <$++> "@" showPeer (peer tojid) return @@ -1074,8 +1088,8 @@ toPeer sock cache chan fail = do Just c -> (("id",[c]):) _ -> id ) [ attr "type" "result" - , attr "to" (toStrict $ L.decodeUtf8 $ L.show to) - , attr "from" (toStrict $ L.decodeUtf8 $ L.show from) + , attr "to" (toStrict $ L.decodeUtf8 $ L.show to) -- TODO: should send numeric address + , attr "from" (toStrict $ L.decodeUtf8 $ L.show from) -- TODO: should send numeric address ] , EventEndElement "{jabber:server}iq" ] @@ -1090,8 +1104,8 @@ toPeer sock cache chan fail = do Just c -> (("id",[c]):) _ -> id ) [("type",[ContentText "error"]) - , attr "to" (toStrict $ L.decodeUtf8 $ L.show to) - , attr "from" (toStrict $ L.decodeUtf8 $ L.show from) + , attr "to" (toStrict $ L.decodeUtf8 $ L.show to) -- TODO: should send numeric address + , attr "from" (toStrict $ L.decodeUtf8 $ L.show from) -- TODO: should send numeric address ] , EventBeginElement req [] , EventEndElement req @@ -1120,28 +1134,58 @@ toPeer sock cache chan fail = do liftIO $ debugL "sending cached solicitation..." sendSolicitation from to - + + let five_sec = 5 * 1000000 :: Int + ping_timer <- liftIO $ newDelay five_sec + let bump = updateDelay ping_timer five_sec + fix $ \loop -> do - event <- lift . atomically $ readTChan chan - case event of - OutBoundPresence p -> sendPresence p - PresenceProbe from to -> do - liftIO $ debugL "sending live probe..." - sendProbe from to - Solicitation from to -> do - liftIO $ debugL "sending live solicitation..." - sendSolicitation from to - Approval from to -> do - liftIO . debugL $ "sending approval "<++>bshow (from,to) - sendApproval True from to - Rejection from to -> do - liftIO . debugL $ "sending rejection "<++>bshow (from,to) - sendApproval False from to - OutBoundMessage msg -> sendMessage msg - Pong from to mid -> sendPong from to mid - Unsupported from to mid tag -> sendUnsupported from to mid tag - Disconnect -> return () - when (not . isQuitCommand $ event) loop + event <- lift . atomically $ orElse (Left `fmap` readTChan chan) + (Right `fmap` waitDelay ping_timer) + let sendPing () = do + ping <- liftIO makePing + yield ping + loop + where makePing = do + addr <- getSocketName sock + remote <- getPeerName sock + let from = toStrict . L.decodeUtf8 . showPeer $ RemotePeer addr + to = toStrict . L.decodeUtf8 . showPeer $ RemotePeer remote + mid = Just (ContentText "iduno") + return $ + [ EventBeginElement "{jabber:server}iq" + $ (case mid of + Just c -> (("id",[c]):) + _ -> id ) + [("type",[ContentText "error"]) + , attr "to" to + , attr "from" from + ] + , EventBeginElement "{urn:xmpp:ping}ping" [] + , EventEndElement "{urn:xmpp:ping}ping" + , EventEndElement "{jabber:server}iq" ] + chanEvent event = do + case event of + OutBoundPresence p -> sendPresence p + PresenceProbe from to -> do + liftIO $ debugL "sending live probe..." + sendProbe from to + Solicitation from to -> do + liftIO $ debugL "sending live solicitation..." + sendSolicitation from to + Approval from to -> do + liftIO . debugL $ "sending approval "<++>bshow (from,to) + sendApproval True from to + Rejection from to -> do + liftIO . debugL $ "sending rejection "<++>bshow (from,to) + sendApproval False from to + OutBoundMessage msg -> sendMessage msg + Pong from to mid -> sendPong from to mid + Unsupported from to mid tag -> sendUnsupported from to mid tag + Disconnect -> return () + ActivityBump -> liftIO bump + when (not . isQuitCommand $ event) loop + either chanEvent sendPing event return () -- send goodbyePeer -- TODO: why does this cause an exception? -- Text/XML/Stream/Render.hs:169:5-15: diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs index 8162ec5d..f1f511e7 100644 --- a/Presence/XMPPTypes.hs +++ b/Presence/XMPPTypes.hs @@ -284,6 +284,7 @@ data OutBoundMessage = OutBoundPresence Presence | Pong JID JID (Maybe Content) | Unsupported JID JID (Maybe Content) XML.Name | Disconnect + | ActivityBump deriving Prelude.Show getNamesForPeer :: Peer -> IO [S.ByteString] -- cgit v1.2.3