improved communication

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

src-client/Main.hs

@@ -21,14 +21,8 @@ main = do
   putStrLn "connected"
   sendMessage (IdRequest) sock
   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
     opts = info (options <**> helper)
       ( fullDesc

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

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

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
+      (\(_, clientSocket) -> do
-        maybe (pure ()) killThread mThread
         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
+  mmsg <- liftIO $ do
     ptr <- mallocArray maxBufferLength
     bufferLength <- recvBuf sock ptr maxBufferLength
-  when (bufferLength > 0) $ do
     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
-    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

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

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