This commit is contained in:
nek0 2024-04-17 19:44:47 +02:00
parent cd16ce7971
commit 65e0c5d272
5 changed files with 39 additions and 26 deletions

View file

@ -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
)

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -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