presence probe bug fixes

2 files changed, 20 insertions, 8 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 99e7b3f1..c81ed8c7 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -543,10 +543,13 @@ handlePresenceProbe session stanza = do
     liftIO $ L.putStrLn $ "RECEIVED PROBE "<++>bshow (peerAddress session,to)
     liftIO $ do
         subs <- getSubscribers (peerSessionFactory session) user
+        liftIO $ L.putStrLn $ "subscribers for "<++>bshow user<++>": " <++>bshow subs
         forM_ subs $ \jidstr -> do
             handle (\(SomeException _) -> return ()) $ do
+                L.putStrLn $ "parsing " <++>jidstr
                 sub <- parseHostNameJID jidstr
-                when (peer sub == peer jid) $ do
+                putStrLn $ "comparing " ++show (peer sub , peerAddress session)
+                when (peer sub == peerAddress session) $ do
                 ps <- userStatus session user
                 mapM_ (announcePresence session) ps
     return ()
@@ -692,6 +695,7 @@ toPeer sock cache chan = do
         send r
     forM_ (Map.assocs . probes $ cache) $ \(to,froms) -> do
         forM_ (Set.toList froms) $ \from -> do
+            liftIO $ L.putStrLn "sending cached probe..."
             r <- liftIO $ presenceProbe sock from to
             send r
     fix $ \loop -> do
@@ -701,22 +705,27 @@ toPeer sock cache chan = do
             r <- lift $ xmlifyPresenceForPeer sock p
             send r
           PresenceProbe from to -> do
+            liftIO $ L.putStrLn "sending live probe..."
             r <- liftIO $ presenceProbe sock from to
             send r
         loop
     send goodbyePeer
 
 handleOutgoingToPeer sock cache chan snk = do
+    p <- getPeerName sock
+    L.putStrLn $ "(>P) connected " <++> showPeer (RemotePeer p)
+    finally (
 #ifdef RENDERFLUSH
-    toPeer sock cache chan 
-        $$  flushList
-        =$= renderBuilderFlush def
-        =$= builderToByteStringFlush
-        =$= discardFlush
-         =$ snk
+        toPeer sock cache chan 
+            $$  flushList
+            =$= renderBuilderFlush def
+            =$= builderToByteStringFlush
+            =$= discardFlush
+             =$ snk
 #else
-    toPeer sock cache chan $$ renderChunks =$ snk
+        toPeer sock cache chan $$ renderChunks =$ snk
 #endif
+        ) $ L.putStrLn $ "(>P) disconnected " <++> showPeer (RemotePeer p)
 
 connect' :: SockAddr -> Int -> IO (Maybe Socket)
 connect' addr port = do
diff --git a/Presence/main.hs b/Presence/main.hs
index 7981f00b..7a0ee2b4 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -247,6 +247,7 @@ newPresenceState hostname = atomically $ do
     return $ PresenceState hostname tty us subs locals_greedy remotes server_connections
 
 sendProbes state jid = do
+    L.putStrLn $ "sending probes for " <++> bshow jid
     withJust (name jid) $ \user -> do
     let parseHostNameJID' str = do
             handle (\(SomeException _) -> return Nothing)
@@ -254,12 +255,14 @@ sendProbes state jid = do
     buddies <- do
         buddies <- ConfigFiles.getBuddies user
         fmap catMaybes (mapM parseHostNameJID' buddies)
+    L.putStrLn $ "buddies for " <++> bshow jid <++> " = " <++> bshow buddies
     remotes <- readTVarIO (remoteUsers state)
     forM_ buddies $ \buddy -> do
         let mjids = fmap snd $ Map.lookup (peer buddy) remotes
         jids <- maybe (return Set.empty) readTVarIO mjids
         let noinfo = Set.notMember buddy jids
         when noinfo $ do
+        L.putStrLn $ "sendMessage " <++> bshow (PresenceProbe jid buddy)
         sendMessage (outGoingConnections state) (PresenceProbe jid buddy) (peer buddy) 
         return ()