include some failsafes

configuration.yaml

@@ -2,4 +2,4 @@ setSocketPath         : "/tmp/wizard.sock"
 setMapRows            : 20
 setMapColumns         : 20
 setSpawnerProbability : 0.01
-setFPS                : 5
+setFPS                : 30

src-client/Client/Communication.hs

@@ -54,6 +54,6 @@ receiveMessage sock queue = do
   msg <- B.pack <$> peekArray bufferLength ptr
   let mJsonMsg = A.decode' $ B8.fromStrict msg
   maybe
-    (pure ())
+    (putStrLn $ "received garbled data: " <> B8.unpack (B8.fromStrict msg))
     (STM.atomically . STM.writeTQueue queue)
     mJsonMsg

src-client/Main.hs

@@ -5,6 +5,8 @@ import Control.Concurrent (threadDelay)
 
 import qualified Control.Concurrent.STM as STM
 
+import Control.Monad.Loops (whileM_)
+
 import Options.Applicative
 
 -- internal imports
@@ -22,24 +24,33 @@ main = do
   sock <- connectSocket socketLocation
   queue <- STM.newTQueueIO
   putStrLn "connected"
+
+
   sendMessage (IdRequest) sock
   threadDelay $ 1 * 10 ^ 6
   receiveMessage sock queue
-  threadDelay $ 1 * 10 ^ 6
+  whileM_
+    (STM.atomically $ STM.isEmptyTQueue queue)
+    (threadDelay $ 1 * 10 ^ 6)
   clientIdMsg <- head <$> STM.atomically (STM.flushTQueue queue)
   let clientId = acClientUUID clientIdMsg
   putStrLn $ "received client UUID: " <> show clientId
-  threadDelay $ 1 * 10 ^ 6
+
-  putStrLn welcomeText
+
-  threadDelay $ 15 * 10 ^ 6
   putStrLn welcomeText
+  -- threadDelay $ 15 * 10 ^ 6
+
+
   sendMessage (ClientMessage clientId ClientRequestWizard) sock
   threadDelay $ 1 * 10 ^ 6
   receiveMessage sock queue
-  threadDelay $ 1 * 10 ^ 6
+  whileM_
+    (STM.atomically $ STM.isEmptyTQueue queue)
+    (threadDelay $ 1 * 10 ^ 6)
   playerWizard <- head <$> STM.atomically (STM.flushTQueue queue)
-  putStrLn "received wizard"
+  putStrLn $ "received wizard: " <> show (initWizard playerWizard)
-  print (initWizard playerWizard)
+
+
   let initRead = ReaderContainer sock clientId
       initState = StateContainer (initWizard playerWizard)
   putStrLn "sending quit message"

src-lib/Library/Types/Communication.hs

@@ -10,6 +10,7 @@ import GHC.Generics
 -- internal imports
 
 import Library.Types.Player
+import Library.Types.Map
 
 data ServerMessage
   = ServerQuit

src-server/Server/Communication.hs

@@ -110,6 +110,7 @@ sendMessage
 sendMessage msg sock = do
   let msgJson = A.encode msg
       msgVector = VS.fromList $ B.unpack $ B.toStrict msgJson
+  putStrLn $ "sending: " <> B8.unpack msgJson
   VS.unsafeWith
     msgVector
     (\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
@@ -125,7 +126,10 @@ processMessages = do
   mapM_
     (\(uuid, clientSocket) -> void $ liftIO $ forkIO $ do
       receiveMessage clientSocket queue
-      handleMessage serverState readerContainer
+      msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
+      mapM_
+        (handleMessage serverState readerContainer)
+        msgs
     )
     clients
 
@@ -151,6 +155,7 @@ receiveMessage sock queue = do
     (pure ())
     (\msg -> do
       liftIO $ STM.atomically $ STM.writeTQueue queue msg
+      when (msg == IdRequest) (threadDelay $ 10 ^ 3)
     )
     mmsg
 
@@ -158,48 +163,42 @@ receiveMessage sock queue = do
 handleMessage
   :: StateContainer
   -> ReaderContainer
+  -> ClientMessage
   -> IO ()
-handleMessage stateContainer readerContainer = do
+handleMessage stateContainer readerContainer msg = do
-  let queue         = scMessageQueue stateContainer
+  let clientList = scClientSockets stateContainer
-      clientList = scClientSockets stateContainer
-  msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
   clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
-  mapM_
+  putStrLn $ "Handling following: " <> show msg
-    (\msg -> liftIO $ do
+  case msg of
-        putStrLn "Handling following:"
+    IdRequest                      -> do
-        print msg
+      clientId <- nextRandom
-        case msg of
+      let clientIdx = findIndex (\a -> fst a == Nothing) clients
-          IdRequest                      -> do
+      let clientSock = snd $ clients !! fromJust clientIdx
-            clientId <- nextRandom
+      let newClients = map
-            let clientIdx = findIndex (\a -> fst a == Nothing) clients
+            (\old@(muuid, oldClientSock) ->
-            let clientSock = snd $ clients !! fromJust clientIdx
+              if oldClientSock == clientSock && muuid == Nothing
-            sendMessage (AcceptClient clientId) clientSock
+              then
-            putStrLn $ "Accepted Client with UUID " <> show clientId
+                (Just clientId, clientSock)
-            let newClients = map
+              else
-                  (\old@(muuid, oldClientSock) ->
+                old
-                    if oldClientSock == clientSock && muuid == Nothing
+            )
-                    then
+            clients
-                      (Just clientId, clientSock)
+      void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
-                    else
+      putStrLn $ "Accepted Client with UUID " <> show clientId
-                      old
+      sendMessage (AcceptClient clientId) clientSock
-                  )
+    ClientMessage clientId payload ->
-                  clients
+      case payload of
-            void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
+        ClientQuit -> do
-          ClientMessage clientId payload ->
+          putStrLn $ "removing client " <> show clientId
-            case payload of
+          let newClients = filter (\a -> fst a /= Just clientId) clients
-              ClientQuit -> do
+          void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
-                putStrLn $ "removing client " <> show clientId
+        ClientRequestWizard -> do
-                let newClients = filter (\a -> fst a /= Just clientId) clients
+          putStrLn "initializing new wizard"
-                void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
+          let arena = rcMap readerContainer
-              ClientRequestWizard -> do
+          initPos <- rollInitPosition arena
-                putStrLn "initializing new wizard"
+          let clientSock = fromJust $ lookup (Just clientId) clients
-                let arena = rcMap readerContainer
+          sendMessage (ProvideInitialWizard (newWizard initPos)) clientSock
-                initPos <- rollInitPosition arena
+        _          -> pure ()
-                let clientSock = fromJust $ lookup (Just clientId) clients
-                sendMessage (ProvideInitialWizard (newWizard initPos)) clientSock
-              _          -> pure ()
-    )
-    msgs
 
 newWizard
   :: Position