more client-server communication

This commit is contained in:
nek0 2023-12-20 08:12:22 +01:00
parent 0c805f3aa2
commit 324a776227
10 changed files with 91 additions and 15 deletions

View file

@ -2,4 +2,4 @@ setSocketPath : "/tmp/wizard.sock"
setMapRows : 40 setMapRows : 40
setMapColumns : 40 setMapColumns : 40
setSpawnerProbability : 0.01 setSpawnerProbability : 0.01
setFPS : 5 setFPS : 30

View file

@ -1,8 +1,7 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module Client.Communication where module Client.Communication where
import Control.Concurrent (threadDelay)
import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM as STM
import Control.Monad.RWS import Control.Monad.RWS
@ -48,6 +47,43 @@ sendMessage msg sock = do
msgVector msgVector
(\ptr -> void $ sendBuf sock ptr (VS.length msgVector)) (\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
handleMessages
:: Game ()
handleMessages = do
sock <- asks rcSocket
queue <- asks rcQueue
msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
mapM_
handleMessage
msgs
handleMessage
:: ServerMessage
-> Game ()
handleMessage ServerQuit = do
state <- get
let stateCont = scClientState state
liftIO $ STM.atomically $ do
state <- STM.readTMVar stateCont
void $ STM.swapTMVar stateCont $ state
{ clientStop = True
}
put $ state
{ scClientState = stateCont
}
liftIO $ putStrLn "Quitting due to server shutdown"
handleMessage (TickUpdate slice wizard) = do
modify' (\state@(StateContainer {..}) ->
state
{ scWizard = wizard
, scMapSlice = slice
}
)
handleMessage x =
liftIO $ putStrLn $ "received unexpected message from server: " <> show x
receiveMessage receiveMessage
:: Socket :: Socket
-> STM.TQueue ServerMessage -> STM.TQueue ServerMessage

23
src-client/Client/Game.hs Normal file
View file

@ -0,0 +1,23 @@
module Client.Game where
import qualified Control.Concurrent.STM as STM
import Control.Monad.Loops
import Control.Monad.RWS
-- internal imports
import Client.Communication
import Client.Types
import Library.Types
runGame :: Game ()
runGame = do
handleMessages
whileM_
(not . clientStop <$> (liftIO . STM.atomically . STM.readTMVar =<< gets scClientState))
(do
pure ()
)

View file

@ -28,11 +28,13 @@ options = Options
data ReaderContainer = ReaderContainer data ReaderContainer = ReaderContainer
{ rcSocket :: Socket { rcSocket :: Socket
, rcClientUUID :: UUID , rcClientUUID :: UUID
, rcQueue :: STM.TQueue ServerMessage
} }
data StateContainer = StateContainer data StateContainer = StateContainer
{ scWizard :: Wizard { scWizard :: Wizard
, scClientState :: STM.TMVar ClientState , scClientState :: STM.TMVar ClientState
, scMapSlice :: MapSlice
} }
type Game = RWST ReaderContainer String StateContainer IO type Game = RWST ReaderContainer String StateContainer IO

View file

@ -13,6 +13,8 @@ import Control.Monad.Loops
import Control.Monad.RWS import Control.Monad.RWS
import qualified Data.Matrix as M
import Graphics.Vty import Graphics.Vty
import Options.Applicative import Options.Applicative
@ -20,6 +22,7 @@ import Options.Applicative
-- internal imports -- internal imports
import Client.Communication import Client.Communication
import Client.Game
import Client.Types import Client.Types
import Library.Types import Library.Types
@ -63,16 +66,15 @@ main = do
shutdown vty shutdown vty
clientState <- STM.newTMVarIO (ClientState vty False False) clientState <- STM.newTMVarIO (ClientState vty False False)
let initRead = ReaderContainer sock clientId let initSlice = MapSlice (M.matrix 9 9 (const Nothing)) []
initState = StateContainer (initWizard playerWizard) clientState let initRead = ReaderContainer sock clientId queue
initState = StateContainer (initWizard playerWizard) clientState initSlice
-- putStrLn "sending quit message" -- putStrLn "sending quit message"
-- sendMessage (ClientMessage clientId ClientQuit) sock -- sendMessage (ClientMessage clientId ClientQuit) sock
void $ execRWST void $ execRWST
(do (do
terminateGameOnSigint terminateGameOnSigint
whileM_ runGame
(not . clientStop <$> (liftIO . STM.atomically . STM.readTMVar =<< gets scClientState))
(pure ())
) )
initRead initRead
initState initState

View file

@ -60,7 +60,6 @@ data SpawnerState
data MapSlice = MapSlice data MapSlice = MapSlice
{ msViewMap :: ClientMap { msViewMap :: ClientMap
, msViewOffset :: Position
, msContents :: [Effigy] , msContents :: [Effigy]
} }
deriving (Eq, Show, Generic) deriving (Eq, Show, Generic)

View file

@ -63,7 +63,7 @@ main = do
) )
initRead initRead
initState initState
removeIfExists setSocketPath -- removeIfExists setSocketPath
putStrLn "bye bye" putStrLn "bye bye"
where where
opts = info (options <**> helper) opts = info (options <**> helper)

View file

@ -69,10 +69,10 @@ terminateGameOnSigint path = do
sigINT sigINT
(CatchOnce $ do (CatchOnce $ do
putStrLn "SIGINT caught, terminating…" putStrLn "SIGINT caught, terminating…"
void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True)
disconnectClients clients disconnectClients clients
close sock close sock
removeIfExists path removeIfExists path
void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True)
-- Raise SIGINT again so it does not get blocked -- Raise SIGINT again so it does not get blocked
-- raiseSignal sigINT -- raiseSignal sigINT
) )
@ -108,7 +108,7 @@ sendMessage
sendMessage msg sock = do sendMessage msg sock = do
let msgJson = A.encode msg let msgJson = A.encode msg
msgVector = VS.fromList $ B.unpack $ B.toStrict msgJson msgVector = VS.fromList $ B.unpack $ B.toStrict msgJson
putStrLn $ "sending: " <> B8.unpack msgJson -- putStrLn $ "sending: " <> B8.unpack msgJson
VS.unsafeWith VS.unsafeWith
msgVector msgVector
(\ptr -> void $ sendBuf sock ptr (VS.length msgVector)) (\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
@ -217,6 +217,7 @@ sendUpdates = do
tileMap <- asks rcMap tileMap <- asks rcMap
stateContainer <- get stateContainer <- get
players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer) players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer)
sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer)
mapM_ mapM_
(\(player@(Player playerId wizard@(Wizard {..}))) -> do (\(player@(Player playerId wizard@(Wizard {..}))) -> do
let V2 wr wc = wizardPos let V2 wr wc = wizardPos
@ -231,7 +232,7 @@ sendUpdates = do
correctionRight = if wizardRot < pi / 2 || wizardRot > 4 * pi / 2 correctionRight = if wizardRot < pi / 2 || wizardRot > 4 * pi / 2
then ceiling then ceiling
else floor else floor
initViewMatrix = M.fromList 9 9 $ map viewMatrix = M.fromList 9 9 $ map
(\(qr, qc) -> (\(qr, qc) ->
if qc - floor wc <= correctionLeft (leftLine (wr - fromIntegral qr)) if qc - floor wc <= correctionLeft (leftLine (wr - fromIntegral qr))
&& qc - floor wc >= correctionRight (rightLine (wr - fromIntegral qr)) && qc - floor wc >= correctionRight (rightLine (wr - fromIntegral qr))
@ -241,7 +242,18 @@ sendUpdates = do
Nothing Nothing
) )
subCoords subCoords
clientSock = fromJust $ lookup (Just playerId) sockets
-- liftIO $ print $ leftLine . (\x -> x - wr) . fromIntegral .fst <$> subCoords -- liftIO $ print $ leftLine . (\x -> x - wr) . fromIntegral .fst <$> subCoords
liftIO $ print initViewMatrix -- liftIO $ print initViewMatrix
liftIO $ sendMessage
(TickUpdate
{ tuWizard = wizard
, tuMapSlice = MapSlice
{ msViewMap = viewMatrix
, msContents = []
}
}
)
clientSock
) )
players players

View file

@ -38,13 +38,13 @@ runGame = do
handleMessages handleMessages
updateSpawners delta updateSpawners delta
updateWizards delta updateWizards delta
sendUpdates
modify' modify'
(\s -> s (\s -> s
{ scServerLastTick = now { scServerLastTick = now
} }
) )
fps <- asks rcFPS fps <- asks rcFPS
sendUpdates
let remainingTime = recip (fromIntegral fps) - delta let remainingTime = recip (fromIntegral fps) - delta
when (remainingTime > 0) $ when (remainingTime > 0) $
liftIO $ threadDelay $ floor $ remainingTime * 10 ^ 6 liftIO $ threadDelay $ floor $ remainingTime * 10 ^ 6

View file

@ -36,11 +36,13 @@ executable wizard-wipeout-client
import: warnings import: warnings
main-is: Main.hs main-is: Main.hs
other-modules: Client.Communication other-modules: Client.Communication
Client.Game
Client.Types Client.Types
-- other-extensions: -- other-extensions:
build-depends: base ^>=4.17.2.1 build-depends: base ^>=4.17.2.1
, aeson , aeson
, bytestring , bytestring
, matrix
, monad-loops , monad-loops
, mtl , mtl
, network , network