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 import System.Random (randomRIO) -- | 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 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) } 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