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 Data.Maybe

import Data.Time

import Data.UUID.V4

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 = findIndex (isNothing . csUUID) socks
          sock = socks !! fromJust clientIdx
          queue = queues !! fromJust 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 client = find (\a -> csUUID a == Just clientId) socks
          dropClient curLevel socketList queueList (csSocket $ fromJust client)
          logPrintIO curLevel Info $ "client has quit the game: " <> show clientId
        ClientRequestWizard -> do
          let arena = rcMap readerContainer
          initPos <- rollInitPosition arena
          now <- liftIO getCurrentTime
          uuid <- nextRandom
          let freshWizard = newWizard initPos
          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)
                            }
                      void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers)
                    sendUpdate curLevel stateContainer (rcMap readerContainer) player
                )
                mPlayer
            )
            mclient

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