128 lines
3.6 KiB
Haskell
128 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 ()
|