1 files changed, 37 insertions, 14 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 498106b9..84035ea2 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -984,7 +984,7 @@ instance CommandCache CachedMessages where
                 cache { approvals= mmInsert (True,from) to $ approvals cache }
     updateCache (Rejection from to) cache =
                 cache { approvals= mmInsert (False,from) to $ approvals cache }
-    updateCache (OutBoundMessage msg) cache = cache -- TODO
+    updateCache (OutBoundMessage msg) cache = cache -- TODO: cache chat?
     updateCache (Pong _ _ _) cache = cache          -- pings are not cached
     updateCache (Unsupported _ _ _ _) cache = cache -- error messages are not cached
     updateCache ActivityBump cache = cache
@@ -1082,14 +1082,16 @@ toPeer sock cache chan fail = do
             sendOrFail (xmlifyPong sock from to mid)
                        (Pong from to mid)
          where
-            xmlifyPong sock from to mid = 
+            xmlifyPong sock from to mid = do
+                fromjid <- peerJidTextLocal  sock to
+                tojid   <- peerJidTextRemote sock to
                 return $ [ EventBeginElement "{jabber:server}iq" 
                           $ (case mid of
                              Just c -> (("id",[c]):)
                              _      -> id               )
                              [ attr "type" "result"
-                             , 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
+                             , attr "to"   tojid
+                             , attr "from" fromjid
                              ]
                       , EventEndElement "{jabber:server}iq"
                       ]
@@ -1097,15 +1099,17 @@ toPeer sock cache chan fail = do
             sendOrFail (xmlifyUnsupported sock from to mid tag)
                        (Unsupported from to mid tag)
          where
-            xmlifyUnsupported sock from to mid req = 
+            xmlifyUnsupported sock from to mid req = do
+                fromjid <- peerJidTextLocal  sock to
+                tojid   <- peerJidTextRemote sock to
                 return $ 
                     [ EventBeginElement "{jabber:server}iq" 
                      $ (case mid of
                         Just c -> (("id",[c]):)
                         _      -> id               )
                         [("type",[ContentText "error"])
-                        , 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
+                        , attr "to"   tojid
+                        , attr "from" fromjid
                         ]
                     , EventBeginElement req []
                     , EventEndElement req
@@ -1136,16 +1140,35 @@ toPeer sock cache chan fail = do
 
 
     let five_sec = 5 * 1000000 :: Int
-    ping_timer <- liftIO $ newDelay five_sec
-    let bump = updateDelay ping_timer five_sec
+    pingref <- liftIO $ do
+                    ping_timer <- liftIO $ newDelay five_sec
+                    newTVarIO (ping_timer,0::Int)
+    let bump = do
+            timer <- atomically $ do
+                        (timer,v) <-  readTVar pingref
+                        writeTVar pingref (timer,0)
+                        return timer
+            updateDelay timer five_sec
+        waitPing = do
+            (timer,v) <- readTVar pingref
+            waitDelay timer
+            return v
 
     fix $ \loop -> do
         event <- lift . atomically $ orElse (Left `fmap` readTChan chan) 
-                                            (Right `fmap` waitDelay ping_timer)
-        let sendPing () = do
-                ping <- liftIO makePing
-                yield ping 
-                loop
+                                            (Right `fmap` waitPing)
+        let sendPing n = do
+                ping_timer <- liftIO $ newDelay five_sec
+                liftIO . atomically $ writeTVar pingref (ping_timer,1)
+                case n of
+                    0 -> do
+                            ping <- liftIO makePing
+                            yield ping 
+                            loop
+                    _ -> do
+                            remote <- liftIO $ getPeerName sock
+                            liftIO . debugL $ "PING TIMEOUT: " <++> showPeer (RemotePeer remote)
+                            return () -- PING TIMEOUT (loop quits)
               where makePing = do
                         addr <- getSocketName sock
                         remote <- getPeerName sock