diff --git a/src-client/Client/Communication.hs b/src-client/Client/Communication.hs index a4962b0..2d90317 100644 --- a/src-client/Client/Communication.hs +++ b/src-client/Client/Communication.hs @@ -29,7 +29,7 @@ connectSocket path = do -- | Sends a specified message through given socket to the server sendMessage - :: ClientMessages + :: ClientMessage -> Socket -> IO () sendMessage msg sock = do diff --git a/src-client/Main.hs b/src-client/Main.hs index d3f568a..163db60 100644 --- a/src-client/Main.hs +++ b/src-client/Main.hs @@ -21,14 +21,8 @@ main = do putStrLn "connected" sendMessage (IdRequest) sock threadDelay $ 5 * 10 ^ 6 - -- message <- receiveMessage sock - -- putStrLn $ "getting first message" <> show message - -- let clientUUID = case message of - -- (AcceptClient aclientUUID ) -> aclientUUID - -- x -> error $ "unexpected message from server: " <> show message - -- let reader = ReaderContainer sock clientUUID - -- putStrLn $ "received uuid " <> show clientUUID - -- threadDelay $ 5 * 10 ^ 6 + clientId <- receiveMessage sock + putStrLn $ "received client UUID: " <> show (acClientUUID clientId) where opts = info (options <**> helper) ( fullDesc diff --git a/src-lib/Library/Types/Communication.hs b/src-lib/Library/Types/Communication.hs index b4e6a3d..8055e65 100644 --- a/src-lib/Library/Types/Communication.hs +++ b/src-lib/Library/Types/Communication.hs @@ -18,11 +18,22 @@ instance FromJSON ServerMessage instance ToJSON ServerMessage -data ClientMessages +data ClientMessagePayload = ClientQuit + deriving (Eq, Show, Generic) + +data ClientMessage + = ClientMessage + { cmClientID :: UUID + , cmPayload :: ClientMessagePayload + } | IdRequest deriving (Eq, Show, Generic) -instance FromJSON ClientMessages +instance FromJSON ClientMessagePayload -instance ToJSON ClientMessages +instance ToJSON ClientMessagePayload + +instance FromJSON ClientMessage + +instance ToJSON ClientMessage diff --git a/src-server/Main.hs b/src-server/Main.hs index fc8a017..c48db85 100644 --- a/src-server/Main.hs +++ b/src-server/Main.hs @@ -50,9 +50,10 @@ main = do putStrLn "starting game…" now <- getCurrentTime sockList <- STM.newTMVarIO [] + messageQueue <- STM.newTQueueIO serverState <- STM.newTMVarIO (ServerState False False) let initRead = ReaderContainer (arenaMap arena) setFPS sock - initState = StateContainer (arenaSpawners arena) [] serverState now sockList + initState = StateContainer (arenaSpawners arena) [] serverState now sockList messageQueue (finalState, finalWrite) <- execRWST (do terminateGameOnSigint diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index f0fc44a..14873b3 100644 --- a/src-server/Server/Communication.hs +++ b/src-server/Server/Communication.hs @@ -16,6 +16,10 @@ import qualified Data.Aeson as A import qualified Data.ByteString as B import qualified Data.ByteString.Lazy.Char8 as B8 +import Data.List + +import Data.Maybe + import Data.UUID.V4 import qualified Data.Vector.Storable as VS @@ -24,8 +28,6 @@ import Foreign hiding (void) import Network.Socket as Net -import System.IO - import System.Posix.Signals -- internal imports @@ -72,8 +74,7 @@ terminateGameOnSigint = do Nothing where disconnectClients = mapM_ - (\(clientSocket, mThread) -> do - maybe (pure ()) killThread mThread + (\(_, clientSocket) -> do close clientSocket ) @@ -87,10 +88,10 @@ processRequests = do acceptConnection mainSocket socketList = do putStrLn "accepting new connections…" (clientSock, _) <- accept mainSocket - putStrLn "accepted new connection" liftIO $ STM.atomically $ do list <- STM.takeTMVar socketList - STM.putTMVar socketList ((clientSock, Nothing) : list) + STM.putTMVar socketList ((Nothing, clientSock) : list) + putStrLn "accepted new connection" acceptConnection mainSocket socketList -- | Sends a specified message through given socket to the client @@ -111,25 +112,66 @@ processMessages = do clientsVar <- gets scClientSockets clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar mapM_ - (\(clientSocket, _) -> liftIO $ + (\(uuid, clientSocket) -> do receiveMessage clientSocket + handleMessage ) clients -- | receive a 'ClientMessage' receiveMessage :: Socket - -> IO () + -> Game () receiveMessage sock = do let maxBufferLength = 4096 - ptr <- mallocArray maxBufferLength - bufferLength <- recvBuf sock ptr maxBufferLength - when (bufferLength > 0) $ do + mmsg <- liftIO $ do + ptr <- mallocArray maxBufferLength + bufferLength <- recvBuf sock ptr maxBufferLength msg <- B.pack <$> peekArray bufferLength ptr - let mJsonMsg = A.decode' $ B8.fromStrict msg :: Maybe ClientMessages - jsonMsg <- maybe - (error $ "unexpected message from Server: " <> show msg) - pure - mJsonMsg + let mJsonMsg = A.decode' $ B8.fromStrict msg :: Maybe ClientMessage free ptr - print jsonMsg + if bufferLength > 0 + then + pure mJsonMsg + else + pure Nothing + 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 + 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 + clientId <- nextRandom + let clientIdx = findIndex (\a -> fst a == Nothing) clients + let clientSock = snd $ clients !! fromJust clientIdx + sendMessage (AcceptClient clientId) clientSock + putStrLn $ "Accepted Client with UUID " <> show clientId + let newClients = map + (\old@(muuid, oldClientSock) -> + if oldClientSock == clientSock && muuid == Nothing + then + (Just clientId, clientSock) + else + old + ) + clients + void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients + _ -> pure () + ) + msgs diff --git a/src-server/Server/Game.hs b/src-server/Server/Game.hs index 0362b28..e2eefc6 100644 --- a/src-server/Server/Game.hs +++ b/src-server/Server/Game.hs @@ -50,7 +50,7 @@ runGame = do updateSpawners :: Float -> Game () updateSpawners dt = - modify' (\sc@(StateContainer spawners _ _ _ _) -> + modify' (\sc@(StateContainer spawners _ _ _ _ _) -> let newSpawners = map (\spawner -> do let newTTL = spawnerReloadTTL spawner - dt @@ -71,7 +71,7 @@ updateSpawners dt = updateWizards :: Float -> Game () updateWizards dt = - modify' (\sc@(StateContainer _ wizards _ _ _) -> + modify' (\sc@(StateContainer _ wizards _ _ _ _) -> let newWizards = map (\wizard@(Wizard _ _ health _ _ effects) -> let newEffects = foldl diff --git a/src-server/Server/Types.hs b/src-server/Server/Types.hs index fef0cf6..ff964eb 100644 --- a/src-server/Server/Types.hs +++ b/src-server/Server/Types.hs @@ -1,8 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} module Server.Types where -import Control.Concurrent (ThreadId) - import qualified Control.Concurrent.STM as STM import Control.Monad.RWS.Strict @@ -11,14 +9,14 @@ import qualified Data.Aeson as Aeson import Data.Time.Clock +import Data.UUID + import GHC.Generics import Network.Socket import Options.Applicative as O -import System.IO - --internal imports import Library.Types @@ -59,7 +57,8 @@ data StateContainer = StateContainer , scPlayers :: [ Wizard ] , scServerState :: STM.TMVar ServerState , scServerLastTick :: UTCTime - , scClientSockets :: STM.TMVar [ (Socket, Maybe ThreadId) ] + , scClientSockets :: STM.TMVar [ (Maybe UUID, Socket) ] + , scMessageQueue :: STM.TQueue ClientMessage } -- | Data object for storing the server's state