Fixed ping bug.

1 files changed, 19 insertions, 9 deletions

diff --git a/Presence/Server.hs b/Presence/Server.hs
index ff3c5d42..a1c4923b 100644
--- a/Presence/Server.hs
+++ b/Presence/Server.hs
@@ -22,7 +22,7 @@
 module Server where
 
 import Data.ByteString (ByteString,hGetNonBlocking)
-import qualified Data.ByteString.Char8 as S ( hPutStrLn, hPutStr, pack)
+import qualified Data.ByteString.Char8 as S -- ( hPutStrLn, hPutStr, pack)
 #if MIN_VERSION_containers(0,5,0)
 import qualified Data.Map.Strict as Map
 import           Data.Map.Strict (Map)
@@ -429,7 +429,7 @@ newConnection server params conkey h inout = do
     hSetBuffering h NoBuffering
     let (forward,idle_ms,timeout_ms) =
             case (inout,duplex params) of
-                (Out,True) -> ( const $ return ()
+                (Out,False) -> ( const $ return ()
                               , 0
                               , 0 )
                 _ -> ( announce . (conkey,) . Got
@@ -613,8 +613,10 @@ connectionThreads h pinglogic = do
             pingBump pinglogic -- start the ping timer
             fix $ \loop -> do
             packet <- getPacket h
+            -- warn $ "read: " <> S.take 60 packet
             atomically $ writeTChan incomming packet
             pingBump pinglogic
+            -- warn $ "bumped: " <> S.take 60 packet
             isEof <- liftIO $ hIsEOF h
             if isEof then finished Nothing else loop
 
@@ -625,7 +627,9 @@ connectionThreads h pinglogic = do
                           atomically $ putTMVar donew ()
         mb <- atomically $ readTMVar outs
         case mb of Just bs -> handle (\(SomeException e)->finished)
-                                     (do S.hPutStr h bs
+                                     (do -- warn $ "writing: " <> S.take 60 bs
+                                         S.hPutStr h bs
+                                         -- warn $ "wrote: " <> S.take 60 bs
                                          atomically $ takeTMVar outs
                                          loop)
                    Nothing -> finished
@@ -744,7 +748,7 @@ connFlush c =
 
 bshow e = S.pack . show $ e
 warn str = S.hPutStrLn stderr str >> hFlush stderr
-debugNoise str = warn str -- return ()
+debugNoise str = return ()
 
 
 data PingEvent = PingIdle | PingTimeOut
@@ -763,13 +767,14 @@ pingMachine idle timeout = do
     canceled <- atomically $ newTVar False
     event <- atomically newEmptyTMVar
     started <- atomically $ newEmptyTMVar
-    thread <- forkIO $ do
+    when (idle/=0) $ void . forkIO $ do
         (>>=) (atomically (readTMVar started)) $ flip when $ do
         fix $ \loop -> do
             atomically $ writeTVar flag False
             fin <- startDelay d (1000*idle)
             (>>=) (atomically (readTMVar started)) $ flip when $ do
-            when (not fin) loop
+            if (not fin) then loop
+            else do
             -- Idle event
             atomically $ do
                 tryTakeTMVar event
@@ -777,7 +782,9 @@ pingMachine idle timeout = do
                 writeTVar flag True
             fin <- startDelay d (1000*timeout)
             (>>=) (atomically (readTMVar started)) $ flip when $ do
-            when (not fin) loop
+            me <- myThreadId
+            if (not fin) then loop
+            else do
             -- Timeout event
             atomically $ do
                 tryTakeTMVar event
@@ -798,8 +805,11 @@ pingCancel me = do
 
 pingBump :: PingMachine -> IO ()
 pingBump me = do
-    atomically $ do tryTakeTMVar (pingStarted me)
-                    putTMVar (pingStarted me) True
+    atomically $ do
+            b <- tryReadTMVar (pingStarted me)
+            when (b/=Just False) $ do
+                tryTakeTMVar (pingStarted me)
+                putTMVar (pingStarted me) True
     interruptDelay (pingInterruptable me)
 
 pingWait :: PingMachine -> STM PingEvent