improved communication

This commit is contained in:
nek0 2023-12-11 09:49:24 +01:00
parent 46f41519fc
commit d245129461
7 changed files with 84 additions and 37 deletions

View file

@ -29,7 +29,7 @@ connectSocket path = do
-- | Sends a specified message through given socket to the server -- | Sends a specified message through given socket to the server
sendMessage sendMessage
:: ClientMessages :: ClientMessage
-> Socket -> Socket
-> IO () -> IO ()
sendMessage msg sock = do sendMessage msg sock = do

View file

@ -21,14 +21,8 @@ main = do
putStrLn "connected" putStrLn "connected"
sendMessage (IdRequest) sock sendMessage (IdRequest) sock
threadDelay $ 5 * 10 ^ 6 threadDelay $ 5 * 10 ^ 6
-- message <- receiveMessage sock clientId <- receiveMessage sock
-- putStrLn $ "getting first message" <> show message putStrLn $ "received client UUID: " <> show (acClientUUID clientId)
-- 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
where where
opts = info (options <**> helper) opts = info (options <**> helper)
( fullDesc ( fullDesc

View file

@ -18,11 +18,22 @@ instance FromJSON ServerMessage
instance ToJSON ServerMessage instance ToJSON ServerMessage
data ClientMessages data ClientMessagePayload
= ClientQuit = ClientQuit
deriving (Eq, Show, Generic)
data ClientMessage
= ClientMessage
{ cmClientID :: UUID
, cmPayload :: ClientMessagePayload
}
| IdRequest | IdRequest
deriving (Eq, Show, Generic) deriving (Eq, Show, Generic)
instance FromJSON ClientMessages instance FromJSON ClientMessagePayload
instance ToJSON ClientMessages instance ToJSON ClientMessagePayload
instance FromJSON ClientMessage
instance ToJSON ClientMessage

View file

@ -50,9 +50,10 @@ main = do
putStrLn "starting game…" putStrLn "starting game…"
now <- getCurrentTime now <- getCurrentTime
sockList <- STM.newTMVarIO [] sockList <- STM.newTMVarIO []
messageQueue <- STM.newTQueueIO
serverState <- STM.newTMVarIO (ServerState False False) serverState <- STM.newTMVarIO (ServerState False False)
let initRead = ReaderContainer (arenaMap arena) setFPS sock 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 (finalState, finalWrite) <- execRWST
(do (do
terminateGameOnSigint terminateGameOnSigint

View file

@ -16,6 +16,10 @@ import qualified Data.Aeson as A
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as B8
import Data.List
import Data.Maybe
import Data.UUID.V4 import Data.UUID.V4
import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable as VS
@ -24,8 +28,6 @@ import Foreign hiding (void)
import Network.Socket as Net import Network.Socket as Net
import System.IO
import System.Posix.Signals import System.Posix.Signals
-- internal imports -- internal imports
@ -72,8 +74,7 @@ terminateGameOnSigint = do
Nothing Nothing
where where
disconnectClients = mapM_ disconnectClients = mapM_
(\(clientSocket, mThread) -> do (\(_, clientSocket) -> do
maybe (pure ()) killThread mThread
close clientSocket close clientSocket
) )
@ -87,10 +88,10 @@ processRequests = do
acceptConnection mainSocket socketList = do acceptConnection mainSocket socketList = do
putStrLn "accepting new connections…" putStrLn "accepting new connections…"
(clientSock, _) <- accept mainSocket (clientSock, _) <- accept mainSocket
putStrLn "accepted new connection"
liftIO $ STM.atomically $ do liftIO $ STM.atomically $ do
list <- STM.takeTMVar socketList list <- STM.takeTMVar socketList
STM.putTMVar socketList ((clientSock, Nothing) : list) STM.putTMVar socketList ((Nothing, clientSock) : list)
putStrLn "accepted new connection"
acceptConnection mainSocket socketList acceptConnection mainSocket socketList
-- | Sends a specified message through given socket to the client -- | Sends a specified message through given socket to the client
@ -111,25 +112,66 @@ processMessages = do
clientsVar <- gets scClientSockets clientsVar <- gets scClientSockets
clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar
mapM_ mapM_
(\(clientSocket, _) -> liftIO $ (\(uuid, clientSocket) -> do
receiveMessage clientSocket receiveMessage clientSocket
handleMessage
) )
clients clients
-- | receive a 'ClientMessage' -- | receive a 'ClientMessage'
receiveMessage receiveMessage
:: Socket :: Socket
-> IO () -> Game ()
receiveMessage sock = do receiveMessage sock = do
let maxBufferLength = 4096 let maxBufferLength = 4096
ptr <- mallocArray maxBufferLength mmsg <- liftIO $ do
bufferLength <- recvBuf sock ptr maxBufferLength ptr <- mallocArray maxBufferLength
when (bufferLength > 0) $ do bufferLength <- recvBuf sock ptr maxBufferLength
msg <- B.pack <$> peekArray bufferLength ptr msg <- B.pack <$> peekArray bufferLength ptr
let mJsonMsg = A.decode' $ B8.fromStrict msg :: Maybe ClientMessages let mJsonMsg = A.decode' $ B8.fromStrict msg :: Maybe ClientMessage
jsonMsg <- maybe
(error $ "unexpected message from Server: " <> show msg)
pure
mJsonMsg
free ptr 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

View file

@ -50,7 +50,7 @@ runGame = do
updateSpawners :: Float -> Game () updateSpawners :: Float -> Game ()
updateSpawners dt = updateSpawners dt =
modify' (\sc@(StateContainer spawners _ _ _ _) -> modify' (\sc@(StateContainer spawners _ _ _ _ _) ->
let newSpawners = map let newSpawners = map
(\spawner -> do (\spawner -> do
let newTTL = spawnerReloadTTL spawner - dt let newTTL = spawnerReloadTTL spawner - dt
@ -71,7 +71,7 @@ updateSpawners dt =
updateWizards :: Float -> Game () updateWizards :: Float -> Game ()
updateWizards dt = updateWizards dt =
modify' (\sc@(StateContainer _ wizards _ _ _) -> modify' (\sc@(StateContainer _ wizards _ _ _ _) ->
let newWizards = map let newWizards = map
(\wizard@(Wizard _ _ health _ _ effects) -> (\wizard@(Wizard _ _ health _ _ effects) ->
let newEffects = foldl let newEffects = foldl

View file

@ -1,8 +1,6 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
module Server.Types where module Server.Types where
import Control.Concurrent (ThreadId)
import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM as STM
import Control.Monad.RWS.Strict import Control.Monad.RWS.Strict
@ -11,14 +9,14 @@ import qualified Data.Aeson as Aeson
import Data.Time.Clock import Data.Time.Clock
import Data.UUID
import GHC.Generics import GHC.Generics
import Network.Socket import Network.Socket
import Options.Applicative as O import Options.Applicative as O
import System.IO
--internal imports --internal imports
import Library.Types import Library.Types
@ -59,7 +57,8 @@ data StateContainer = StateContainer
, scPlayers :: [ Wizard ] , scPlayers :: [ Wizard ]
, scServerState :: STM.TMVar ServerState , scServerState :: STM.TMVar ServerState
, scServerLastTick :: UTCTime , 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 -- | Data object for storing the server's state