wizard-wipeout/src-server/Server/Communication/Send.hs

{-# 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
queueMessage
  :: ServerMessage
  -> UUID
  -> STM.TMVar [ClientComms]
  -> IO ()
queueMessage msg uuid clientList = do
  clients <- STM.atomically $ STM.readTMVar clientList
  let mQueue = ccQueue <$> find (\client -> ccUUID client == Just uuid) clients
  maybe
    (putStrLn $ "unknown client UUID: " <> show uuid)
    (\queue ->
      STM.atomically $ STM.writeTQueue queue msg
      )
    mQueue

sendMessageQueue
  :: STM.TMVar Socket
  -> STM.TQueue ServerMessage
  -> IO ()
sendMessageQueue sockContainer queue = do
  sock <- STM.atomically $ STM.takeTMVar sockContainer
  msgs <- STM.atomically $ STM.flushTQueue queue
  mapM_
    (\msg -> do
      print msg
      let msgJson = A.encode msg
          msgVector = VS.fromList $ B.unpack $ B.toStrict ('<' `B8.cons` (msgJson `B8.snoc` '>'))
      VS.unsafeWith
        msgVector
        (\ptr -> do
          eResult <- try $ void $ sendBuf sock ptr (VS.length msgVector)
          case eResult of
            Left (e :: IOException) ->
              putStrLn $ "can't reach client after " <> show e
            Right _ ->
              pure ()
        )
    )
    msgs
  STM.atomically $ STM.putTMVar sockContainer sock

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 = (lastPongTime, random)
            liftIO $ queueMessage
              ( 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 $ queueMessage msg playerId (scClientSockets stateContainer)