hunting bugs, found space leak in client

This commit is contained in:
nek0 2024-04-06 02:18:08 +02:00
parent 540874917c
commit 82598aaafb
6 changed files with 72 additions and 73 deletions

View file

@ -64,7 +64,7 @@ handleMessages = do
msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
mapM_
(\msg -> do
liftIO $ putStrLn $ "handling following: " <> show msg
-- liftIO $ putStrLn $ "Handling following: " <> show msg
handleMessage msg
)
msgs

View file

@ -65,7 +65,7 @@ main = do
initState = StateContainer (arenaSpawners arena) emptyPLayers serverState now sockList messageQueue
(finalState, finalWrite) <- execRWST
(do
terminateGameOnSigint setSocketPath
terminateGameOnSigint
runGame
)
initRead

View file

@ -1,5 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Server.Communication where
import Control.Concurrent
@ -52,7 +51,7 @@ bindSocket path = do
let sockAddr = SockAddrUnix path
unless (isSupportedSockAddr sockAddr)
(error $ "invalid socket path " <> path)
-- aremoveIfExists path
-- removeIfExists path
sock <- socket AF_UNIX Stream defaultProtocol
bind sock sockAddr
Net.listen sock 5
@ -60,9 +59,8 @@ bindSocket path = do
-- | Function that installs a handler on SIGINT to terminate game
terminateGameOnSigint
:: FilePath
-> Game ()
terminateGameOnSigint path = do
:: Game ()
terminateGameOnSigint = do
sock <- asks rcMainSocket
clientList <- gets scClientSockets
clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
@ -73,75 +71,79 @@ terminateGameOnSigint path = do
putStrLn "SIGINT caught, terminating…"
disconnectClients clientList clients
close sock
-- removeIfExists path
void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True)
)
Nothing
-- | Disconnect all connected clients gracefully by announcing the server quitting
disconnectClients
:: STM.TMVar [(Maybe UUID, Socket)]
-> [(Maybe UUID, Socket)]
:: STM.TMVar [ClientComms]
-> [ClientComms]
-> IO ()
disconnectClients clientList = mapM_
(\client@(muuid, _) -> do
(\client -> do
maybe
(pure ())
(\uuid -> do
sendMessage ServerQuit uuid clientList
dropClient clientList uuid
dropClient clientList (ccSocket client)
)
muuid
(ccUUID client)
)
-- | Drops the client from internal management and closes its socket, if still present.
dropClient
:: STM.TMVar [(Maybe UUID, Socket)]
-> UUID
:: STM.TMVar [ClientComms]
-> Socket
-> IO ()
dropClient clientList uuid = do
msock <- STM.atomically $ do
dropClient clientList sock = do
mclient <- STM.atomically $ do
clients <- STM.readTMVar clientList
let msock = lookup (Just uuid) clients
let reducedClients = filter ((/= Just uuid) . fst) clients
let mclient = find (\client -> ccSocket client == sock) clients
let reducedClients = filter (\client -> ccSocket client /= sock) clients
void $ STM.swapTMVar clientList reducedClients
pure msock
putStrLn $ "dropping client " <> show uuid
pure mclient
maybe
(pure ())
close
msock
(putStrLn $ "closing unknown socket: " <> show sock)
(\client -> do
putStrLn $ "dropping client: " <> show (ccUUID client)
killThread (ccListener client)
)
mclient
close sock
-- | Process incoming connection requests
processRequests :: Game ()
processRequests = do
mainSocket <- asks rcMainSocket
queue <- gets scMessageQueue
socketList <- gets scClientSockets
void $ liftIO $ forkIO $ acceptConnection mainSocket socketList
void $ liftIO $ forkIO $ forever $ acceptConnection mainSocket socketList queue
where
acceptConnection mainSocket socketList = do
putStrLn "accepting new connections"
acceptConnection mainSocket socketList queue = do
putStrLn "New connection request incoming"
(clientSock, _) <- accept mainSocket
clientThreadId <- liftIO $ forkIO $ forever $ do
receiveMessage clientSock queue socketList
liftIO $ STM.atomically $ do
list <- STM.takeTMVar socketList
STM.putTMVar socketList ((Nothing, clientSock) : list)
STM.putTMVar socketList ((ClientComms Nothing clientSock clientThreadId) : list)
putStrLn "accepted new connection"
acceptConnection mainSocket socketList
-- | Sends a specified message through given socket to the client
sendMessage
:: ServerMessage
-> UUID
-> STM.TMVar [(Maybe UUID, Socket)]
-> STM.TMVar [ClientComms]
-> IO ()
sendMessage msg uuid clientList = do
clients <- STM.atomically $ STM.readTMVar clientList
let msock = lookup (Just uuid) clients
let msock = ccSocket <$> find (\client -> ccUUID client == Just uuid) clients
msgJson = A.encode msg
msgVector = VS.fromList $ B.unpack $ B.toStrict $ ('<' `B8.cons` (msgJson `B8.snoc` '>'))
-- putStrLn $ "sending: " <> B8.unpack msgJson
putStrLn $ "Sending: " <> B8.unpack msgJson
maybe
(dropClient clientList uuid)
(putStrLn $ "unknown client UUID: " <> show uuid)
(\sock ->
VS.unsafeWith
msgVector
@ -149,29 +151,22 @@ sendMessage msg uuid clientList = do
)
msock
-- | receive incoming messages from clients
receiveMessages
:: STM.TMVar [(Maybe UUID, Socket)]
-> STM.TQueue ClientMessage
-> IO ()
receiveMessages clientsVar queue = do
clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar
mapM_
(\(muuid, clientSocket) -> do
receiveMessage clientSocket queue muuid clientsVar
)
clients
-- | handle received messages
handleMessages :: Game ()
handleMessages = do
queue <- gets scMessageQueue
serverState <- get
readerContainer <- ask
emptyState <- liftIO $ STM.atomically $ STM.isEmptyTQueue queue
unless emptyState $ do
msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
void $ liftIO $ do
liftIO $ do
msgs <- STM.atomically $ do
emptyState <- STM.isEmptyTQueue queue
if emptyState
then
pure []
else
STM.flushTQueue queue
unless (null msgs) $ putStrLn "GET"
void $ do
mapM_
(handleMessage serverState readerContainer)
msgs
@ -180,10 +175,9 @@ handleMessages = do
receiveMessage
:: Socket
-> STM.TQueue ClientMessage
-> Maybe UUID
-> STM.TMVar [(Maybe UUID, Socket)]
-> STM.TMVar [ClientComms]
-> IO ()
receiveMessage sock queue muuid clientList = do
receiveMessage sock queue clientList = do
let maxBufferLength = 4096
mmsg <- do
ptr <- mallocArray maxBufferLength
@ -192,10 +186,7 @@ receiveMessage sock queue muuid clientList = do
bufferLength <- case ebufferLength of
Left (_ :: IOException) -> do
putStrLn "Socket vanished, cleaning up…"
maybe
(pure ())
(dropClient clientList)
muuid
dropClient clientList sock
pure 0
Right len -> pure len
msg <- B.pack <$> peekArray bufferLength ptr
@ -209,6 +200,7 @@ receiveMessage sock queue muuid clientList = do
maybe
(pure ())
(\msg -> do
putStrLn "PUT"
liftIO $ STM.atomically $ STM.writeTQueue queue msg
-- when (msg == IdRequest) (threadDelay $ 10 ^ 3)
)
@ -223,17 +215,19 @@ handleMessage
handleMessage stateContainer readerContainer msg = do
let clientList = scClientSockets stateContainer
clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
putStrLn $ "Handling following: " <> show msg
-- putStrLn $ "Handling: " <> show msg
case msg of
IdRequest -> do
clientId <- nextRandom
let clientIdx = findIndex (isNothing . fst) clients
let clientSock = snd $ clients !! fromJust clientIdx
let clientIdx = findIndex (isNothing . ccUUID) clients
let clientSock = ccSocket $ clients !! fromJust clientIdx
let newClients = map
(\old@(muuid, oldClientSock) ->
(\old@(ClientComms muuid oldClientSock _) ->
if oldClientSock == clientSock && isNothing muuid
then
(Just clientId, clientSock)
old
{ ccUUID = Just clientId
}
else
old
)
@ -245,7 +239,7 @@ handleMessage stateContainer readerContainer msg = do
case payload of
ClientQuit -> do
putStrLn $ "removing client " <> show clientId
let newClients = filter (\a -> fst a /= Just clientId) clients
let newClients = filter (\a -> ccUUID a /= Just clientId) clients
STM.atomically $ do
currentPlayers <- STM.readTMVar (scPlayers stateContainer)
let newPlayers = filter (\p -> playerId p /= clientId) currentPlayers
@ -273,7 +267,7 @@ 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 (find (\c -> ccUUID c == Just clientId) clients)
player <- STM.atomically $ do
players <- STM.readTMVar (scPlayers stateContainer)
pure $ head $ filter (\p -> playerId p == clientId) players
@ -290,7 +284,6 @@ handleMessage stateContainer readerContainer msg = do
{ playerLastPong = (now, uuid)
}
void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers)
_ -> pure ()
sendPings :: Game ()
sendPings = do
@ -303,13 +296,13 @@ sendPings = do
sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer)
mapM_
(\player@(Player plId (Wizard {}) readiness (lastPongTime, _)) -> do
let timeDiff = realToFrac $ diffUTCTime now lastPongTime
let timeDiff = realToFrac $ diffUTCTime now lastPongTime :: Float
when (readiness && timeDiff > (fromIntegral framesPerPing * recip (fromIntegral fps))) $ do
let clientSock = lookup (Just plId) sockets
let clientSock = ccSocket <$> find (\c -> ccUUID c == Just plId) sockets
when (isJust clientSock) $
if timeDiff > realToFrac maxTimeout
then do
liftIO $ dropClient (scClientSockets stateContainer) plId
liftIO $ dropClient (scClientSockets stateContainer) (fromJust clientSock)
put stateContainer
else do
random <- liftIO nextRandom

View file

@ -27,9 +27,6 @@ import Server.Types
runGame :: Game ()
runGame = do
processRequests
clientsVar <- gets scClientSockets
queue <- gets scMessageQueue
recvThread <- liftIO $ forkIO $ forever $ receiveMessages clientsVar queue
whileM_
(not . serverStop <$> (liftIO . STM.atomically . STM.readTMVar =<< gets scServerState))
(do

View file

@ -1,6 +1,8 @@
{-# LANGUAGE DeriveGeneric #-}
module Server.Types where
import Control.Concurrent
import qualified Control.Concurrent.STM as STM
import Control.Monad.RWS.Strict
@ -61,10 +63,17 @@ data StateContainer = StateContainer
, scPlayers :: STM.TMVar [Player]
, scServerState :: STM.TMVar ServerState
, scServerLastTick :: UTCTime
, scClientSockets :: STM.TMVar [(Maybe UUID, Socket)]
, scClientSockets :: STM.TMVar [ClientComms]
, scMessageQueue :: STM.TQueue ClientMessage
}
data ClientComms = ClientComms
{ ccUUID :: Maybe UUID
, ccSocket :: Socket
, ccListener :: ThreadId
}
deriving (Eq)
data Player = Player
{ playerId :: UUID
, playerWizard :: Wizard

View file

@ -14,7 +14,7 @@ extra-doc-files: CHANGELOG.md
-- extra-source-files:
common warnings
ghc-options: -Wall -threaded
ghc-options: -Wall -threaded -prof
library
import: warnings