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]