diff --git a/backend/src/Types/WebSocketMessages/WebSocketMessages.hs b/backend/src/Types/WebSocketMessages/WebSocketMessages.hs new file mode 100644 index 0000000..9269cb2 --- /dev/null +++ b/backend/src/Types/WebSocketMessages/WebSocketMessages.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Types.WebSocketMessages.WebSocketMessages + ( WebSocketMessage (..), + SetClientInfo (..), + JoinRoom (..), + ) +where + +import ClassyPrelude +import Data.Aeson + ( FromJSON (parseJSON), + Options (sumEncoding), + SumEncoding (..), + decode, + defaultOptions, + genericParseJSON, + withObject, + (.:), + ) + +data WebSocketMessage = ClientInfoMessage SetClientInfo | JoinRoomMessage JoinRoom + deriving (Generic) + +instance FromJSON WebSocketMessage where + parseJSON = genericParseJSON defaultOptions {sumEncoding = UntaggedValue} + +data SetClientInfo = SetClientInfo + { displayName :: Text + } + deriving (Generic, Show) + +instance FromJSON SetClientInfo + +data JoinRoom = JoinRoom + { roomName :: Text + } + deriving (Generic, Show) + +instance FromJSON JoinRoom diff --git a/backend/src/WebServer.hs b/backend/src/WebServer.hs index 9ed68b0..55abc0e 100644 --- a/backend/src/WebServer.hs +++ b/backend/src/WebServer.hs @@ -7,7 +7,6 @@ module WebServer (runWebServer) where import ClassyPrelude hiding (decodeUtf8) import Control.Monad.Except -import Data.Text.Encoding import Network.HTTP.Types import Network.Wai import Network.Wai.Handler.Warp (run) @@ -44,8 +43,6 @@ newtype WebApp env a = WebApp {unWebApp :: env -> IO (Either ResponseReceived a) ) via ReaderT env (ExceptTApp ResponseReceived) --- via ExceptT ResponseReceived (ReaderT env IO) - getRequestPath :: ( MonadIO m, HasWebEnv env, diff --git a/backend/src/WebSocket.hs b/backend/src/WebSocket.hs index dde6a6a..2065dcb 100644 --- a/backend/src/WebSocket.hs +++ b/backend/src/WebSocket.hs @@ -1,11 +1,13 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} module WebSocket (runWebSocketServer) where import BroadcastUserData (broadcastUserData) import ClassyPrelude +import Data.Aeson import Data.UUID (UUID) import Data.UUID.V4 (nextRandom) import Network.WebSockets qualified as WS @@ -13,8 +15,15 @@ import Types.AppTypes ( Env (..), HasConnectedClientState (getConnectedClientState), ) -import Types.ConnectionState (Client (..), ConnectedClients) +import Types.ConnectionState + ( Client (..), + ConnectedClients, + ) import Types.RoomsState (HasRoomsState (..)) +import Types.WebSocketMessages.WebSocketMessages + ( SetClientInfo (displayName), + WebSocketMessage (..), + ) data WSEnv = WSEnv { appEnv :: Env, @@ -81,6 +90,21 @@ joinRoom = do let s' = updateClient clientId (\c -> c {joinedRoom = True}) s in return s' +updateClientName :: + ( HasWSEnv env, + HasConnectedClientState env, + MonadReader env m, + MonadUnliftIO m + ) => + SetClientInfo -> + m () +updateClientName clientInfo = do + clientId <- getClientId <$> ask + state <- getConnectedClientState <$> ask + modifyMVar_ state $ \s -> + let s' = updateClient clientId (\c -> c {name = displayName clientInfo}) s + in return s' + removeClient :: UUID -> ConnectedClients -> ConnectedClients removeClient toRemove = filter ((/= toRemove) . uuid) @@ -121,11 +145,11 @@ newClient :: HasWSEnv env, MonadReader env m ) => - Text -> + SetClientInfo -> m Client -newClient name = do +newClient clientInfo = do env <- ask - return $ Client {uuid = getClientId env, name = name, conn = getConn env, joinedRoom = False} + return $ Client {uuid = getClientId env, name = displayName clientInfo, conn = getConn env, joinedRoom = False} newtype WSApp env a = WSApp {unWSApp :: env -> IO a} deriving @@ -138,25 +162,54 @@ newtype WSApp env a = WSApp {unWSApp :: env -> IO a} ) via ReaderT env IO +class Monad m => MonadWebSocket m where + getTypedWSMessage :: FromJSON a => m a + +instance MonadWebSocket (WSApp WSEnv) where + getTypedWSMessage = do + msg <- getMessage + case eitherDecodeStrict $ encodeUtf8 msg of + Right a -> return a + Left err -> do + sendMessage $ "Bad message: " <> pack err + getTypedWSMessage + wsApp :: ( HasWSEnv env, HasConnectedClientState env, HasRoomsState env, MonadReader env m, - MonadUnliftIO m + MonadUnliftIO m, + MonadWebSocket m ) => m () wsApp = do - msg <- getMessage - putStrLn msg + msg <- getTypedWSMessage + print msg client <- newClient msg addWSClient client broadcastUserData flip finally disconnectWsClient $ forever $ do - currentMsg <- getMessage - joinRoom + handleWSAction broadcastUserData - putStrLn currentMsg + +handleWSAction :: + ( HasWSEnv env, + HasConnectedClientState env, + HasRoomsState env, + MonadReader env m, + MonadUnliftIO m, + MonadWebSocket m + ) => + m () +handleWSAction = do + msg <- getTypedWSMessage + case msg of + JoinRoomMessage _ -> do + joinRoom + return () + ClientInfoMessage clientInfo -> do + updateClientName clientInfo getMessage :: ( HasWSEnv env, @@ -167,3 +220,14 @@ getMessage :: getMessage = do conn' <- getConn <$> ask liftIO $ WS.receiveData conn' + +sendMessage :: + ( HasWSEnv env, + MonadIO m, + MonadReader env m + ) => + Text -> + m () +sendMessage msg = do + conn' <- getConn <$> ask + liftIO $ WS.sendTextData conn' msg