attempting to fix communication again

src-client/Client/Communication.hs

@@ -35,7 +35,7 @@ connectSocket
   :: FilePath
   -> IO Socket
 connectSocket path = do
-  sock <- socket AF_UNIX Stream defaultProtocol
+  sock <- socket AF_UNIX Stream 0
   setSocketOption sock KeepAlive 1
   connect sock (SockAddrUnix path)
   pure sock
@@ -122,7 +122,10 @@ receiveMessage sock queue st = do
       let mJsonMsg = A.decode' msg
       maybe
         (putStrLn $ "received garbled data: " <> B8.unpack (B8.fromStrict rawMsg))
-        (STM.atomically . STM.writeTQueue queue)
+        (\jsonMsg -> do
+          print jsonMsg
+          STM.atomically $ STM.writeTQueue queue jsonMsg
+        )
         mJsonMsg
     )
     msgs

src-client/Client/Game.hs

@@ -2,8 +2,6 @@ module Client.Game where
 
 import Control.Concurrent.STM (atomically, readTMVar)
 
-import Control.Monad.IO.Class (liftIO)
-
 import Control.Monad.Loops
 
 import Control.Monad.RWS

src-server/Server/Communication.hs

@@ -39,7 +39,7 @@ bindSocket path = do
   unless (isSupportedSockAddr sockAddr)
     (error $ "invalid socket path " <> path)
   -- removeIfExists path
-  sock <- socket AF_UNIX Stream defaultProtocol
+  sock <- socket AF_UNIX Stream 0
   bind sock sockAddr
   Net.listen sock 5
   pure sock
@@ -77,7 +77,7 @@ disconnectClients clientList clients = do
       maybe
         (pure ())
         (\uuid -> do
-          sendMessage ServerQuit uuid clientList
+          queueMessage ServerQuit uuid clientList
           dropClient clientList (ccSocket client)
         )
         (ccUUID client)
@@ -101,11 +101,25 @@ processRequests = do
         Left (_ :: SomeException) ->
           putStrLn "Main socket vanished!"
         Right (clientSock, _) -> do
-          clientThreadId <- liftIO $ forkIO $ forever $ do
+          messageQueue <- STM.newTQueueIO
-            receiveMessage clientSock queue socketList
+          sockCOntainer <- STM.newTMVarIO clientSock
+          clientWriteThreadId <- liftIO $ forkIO $ forever $ do
+            receiveMessage sockCOntainer queue socketList
+          clientListenThreadId <- liftIO $ forkIO $ forever $ do
+            sendMessageQueue sockCOntainer messageQueue
+          print clientSock
           liftIO $ STM.atomically $ do
             list <- STM.takeTMVar socketList
-            STM.putTMVar socketList (ClientComms Nothing clientSock clientThreadId : list)
+            STM.putTMVar
+              socketList
+              (ClientComms
+                Nothing
+                clientSock
+                messageQueue
+                clientWriteThreadId
+                clientListenThreadId
+                : list
+              )
           putStrLn "accepted new connection"
           abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st)
           unless abortCondition $

src-server/Server/Communication/Handler.hs

@@ -37,7 +37,7 @@ handleMessage stateContainer readerContainer msg = do
       let clientIdx = findIndex (isNothing . ccUUID) clients
           clientSock = ccSocket $ clients !! fromJust clientIdx
           newClients = map
-            (\old@(ClientComms mUUID oldClientSock _) ->
+            (\old@(ClientComms mUUID oldClientSock _ _ _) ->
               if oldClientSock == clientSock && isNothing mUUID
               then
                 old
@@ -49,7 +49,7 @@ handleMessage stateContainer readerContainer msg = do
             clients
       void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
       putStrLn $ "Accepted Client with UUID " <> show clientId
-      sendMessage (AcceptClient clientId) clientId clientList
+      queueMessage (AcceptClient clientId) clientId clientList
     ClientMessage clientId payload ->
       case payload of
         ClientQuit -> do
@@ -67,7 +67,7 @@ handleMessage stateContainer readerContainer msg = do
             currentPlayers <- STM.readTMVar (scPlayers stateContainer)
             void $ STM.swapTMVar (scPlayers stateContainer) $
               Player clientId freshWizard False (now, uuid) : currentPlayers
-          sendMessage (ProvideInitialWizard freshWizard) clientId clientList
+          queueMessage (ProvideInitialWizard freshWizard) clientId clientList
         ClientReady -> do
           putStrLn $ "client " <> show clientId <> " is ready!"
           now <- getCurrentTime
@@ -118,14 +118,9 @@ handleMessages = do
   serverState <- get
   readerContainer <- ask
   liftIO $ do
-    msgs <- STM.atomically $ do
+    msgs <- STM.atomically $
-      emptyState <- STM.isEmptyTQueue queue
-      if emptyState
-      then
-        pure []
-      else
       STM.flushTQueue queue
-    void $ do
+    do
       mapM_
         (handleMessage serverState readerContainer)
         msgs

src-server/Server/Communication/Receive.hs

@@ -11,10 +11,12 @@ import qualified Data.Aeson as A
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy.Char8 as B8
 
-import Foreign.Marshal
+import Foreign.Marshal hiding (void)
 
 import Network.Socket
 
+-- internal imports
+
 import Library.Types
 
 import Server.Communication.Send
@@ -22,19 +24,20 @@ import Server.Types
 
 -- | receive a 'ClientMessage'
 receiveMessage
-  :: Socket
+  :: STM.TMVar Socket
   -> STM.TQueue ClientMessage
   -> STM.TMVar [ClientComms]
   -> IO ()
-receiveMessage sock queue clientList = do
+receiveMessage sockContainer queue clientList = do
+  sock <- STM.atomically $ STM.readTMVar sockContainer
   let maxBufferLength = 4096
   mMsg <- do
     ptr <- mallocArray maxBufferLength
     eBufferLength <-
       try $ recvBuf sock ptr maxBufferLength
     bufferLength <- case eBufferLength of
-      Left (_ :: IOException) -> do
+      Left (e :: IOException) -> do
-        putStrLn "Socket vanished, cleaning up…"
+        putStrLn ("Socket vanished, cleaning up after " <> show e)
         dropClient clientList sock
         pure 0
       Right len -> pure len

src-server/Server/Communication/Send.hs

@@ -42,32 +42,46 @@ import Library.Types
 import Server.Types
 
 -- | Sends a specified message through given socket to the client
-sendMessage
+queueMessage
   :: ServerMessage
   -> UUID
   -> STM.TMVar [ClientComms]
   -> IO ()
-sendMessage msg uuid clientList = do
+queueMessage msg uuid clientList = do
   clients <- STM.atomically $ STM.readTMVar clientList
-  let mSock = ccSocket <$> find (\client -> ccUUID client == Just uuid) clients
+  let mQueue = ccQueue <$> find (\client -> ccUUID client == Just uuid) clients
-      msgJson = A.encode msg
-      msgVector = VS.fromList $ B.unpack $ B.toStrict ('<' `B8.cons` (msgJson `B8.snoc` '>'))
-  -- putStrLn $ "Sending: " <> B8.unpack msgJson
   maybe
     (putStrLn $ "unknown client UUID: " <> show uuid)
-    (\sock ->
+    (\queue ->
+      STM.atomically $ STM.writeTQueue queue msg
+      )
+    mQueue
+
+sendMessageQueue
+  :: STM.TMVar Socket
+  -> STM.TQueue ServerMessage
+  -> IO ()
+sendMessageQueue sockContainer queue = do
+  sock <- STM.atomically $ STM.takeTMVar sockContainer
+  msgs <- STM.atomically $ STM.flushTQueue queue
+  mapM_
+    (\msg -> do
+      print msg
+      let msgJson = A.encode msg
+          msgVector = VS.fromList $ B.unpack $ B.toStrict ('<' `B8.cons` (msgJson `B8.snoc` '>'))
       VS.unsafeWith
         msgVector
         (\ptr -> do
           eResult <- try $ void $ sendBuf sock ptr (VS.length msgVector)
           case eResult of
-            Left (_ :: IOException) ->
+            Left (e :: IOException) ->
-              putStrLn $ "can't reach client " <> show uuid
+              putStrLn $ "can't reach client after " <> show e
             Right _ ->
               pure ()
         )
     )
-    mSock
+    msgs
+  STM.atomically $ STM.putTMVar sockContainer sock
 
 sendPings :: Game ()
 sendPings = do
@@ -91,7 +105,7 @@ sendPings = do
           else do
             random <- liftIO nextRandom
             let newPong = (lastPongTime, random)
-            liftIO $ sendMessage
+            liftIO $ queueMessage
               ( Ping random
               )
               plId
@@ -165,4 +179,4 @@ sendUpdate stateContainer tileMap player = do
     sendSlice slice (Player playerId wizard _ _) = do
       let msg = TickUpdate slice wizard
       print slice
-      liftIO $ sendMessage msg playerId (scClientSockets stateContainer)
+      liftIO $ queueMessage msg playerId (scClientSockets stateContainer)

src-server/Server/Types.hs

@@ -70,6 +70,8 @@ data StateContainer = StateContainer
 data ClientComms = ClientComms
   { ccUUID     :: Maybe UUID
   , ccSocket   :: Socket
+  , ccQueue    :: STM.TQueue ServerMessage
+  , ccWriter   :: ThreadId
   , ccListener :: ThreadId
   }
   deriving (Eq)

wizard-wipeout.cabal

@@ -15,6 +15,8 @@ extra-doc-files:    CHANGELOG.md
 
 common warnings
     ghc-options: -Wall -threaded -rtsopts
+                 -fwrite-ide-info
+                 -hiedir=.hie
 
 library
     import:           warnings