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

module Server.Communication.Handler where

import Control.Concurrent (threadDelay)

import qualified Control.Concurrent.STM as STM

import Control.Monad

import Control.Monad.Reader
import Control.Monad.State

import Data.List

import qualified Data.Matrix as M

import Data.Maybe

import Data.Time

import Data.UUID.V4

import Linear

import System.Random (randomRIO)

-- internal imports

import Library.Types

import Server.Communication.Send
import Server.Log
import Server.Types
import Server.Util

-- | function for translating 'ClientMessage's into server actions
handleMessage
  :: StateContainer
  -> ReaderContainer
  -> ClientMessage
  -> IO ()
handleMessage stateContainer readerContainer msg = do
  let socketList = scClientSockets stateContainer
      queueList = scClientQueues stateContainer
      curLevel = rcLogLevel readerContainer
  socks <- liftIO $ STM.atomically $ STM.readTMVar socketList
  queues <- liftIO $ STM.atomically $ STM.readTMVar queueList
  logPrintIO curLevel Verbose $ "Handling: " <> show msg
  case msg of
    IdRequest                      -> do
      clientId <- nextRandom
      threadDelay 1000
      let clientIdx = fromMaybe (error "no socket found of new client") (findIndex (isNothing . csUUID) socks)
          sock = socks !! clientIdx
          queue = queues !! clientIdx
      if csUUID sock == cqUUID queue
      then do
        let otherSocks = delete sock socks
            newSocks = sock
              { csUUID = Just clientId
              } : otherSocks
            otherQueues = delete queue queues
            newQueues = queue
              { cqUUID = Just clientId
              } : otherQueues
        liftIO $ STM.atomically $ do
          void $ STM.swapTMVar socketList newSocks
          void $ STM.swapTMVar queueList newQueues
        logPrintIO curLevel Info $ "Accepted Client with UUID: " <> show clientId
        queueMessage curLevel (AcceptClient clientId) clientId queueList
      else
        logPrintIO curLevel Error $ "Unable to assign ID to socket and queue: " <> show clientId
    ClientMessage clientId payload ->
      case payload of
        ClientQuit -> do
          currentPlayers <- STM.atomically $ STM.readTMVar (scPlayers stateContainer)
          let newPlayers = filter (\p -> playerId p /= clientId) currentPlayers
          void $ STM.atomically $ STM.swapTMVar (scPlayers stateContainer) newPlayers
          let mclient = find (\a -> csUUID a == Just clientId) socks
          maybe
            (logPrintIO curLevel Warning $ "unknown client: " <> show clientId)
            (dropClient curLevel socketList queueList . csSocket)
            mclient
          logPrintIO curLevel Info $ "client has quit the game: " <> show clientId
        ClientRequestWizard -> do
          let arena = rcMap readerContainer
          initPos <- rollInitPosition arena
          initRot <- randomRIO (0, 2 * pi)
          now <- liftIO getCurrentTime
          uuid <- nextRandom
          let freshWizard = newWizard initPos initRot
          STM.atomically $ do
            currentPlayers <- STM.readTMVar (scPlayers stateContainer)
            void $ STM.swapTMVar (scPlayers stateContainer) $
              Player clientId freshWizard False (now, uuid) : currentPlayers
          queueMessage curLevel (ProvideInitialWizard freshWizard) clientId queueList
          logPrintIO curLevel Info $ "initialized new wizard for: " <> show clientId
        ClientReady -> do
          now <- getCurrentTime
          STM.atomically $ do
            currentPlayers <- STM.readTMVar (scPlayers stateContainer)
            let (thisPlayers, otherPlayers) =
                  partition (\p -> playerId p == clientId) currentPlayers
            unless (null thisPlayers) $
              void $ STM.swapTMVar (scPlayers stateContainer) $
                (head thisPlayers)
                  { playerReady = True
                  , playerLastPong = (now, snd (playerLastPong $ head thisPlayers))
                  }
                  : otherPlayers
          logPrintIO curLevel Info $ "client ready: " <> show clientId
        Pong pongUuid -> do
          let mclient = find (\c -> csUUID c == Just clientId) socks
          players <- STM.atomically $ STM.readTMVar (scPlayers stateContainer)
          maybe
            (logPrintIO curLevel Warning $ "Unknown client: " <> show clientId)
            (const $ do
              mPlayer <- STM.atomically $ do
                pure $ find (\p -> playerId p == clientId) players
              maybe
                (pure ())
                (\player ->
                  if snd (playerLastPong player) /= pongUuid
                  then
                    logPrintIO curLevel Warning $ "Pong ID mismatch from: " <> show clientId
                  else do
                    now <- getCurrentTime
                    STM.atomically$ do
                      let !otherPlayers = filter (\a -> playerId a /= playerId player) players
                          !modPlayer = player
                            { playerLastPong = (now, pongUuid)
                            }
                          !newPlayers = modPlayer : otherPlayers
                      void $ STM.swapTMVar (scPlayers stateContainer) newPlayers
                    sendUpdate curLevel stateContainer (rcMap readerContainer) player
                )
                mPlayer
            )
            mclient
        ClientAction act -> do
          players <- STM.atomically $ STM.readTMVar (scPlayers stateContainer)
          mPlayer <- STM.atomically $ do
            pure $ find (\p -> playerId p == clientId) players
          maybe
            (pure ())
            (\player -> do
              let wiz = playerWizard player
                  mat = rcMap readerContainer
                  rotStep = pi / 18
                  newRot = wizardRot wiz + case act of
                    TurnLeft  -> -rotStep
                    TurnRight -> rotStep
                    _         -> 0
                  newPos = wizardPos wiz + ((0.25 *) <$>
                    case act of
                      StepForward  -> -(angle (-newRot))
                      StepBackward -> angle (-newRot)
                      StrifeRight  -> perp (angle (-newRot))
                      StrifeLeft   -> -(perp (angle (-newRot)))
                      _            -> 0
                    )
                  doesCollide (V2 prow pcol) = (M.safeGet (floor prow) (floor pcol) mat) == Just Wall
                  newWiz = wiz
                    { wizardRot = newRot
                    , wizardPos = if doesCollide newPos then wizardPos wiz else newPos
                    }
                  newPlayer = player
                    { playerWizard = newWiz
                    }
                  otherPlayers = filter (\p -> playerId p /= clientId) players
                  newPlayers = newPlayer : otherPlayers
              void $ STM.atomically $ STM.swapTMVar (scPlayers stateContainer) newPlayers
              sendUpdate curLevel stateContainer (rcMap readerContainer) player
            )
            mPlayer
        x -> logPrintIO (rcLogLevel readerContainer) Verbose ("Unhandled message: " <> show x)

-- | handle received messages
handleMessages :: Game ()
handleMessages = do
  queue <- gets scMessageQueue
  serverState <- get
  readerContainer <- ask
  liftIO $ do
    msgs <- STM.atomically $
      STM.flushTQueue queue
    mapM_
      (handleMessage serverState readerContainer)
      msgs