diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index ddf79b5..58a67b1 100644 --- a/src-server/Server/Communication.hs +++ b/src-server/Server/Communication.hs @@ -19,8 +19,6 @@ import qualified Data.ByteString.Lazy.Char8 as B8 import Data.List -import qualified Data.Matrix as M - import Data.Maybe import Data.UUID hiding (null) @@ -32,8 +30,6 @@ import qualified Data.Vector.Storable as VS import Foreign hiding (void) -import Linear - import Network.Socket as Net import System.Posix.Signals @@ -66,13 +62,14 @@ terminateGameOnSigint -> Game () terminateGameOnSigint path = do sock <- asks rcMainSocket - clients <- liftIO . STM.atomically . STM.readTMVar =<< gets scClientSockets + clientList <- gets scClientSockets + clients <- liftIO $ STM.atomically $ STM.readTMVar clientList serverState <- gets scServerState void $ liftIO $ installHandler sigINT (CatchOnce $ do putStrLn "SIGINT caught, terminating…" - disconnectClients clients + disconnectClients clientList clients close sock removeIfExists path void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True) @@ -82,19 +79,25 @@ terminateGameOnSigint path = do Nothing disconnectClients - :: [(Maybe UUID, Socket)] + :: STM.TMVar [(Maybe UUID, Socket)] + -> [(Maybe UUID, Socket)] -> IO () -disconnectClients = mapM_ - (\(_, clientSocket) -> do +disconnectClients clientList = mapM_ + (\client@(_, clientSocket) -> do sendMessage ServerQuit clientSocket - close clientSocket + dropClient clientList client ) dropClient - :: (Maybe UUID, Socket) + :: STM.TMVar [(Maybe UUID, Socket)] + -> (Maybe UUID, Socket) -> IO () -dropClient = - close . snd +dropClient clientList (uuid, clientSocket) = do + STM.atomically $ do + clients <- STM.readTMVar clientList + let reducedClients = filter ((/= uuid) . fst) clients + void $ STM.swapTMVar clientList reducedClients + close clientSocket -- | Process incoming connection requests processRequests :: Game () @@ -236,12 +239,22 @@ handleMessage stateContainer readerContainer msg = do void $ STM.swapTMVar (scPlayers stateContainer) $ (head thisPlayers) {playerReady = True} : otherPlayers Pong uuid -> do - let client = fromJust $ (lookup (Just clientId) clients) + 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) + if snd (playerLastPong player) /= uuid + then + dropClient clientList (Just clientId, client) + else do + now <- getCurrentTime + STM.atomically$ do + players <- STM.readTMVar (scPlayers stateContainer) + let otherPlayers = filter (/= player) players + modPlayer = player + { playerLastPong = (now, uuid) + } + void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers) _ -> pure () sendPings :: Game () @@ -257,15 +270,16 @@ sendPings = do (\(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 $ dropClient (Just playerId, clientSock) - else do - random <- liftIO nextRandom - liftIO $ sendMessage - ( Ping random - ) - clientSock + let clientSock = lookup (Just playerId) sockets + when (isJust clientSock) $ + if timeDiff > realToFrac maxTimeout + then + liftIO $ dropClient (scClientSockets stateContainer) (Just playerId, fromJust clientSock) + else do + random <- liftIO nextRandom + liftIO $ sendMessage + ( Ping random + ) + (fromJust clientSock) ) players