From 82598aaafb1b3dc762a19e6d2a8f74dd7eba4e00 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 6 Apr 2024 02:18:08 +0200 Subject: [PATCH] hunting bugs, found space leak in client --- src-client/Client/Communication.hs | 2 +- src-server/Main.hs | 2 +- src-server/Server/Communication.hs | 125 ++++++++++++++--------------- src-server/Server/Game.hs | 3 - src-server/Server/Types.hs | 11 ++- wizard-wipeout.cabal | 2 +- 6 files changed, 72 insertions(+), 73 deletions(-) diff --git a/src-client/Client/Communication.hs b/src-client/Client/Communication.hs index 1df0c28..5364a14 100644 --- a/src-client/Client/Communication.hs +++ b/src-client/Client/Communication.hs @@ -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 diff --git a/src-server/Main.hs b/src-server/Main.hs index 70074f3..88e08b8 100644 --- a/src-server/Main.hs +++ b/src-server/Main.hs @@ -65,7 +65,7 @@ main = do initState = StateContainer (arenaSpawners arena) emptyPLayers serverState now sockList messageQueue (finalState, finalWrite) <- execRWST (do - terminateGameOnSigint setSocketPath + terminateGameOnSigint runGame ) initRead diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index 857bb01..99c44ac 100644 --- a/src-server/Server/Communication.hs +++ b/src-server/Server/Communication.hs @@ -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 diff --git a/src-server/Server/Game.hs b/src-server/Server/Game.hs index 868b009..fb06636 100644 --- a/src-server/Server/Game.hs +++ b/src-server/Server/Game.hs @@ -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 diff --git a/src-server/Server/Types.hs b/src-server/Server/Types.hs index 1f930c4..6cd9dee 100644 --- a/src-server/Server/Types.hs +++ b/src-server/Server/Types.hs @@ -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 diff --git a/wizard-wipeout.cabal b/wizard-wipeout.cabal index 7b7f270..b832c0e 100644 --- a/wizard-wipeout.cabal +++ b/wizard-wipeout.cabal @@ -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