nek0/wizard-wipeout
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

server start hadling pongs

Browse source
This commit is contained in:
nek0 2024-02-02 16:34:50 +01:00
parent baae726e56
commit d2062b2cbe
2 changed files with 17 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
src-server/Server/Communication.hs
View file

@ -90,13 +90,11 @@ disconnectClients = mapM_
close clientSocket close clientSocket
) )
timeoutClients dropClient
:: [(Maybe UUID, Socket)] :: (Maybe UUID, Socket)
-> IO () -> IO ()
timeoutClients = mapM_ dropClient =
(\(_, clientSocket) -> do close . snd
close clientSocket
)
-- | Process incoming connection requests -- | Process incoming connection requests
processRequests :: Game () processRequests :: Game ()
@ -220,11 +218,12 @@ handleMessage stateContainer readerContainer msg = do
let arena = rcMap readerContainer let arena = rcMap readerContainer
initPos <- rollInitPosition arena initPos <- rollInitPosition arena
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
uuid <- nextRandom
let freshWizard = newWizard initPos let freshWizard = newWizard initPos
STM.atomically $ do STM.atomically $ do
currentPlayers <- STM.readTMVar (scPlayers stateContainer) currentPlayers <- STM.readTMVar (scPlayers stateContainer)
void $ STM.swapTMVar (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 let clientSock = fromJust $ lookup (Just clientId) clients
sendMessage (ProvideInitialWizard freshWizard) clientSock sendMessage (ProvideInitialWizard freshWizard) clientSock
ClientReady -> do ClientReady -> do
@ -236,6 +235,13 @@ handleMessage stateContainer readerContainer msg = do
unless (null thisPlayers) $ unless (null thisPlayers) $
void $ STM.swapTMVar (scPlayers stateContainer) $ void $ STM.swapTMVar (scPlayers stateContainer) $
(head thisPlayers) {playerReady = True} : otherPlayers (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 () _ -> pure ()
sendPings :: Game () sendPings :: Game ()
@ -248,13 +254,13 @@ sendPings = do
players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer) players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer)
sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer) sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer)
mapM_ mapM_
(\(Player playerId (Wizard {}) readiness lastPong) -> do (\(Player playerId (Wizard {}) readiness (lastPongTime, _)) -> do
let timeDiff = realToFrac $ diffUTCTime now lastPong 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 = fromJust (lookup (Just playerId) sockets)
if timeDiff > realToFrac maxTimeout if timeDiff > realToFrac maxTimeout
then then
liftIO $ disconnectClients [(Just playerId, clientSock)] liftIO $ dropClient (Just playerId, clientSock)
else do else do
random <- liftIO nextRandom random <- liftIO nextRandom
liftIO $ sendMessage liftIO $ sendMessage

2
src-server/Server/Types.hs
View file

@ -69,7 +69,7 @@ data Player = Player
{ playerId :: UUID { playerId :: UUID
, playerWizard :: Wizard , playerWizard :: Wizard
, playerReady :: Bool , playerReady :: Bool
, playerLastPong :: UTCTime , playerLastPong :: (UTCTime, UUID)
} }
deriving (Eq, Show) deriving (Eq, Show)