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 System.Random (randomRIO) -- internal imports 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 = fromMaybe (error "no socket found of new client") (findIndex (isNothing . csUUID) socks) sock = socks !! clientIdx queue = queues !! 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) } !newPlayers = modPlayer : otherPlayers void $ STM.swapTMVar (scPlayers stateContainer) newPlayers sendUpdate curLevel stateContainer (rcMap readerContainer) player ) mPlayer ) mclient -- ClientAction act -> do -- let mclient = find (\c -> csUUID c == Just clientId) socks x -> logPrintIO (rcLogLevel readerContainer) Verbose ("Unhandled message: " <> show x) -- | 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