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
sendMessage
:: ClientMessages
:: ClientMessage
-> Socket
-> IO ()
sendMessage msg sock = do

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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