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 currentPlayers <- STM.atomically $ STM.readTMVar (scPlayers stateContainer) let newPlayers = filter (\p -> playerId p /= clientId) currentPlayers void $ STM.atomically $ STM.swapTMVar (scPlayers stateContainer) newPlayers 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