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 clientList = scClientSockets stateContainer
  clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
  -- putStrLn $ "Handling: " <> show msg
  case msg of
    IdRequest                      -> do
      clientId <- nextRandom
      let clientIdx = findIndex (isNothing . ccUUID) clients
          clientSock = ccSocket $ clients !! fromJust clientIdx
          newClients = map
            (\old@(ClientComms mUUID oldClientSock _ _ _) ->
              if oldClientSock == clientSock && isNothing mUUID
              then
                old
                  { ccUUID = Just clientId
                  }
              else
                old
            )
            clients
      void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
      putStrLn $ "Accepted Client with UUID " <> show clientId
      queueMessage (AcceptClient clientId) clientId clientList
    ClientMessage clientId payload ->
      case payload of
        ClientQuit -> do
          putStrLn $ "client " <> show clientId <> " has quit the game"
          let client = find (\a -> ccUUID a == Just clientId) clients
          dropClient clientList (ccSocket $ 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 clientList
        ClientReady -> do
          putStrLn $ "client " <> show clientId <> " is ready!"
          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
        Pong uuid -> do
          let mclient = find (\c -> ccUUID c == Just clientId) clients
          maybe
            (putStrLn $ "Who is " <> show uuid <> "?")
            (\_ -> do
              mPlayer <- STM.atomically $ do
                players <- STM.readTMVar (scPlayers stateContainer)
                pure $ find (\p -> playerId p == clientId) players
              maybe
                (pure ())
                (\player ->
                  if snd (playerLastPong player) /= uuid
                  then
                    putStrLn $ "Pong ID mismatch from " <> show clientId
                  else do
                    now <- getCurrentTime
                    STM.atomically$ do
                      players <- STM.readTMVar (scPlayers stateContainer)
                      let otherPlayers = filter (\a -> playerId a /= playerId player) players
                          modPlayer = player
                            { playerLastPong = (now, uuid)
                            }
                      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