fix some communication issues

src-client/Client/Communication.hs

@@ -2,6 +2,8 @@
 {-# LANGUAGE RecordWildCards #-}
 module Client.Communication where
 
+import Control.Exception
+
 import qualified Control.Concurrent.STM as STM
 
 import Control.Monad.RWS
@@ -39,15 +41,21 @@ connectSocket path = do
 
 -- | Sends a specified message through given socket to the server
 sendMessage
-  :: ClientMessage
+  :: StateContainer
+  -> ClientMessage
   -> Socket
   -> IO ()
-sendMessage msg sock = do
+sendMessage st msg sock = do
   let msgJson = A.encode msg
       msgVector = VS.fromList $ B.unpack $ B.toStrict msgJson
   VS.unsafeWith
     msgVector
-    (\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
+    (\ptr -> do
+      eResult <- try $ sendBuf sock ptr (VS.length msgVector)
+      case eResult of
+        Left (_ :: IOException) -> gracefulExit st "Quitting due to connection loss…"
+        Right _ -> pure ()
+      )
 
 handleMessages
   :: Game ()
@@ -55,7 +63,10 @@ handleMessages = do
   queue <- asks rcQueue
   msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
   mapM_
-    handleMessage
+    (\msg -> do
+      liftIO $ print msg
+      handleMessage msg
+    )
     msgs
 
 handleMessage
@@ -63,21 +74,14 @@ handleMessage
   -> Game ()
 handleMessage ServerQuit = do
   st <- get
-  let stateCont = scClientState st
+  liftIO (gracefulExit st "Quitting due to server shutdown")
-  liftIO $ STM.atomically $ do
-    stateContainer <- STM.readTMVar stateCont
-    void $ STM.swapTMVar stateCont $ stateContainer
-      { clientStop = True
-      }
-  put $ st
-    { scClientState = stateCont
-    }
-  liftIO $ putStrLn "Quitting due to server shutdown"
 
 handleMessage (Ping id') = do
   cid <- asks rcClientUUID
   sock <- asks rcSocket
+  st <- get
   liftIO $ sendMessage
+    st
     ( ClientMessage
       cid
       (Pong id')
@@ -95,14 +99,34 @@ handleMessage (TickUpdate slice wizard) = do
 handleMessage x =
   liftIO $ putStrLn $ "received unexpected message from server: " <> show x
 
+-- Gracefully shut down the client with an error message
+gracefulExit
+  :: StateContainer
+  -> String
+  -> IO ()
+gracefulExit st reason = do
+  liftIO $ putStrLn reason
+  let stateCont = scClientState st
+  liftIO $ STM.atomically $ do
+    stateContainer <- STM.readTMVar stateCont
+    void $ STM.swapTMVar stateCont $ stateContainer
+      { clientStop = True
+      }
+
 receiveMessage
   :: Socket
   -> STM.TQueue ServerMessage
+  -> StateContainer
   -> IO ()
-receiveMessage sock queue = do
+receiveMessage sock queue st = do
   let maxBufferLength = 4096
   ptr <- mallocArray maxBufferLength
-  bufferLength <- recvBuf sock ptr maxBufferLength
+  ebufferLength <- try $ recvBuf sock ptr maxBufferLength
+  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
   let msgs =
         if B.length rawMsg < 1
@@ -125,23 +149,26 @@ terminateGameOnSigint = do
   sock <- asks rcSocket
   clientId <- asks rcClientUUID
   clientState <- gets scClientState
+  st <- get
   void $ liftIO $ installHandler
     keyboardSignal
     (CatchOnce $ do
+      putStrLn "SIGINT caught, terminating…"
       STM.atomically $ do
         currentState <- STM.readTMVar clientState
         void $ STM.swapTMVar clientState $ currentState { clientStop = True }
       -- Vty.shutdown (clientVty currentState)
-      partingMessage clientId sock
+      partingMessage st clientId sock
       -- Raise SIGINT again so it does not get blocked
-      raiseSignal keyboardSignal
+      -- raiseSignal keyboardSignal
     )
     Nothing
 
 partingMessage
-  :: UUID
+  :: StateContainer
+  -> UUID
   -> Socket
   -> IO ()
-partingMessage clientId sock = do
+partingMessage st clientId sock = do
-  sendMessage (ClientMessage clientId ClientQuit) sock
+  sendMessage st (ClientMessage clientId ClientQuit) sock
   -- close sock

src-client/Client/Game.hs

@@ -25,15 +25,16 @@ runGame = do
   sock <- asks rcSocket
   queue <- asks rcQueue
   clientId <- asks rcClientUUID
-  recvThread <- liftIO $ forkIO $ forever $ receiveMessage sock queue
+  st <- get
-  liftIO $ sendMessage (ClientMessage clientId ClientReady) sock
+  recvThread <- liftIO $ forkIO $ forever $ receiveMessage sock queue st
+  liftIO $ sendMessage st(ClientMessage clientId ClientReady) sock
   whileM_
     (not . clientStop <$> (liftIO . STM.atomically . STM.readTMVar =<< gets scClientState))
     (do
       handleMessages
       -- draw
     )
-  liftIO $ killThread recvThread
+  -- liftIO $ killThread recvThread
 
 handleEvent
   :: Maybe Event

src-client/Main.hs

@@ -36,9 +36,11 @@ main = do
   queue <- STM.newTQueueIO
 
 
-  sendMessage (IdRequest) sock
   -- threadDelay $ 1 * 10 ^ 6
-  receiveMessage sock queue
+  mockClientState <- STM.newTMVarIO (ClientState undefined False False)
+  let mockState = StateContainer undefined mockClientState undefined
+  sendMessage mockState (IdRequest) sock
+  receiveMessage sock queue mockState
   awaitResponse queue 1
   clientIdMsg <- head <$> STM.atomically (STM.flushTQueue queue)
   let clientId = acClientUUID clientIdMsg
@@ -49,9 +51,9 @@ main = do
   threadDelay $ 5 * 10 ^ 6
 
 
-  sendMessage (ClientMessage clientId ClientRequestWizard) sock
+  sendMessage mockState (ClientMessage clientId ClientRequestWizard) sock
   -- threadDelay $ 1 * 10 ^ 6
-  receiveMessage sock queue
+  receiveMessage sock queue mockState
   awaitResponse queue 1
   playerWizard <- head <$> STM.atomically (STM.flushTQueue queue)
   putStrLn $ "received wizard: " <> show (initWizard playerWizard)
@@ -77,7 +79,7 @@ main = do
     initRead
     initState
   -- shutdown vty
-  partingMessage clientId sock
+  partingMessage initState clientId sock
   threadDelay 100
   close sock
   where

src-server/Main.hs

@@ -70,7 +70,7 @@ main = do
         )
         initRead
         initState
-      -- removeIfExists setSocketPath
+      removeIfExists setSocketPath
       threadDelay 1000
       putStrLn "bye bye"
   where

src-server/Server/Communication.hs

@@ -73,7 +73,7 @@ terminateGameOnSigint path = do
       putStrLn "SIGINT caught, terminating…"
       disconnectClients clientList clients
       close sock
-      removeIfExists path
+      -- removeIfExists path
       void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True)
     )
     Nothing

src-server/Server/Game.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Server.Game where
 
-import Control.Concurrent (threadDelay)
+import Control.Concurrent
 
 import qualified Control.Concurrent.STM as STM
 
@@ -9,8 +9,6 @@ import Control.Monad.RWS.Strict
 
 import Control.Monad.Loops
 
-import Control.Concurrent
-
 import qualified Data.ByteString.Char8 as B8
 
 import Data.Time
@@ -53,7 +51,8 @@ runGame = do
       when (remainingTime > 0) $
         liftIO $ threadDelay $ floor $ remainingTime * 10 ^ 6
     )
-  liftIO $ killThread recvThread
+  liftIO $ threadDelay (10 ^ 6)
+  -- liftIO $ killThread recvThread
 
 updateSpawners :: Float -> Game ()
 updateSpawners dt =