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.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
      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
        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 queueList (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