Adjusted ping behavior for toxcore compatibility.

1 files changed, 16 insertions, 3 deletions

diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index 5192e180..2632c936 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -769,8 +769,9 @@ runUponHandshake netCryptoSession0 addr pktoq = do
             loop
     dput XNetCrypto $ "runUponHandshake: " ++ show threadidOutgoing ++ " = NetCryptoDequeueOutgoing." ++ show (key2id remotePublicKey)
     -- launch ping Machine thread
-    fuzz <- randomRIO (0,2000)
-    pingMachine <- forkPingMachine ("NetCrypto." ++ show (key2id remotePublicKey)) (15000 + fuzz) 2000
+    fuzz <- return 0 -- randomRIO (0,2000) -- Fuzz to prevent simultaneous ping/pong exchanges.
+                                           -- Disabled because tox has no pong event.
+    pingMachine <- forkPingMachine ("NetCrypto." ++ show (key2id remotePublicKey)) (8000 + fuzz) 4000
     pingThreadId <- forkIO $ do
         tid <- myThreadId
         event <- atomically $ pingWait pingMachine
@@ -778,6 +779,12 @@ runUponHandshake netCryptoSession0 addr pktoq = do
         case event of
             PingIdle -> do
                 dput XNetCrypto $ "pingThread (session: " ++ show (ncSessionId netCryptoSession0) ++ ") PingIdle"
+                -- Normally, we would not bump the PingMachine until we receive
+                -- an inbound packet.  We are doing this here because tox has
+                -- no pong response packet and so we need to mark the
+                -- connection non-idle here.  Doing this prevents a PingTimeOut
+                -- from ever occurring. (TODO: handle timed-out sessions somehow.)
+                pingBump pingMachine
                 lr <- sendPing crypto netCryptoSession0
                 case lr of
                     Left s -> dput XNetCrypto $ "(pingThread session: " ++ show (ncSessionId netCryptoSession0) ++ ") " ++ s
@@ -1043,7 +1050,13 @@ sessionPacketH sessions addrRaw (CryptoPacket nonce16 encrypted) = do
                     atomically $ writeTVar ncState {-Confirmed-}Established
                     -- bump ping machine
                     case ncPingMachine of
-                        Just pingMachine -> pingBump pingMachine
+                        Just pingMachine -> -- Normally, we would bump the PingMachine to mark the connection
+                                            -- as non-idle so that we don't need to send a ping message.
+                                            -- Because tox has no pong message, we need to send a ping every
+                                            -- eight seconds regardless, so we will let the PingIdle event be
+                                            -- signaled even when we receive packets.
+                                            -- pingBump pingMachine
+                                            return ()
                         Nothing -> return ()
                     msgTypes <- atomically $ readTVar ncIncomingTypeArray
                     let msgTyp = cd ^. messageType