From cd16ce79715d0a7f0a3954feb0e7756f5e02628c Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 8 Apr 2024 03:50:12 +0200 Subject: [PATCH] fix pingpong procedure --- configuration.yaml | 2 +- src-server/Server/Communication.hs | 78 +++++++++++++++++++----------- 2 files changed, 51 insertions(+), 29 deletions(-) diff --git a/configuration.yaml b/configuration.yaml index ad8b6a1..12bc274 100644 --- a/configuration.yaml +++ b/configuration.yaml @@ -4,4 +4,4 @@ setMapColumns : 40 setSpawnerProbability : 0.01 setFPS : 60 setClientMaxTimeout : 5 -setFramesPerPing : 30 +setFramesPerPing : 120 diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index a83b63f..82527e3 100644 --- a/src-server/Server/Communication.hs +++ b/src-server/Server/Communication.hs @@ -71,7 +71,10 @@ terminateGameOnSigint = do putStrLn "SIGINT caught, terminating…" disconnectClients clientList clients close sock - void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True) + st <- STM.atomically $ STM.readTMVar serverState + void $ STM.atomically $ STM.swapTMVar serverState $ st + { serverStop = True + } ) Nothing @@ -118,17 +121,26 @@ processRequests = do mainSocket <- asks rcMainSocket queue <- gets scMessageQueue socketList <- gets scClientSockets - void $ liftIO $ forkIO $ forever $ acceptConnection mainSocket socketList queue + st <- gets scServerState + void $ liftIO $ forkIO $ acceptConnection mainSocket socketList queue st where - acceptConnection mainSocket socketList queue = do + acceptConnection mainSocket socketList queue st = do putStrLn "Ready for new connection requests…" - (clientSock, _) <- accept mainSocket - clientThreadId <- liftIO $ forkIO $ forever $ do - receiveMessage clientSock queue socketList - liftIO $ STM.atomically $ do - list <- STM.takeTMVar socketList - STM.putTMVar socketList ((ClientComms Nothing clientSock clientThreadId) : list) - putStrLn "accepted new connection" + esock <- try $ accept mainSocket + case esock of + Left (_ :: SomeException) -> + putStrLn "Main socket vanished!" + Right (clientSock, _) -> do + clientThreadId <- liftIO $ forkIO $ forever $ do + receiveMessage clientSock queue socketList + liftIO $ STM.atomically $ do + list <- STM.takeTMVar socketList + STM.putTMVar socketList ((ClientComms Nothing clientSock clientThreadId) : list) + putStrLn "accepted new connection" + abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st) + unless abortCondition $ + acceptConnection mainSocket socketList queue st + -- | Sends a specified message through given socket to the client sendMessage @@ -267,23 +279,33 @@ handleMessage stateContainer readerContainer msg = do void $ STM.swapTMVar (scPlayers stateContainer) $ (head thisPlayers) {playerReady = True} : otherPlayers Pong uuid -> do - -- let client = fromJust (find (\c -> ccUUID c == Just clientId) clients) - player <- STM.atomically $ do - players <- STM.readTMVar (scPlayers stateContainer) - pure $ head $ filter (\p -> playerId p == clientId) players - -- if snd (playerLastPong player) /= uuid - -- then do - -- putStrLn $ "dropping client " <> show clientId - -- dropClient clientList (Just clientId, client) - -- else do - now <- getCurrentTime - STM.atomically$ do - players <- STM.readTMVar (scPlayers stateContainer) - let otherPlayers = filter (\a -> playerId a /= playerId player) players - modPlayer = player - { playerLastPong = (now, uuid) - } - void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers) + let mclient = find (\c -> ccUUID c == Just clientId) clients + maybe + (putStrLn $ "Who is " <> show uuid <> "?") + (\client -> do + mplayer <- STM.atomically $ do + players <- STM.readTMVar (scPlayers stateContainer) + pure $ find (\p -> playerId p == clientId) players + maybe + (pure ()) + (\player -> + if snd (playerLastPong player) /= uuid + then do + putStrLn $ "dropping client " <> show clientId + dropClient clientList (ccSocket client) + else do + now <- getCurrentTime + STM.atomically$ do + players <- STM.readTMVar (scPlayers stateContainer) + let otherPlayers = filter (\a -> playerId a /= playerId player) players + modPlayer = player + { playerLastPong = (now, uuid) + } + void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers) + ) + mplayer + ) + mclient sendPings :: Game () sendPings = do @@ -306,7 +328,7 @@ sendPings = do put stateContainer else do random <- liftIO nextRandom - let newPong = (lastPongTime, random) + let newPong = (now, random) liftIO $ sendMessage ( Ping random )