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 msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
mapM_ mapM_
(\msg -> do (\msg -> do
liftIO $ putStrLn $ "handling following: " <> show msg -- liftIO $ putStrLn $ "Handling following: " <> show msg
handleMessage msg handleMessage msg
) )
msgs msgs

View file

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

View file

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

View file

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

View file

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

View file

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