summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Presence/Server.hs28
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 @@
22module Server where 22module Server where
23 23
24import Data.ByteString (ByteString,hGetNonBlocking) 24import Data.ByteString (ByteString,hGetNonBlocking)
25import qualified Data.ByteString.Char8 as S ( hPutStrLn, hPutStr, pack) 25import qualified Data.ByteString.Char8 as S -- ( hPutStrLn, hPutStr, pack)
26#if MIN_VERSION_containers(0,5,0) 26#if MIN_VERSION_containers(0,5,0)
27import qualified Data.Map.Strict as Map 27import qualified Data.Map.Strict as Map
28import Data.Map.Strict (Map) 28import Data.Map.Strict (Map)
@@ -429,7 +429,7 @@ newConnection server params conkey h inout = do
429 hSetBuffering h NoBuffering 429 hSetBuffering h NoBuffering
430 let (forward,idle_ms,timeout_ms) = 430 let (forward,idle_ms,timeout_ms) =
431 case (inout,duplex params) of 431 case (inout,duplex params) of
432 (Out,True) -> ( const $ return () 432 (Out,False) -> ( const $ return ()
433 , 0 433 , 0
434 , 0 ) 434 , 0 )
435 _ -> ( announce . (conkey,) . Got 435 _ -> ( announce . (conkey,) . Got
@@ -613,8 +613,10 @@ connectionThreads h pinglogic = do
613 pingBump pinglogic -- start the ping timer 613 pingBump pinglogic -- start the ping timer
614 fix $ \loop -> do 614 fix $ \loop -> do
615 packet <- getPacket h 615 packet <- getPacket h
616 -- warn $ "read: " <> S.take 60 packet
616 atomically $ writeTChan incomming packet 617 atomically $ writeTChan incomming packet
617 pingBump pinglogic 618 pingBump pinglogic
619 -- warn $ "bumped: " <> S.take 60 packet
618 isEof <- liftIO $ hIsEOF h 620 isEof <- liftIO $ hIsEOF h
619 if isEof then finished Nothing else loop 621 if isEof then finished Nothing else loop
620 622
@@ -625,7 +627,9 @@ connectionThreads h pinglogic = do
625 atomically $ putTMVar donew () 627 atomically $ putTMVar donew ()
626 mb <- atomically $ readTMVar outs 628 mb <- atomically $ readTMVar outs
627 case mb of Just bs -> handle (\(SomeException e)->finished) 629 case mb of Just bs -> handle (\(SomeException e)->finished)
628 (do S.hPutStr h bs 630 (do -- warn $ "writing: " <> S.take 60 bs
631 S.hPutStr h bs
632 -- warn $ "wrote: " <> S.take 60 bs
629 atomically $ takeTMVar outs 633 atomically $ takeTMVar outs
630 loop) 634 loop)
631 Nothing -> finished 635 Nothing -> finished
@@ -744,7 +748,7 @@ connFlush c =
744 748
745bshow e = S.pack . show $ e 749bshow e = S.pack . show $ e
746warn str = S.hPutStrLn stderr str >> hFlush stderr 750warn str = S.hPutStrLn stderr str >> hFlush stderr
747debugNoise str = warn str -- return () 751debugNoise str = return ()
748 752
749 753
750data PingEvent = PingIdle | PingTimeOut 754data PingEvent = PingIdle | PingTimeOut
@@ -763,13 +767,14 @@ pingMachine idle timeout = do
763 canceled <- atomically $ newTVar False 767 canceled <- atomically $ newTVar False
764 event <- atomically newEmptyTMVar 768 event <- atomically newEmptyTMVar
765 started <- atomically $ newEmptyTMVar 769 started <- atomically $ newEmptyTMVar
766 thread <- forkIO $ do 770 when (idle/=0) $ void . forkIO $ do
767 (>>=) (atomically (readTMVar started)) $ flip when $ do 771 (>>=) (atomically (readTMVar started)) $ flip when $ do
768 fix $ \loop -> do 772 fix $ \loop -> do
769 atomically $ writeTVar flag False 773 atomically $ writeTVar flag False
770 fin <- startDelay d (1000*idle) 774 fin <- startDelay d (1000*idle)
771 (>>=) (atomically (readTMVar started)) $ flip when $ do 775 (>>=) (atomically (readTMVar started)) $ flip when $ do
772 when (not fin) loop 776 if (not fin) then loop
777 else do
773 -- Idle event 778 -- Idle event
774 atomically $ do 779 atomically $ do
775 tryTakeTMVar event 780 tryTakeTMVar event
@@ -777,7 +782,9 @@ pingMachine idle timeout = do
777 writeTVar flag True 782 writeTVar flag True
778 fin <- startDelay d (1000*timeout) 783 fin <- startDelay d (1000*timeout)
779 (>>=) (atomically (readTMVar started)) $ flip when $ do 784 (>>=) (atomically (readTMVar started)) $ flip when $ do
780 when (not fin) loop 785 me <- myThreadId
786 if (not fin) then loop
787 else do
781 -- Timeout event 788 -- Timeout event
782 atomically $ do 789 atomically $ do
783 tryTakeTMVar event 790 tryTakeTMVar event
@@ -798,8 +805,11 @@ pingCancel me = do
798 805
799pingBump :: PingMachine -> IO () 806pingBump :: PingMachine -> IO ()
800pingBump me = do 807pingBump me = do
801 atomically $ do tryTakeTMVar (pingStarted me) 808 atomically $ do
802 putTMVar (pingStarted me) True 809 b <- tryReadTMVar (pingStarted me)
810 when (b/=Just False) $ do
811 tryTakeTMVar (pingStarted me)
812 putTMVar (pingStarted me) True
803 interruptDelay (pingInterruptable me) 813 interruptDelay (pingInterruptable me)
804 814
805pingWait :: PingMachine -> STM PingEvent 815pingWait :: PingMachine -> STM PingEvent