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
+          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,30 +33,40 @@ 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
-  mMsg <- do
-    ptr <- mallocArray maxBufferLength
-    eBufferLength <-
-      try $ recvBuf sock ptr maxBufferLength
-    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
-    msg <- B.pack <$> peekArray bufferLength ptr
-    let mJsonMsg = A.decode' $ B8.fromStrict msg :: Maybe ClientMessage
-    free ptr
-    if bufferLength > 0
-    then
-      pure mJsonMsg
-    else
-      pure Nothing
   maybe
     (pure ())
-    (\msg -> do
+    (\sock -> do
-      liftIO $ STM.atomically $ STM.writeTQueue queue msg
+      putStrLn "took socket container for receiving"
-      -- when (msg == IdRequest) (threadDelay $ 10 ^ 3)
+      mMsg <- do
+        ptr <- mallocArray maxBufferLength
+        eBufferLength <-
+          try $ recvBuf sock ptr maxBufferLength
+        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
+        msg <- B.pack <$> peekArray bufferLength ptr
+        let mJsonMsg = A.decode' $ B8.fromStrict msg :: Maybe ClientMessage
+        free ptr
+        if bufferLength > 0
+        then
+          pure mJsonMsg
+        else
+          pure Nothing
+      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
     )
-    mMsg
+    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,24 +64,33 @@ sendMessageQueue
   -> STM.TQueue ServerMessage
   -> IO ()
 sendMessageQueue sockContainer queue = do
-  sock <- STM.atomically $ STM.readTMVar sockContainer
+  randSleep <- randomRIO (1, 1000)
-  msgs <- STM.atomically $ STM.flushTQueue queue
+  threadDelay randSleep
-  mapM_
+  msock <- STM.atomically $ STM.tryTakeTMVar sockContainer
-    (\msg -> do
+  maybe
-      let msgJson = A.encode msg
+    (pure ())
-          msgVector = VS.fromList $ B.unpack $ B.toStrict ('<' `B8.cons` (msgJson `B8.snoc` '>'))
+    (\sock -> do
-      VS.unsafeWith
+      putStrLn "took socket container for sending"
-        msgVector
+      msgs <- STM.atomically $ STM.flushTQueue queue
-        (\ptr -> do
+      mapM_
-          eResult <- try $ void $ sendBuf sock ptr (VS.length msgVector)
+        (\msg -> do
-          case eResult of
+          let msgJson = A.encode msg
-            Left (e :: IOException) ->
+              msgVector = VS.fromList $ B.unpack $ B.toStrict ('<' `B8.cons` (msgJson `B8.snoc` '>'))
-              putStrLn $ "can't reach client after " <> show e
+          VS.unsafeWith
-            Right _ ->
+            msgVector
-              pure ()
+            (\ptr -> do
+              eResult <- try $ void $ sendBuf sock ptr (VS.length msgVector)
+              case eResult of
+                Left (e :: IOException) ->
+                  putStrLn $ "can't reach client after " <> show e
+                Right _ ->
+                  pure ()
+            )
         )
+        msgs
+      STM.atomically $ STM.putTMVar sockContainer sock
     )
-    msgs
+    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)