From 274f90dca1a12844c797c86f12754475b42a65d8 Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Mon, 18 Nov 2013 17:55:02 -0500
Subject: ping work

---
 Presence/XMPP.hs | 29 +++++++++++++++++++----------
 1 file changed, 19 insertions(+), 10 deletions(-)

(limited to 'Presence/XMPP.hs')

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 853b015a..c7525159 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -933,7 +933,7 @@ fromPeer sock session = doNestingXML $ do
                     xs <- gatherElement stanza Seq.empty
                     prettyPrint "P: " (toList xs)
             case () of
-              _ | stanza `isIQOf` iqTypeGet -> handlePeerIQGet session stanza
+              _ | stanza `isServerIQOf` iqTypeGet -> handlePeerIQGet session stanza
               _ | stanza `isPresenceOf` presenceTypeOnline
                     -> handlePeerPresence session stanza True
               _ | stanza `isPresenceOf` presenceTypeOffline
@@ -985,7 +985,7 @@ instance CommandCache CachedMessages where
     updateCache (Rejection from to) cache =
                 cache { approvals= mmInsert (False,from) to $ approvals cache }
     updateCache (OutBoundMessage msg) cache = cache -- TODO: cache chat?
-    updateCache (Pong _ _ _) cache = cache          -- pings are not cached
+    updateCache (Pong _ _ _) cache = trace "(DISCARDING Pong)" cache          -- pings are not cached
     updateCache (Unsupported _ _ _ _) cache = cache -- error messages are not cached
     updateCache (ActivityBump sock) cache = cache
 
@@ -1078,7 +1078,8 @@ toPeer sock cache chan fail = do
             sendOrFail (xmlifyMessageForPeer sock msg)
                        (OutBoundMessage msg)
 
-        sendPong from to mid =
+        sendPong from to mid = do
+            liftIO . debugL $ "SEND PONG" 
             sendOrFail (xmlifyPong sock from to mid)
                        (Pong from to mid)
          where
@@ -1146,9 +1147,11 @@ toPeer sock cache chan fail = do
 
     sockref <- liftIO $ atomically newEmptyTMVar
     let bump fromsock = do
-            remote <- getPeerName sock
-            debugL $ "PING BUMP" <++> showPeer (RemotePeer remote)
+            remote <- liftIO $ catchIO (fmap Just $ getPeerName sock)
+                                       (\_ -> return Nothing)
+            debugL $ "PING BUMP" <++?> fmap (showPeer . RemotePeer) remote
             timer <- atomically $ do
+                        tryTakeTMVar sockref
                         putTMVar sockref fromsock
                         (timer,v) <-  readTVar pingref
                         writeTVar pingref (timer,0)
@@ -1160,23 +1163,27 @@ toPeer sock cache chan fail = do
             return v
 
     fix $ \loop -> do
+        liftIO . debugStr $ "LOOP waiting..."
         event <- lift . atomically $ orElse (Left `fmap` readTChan chan) 
                                             (Right `fmap` waitPing)
+        liftIO . debugStr $ "LOOP event = " ++ show event
         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 
+                            liftIO . debugL $ "SEND PING"
                             prettyPrint ">P: " ping
+                            ping_timer <- liftIO $ newDelay five_sec
+                            liftIO . atomically $ writeTVar pingref (ping_timer,1)
                             loop
-                    _ -> do
+                    1 -> do
                             remote <- liftIO $ getPeerName sock
                             liftIO . debugL $ "PING TIMEOUT: " <++> showPeer (RemotePeer remote)
                             fromsock <- liftIO $ atomically $ readTMVar sockref
                             liftIO $ sClose fromsock
                             return () -- PING TIMEOUT (loop quits)
+                    x -> error ("What? "++show x)
               where makePing = do
                         addr <- getSocketName sock
                         remote <- getPeerName sock
@@ -1188,7 +1195,7 @@ toPeer sock cache chan fail = do
                              $ (case mid of
                                 Just c -> (("id",[c]):)
                                 _      -> id               )
-                                [("type",[ContentText "error"])
+                                [ ("type",[ContentText "get"])
                                 , attr "to"   to
                                 , attr "from" from
                                 ]
@@ -1211,7 +1218,9 @@ toPeer sock cache chan fail = do
                     liftIO . debugL $ "sending rejection "<++>bshow (from,to)
                     sendApproval False from to
                   OutBoundMessage msg -> sendMessage msg
-                  Pong from to mid -> sendPong from to mid
+                  Pong from to mid -> do
+                    liftIO . debugL $ "sending pong "<++>bshow (from,to)
+                    sendPong from to mid
                   Unsupported from to mid tag -> sendUnsupported from to mid tag
                   Disconnect -> return ()
                   ActivityBump fromsock -> liftIO (bump fromsock)
-- 
cgit v1.2.3