hunting bugs, found space leak in client

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

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

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 ()
-  -> Game ()
+terminateGameOnSigint = do
-terminateGameOnSigint path = 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)]
+  :: STM.TMVar [ClientComms]
-  -> [(Maybe UUID, Socket)]
+  -> [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)]
+  :: STM.TMVar [ClientComms]
-  -> UUID
+  -> Socket
   -> IO ()
-dropClient clientList uuid = do
+dropClient clientList sock = do
-  msock <- STM.atomically $ do
+  mclient <- STM.atomically $ do
     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
-    pure msock
+    pure mclient
-  putStrLn $ "dropping client " <> show uuid
   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
 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
+    acceptConnection mainSocket socketList queue = do
-      putStrLn "accepting new connections…"
+      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
+  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_
         (handleMessage serverState readerContainer)
         msgs
@@ -180,10 +175,9 @@ handleMessages = do
 receiveMessage
   :: Socket
   -> STM.TQueue ClientMessage
-  -> Maybe UUID
+  -> STM.TMVar [ClientComms]
-  -> STM.TMVar [(Maybe UUID, Socket)]
   -> 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
+        dropClient clientList sock
-          (pure ())
-          (dropClient clientList)
-          muuid
         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 clientIdx = findIndex (isNothing . ccUUID) clients
-      let clientSock = snd $ clients !! fromJust clientIdx
+      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

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

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

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