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 ()