begin synchronisation primitives

This commit is contained in:
nek0 2024-02-02 08:16:28 +01:00
parent 14fd41ef04
commit 6587f97312
2 changed files with 43 additions and 53 deletions

View file

@ -26,6 +26,8 @@ import Data.Maybe
import Data.UUID hiding (null)
import Data.UUID.V4
import Data.Time
import qualified Data.Vector.Storable as VS
import Foreign hiding (void)
@ -78,12 +80,15 @@ terminateGameOnSigint path = do
-- raiseSignal sigINT
)
Nothing
where
disconnectClients = mapM_
(\(_, clientSocket) -> do
sendMessage ServerQuit clientSocket
close clientSocket
)
disconnectClients
:: [Client]
-> IO ()
disconnectClients = mapM_
(\(_, clientSocket) -> do
sendMessage ServerQuit clientSocket
close clientSocket
)
-- | Process incoming connection requests
processRequests :: Game ()
@ -178,11 +183,11 @@ handleMessage stateContainer readerContainer msg = do
case msg of
IdRequest -> do
clientId <- nextRandom
let clientIdx = findIndex (\a -> fst a == Nothing) clients
let clientIdx = findIndex (isNothing . fst) clients
let clientSock = snd $ clients !! fromJust clientIdx
let newClients = map
(\old@(muuid, oldClientSock) ->
if oldClientSock == clientSock && muuid == Nothing
if oldClientSock == clientSock && isNothing muuid
then
(Just clientId, clientSock)
else
@ -224,49 +229,29 @@ handleMessage stateContainer readerContainer msg = do
(head thisPlayers) {playerReady = True} : otherPlayers
_ -> pure ()
sendUpdates :: Game ()
sendUpdates = do
sendPings :: Game ()
sendPings = do
now <- liftIO getCurrentTime
tileMap <- asks rcMap
maxTimeout <- asks rcClientMaxTimeout
framesPerPing <- asks rcFramesPerPing
fps <- asks rcFPS
stateContainer <- get
players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer)
sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer)
mapM_
(\(Player playerId wizard@(Wizard {..}) readiness) -> do
when readiness $ do
let V2 wr wc = wizardPos
subCoords = (,) <$> [floor wr - 4 .. floor wr + 4] <*> [floor wc - 4 .. floor wc + 4]
leftBound = wizardRot + (pi / 4)
rightBound = wizardRot - (pi / 4)
leftLine row = cos leftBound * row
rightLine row = sin rightBound * row
correctionLeft = if wizardRot < pi / 2 || wizardRot > 4 * pi / 2
then floor
else ceiling
correctionRight = if wizardRot < pi / 2 || wizardRot > 4 * pi / 2
then ceiling
else floor
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))
then
M.safeGet qr qc tileMap
else
Nothing
)
subCoords
clientSock = fromJust $ lookup (Just playerId) sockets
-- liftIO $ print $ leftLine . (\x -> x - wr) . fromIntegral .fst <$> subCoords
-- liftIO $ print initViewMatrix
liftIO $ sendMessage
(TickUpdate
{ tuWizard = wizard
, tuMapSlice = MapSlice
{ msViewMap = viewMatrix
, msContents = []
}
}
)
clientSock
(\(Player playerId (Wizard {}) readiness lastPong) -> do
let timeDiff = realToFrac $ diffUTCTime now lastPong
when (readiness && timeDiff > (framesPerPing * recip fps)) $ do
let clientSock = fromJust (lookup (Just playerId) sockets)
if timeDiff > maxTimeout
then
liftIO $ disconnectClients [clientSock]
else do
random <- liftIO $ nextRandom
liftIO $ sendMessage
( Ping random
)
clientSock
)
players

View file

@ -27,6 +27,8 @@ data Settings = Settings
, setMapColumns :: Int
, setSpawnerProbability :: Float
, setFPS :: Int
, setClientMaxTimeout :: Float
, setFramesPerPing :: Int
}
deriving (Show, Generic)
@ -46,9 +48,11 @@ options = Options
)
data ReaderContainer = ReaderContainer
{ rcMap :: ServerMap
, rcFPS :: Int
, rcMainSocket :: Socket
{ rcMap :: ServerMap
, rcFPS :: Int
, rcFramesPerPing :: Int
, rcClientMaxTimeout :: Float
, rcMainSocket :: Socket
}
deriving (Eq, Show)
@ -62,9 +66,10 @@ data StateContainer = StateContainer
}
data Player = Player
{ playerId :: UUID
, playerWizard :: Wizard
, playerReady :: Bool
{ playerId :: UUID
, playerWizard :: Wizard
, playerReady :: Bool
, playerLastPong :: UTCTime
}
deriving (Eq, Show)