From d2062b2cbe1ffc49c07a182739f6cc6115f7cc96 Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 2 Feb 2024 16:34:50 +0100 Subject: [PATCH] server start hadling pongs --- src-server/Server/Communication.hs | 26 ++++++++++++++++---------- src-server/Server/Types.hs | 2 +- 2 files changed, 17 insertions(+), 11 deletions(-) diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index 02b9577..ddf79b5 100644 --- a/src-server/Server/Communication.hs +++ b/src-server/Server/Communication.hs @@ -90,13 +90,11 @@ disconnectClients = mapM_ close clientSocket ) -timeoutClients - :: [(Maybe UUID, Socket)] +dropClient + :: (Maybe UUID, Socket) -> IO () -timeoutClients = mapM_ - (\(_, clientSocket) -> do - close clientSocket - ) +dropClient = + close . snd -- | Process incoming connection requests processRequests :: Game () @@ -220,11 +218,12 @@ handleMessage stateContainer readerContainer msg = do let arena = rcMap readerContainer initPos <- rollInitPosition arena now <- liftIO getCurrentTime + uuid <- nextRandom let freshWizard = newWizard initPos STM.atomically $ do currentPlayers <- STM.readTMVar (scPlayers stateContainer) void $ STM.swapTMVar (scPlayers stateContainer) $ - Player clientId freshWizard False now : currentPlayers + Player clientId freshWizard False (now, uuid) : currentPlayers let clientSock = fromJust $ lookup (Just clientId) clients sendMessage (ProvideInitialWizard freshWizard) clientSock ClientReady -> do @@ -236,6 +235,13 @@ handleMessage stateContainer readerContainer msg = do unless (null thisPlayers) $ void $ STM.swapTMVar (scPlayers stateContainer) $ (head thisPlayers) {playerReady = True} : otherPlayers + Pong uuid -> do + let client = fromJust $ (lookup (Just clientId) clients) + player <- STM.atomically $ do + players <- STM.readTMVar (scPlayers stateContainer) + pure $ head $ filter (\p -> playerId p == clientId) players + when (snd (playerLastPong player) /= uuid) $ + dropClient (Just clientId, client) _ -> pure () sendPings :: Game () @@ -248,13 +254,13 @@ sendPings = do players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer) sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer) mapM_ - (\(Player playerId (Wizard {}) readiness lastPong) -> do - let timeDiff = realToFrac $ diffUTCTime now lastPong + (\(Player playerId (Wizard {}) readiness (lastPongTime, _)) -> do + let timeDiff = realToFrac $ diffUTCTime now lastPongTime when (readiness && timeDiff > (fromIntegral framesPerPing * recip (fromIntegral fps))) $ do let clientSock = fromJust (lookup (Just playerId) sockets) if timeDiff > realToFrac maxTimeout then - liftIO $ disconnectClients [(Just playerId, clientSock)] + liftIO $ dropClient (Just playerId, clientSock) else do random <- liftIO nextRandom liftIO $ sendMessage diff --git a/src-server/Server/Types.hs b/src-server/Server/Types.hs index 97789c4..1f930c4 100644 --- a/src-server/Server/Types.hs +++ b/src-server/Server/Types.hs @@ -69,7 +69,7 @@ data Player = Player { playerId :: UUID , playerWizard :: Wizard , playerReady :: Bool - , playerLastPong :: UTCTime + , playerLastPong :: (UTCTime, UUID) } deriving (Eq, Show)