2 files changed, 22 insertions, 5 deletions

diff --git a/PingMachine.hs b/PingMachine.hs
index b714d71e..5cd70f95 100644
--- a/PingMachine.hs
+++ b/PingMachine.hs
@@ -48,17 +48,18 @@ data PingMachine = PingMachine
 -- 'pingFlag' is difficult to use properly because it is up to the caller to
 -- remember that the ping is already in progress.
 forkPingMachine
-    :: PingInterval -- ^ Milliseconds of idle before a ping is considered necessary.
+    :: String
+    -> PingInterval -- ^ Milliseconds of idle before a ping is considered necessary.
     -> TimeOut      -- ^ Milliseconds after 'PingIdle' before we signal 'PingTimeOut'.
     -> IO PingMachine
-forkPingMachine idle timeout = do
+forkPingMachine label idle timeout = do
     d <- interruptibleDelay
     flag <- atomically $ newTVar False
     canceled <- atomically $ newTVar False
     event <- atomically newEmptyTMVar
     started <- atomically $ newEmptyTMVar
     when (idle/=0) $ void . forkIO $ do
-        myThreadId >>= flip labelThread ("ping.watchdog")
+        myThreadId >>= flip labelThread ("Ping." ++ label) -- ("ping.watchdog")
         (>>=) (atomically (readTMVar started)) $ flip when $ do
         fix $ \loop -> do
             atomically $ writeTVar flag False
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index 10a24e50..cbd820de 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -32,9 +32,11 @@ import System.FilePath
 import System.IO.Temp
 import System.Environment
 import System.Directory
+import System.Random -- for ping fuzz
 import Control.Concurrent
 import GHC.Conc (labelThread)
 import System.IO.Unsafe(unsafeDupablePerformIO {- unsafeIOToSTM -})
+import PingMachine
 
 -- util, todo: move to another module
 maybeToEither :: Maybe b -> Either String b
@@ -101,6 +103,7 @@ data NetCryptoSession = NCrypto { ncState          :: TVar NetCryptoSessionStatu
                                 , ncPacketQueue :: PacketQueue CryptoData
                                 , ncBufferStart :: TVar Word32
                                 , ncDequeueThread :: Maybe ThreadId
+                                , ncPingMachine :: Maybe PingMachine
                                 , ncOutgoingQueue :: PQ.PacketOutQueue (State,Nonce24,TVar MsgOutMap) CryptoMessage (CryptoPacket Encrypted) CryptoData
                                 }
 
@@ -350,8 +353,10 @@ freshCryptoSession  sessions
                     , ncPacketQueue        = pktq
                     , ncBufferStart        = bufstart
                     , ncDequeueThread      = Nothing -- error "you want the NetCrypto-Dequeue thread id, but is it started?"
+                    , ncPingMachine        = Nothing -- error "you want the NetCrypto-PingMachine, but is it started?"
                     , ncOutgoingQueue      = pktoq
                     }
+    -- launch dequeue thread
     threadid <- forkIO $ do
         tid <- myThreadId
         labelThread tid ("NetCryptoDequeue." ++ show (key2id remotePublicKey))
@@ -359,7 +364,12 @@ freshCryptoSession  sessions
             cd <- atomically $ PQ.dequeue pktq
             _ <- runCryptoHook (netCryptoSession0 {ncDequeueThread=Just tid}) cd
             loop
-    let netCryptoSession = netCryptoSession0 {ncDequeueThread=Just threadid}
+    -- launch ping thread
+    fuzz <- randomRIO (0,2000)
+    pingMachine <- forkPingMachine ("NetCrypto." ++ show (key2id remotePublicKey)) (15000 + fuzz) 2000
+    -- update session with thread ids
+    let netCryptoSession = netCryptoSession0 {ncDequeueThread=Just threadid, ncPingMachine=Just pingMachine}
+    -- add this session to the lookup maps
     atomically $ do
         modifyTVar allsessions (Map.insert addr netCryptoSession)
         byKeyResult <- readTVar allsessionsByKey >>= return . Map.lookup remotePublicKey
@@ -459,7 +469,9 @@ cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do
     -- Handle Encrypted Message
     case Map.lookup addr sessionsmap of
         Nothing -> return Nothing -- drop packet, we have no session
-        Just session@(NCrypto {ncIncomingTypeArray, ncState, ncPacketQueue, ncHooks,ncSessionSecret,ncTheirSessionPublic,ncTheirBaseNonce}) -> do
+        Just session@(NCrypto { ncIncomingTypeArray, ncState, ncPacketQueue, ncHooks,
+                                ncSessionSecret, ncTheirSessionPublic, ncTheirBaseNonce,
+                                ncPingMachine}) -> do
             theirBaseNonce <- atomically $ readTVar ncTheirBaseNonce
             -- Try to decrypt message
             let diff :: Word16
@@ -488,6 +500,10 @@ cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do
                             writeTVar ncTheirBaseNonce y
                     -- then set session confirmed,
                     atomically $ writeTVar ncState Confirmed
+                    -- bump ping machine
+                    case ncPingMachine of
+                        Just pingMachine -> pingBump pingMachine
+                        Nothing -> return ()
                     msgTypes <- atomically $ readTVar ncIncomingTypeArray
                     let msgTyp = cd ^. messageType
                         msgTypMapped16 = msgTypes A.! fromEnum8 (msgID cm)