ping work

3 files changed, 24 insertions, 13 deletions

diff --git a/Presence/SendMessage.hs b/Presence/SendMessage.hs
index 71b6a3bd..e7b3db33 100644
--- a/Presence/SendMessage.hs
+++ b/Presence/SendMessage.hs
@@ -53,6 +53,7 @@ import ServerC (packetSink)
 import ControlMaybe 
 import Data.Conduit (Sink,Source)
 import qualified Data.ByteString as S (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as L
 import XMLToByteStrings
 import Logging
 import ByteStringOperators
@@ -125,7 +126,8 @@ sendMessage (OutgoingConnections cons interpretCommands) msg peer0 = do
                           ThreadFinished  -> died
                         )
           found
-    -- L.putStrLn $ "sendMessage ->"<++>showPeer peer<++>": "<++>bshow msg
+    if is_new then L.putStrLn $ "sendMessage NEW ->"<++>showPeer peer<++>": "<++>bshow msg
+              else L.putStrLn $ "sendMessage ->"<++>showPeer peer<++>": "<++>bshow msg
     atomically $ writeTChan (fst entry) msg
     when is_new . atomically $
         readTVar cons >>= writeTVar cons . Map.insert peer entry
@@ -163,7 +165,7 @@ connect_to_server chan peer toPeer = (>> return ()) . runMaybeT $ do
             MaybeT $ handleOutgoingToPeer toPeer (restrictSocket sock) cache chan snk
 
         liftIO $ cacheCmd retry cached
-        -- liftIO $ putStrLn $ "retrying " ++ show retry
+        liftIO $ putStrLn $ "retrying " ++ show retry
         sendmsgs
 
 connect' :: SockAddr -> Int -> IO (Maybe Socket)
diff --git a/Presence/SocketLike.hs b/Presence/SocketLike.hs
index c2f14460..af0249ae 100644
--- a/Presence/SocketLike.hs
+++ b/Presence/SocketLike.hs
@@ -67,7 +67,7 @@ instance SocketLike RestrictedSocket where
     sIsListening  (Restricted mb sock) = NS.sIsListening sock
     sIsReadable   (Restricted mb sock) = NS.sIsReadable sock
     sIsWritable   (Restricted mb sock) = NS.sIsWritable sock
-    sClose        (Restricted mb sock) = maybe (NS.sClose sock) hClose mb
+    sClose        (Restricted mb sock) = maybe (NS.sClose sock) (\h -> hClose h >> NS.sClose sock) mb
 
 restrictSocket :: NS.Socket -> RestrictedSocket
 restrictSocket socket = Restricted Nothing socket
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)