fix pingpong procedure

This commit is contained in:
nek0 2024-04-08 03:50:12 +02:00
parent b8aefd57fc
commit cd16ce7971
2 changed files with 51 additions and 29 deletions

View file

@ -4,4 +4,4 @@ setMapColumns : 40
setSpawnerProbability : 0.01 setSpawnerProbability : 0.01
setFPS : 60 setFPS : 60
setClientMaxTimeout : 5 setClientMaxTimeout : 5
setFramesPerPing : 30 setFramesPerPing : 120

View file

@ -71,7 +71,10 @@ terminateGameOnSigint = do
putStrLn "SIGINT caught, terminating…" putStrLn "SIGINT caught, terminating…"
disconnectClients clientList clients disconnectClients clientList clients
close sock 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 Nothing
@ -118,17 +121,26 @@ processRequests = do
mainSocket <- asks rcMainSocket mainSocket <- asks rcMainSocket
queue <- gets scMessageQueue queue <- gets scMessageQueue
socketList <- gets scClientSockets socketList <- gets scClientSockets
void $ liftIO $ forkIO $ forever $ acceptConnection mainSocket socketList queue st <- gets scServerState
void $ liftIO $ forkIO $ acceptConnection mainSocket socketList queue st
where where
acceptConnection mainSocket socketList queue = do acceptConnection mainSocket socketList queue st = do
putStrLn "Ready for new connection requests…" putStrLn "Ready for new connection requests…"
(clientSock, _) <- accept mainSocket esock <- try $ accept mainSocket
clientThreadId <- liftIO $ forkIO $ forever $ do case esock of
receiveMessage clientSock queue socketList Left (_ :: SomeException) ->
liftIO $ STM.atomically $ do putStrLn "Main socket vanished!"
list <- STM.takeTMVar socketList Right (clientSock, _) -> do
STM.putTMVar socketList ((ClientComms Nothing clientSock clientThreadId) : list) clientThreadId <- liftIO $ forkIO $ forever $ do
putStrLn "accepted new connection" 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 -- | Sends a specified message through given socket to the client
sendMessage sendMessage
@ -267,23 +279,33 @@ 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 (find (\c -> ccUUID c == Just clientId) clients) let mclient = find (\c -> ccUUID c == Just clientId) clients
player <- STM.atomically $ do maybe
players <- STM.readTMVar (scPlayers stateContainer) (putStrLn $ "Who is " <> show uuid <> "?")
pure $ head $ filter (\p -> playerId p == clientId) players (\client -> do
-- if snd (playerLastPong player) /= uuid mplayer <- STM.atomically $ do
-- then do players <- STM.readTMVar (scPlayers stateContainer)
-- putStrLn $ "dropping client " <> show clientId pure $ find (\p -> playerId p == clientId) players
-- dropClient clientList (Just clientId, client) maybe
-- else do (pure ())
now <- getCurrentTime (\player ->
STM.atomically$ do if snd (playerLastPong player) /= uuid
players <- STM.readTMVar (scPlayers stateContainer) then do
let otherPlayers = filter (\a -> playerId a /= playerId player) players putStrLn $ "dropping client " <> show clientId
modPlayer = player dropClient clientList (ccSocket client)
{ playerLastPong = (now, uuid) else do
} now <- getCurrentTime
void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers) 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 :: Game ()
sendPings = do sendPings = do
@ -306,7 +328,7 @@ sendPings = do
put stateContainer put stateContainer
else do else do
random <- liftIO nextRandom random <- liftIO nextRandom
let newPong = (lastPongTime, random) let newPong = (now, random)
liftIO $ sendMessage liftIO $ sendMessage
( Ping random ( Ping random
) )