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 hiding (null)
import Data.UUID.V4

import Linear

import Network.Socket

-- internal imports

import Library.Types

import Server.Log (logPrintIO)
import Server.Types

-- | Sends a specified message through given socket to the client
queueMessage
  :: LogLevel
  -> ServerMessage
  -> UUID
  -> STM.TMVar [ClientQueue]
  -> IO ()
queueMessage curLevel msg uuid queueListContainer = do
  queueList <- STM.atomically $ STM.readTMVar queueListContainer
  logPrintIO curLevel Verbose $ "queueing message \"" <> show msg <> "\" for client " <> show uuid <> " …"
  let mQueue = cqQueue <$> find (\client -> cqUUID client == Just uuid) queueList
  maybe
    (logPrintIO curLevel Warning $ "no queue found for client: " <> show uuid)
    (\queue ->
      STM.atomically $ STM.writeTQueue queue msg
      )
    mQueue
  logPrintIO curLevel Verbose "message queued!"

sendMessageQueue
  :: LogLevel
  -> STM.TMVar Socket
  -> STM.TQueue ServerMessage
  -> IO ()
sendMessageQueue curLevel sockContainer queue = do
  -- randTime <- randomRIO (1, 1000)
  -- threadDelay randTime
  msgs <- STM.atomically $ STM.flushTQueue queue
  unless (null msgs) $ logPrintIO curLevel Verbose $ "messages in queue: " <> show msgs
  mapM_
    (\msg -> do
      sock <- STM.atomically $ STM.readTMVar sockContainer
      logPrintIO curLevel Verbose "read socket container for sending"
      logPrintIO curLevel Verbose $ "sending message: " <> show 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) ->
              logPrintIO curLevel Error $ "can't reach client after " <> show e
            Right _ ->
              pure ()
        )
    )
    msgs

sendPings :: Game ()
sendPings = do
  now <- liftIO getCurrentTime
  _maxTimeout <- asks rcClientMaxTimeout
  framesPerPing <- asks rcFramesPerPing
  curLevel <- asks rcLogLevel
  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 $ do
          --     putStrLn $ "dropping client because of timeout: " <> show plId
          --     dropClient (scClientSockets stateContainer) (fromJust clientSock)
          --   put stateContainer
          -- else do
            random <- liftIO nextRandom
            let newPong = (now, random)
            liftIO $ do
              let queues = scClientQueues stateContainer
              queueMessage
                curLevel
                ( Ping random
                )
                plId
                queues
            let newPlayer = player
                  { playerLastPong = newPong
                  }
                otherPlayers = filter (\a -> playerId a /= plId) players
            liftIO $ do
              void $ STM.atomically $
                STM.swapTMVar (scPlayers stateContainer) (newPlayer : otherPlayers)
              logPrintIO curLevel Verbose "ping!"
    )
    players
  put stateContainer

-- | Drops the client from internal management and closes its socket, if still present.
dropClient
  :: LogLevel
  -> STM.TMVar [ClientSocket]
  -> STM.TMVar [ClientQueue]
  -> Socket
  -> IO ()
dropClient curLevel socketList queueList sock = do
  clients <- STM.atomically $ STM.readTMVar socketList
  mClient <- STM.atomically $ do
    let mclient = find (\client -> csSocket client == sock) clients
    pure mclient
  maybe
    (logPrintIO curLevel Warning $ "closing unknown socket: " <> show sock)
    (\client -> do
      let clientUUID = fromMaybe (error "no UUID for client?!") (csUUID client)
      logPrintIO curLevel Info $ "killing client sender and listener because of socket closing: " <> show clientUUID
      killThread (csSender client)
      killThread (csReceiver client)
      logPrintIO curLevel Info $ "dropping client because of socket closing: " <> show clientUUID
    )
    mClient
  STM.atomically $ do
    queues <- STM.readTMVar queueList
    let reducedClients = filter (\client -> csSocket client /= sock) clients
        reducedQueues = filter (\queue -> cqUUID queue /= csUUID (fromMaybe (error "What happened to the client?!") mClient)) queues
    void $ STM.swapTMVar socketList reducedClients
    void $ STM.swapTMVar queueList reducedQueues
  close sock

sendUpdate
  :: LogLevel
  -> StateContainer
  -> ServerMap
  -> Player
  -> IO ()
sendUpdate curLevel stateContainer tileMap player = do
  let slice = buildSlice player
  sendSlice slice player
  where
    buildSlice :: Player -> MapSlice
    buildSlice (Player _ (Wizard {..}) _ _) =
      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
              M.safeGet qr qc tileMap
            )
            subCoords
      in
        MapSlice initViewMatrix []
    sendSlice :: MapSlice -> Player -> IO ()
    sendSlice slice (Player playerId wizard _ _) = do
      let msg = TickUpdate slice wizard
      -- print slice
      liftIO $ do
        let queues = scClientQueues stateContainer
        queueMessage curLevel msg playerId queues