figure out timing problems

configuration.yaml

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

src-client/Client/Communication.hs

@@ -11,6 +11,8 @@ import qualified Data.Aeson as A
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy.Char8 as B8
 
+import Data.UUID
+
 import qualified Data.Vector.Storable as VS
 
 import Foreign hiding (void)
@@ -50,7 +52,6 @@ sendMessage msg sock = do
 handleMessages
   :: Game ()
 handleMessages = do
-  sock <- asks rcSocket
   queue <- asks rcQueue
   msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
   mapM_
@@ -61,21 +62,21 @@ handleMessage
   :: ServerMessage
   -> Game ()
 handleMessage ServerQuit = do
-  state <- get
-  let stateCont = scClientState state
+  st <- get
+  let stateCont = scClientState st
   liftIO $ STM.atomically $ do
-    state <- STM.readTMVar stateCont
-    void $ STM.swapTMVar stateCont $ state
+    stateContainer <- STM.readTMVar stateCont
+    void $ STM.swapTMVar stateCont $ stateContainer
       { clientStop = True
       }
-  put $ state
+  put $ st
     { scClientState = stateCont
     }
   liftIO $ putStrLn "Quitting due to server shutdown"
 
 handleMessage (TickUpdate slice wizard) = do
-  modify' (\state@(StateContainer {..}) ->
-    state
+  modify' (\st@(StateContainer {}) ->
+    st
       { scWizard   = wizard
       , scMapSlice = slice
       }
@@ -103,8 +104,8 @@ receiveMessage sock queue = do
 terminateGameOnSigint
   :: Game ()
 terminateGameOnSigint = do
-  sock <- asks rcSocket
-  clientId <- asks rcClientUUID
+  -- sock <- asks rcSocket
+  -- clientId <- asks rcClientUUID
   clientState <- gets scClientState
   void $ liftIO $ installHandler
     keyboardSignal
@@ -114,9 +115,16 @@ terminateGameOnSigint = do
         void $ STM.swapTMVar clientState $ currentState { clientStop = True }
         pure currentState
       Vty.shutdown (clientVty currentState)
-      sendMessage (ClientMessage clientId ClientQuit) sock
-      close sock
+      -- partingMessage clientId sock
       -- Raise SIGINT again so it does not get blocked
       -- raiseSignal keyboardSignal
     )
     Nothing
+
+partingMessage
+  :: UUID
+  -> Socket
+  -> IO ()
+partingMessage clientId sock = do
+  sendMessage (ClientMessage clientId ClientQuit) sock
+  -- close sock

src-client/Client/Game.hs

@@ -1,7 +1,11 @@
 module Client.Game where
 
+import Control.Concurrent
+
 import qualified Control.Concurrent.STM as STM
 
+import Control.Monad
+
 import Control.Monad.Loops
 
 import Control.Monad.RWS
@@ -15,9 +19,12 @@ import Library.Types
 
 runGame :: Game ()
 runGame = do
-  handleMessages
+  sock <- asks rcSocket
+  queue <- asks rcQueue
+  recvThread <- liftIO $ forkIO $ forever $ receiveMessage sock queue
   whileM_
     (not . clientStop <$> (liftIO . STM.atomically . STM.readTMVar =<< gets scClientState))
     (do
-      pure ()
+      handleMessages
     )
+  liftIO $ killThread recvThread

src-client/Main.hs

@@ -7,16 +7,14 @@ import qualified Control.Concurrent.STM as STM
 
 import Control.Monad
 
-import Control.Monad.IO.Class
-
-import Control.Monad.Loops
-
 import Control.Monad.RWS
 
 import qualified Data.Matrix as M
 
 import Graphics.Vty
 
+import Network.Socket (close)
+
 import Options.Applicative
 
 -- internal imports
@@ -78,6 +76,9 @@ main = do
     )
     initRead
     initState
+  partingMessage clientId sock
+  threadDelay $ 1 * 10 ^ 6
+  close sock
   where
     opts = info (options <**> helper)
       ( fullDesc

src-server/Server/Communication.hs

@@ -23,6 +23,7 @@ import qualified Data.Matrix as M
 
 import Data.Maybe
 
+import Data.UUID
 import Data.UUID.V4
 
 import qualified Data.Vector.Storable as VS
@@ -114,12 +115,13 @@ sendMessage msg sock = do
     (\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
 
 -- | receive incoming messages from clients
-receiveMessages :: Game ()
-receiveMessages = do
-  clientsVar <- gets scClientSockets
+receiveMessages
+  :: STM.TMVar [(Maybe UUID, Socket)]
+  -> STM.TQueue ClientMessage
+  -> IO ()
+receiveMessages clientsVar queue = do
   clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar
-  queue <- gets scMessageQueue
-  void $ liftIO $ forkIO $ mapM_
+  mapM_
     (\(_, clientSocket) -> do
       receiveMessage clientSocket queue
     )
@@ -159,7 +161,7 @@ receiveMessage sock queue = do
     (pure ())
     (\msg -> do
       liftIO $ STM.atomically $ STM.writeTQueue queue msg
-      when (msg == IdRequest) (threadDelay $ 10 ^ 3)
+      -- when (msg == IdRequest) (threadDelay $ 10 ^ 3)
     )
     mmsg
 

src-server/Server/Game.hs

@@ -9,6 +9,8 @@ import Control.Monad.RWS.Strict
 
 import Control.Monad.Loops
 
+import Control.Concurrent
+
 import qualified Data.ByteString.Char8 as B8
 
 import Data.Time
@@ -27,6 +29,9 @@ import Server.Types
 runGame :: Game ()
 runGame = do
   processRequests
+  clientsVar <- gets scClientSockets
+  queue <- gets scMessageQueue
+  recvThread <- liftIO $ forkIO $ forever $ receiveMessages clientsVar queue
   whileM_
     (not . serverStop <$> (liftIO . STM.atomically . STM.readTMVar =<< gets scServerState))
     (do
@@ -34,7 +39,6 @@ runGame = do
       now <- liftIO getCurrentTime
       let delta = realToFrac $ diffUTCTime now before
       liftIO $ B8.hPutStr stdout $ "tick: " <> fromString (show delta) <> "  \r"
-      receiveMessages
       handleMessages
       updateSpawners delta
       updateWizards delta
@@ -44,11 +48,12 @@ runGame = do
           }
         )
       fps <- asks rcFPS
-      sendUpdates
+      -- sendUpdates
       let remainingTime = recip (fromIntegral fps) - delta
       when (remainingTime > 0) $
         liftIO $ threadDelay $ floor $ remainingTime * 10 ^ 6
     )
+  liftIO $ killThread recvThread
 
 updateSpawners :: Float -> Game ()
 updateSpawners dt =