make more sync

This commit is contained in:
nek0 2024-02-03 18:01:45 +01:00
parent d2062b2cbe
commit ce69da9e43

View file

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