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

module Server.Communication.Handler where

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.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
  socks <- liftIO $ STM.atomically $ STM.readTMVar socketList
  queues <- liftIO $ STM.atomically $ STM.readTMVar queueList
  -- putStrLn $ "Handling: " <> show msg
  case msg of
    IdRequest                      -> do
      clientId <- nextRandom
      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
        putStrLn $ "Accepted Client with UUID: " <> show clientId
        queueMessage (AcceptClient clientId) clientId queueList
      else
        putStrLn $ "Unable to assign ID to Socket and queue: " <> show clientId
    ClientMessage clientId payload ->
      case payload of
        ClientQuit -> do
          putStrLn $ "client has quit the game: " <> show clientId
          let client = find (\a -> csUUID a == Just clientId) socks
          dropClient socketList (csSocket $ fromJust client)
        ClientRequestWizard -> do
          putStrLn "initializing new wizard"
          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 (ProvideInitialWizard freshWizard) clientId queueList
        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
          putStrLn $ "client ready: " <> show clientId
        Pong pongUuid -> do
          let mclient = find (\c -> csUUID c == Just clientId) socks
          players <- STM.atomically $ STM.readTMVar (scPlayers stateContainer)
          maybe
            (putStrLn $ "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
                    putStrLn $ "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 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