{-# 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)