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 do mapM_ (handleMessage serverState readerContainer) msgs