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
setMapColumns : 40
setSpawnerProbability : 0.01
setFPS : 5
setFPS : 30

View file

@ -1,8 +1,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module Client.Communication where
import Control.Concurrent (threadDelay)
import qualified Control.Concurrent.STM as STM
import Control.Monad.RWS
@ -48,6 +47,43 @@ sendMessage msg sock = do
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
:: Socket
-> 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
{ rcSocket :: Socket
, rcClientUUID :: UUID
, rcQueue :: STM.TQueue ServerMessage
}
data StateContainer = StateContainer
{ scWizard :: Wizard
, scClientState :: STM.TMVar ClientState
, scMapSlice :: MapSlice
}
type Game = RWST ReaderContainer String StateContainer IO

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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