130 lines
4.7 KiB
Haskell
130 lines
4.7 KiB
Haskell
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 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
|
|
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
|
|
let client = find (\a -> csUUID a == Just clientId) socks
|
|
dropClient socketList (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
|