wizard-wipeout/src-server/Server/Communication/Send.hs
2024-06-09 07:32:03 +02:00

168 lines
5.1 KiB
Haskell

{-# LANGUAGE RecordWildCards #-}
module Server.Communication.Send where
import Control.Concurrent
import qualified Control.Concurrent.STM as STM
import Control.Exception
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State
import qualified Data.Aeson as A
import qualified Data.Matrix as M
import Data.Maybe
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.Char8 as B8
import Data.Time
import qualified Data.Vector.Storable as VS
import Data.List
import Data.UUID
import Data.UUID.V4
import Linear
import Network.Socket
-- internal imports
import Library.Types
import Server.Types
-- | Sends a specified message through given socket to the client
sendMessage
:: ServerMessage
-> UUID
-> STM.TMVar [ClientComms]
-> IO ()
sendMessage msg uuid clientList = do
clients <- STM.atomically $ STM.readTMVar clientList
let mSock = ccSocket <$> find (\client -> ccUUID client == Just uuid) clients
msgJson = A.encode msg
msgVector = VS.fromList $ B.unpack $ B.toStrict ('<' `B8.cons` (msgJson `B8.snoc` '>'))
-- putStrLn $ "Sending: " <> B8.unpack msgJson
maybe
(putStrLn $ "unknown client UUID: " <> show uuid)
(\sock ->
VS.unsafeWith
msgVector
(\ptr -> do
eResult <- try $ void $ sendBuf sock ptr (VS.length msgVector)
case eResult of
Left (_ :: IOException) ->
putStrLn $ "cant reach client " <> show uuid
Right _ ->
pure ()
)
)
mSock
sendPings :: Game ()
sendPings = do
now <- liftIO getCurrentTime
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@(Player plId (Wizard {}) readiness (lastPongTime, _)) -> do
let timeDiff = realToFrac $ diffUTCTime now lastPongTime :: Float
when (readiness && timeDiff > (fromIntegral framesPerPing * recip (fromIntegral fps))) $ do
let clientSock = ccSocket <$> find (\c -> ccUUID c == Just plId) sockets
when (isJust clientSock) $
if timeDiff > realToFrac maxTimeout
then do
liftIO $ dropClient (scClientSockets stateContainer) (fromJust clientSock)
put stateContainer
else do
random <- liftIO nextRandom
let newPong = (now, random)
liftIO $ sendMessage
( Ping random
)
plId
(scClientSockets stateContainer)
let newPlayer = player
{ playerLastPong = newPong
}
otherPlayers = filter (\a -> playerId a /= plId) players
liftIO $ void $ STM.atomically $
STM.swapTMVar (scPlayers stateContainer) (newPlayer : otherPlayers)
)
players
put stateContainer
-- | Drops the client from internal management and closes its socket, if still present.
dropClient
:: STM.TMVar [ClientComms]
-> Socket
-> IO ()
dropClient clientList sock = do
mClient <- STM.atomically $ do
clients <- STM.readTMVar clientList
let mclient = find (\client -> ccSocket client == sock) clients
let reducedClients = filter (\client -> ccSocket client /= sock) clients
void $ STM.swapTMVar clientList reducedClients
pure mclient
maybe
(putStrLn $ "closing unknown socket: " <> show sock)
(\client -> do
putStrLn $ "dropping client: " <> show (fromJust $ ccUUID client)
killThread (ccListener client)
)
mClient
close sock
sendUpdate
:: StateContainer
-> ServerMap
-> Player
-> IO ()
sendUpdate stateContainer tileMap player = do
slice <- buildSlice player
sendSlice slice player
where
buildSlice :: Player -> IO MapSlice
buildSlice (Player _ (Wizard {..}) _ _) = 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 > 2 * pi
then ceiling
else floor
correctionRight = if wizardRot < pi / 2 || wizardRot > 2 * pi
then ceiling
else floor
initViewMatrix = 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
pure (MapSlice initViewMatrix [])
sendSlice :: MapSlice -> Player -> IO ()
sendSlice slice (Player playerId wizard _ _) = do
let msg = TickUpdate slice wizard
print slice
liftIO $ sendMessage msg playerId (scClientSockets stateContainer)