fixing queu identification

configuration.yaml

@@ -2,6 +2,6 @@ setSocketPath         : "/tmp/wizard.sock"
 setMapRows            : 40
 setMapColumns         : 40
 setSpawnerProbability : 0.01
-setFPS                : 1
+setFPS                : 30
 setClientMaxTimeout   : 5
 setFramesPerPing      : 120

src-client/Client/Communication.hs

@@ -47,11 +47,13 @@ sendMessage
   -> Socket
   -> IO ()
 sendMessage msg sock = do
-  print msg
+  putStrLn $ "sending message: " <> show msg
   let msgJson = A.encode msg
       msgList = B.unpack $ B.toStrict msgJson
+  putStrLn $ "sending raw message buffer: " <> show msgList
   ptr <- newArray msgList
   void $ sendBuf sock ptr (length msgList)
+  putStrLn "raw message buffer sent"
   free ptr
 
 handleMessages
@@ -109,16 +111,19 @@ receiveMessage sock queue st = do
   let maxBufferLength = 4096
   ptr <- mallocArray maxBufferLength
   ebufferLength <- try $ recvBuf sock ptr maxBufferLength
+  -- putStrLn $ "received buffer of length: " <> show ebufferLength
   bufferLength <- case ebufferLength of
     Left (_ :: IOException) ->  do
       gracefulExit st "Quitting due to connection loss"
       pure 0
     Right len -> pure len
   rawMsg <- B.pack <$> peekArray bufferLength ptr
+  -- putStrLn $ "received raw message: " <> show rawMsg
   let msgs =
         if B.length rawMsg < 1
         then []
         else map B8.tail $ init $ B8.split '>' $ B8.fromStrict rawMsg
+  -- putStrLn $ "resulting split messages: " <> show msgs
   mapM_
     (\msg -> do
       let mJsonMsg = A.decode' msg

src-client/Client/Game.hs

@@ -28,15 +28,22 @@ runGame = do
   st <- get
   vty <- clientVty <$> liftIO (atomically $ readTMVar (scClientState st))
   liftIO $ sendMessage (ClientMessage clientId ClientReady) sock
+  liftIO $ putStrLn "entering game loop"
   whileM_
     (liftIO (not <$> readIORef (scStopper st)))
     (do
       liftIO $ receiveMessage sock messageQueue st
+      -- liftIO $ putStrLn "received messages"
       handleMessages
+      -- liftIO $ putStrLn "handled messages"
       pumpEvents vty
+      -- liftIO $ putStrLn "pumped events"
       handleEvents
+      -- liftIO $ putStrLn "handled events"
       draw
+      -- liftIO $ putStrLn "drew"
     )
   liftIO $ do
+    liftIO $ putStrLn "left game loop"
     partingMessage clientId sock
     threadDelay (10 ^ 6)

src-client/Main.hs

@@ -73,9 +73,11 @@ main = do
       initState = StateContainer (initWizard playerWizard) clientState initSlice stopper
   -- putStrLn "sending quit message"
   -- sendMessage (ClientMessage clientId ClientQuit) sock
+  putStrLn "entering Game Monad"
   void $ execRWST
     (do
       terminateGameOnSigint stopper
+      liftIO $ putStrLn "entering main game function"
       runGame
     )
     initRead

src-server/Server/Communication/Handler.hs

@@ -28,35 +28,40 @@ handleMessage
   -> ClientMessage
   -> IO ()
 handleMessage stateContainer readerContainer msg = do
-  let clientList = scClientSockets stateContainer
+  let socketList = scClientSockets stateContainer
-  queueList <- STM.atomically $ STM.readTMVar $ scClientQueues stateContainer
+      queueList = scClientQueues stateContainer
-  clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
+  socks <- liftIO $ STM.atomically $ STM.readTMVar socketList
+  queues <- liftIO $ STM.atomically $ STM.readTMVar queueList
   -- putStrLn $ "Handling: " <> show msg
   case msg of
     IdRequest                      -> do
       clientId <- nextRandom
-      let clientIdx = findIndex (isNothing . csUUID) clients
+      let clientIdx = findIndex (isNothing . csUUID) socks
-          clientSock = csSocket $ clients !! fromJust clientIdx
+          sock = socks !! fromJust clientIdx
-          newClients = map
+          queue = queues !! fromJust clientIdx
-            (\old@(ClientSocket mUUID oldClientSock _ _) ->
+      if csUUID sock == cqUUID queue
-              if oldClientSock == clientSock && isNothing mUUID
+      then do
-              then
+        let otherSocks = delete sock socks
-                old
+            newSocks = sock
               { csUUID = Just clientId
-                  }
+              } : otherSocks
+            otherQueues = delete queue queues
+            newQueues = queue
+              { cqUUID = Just clientId
+              } : otherQueues
+        liftIO $ STM.atomically $ do
+          void $ STM.swapTMVar socketList newSocks
+          void $ STM.swapTMVar queueList newQueues
+        putStrLn $ "Accepted Client with UUID: " <> show clientId
+        queueMessage (AcceptClient clientId) clientId newQueues
       else
-                old
+        putStrLn $ "Unable to assign ID to Socket and queue: " <> show clientId
-            )
-            clients
-      void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
-      putStrLn $ "Accepted Client with UUID " <> show clientId
-      queueMessage (AcceptClient clientId) clientId queueList
     ClientMessage clientId payload ->
       case payload of
         ClientQuit -> do
           putStrLn $ "client has quit the game: " <> show clientId
-          let client = find (\a -> csUUID a == Just clientId) clients
+          let client = find (\a -> csUUID a == Just clientId) socks
-          dropClient clientList (csSocket $ fromJust client)
+          dropClient socketList (csSocket $ fromJust client)
         ClientRequestWizard -> do
           putStrLn "initializing new wizard"
           let arena = rcMap readerContainer
@@ -68,7 +73,7 @@ handleMessage stateContainer readerContainer msg = do
             currentPlayers <- STM.readTMVar (scPlayers stateContainer)
             void $ STM.swapTMVar (scPlayers stateContainer) $
               Player clientId freshWizard False (now, uuid) : currentPlayers
-          queueMessage (ProvideInitialWizard freshWizard) clientId queueList
+          queueMessage (ProvideInitialWizard freshWizard) clientId queues
         ClientReady -> do
           now <- getCurrentTime
           STM.atomically $ do
@@ -84,7 +89,7 @@ handleMessage stateContainer readerContainer msg = do
                   : otherPlayers
           putStrLn $ "client ready: " <> show clientId
         Pong pongUuid -> do
-          let mclient = find (\c -> csUUID c == Just clientId) clients
+          let mclient = find (\c -> csUUID c == Just clientId) socks
           players <- STM.atomically $ STM.readTMVar (scPlayers stateContainer)
           maybe
             (putStrLn $ "Unknown client: " <> show clientId)

src-server/Server/Communication/Receive.hs

@@ -35,21 +35,23 @@ receiveMessage
 receiveMessage sockContainer queue = do
   randSleep <- randomRIO (1, 1000)
   threadDelay randSleep
-  sock <- STM.atomically $ STM.readTMVar sockContainer
+  sock <- STM.atomically $ STM.takeTMVar sockContainer
   let maxBufferLength = 4096
-  putStrLn "read socket container for receiving"
+  putStrLn "took socket container for receiving"
   mMsg <- do
     ptr <- mallocArray maxBufferLength
     putStrLn "receiving data"
     eBufferLength <-
       try $ recvBuf sock ptr maxBufferLength
+    putStrLn $ "received raw buffer length of: " <> show eBufferLength
+    free ptr
     bufferLength <- case eBufferLength of
       Left (e :: IOException) -> do
         -- putStrLn ("Socket vanished, cleaning up after " <> show e)
         -- dropClient clientList sock
         pure 0
       Right len -> pure len
-    free ptr
+    putStrLn $ "received buffer of length: " <> show bufferLength
     msg <- B.pack <$> peekArray bufferLength ptr
     putStrLn $ "received data: " <> show msg
     if bufferLength > 0 && msg /= ""

src-server/Server/Communication/Send.hs

@@ -65,6 +65,8 @@ sendMessageQueue
   -> STM.TQueue ServerMessage
   -> IO ()
 sendMessageQueue sockContainer queue = do
+  randTime <- randomRIO (1, 1000)
+  threadDelay randTime
   msgs <- STM.atomically $ STM.flushTQueue queue
   mapM_
     (\msg -> do