meow

src-client/Client/Communication.hs

@@ -16,6 +16,8 @@ import qualified Data.Aeson as A
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy.Char8 as B8
 
+import Data.IORef
+
 import Data.UUID
 
 import qualified Data.Vector.Storable as VS
@@ -50,12 +52,10 @@ sendMessage
   -> IO ()
 sendMessage st msg sock = do
   let msgJson = A.encode msg
-      msgVector = VS.fromList $ B.unpack $ B.toStrict msgJson
-  VS.unsafeWith
-    msgVector
-    (\ptr -> do
-      void $ sendBuf sock ptr (VS.length msgVector)
-      )
+      msgList = B.unpack $ B.toStrict msgJson
+  ptr <- newArray msgList
+  void $ sendBuf sock ptr (length msgList)
+  free ptr
 
 handleMessages
   :: Game ()
@@ -141,24 +141,19 @@ receiveMessage sock queue st = do
         mJsonMsg
     )
     msgs
+  free ptr
 
 -- | Function that installs a handler on SIGINT to terminate game
 terminateGameOnSigint
-  :: Game ()
-terminateGameOnSigint = do
-  sock <- asks rcSocket
-  clientId <- asks rcClientUUID
-  clientState <- gets scClientState
-  st <- get
+  :: IORef Bool
+  -> Game ()
+terminateGameOnSigint stopper = do
   void $ liftIO $ installHandler
     keyboardSignal
     (CatchOnce $ do
       putStrLn "receiveMessage: SIGINT caught, terminating…"
-      STM.atomically $ do
-        currentState <- STM.readTMVar clientState
-        void $ STM.swapTMVar clientState $ currentState { clientStop = True }
+      atomicWriteIORef stopper True
       -- Vty.shutdown (clientVty currentState)
-      partingMessage st clientId sock
       -- Raise SIGINT again so it does not get blocked
       -- raiseSignal keyboardSignal
     )

src-client/Client/Game.hs

@@ -10,6 +10,8 @@ import Control.Monad.Loops
 
 import Control.Monad.RWS
 
+import Data.IORef (IORef, readIORef)
+
 import Graphics.Vty
 
 -- internal imports
@@ -20,21 +22,25 @@ import Client.Types
 
 import Library.Types
 
-runGame :: Game ()
-runGame = do
+runGame 
+  :: IORef Bool
+  -> Game ()
+runGame stopper = do
   sock <- asks rcSocket
   queue <- asks rcQueue
   clientId <- asks rcClientUUID
   st <- get
-  recvThread <- liftIO $ forkIO $ forever $ receiveMessage sock queue st
+  -- 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))
+    (liftIO (not <$> readIORef stopper))
     (do
+      liftIO $ receiveMessage sock queue st
       handleMessages
       -- draw
     )
-  liftIO $ killThread recvThread
+  liftIO $ partingMessage st clientId sock
+  -- liftIO $ killThread recvThread
 
 handleEvent
   :: Maybe Event

src-client/Client/Types.hs

@@ -2,6 +2,8 @@ module Client.Types where
 
 import qualified Control.Concurrent.STM as STM
 
+import Control.Exception (Exception)
+
 import Control.Monad.RWS
 
 import Data.UUID
@@ -38,3 +40,8 @@ data StateContainer = StateContainer
   }
 
 type Game = RWST ReaderContainer String StateContainer IO
+
+data ClientTerminate = ClientTerminate
+  deriving (Show)
+
+instance Exception ClientTerminate

src-client/Main.hs

@@ -8,6 +8,8 @@ import Control.Monad
 
 import Control.Monad.RWS
 
+import Data.IORef
+
 import qualified Data.Matrix as M
 
 import Graphics.Vty
@@ -71,17 +73,18 @@ main = do
       initState = StateContainer (initWizard playerWizard) clientState initSlice
   -- putStrLn "sending quit message"
   -- sendMessage (ClientMessage clientId ClientQuit) sock
+  stopper <- newIORef False
   void $ execRWST
     (do
-      terminateGameOnSigint
-      runGame
+      terminateGameOnSigint stopper
+      runGame stopper
     )
     initRead
     initState
   -- shutdown vty
-  partingMessage initState clientId sock
-  threadDelay 100
-  close sock
+  putStrLn "Shutting down client…"
+  -- threadDelay 100
+  -- close sock
   putStrLn "bye bye"
   where
     opts = info (options <**> helper)

src-server/Server/Communication.hs

@@ -252,11 +252,13 @@ handleMessage stateContainer readerContainer msg = do
         ClientQuit -> do
           putStrLn $ "removing client " <> show clientId
           let newClients = filter (\a -> ccUUID a /= Just clientId) clients
+              client = find (\a -> ccUUID a == Just clientId) clients
           STM.atomically $ do
             currentPlayers <- STM.readTMVar (scPlayers stateContainer)
             let newPlayers = filter (\p -> playerId p /= clientId) currentPlayers
             void $ STM.swapTMVar (scPlayers stateContainer) newPlayers
             void $ STM.swapTMVar clientList newClients
+          close (ccSocket $ fromJust client)
         ClientRequestWizard -> do
           putStrLn "initializing new wizard"
           let arena = rcMap readerContainer