diff --git a/configuration.yaml b/configuration.yaml index 73f2c48..385d470 100644 --- a/configuration.yaml +++ b/configuration.yaml @@ -2,4 +2,4 @@ setSocketPath : "/tmp/wizard.sock" setMapRows : 20 setMapColumns : 20 setSpawnerProbability : 0.01 -setFPS : 1 +setFPS : 5 diff --git a/src-client/Main.hs b/src-client/Main.hs index 163db60..7dc4229 100644 --- a/src-client/Main.hs +++ b/src-client/Main.hs @@ -23,6 +23,9 @@ main = do threadDelay $ 5 * 10 ^ 6 clientId <- receiveMessage sock putStrLn $ "received client UUID: " <> show (acClientUUID clientId) + threadDelay $ 5 * 10 ^ 6 + putStrLn "sending quit message" + sendMessage (ClientMessage (acClientUUID clientId) ClientQuit) sock where opts = info (options <**> helper) ( fullDesc diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index 14873b3..1a6508a 100644 --- a/src-server/Server/Communication.hs +++ b/src-server/Server/Communication.hs @@ -20,6 +20,7 @@ import Data.List import Data.Maybe +import Data.UUID import Data.UUID.V4 import qualified Data.Vector.Storable as VS @@ -75,6 +76,7 @@ terminateGameOnSigint = do where disconnectClients = mapM_ (\(_, clientSocket) -> do + sendMessage ServerQuit clientSocket close clientSocket ) @@ -111,20 +113,22 @@ processMessages :: Game () processMessages = do clientsVar <- gets scClientSockets clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar + queue <- gets scMessageQueue mapM_ - (\(uuid, clientSocket) -> do - receiveMessage clientSocket - handleMessage + (\(uuid, clientSocket) -> void $ liftIO $ forkIO $ do + receiveMessage clientSocket queue + handleMessage queue clientsVar ) clients -- | receive a 'ClientMessage' receiveMessage :: Socket - -> Game () -receiveMessage sock = do + -> STM.TQueue ClientMessage + -> IO () +receiveMessage sock queue = do let maxBufferLength = 4096 - mmsg <- liftIO $ do + mmsg <- do ptr <- mallocArray maxBufferLength bufferLength <- recvBuf sock ptr maxBufferLength msg <- B.pack <$> peekArray bufferLength ptr @@ -138,25 +142,24 @@ receiveMessage sock = do maybe (pure ()) (\msg -> do - queue <- gets scMessageQueue liftIO $ STM.atomically $ STM.writeTQueue queue msg ) mmsg -- | function for translating 'ClientMessage's into server actions handleMessage - :: Game () -handleMessage = do - queue <- gets scMessageQueue + :: STM.TQueue ClientMessage + -> STM.TMVar [(Maybe UUID, Socket)] + -> IO () +handleMessage queue clientList = do msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue - clientList <- gets scClientSockets clients <- liftIO $ STM.atomically $ STM.readTMVar clientList mapM_ (\msg -> liftIO $ do putStrLn "Handling following:" print msg case msg of - IdRequest -> do + IdRequest -> do clientId <- nextRandom let clientIdx = findIndex (\a -> fst a == Nothing) clients let clientSock = snd $ clients !! fromJust clientIdx @@ -172,6 +175,12 @@ handleMessage = do ) clients void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients - _ -> pure () + ClientMessage clientId payload -> + case payload of + ClientQuit -> do + putStrLn $ "removing client " <> show clientId + let newClients = filter (\a -> fst a /= Just clientId) clients + void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients + _ -> pure () ) msgs