71 lines
1.7 KiB
Haskell
71 lines
1.7 KiB
Haskell
module WebSocket.WSApp (WSEnv (..), wsApp, WSApp (..)) where
|
|
|
|
import BroadcastUserData
|
|
( MonadBroadcast (..),
|
|
broadcastUserData,
|
|
)
|
|
import ClassyPrelude
|
|
import Data.UUID.V4 ()
|
|
import State.ConnectedClientsState (MonadConnectedClientsModify (..))
|
|
import State.RoomDataState (MonadRoomDataStateRead (..))
|
|
import Types.ConnectionState (Client (..))
|
|
import Types.WebSocketMessages.WebSocketMessages
|
|
( SetClientInfo (displayName),
|
|
WebSocketMessage (..),
|
|
)
|
|
import WebSocket.AllChat (broadCastAllChatMessage)
|
|
import WebSocket.MonadWebSocketSession
|
|
import WebSocket.WSReaderTApp
|
|
|
|
wsApp ::
|
|
( MonadWebSocketSession m,
|
|
MonadWebSocketSessionInit m,
|
|
MonadConnectedClientsModify m,
|
|
MonadRoomDataStateRead m,
|
|
MonadBroadcast m
|
|
) =>
|
|
m ()
|
|
wsApp = do
|
|
clientInfo <- getTypedWSMessage
|
|
client <- newClient clientInfo
|
|
addWSClient client
|
|
broadcastUserData
|
|
withCleanUp $ forever $ do
|
|
handleWSAction
|
|
broadcastUserData
|
|
|
|
handleWSAction ::
|
|
( MonadWebSocketSession m,
|
|
MonadConnectedClientsModify m,
|
|
MonadBroadcast m
|
|
) =>
|
|
m ()
|
|
handleWSAction = do
|
|
msg <- getTypedWSMessage
|
|
case msg of
|
|
JoinRoomMessage _ -> do
|
|
joinRoom
|
|
ClientInfoMessage clientInfo -> do
|
|
updateClientName clientInfo
|
|
AllChatMessageIncomingMessage incomingMessage -> do
|
|
broadCastAllChatMessage incomingMessage
|
|
|
|
joinRoom ::
|
|
( MonadConnectedClientsModify m,
|
|
MonadWebSocketSession m
|
|
) =>
|
|
m ()
|
|
joinRoom = do
|
|
clientId <- getSesssionId
|
|
updateWSClient clientId (\c -> c {joinedRoom = True})
|
|
|
|
updateClientName ::
|
|
( MonadWebSocketSession m,
|
|
MonadConnectedClientsModify m
|
|
) =>
|
|
SetClientInfo ->
|
|
m ()
|
|
updateClientName clientInfo = do
|
|
clientId <- getSesssionId
|
|
updateWSClient clientId (\c -> c {name = displayName clientInfo})
|