wizard-wipeout/src-server/Server/Communication/Send.hs
2024-05-01 23:52:49 +02:00

127 lines
3.6 KiB
Haskell

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 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 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
sendUpdates
:: Game ()
sendUpdates = pure ()