trying to decouple sending and receiving in server

configuration.yaml

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

src-client/Client/Communication.hs

@@ -30,6 +30,7 @@ import System.Posix.Signals
 
 import Library.Types
 import Client.Types
+import GHC.Conc (threadDelay)
 
 connectSocket
   :: FilePath
@@ -46,6 +47,7 @@ sendMessage
   -> Socket
   -> IO ()
 sendMessage msg sock = do
+  print msg
   let msgJson = A.encode msg
       msgList = B.unpack $ B.toStrict msgJson
   ptr <- newArray msgList
@@ -153,5 +155,6 @@ partingMessage
   -> Socket
   -> IO ()
 partingMessage clientId sock = do
-  putStrLn "sending parting message to server…"
   sendMessage (ClientMessage clientId ClientQuit) sock
+  putStrLn "sent parting message to server"
+  threadDelay (10 ^ 6)

src-client/Client/Game.hs

@@ -1,5 +1,7 @@
 module Client.Game where
 
+import Control.Concurrent (threadDelay)
+
 import Control.Concurrent.STM (atomically, readTMVar)
 
 import Control.Monad.Loops
@@ -35,4 +37,6 @@ runGame = do
       handleEvents
       draw
     )
-  liftIO $ sendMessage (ClientMessage clientId ClientQuit) sock
+  liftIO $ do
+    partingMessage clientId sock
+    threadDelay (10 ^ 6)

src-client/Main.hs

@@ -15,6 +15,8 @@ import qualified Data.Matrix as M
 import Graphics.Vty
 import Graphics.Vty.CrossPlatform
 
+import Network.Socket (close)
+
 import Options.Applicative
 
 -- internal imports
@@ -80,11 +82,12 @@ main = do
     )
     initRead
     initState
+  putStrLn "Shutting down client…"
   showCursor (outputIface vty)
   shutdown vty
-  putStrLn "Shutting down client…"
+  threadDelay (10 ^ 6)
-  -- threadDelay 100
+  putStrLn "Closing connection to server…"
-  -- close sock
+  close sock
   putStrLn "bye bye"
   where
     opts = info (options <**> helper)

src-server/Server/Communication.hs

@@ -78,6 +78,7 @@ disconnectClients clientList clients = do
       maybe
         (pure ())
         (\uuid -> do
+          putStrLn $ "notifying client: " <> show uuid
           queueMessage ServerQuit uuid clientList
           dropClient clientList (ccSocket client)
         )
@@ -103,11 +104,11 @@ processRequests = do
           putStrLn "Main socket vanished!"
         Right (clientSock, _) -> do
           messageQueue <- STM.newTQueueIO
-          sockCOntainer <- STM.newTMVarIO clientSock
+          sockContainer <- STM.newTMVarIO clientSock
           clientWriteThreadId <- liftIO $ forkIO $ forever $ do
-            receiveMessage sockCOntainer queue socketList
+            receiveMessage sockContainer queue socketList
           clientListenThreadId <- liftIO $ forkIO $ forever $ do
-            sendMessageQueue sockCOntainer messageQueue
+            sendMessageQueue sockContainer messageQueue
           print clientSock
           liftIO $ STM.atomically $ do
             list <- STM.takeTMVar socketList
@@ -122,6 +123,7 @@ processRequests = do
                 : list
               )
           putStrLn "accepted new connection"
-          abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st)
+          -- abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st)
-          unless abortCondition $
+          -- unless abortCondition $
+          --   acceptConnection mainSocket socketList queue st
           acceptConnection mainSocket socketList queue st

src-server/Server/Communication/Handler.hs

@@ -53,7 +53,7 @@ handleMessage stateContainer readerContainer msg = do
     ClientMessage clientId payload ->
       case payload of
         ClientQuit -> do
-          putStrLn $ "client " <> show clientId <> " has quit the game"
+          putStrLn $ "client has quit the game: " <> show clientId
           let client = find (\a -> ccUUID a == Just clientId) clients
           dropClient clientList (ccSocket $ fromJust client)
         ClientRequestWizard -> do

src-server/Server/Communication/Receive.hs

@@ -1,5 +1,7 @@
 module Server.Communication.Receive where
 
+import Control.Concurrent (threadDelay)
+
 import qualified Control.Concurrent.STM as STM
 
 import Control.Exception
@@ -15,6 +17,8 @@ import Foreign.Marshal hiding (void)
 
 import Network.Socket
 
+import System.Random
+
 -- internal imports
 
 import Library.Types
@@ -29,8 +33,14 @@ receiveMessage
   -> STM.TMVar [ClientComms]
   -> IO ()
 receiveMessage sockContainer queue clientList = do
-  sock <- STM.atomically $ STM.readTMVar sockContainer
+  randSleep <- randomRIO (1, 1000)
+  threadDelay randSleep
+  msock <- STM.atomically $ STM.tryTakeTMVar sockContainer
   let maxBufferLength = 4096
+  maybe
+    (pure ())
+    (\sock -> do
+      putStrLn "took socket container for receiving"
       mMsg <- do
         ptr <- mallocArray maxBufferLength
         eBufferLength <-
@@ -38,7 +48,7 @@ receiveMessage sockContainer queue clientList = do
         bufferLength <- case eBufferLength of
           Left (e :: IOException) -> do
             -- putStrLn ("Socket vanished, cleaning up after " <> show e)
-        dropClient clientList sock
+            -- dropClient clientList sock
             pure 0
           Right len -> pure len
         msg <- B.pack <$> peekArray bufferLength ptr
@@ -52,7 +62,11 @@ receiveMessage sockContainer queue clientList = do
       maybe
         (pure ())
         (\msg -> do
+          print msg
           liftIO $ STM.atomically $ STM.writeTQueue queue msg
           -- when (msg == IdRequest) (threadDelay $ 10 ^ 3)
         )
         mMsg
+      STM.atomically $ STM.putTMVar sockContainer sock
+    )
+    msock

src-server/Server/Communication/Send.hs

@@ -35,6 +35,8 @@ import Linear
 
 import Network.Socket
 
+import System.Random (randomRIO)
+
 -- internal imports
 
 import Library.Types
@@ -62,7 +64,13 @@ sendMessageQueue
   -> STM.TQueue ServerMessage
   -> IO ()
 sendMessageQueue sockContainer queue = do
-  sock <- STM.atomically $ STM.readTMVar sockContainer
+  randSleep <- randomRIO (1, 1000)
+  threadDelay randSleep
+  msock <- STM.atomically $ STM.tryTakeTMVar sockContainer
+  maybe
+    (pure ())
+    (\sock -> do
+      putStrLn "took socket container for sending"
       msgs <- STM.atomically $ STM.flushTQueue queue
       mapM_
         (\msg -> do
@@ -80,6 +88,9 @@ sendMessageQueue sockContainer queue = do
             )
         )
         msgs
+      STM.atomically $ STM.putTMVar sockContainer sock
+    )
+    msock
 
 sendPings :: Game ()
 sendPings = do
@@ -98,7 +109,9 @@ sendPings = do
         when (isJust clientSock) $
           if timeDiff > realToFrac maxTimeout
           then do
-            liftIO $ dropClient (scClientSockets stateContainer) (fromJust clientSock)
+            liftIO $ do
+              putStrLn $ "dropping client because of timeout: " <> show plId
+              dropClient (scClientSockets stateContainer) (fromJust clientSock)
             put stateContainer
           else do
             random <- liftIO nextRandom
@@ -131,9 +144,9 @@ dropClient clientList sock = do
     void $ STM.swapTMVar clientList reducedClients
     pure mclient
   maybe
-    (pure ()) -- putStrLn $ "closing unknown socket: " <> show sock)
+    (putStrLn $ "closing unknown socket: " <> show sock)
     (\client -> do
-      putStrLn $ "dropping client: " <> show (fromJust $ ccUUID client)
+      putStrLn $ "dropping client because of closed socket: " <> show (fromJust $ ccUUID client)
       killThread (ccListener client)
     )
     mClient
@@ -176,5 +189,5 @@ sendUpdate stateContainer tileMap player = do
     sendSlice :: MapSlice -> Player -> IO ()
     sendSlice slice (Player playerId wizard _ _) = do
       let msg = TickUpdate slice wizard
-      print slice
+      -- print slice
       liftIO $ queueMessage msg playerId (scClientSockets stateContainer)