wizard-wipeout/src-server/Server/Communication/Handler.hs

131 lines
4.5 KiB
Haskell
Raw Normal View History

2024-05-01 21:52:49 +00:00
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
sendMessage (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
sendMessage (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)
)
mPlayer
)
mclient
-- | handle received messages
handleMessages :: Game ()
handleMessages = do
queue <- gets scMessageQueue
serverState <- get
readerContainer <- ask
liftIO $ do
msgs <- STM.atomically $ do
emptyState <- STM.isEmptyTQueue queue
if emptyState
then
pure []
else
STM.flushTQueue queue
void $ do
mapM_
(handleMessage serverState readerContainer)
msgs