diff --git a/src-client/Client/Communication.hs b/src-client/Client/Communication.hs index c0f0f50..cc19823 100644 --- a/src-client/Client/Communication.hs +++ b/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 ) diff --git a/src-client/Client/Game.hs b/src-client/Client/Game.hs index 4dc3ba3..f4b87b9 100644 --- a/src-client/Client/Game.hs +++ b/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 diff --git a/src-client/Client/Types.hs b/src-client/Client/Types.hs index 523c551..84aa9fd 100644 --- a/src-client/Client/Types.hs +++ b/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 diff --git a/src-client/Main.hs b/src-client/Main.hs index 5202bda..92e8daf 100644 --- a/src-client/Main.hs +++ b/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) diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index 82527e3..e14105a 100644 --- a/src-server/Server/Communication.hs +++ b/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