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
setFPS : 60
setClientMaxTimeout : 5
setFramesPerPing : 30
setFramesPerPing : 120

View file

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