From cf1c7625be085efe47026b13d82dcca651ac80af Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sat, 8 Apr 2023 15:57:33 +0200 Subject: [PATCH] All Chat Backend --- backend/jitsi-rooms.cabal | 5 ++-- backend/package.yaml | 10 -------- backend/src/BroadcastUserData.hs | 21 ++++++++-------- backend/src/Types/User.hs | 21 ++++++++++++++++ backend/src/Types/UsersData.hs | 11 ++++---- .../WebSocketMessages/WebSocketMessages.hs | 25 ++++++++++++++++--- backend/src/WebSocket/AllChat.hs | 18 +++++++++++++ .../src/WebSocket/MonadWebSocketSession.hs | 7 +++++- backend/src/WebSocket/WSApp.hs | 6 ++++- backend/test/Spec.hs | 2 -- 10 files changed, 90 insertions(+), 36 deletions(-) create mode 100644 backend/src/Types/User.hs create mode 100644 backend/src/WebSocket/AllChat.hs diff --git a/backend/jitsi-rooms.cabal b/backend/jitsi-rooms.cabal index e789efa..13ee870 100644 --- a/backend/jitsi-rooms.cabal +++ b/backend/jitsi-rooms.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.1. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack @@ -35,10 +35,12 @@ library Types.Participant Types.RoomData Types.RoomsState + Types.User Types.UsersData Types.WebEnv Types.WebSocketMessages.WebSocketMessages WebServer + WebSocket.AllChat WebSocket.Messages WebSocket.MonadWebSocketSession WebSocket.Server @@ -90,4 +92,3 @@ executable jitsi-rooms-exe , warp , websockets default-language: Haskell2010 - diff --git a/backend/package.yaml b/backend/package.yaml index 2444dbe..d35a14c 100644 --- a/backend/package.yaml +++ b/backend/package.yaml @@ -58,14 +58,4 @@ executables: dependencies: - jitsi-rooms -tests: - jitsi-rooms-test: - main: Spec.hs - source-dirs: test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - jitsi-rooms default-extensions: NoImplicitPrelude,OverloadedStrings,ImportQualifiedPost diff --git a/backend/src/BroadcastUserData.hs b/backend/src/BroadcastUserData.hs index b1a0a54..bc00f48 100644 --- a/backend/src/BroadcastUserData.hs +++ b/backend/src/BroadcastUserData.hs @@ -5,15 +5,14 @@ module BroadcastUserData ) where -import ClassyPrelude -import Data.Aeson (encode) -import qualified Network.WebSockets as WS -import State.ConnectedClientsState (MonadConnectedClientsRead (getConnctedClients)) -import State.RoomDataState (MonadRoomDataStateRead (getRoomDataState)) -import Types.AppTypes (HasConnectedClientState (..)) -import Types.ConnectionState (Client (..), ConnectedClients) -import Types.RoomsState (HasRoomsState (..)) -import Types.UsersData (UsersData (..)) +import ClassyPrelude +import Data.Aeson (encode) +import Network.WebSockets qualified as WS +import State.ConnectedClientsState (MonadConnectedClientsRead (getConnctedClients)) +import State.RoomDataState (MonadRoomDataStateRead (getRoomDataState)) +import Types.ConnectionState (Client (..), ConnectedClients) +import Types.User (User, clientToUser) +import Types.UsersData (UsersData (..)) class (Monad m, MonadConnectedClientsRead m) => MonadBroadcast m where broadCastToClients :: Text -> m () @@ -32,8 +31,8 @@ broadcastUserData = do getUsersWithoutRoom :: ( MonadConnectedClientsRead m ) => - m [Text] -getUsersWithoutRoom = map name . filter (not . joinedRoom) <$> getConnctedClients + m [User] +getUsersWithoutRoom = map clientToUser . filter (not . joinedRoom) <$> getConnctedClients broadCastToClientsGeneric :: ( MonadIO m, diff --git a/backend/src/Types/User.hs b/backend/src/Types/User.hs new file mode 100644 index 0000000..f773587 --- /dev/null +++ b/backend/src/Types/User.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Types.User (User, clientToUser) where + +import ClassyPrelude +import Data.Aeson (FromJSON, ToJSON) +import Data.UUID (UUID) +import Types.ConnectionState qualified as C + +data User = User + { uuid :: UUID, + name :: Text + } + deriving (Generic, Show, Eq) + +clientToUser :: C.Client -> User +clientToUser C.Client {C.uuid = userUuid, C.name = userName, C.joinedRoom = _, C.conn = _} = User userUuid userName + +instance ToJSON User + +instance FromJSON User diff --git a/backend/src/Types/UsersData.hs b/backend/src/Types/UsersData.hs index 04ffe1a..fa8ad52 100644 --- a/backend/src/Types/UsersData.hs +++ b/backend/src/Types/UsersData.hs @@ -5,16 +5,17 @@ module Types.UsersData ) where -import ClassyPrelude -import Data.Aeson (ToJSON) -import Types.RoomData (RoomsData) +import ClassyPrelude +import Data.Aeson (ToJSON) +import Types.RoomData (RoomsData) +import Types.User (User) data UsersData = UsersData - { roomsData :: RoomsData, + { roomsData :: RoomsData, usersWithOutRoom :: UsersWithoutRoom } deriving (Generic, Show) instance ToJSON UsersData -type UsersWithoutRoom = [Text] +type UsersWithoutRoom = [User] diff --git a/backend/src/Types/WebSocketMessages/WebSocketMessages.hs b/backend/src/Types/WebSocketMessages/WebSocketMessages.hs index 9269cb2..30049ba 100644 --- a/backend/src/Types/WebSocketMessages/WebSocketMessages.hs +++ b/backend/src/Types/WebSocketMessages/WebSocketMessages.hs @@ -1,9 +1,12 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} module Types.WebSocketMessages.WebSocketMessages ( WebSocketMessage (..), SetClientInfo (..), JoinRoom (..), + AllChatMessageIncoming (..), + AllChatMessageOutgoing (..), ) where @@ -12,14 +15,13 @@ import Data.Aeson ( FromJSON (parseJSON), Options (sumEncoding), SumEncoding (..), - decode, + ToJSON, defaultOptions, genericParseJSON, - withObject, - (.:), ) +import Types.User (User) -data WebSocketMessage = ClientInfoMessage SetClientInfo | JoinRoomMessage JoinRoom +data WebSocketMessage = ClientInfoMessage SetClientInfo | JoinRoomMessage JoinRoom | AllChatMessageIncomingMessage AllChatMessageIncoming deriving (Generic) instance FromJSON WebSocketMessage where @@ -38,3 +40,18 @@ data JoinRoom = JoinRoom deriving (Generic, Show) instance FromJSON JoinRoom + +data AllChatMessageIncoming = AllChatMessageIncoming + { content :: Text + } + deriving (Generic, Show) + +instance FromJSON AllChatMessageIncoming + +data AllChatMessageOutgoing = AllChatMessageOutgoing + { content :: Text, + sender :: User + } + deriving (Generic, Show) + +instance ToJSON AllChatMessageOutgoing diff --git a/backend/src/WebSocket/AllChat.hs b/backend/src/WebSocket/AllChat.hs new file mode 100644 index 0000000..fce86ef --- /dev/null +++ b/backend/src/WebSocket/AllChat.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE LambdaCase #-} + +module WebSocket.AllChat (broadCastAllChatMessage) where + +import BroadcastUserData (MonadBroadcast (..)) +import ClassyPrelude +import Data.Aeson (encode) +import Types.User (clientToUser) +import Types.WebSocketMessages.WebSocketMessages (AllChatMessageIncoming (..), AllChatMessageOutgoing (AllChatMessageOutgoing)) +import WebSocket.MonadWebSocketSession (MonadWebSocketSession (getClient)) + +broadCastAllChatMessage :: (MonadBroadcast m, MonadWebSocketSession m) => AllChatMessageIncoming -> m () +broadCastAllChatMessage AllChatMessageIncoming {content = message} = do + getClient >>= \case + Nothing -> return () + Just client -> do + let broadCastValue = AllChatMessageOutgoing message (clientToUser client) + broadCastToClients $ (decodeUtf8 . toStrict . encode) broadCastValue diff --git a/backend/src/WebSocket/MonadWebSocketSession.hs b/backend/src/WebSocket/MonadWebSocketSession.hs index 7893af5..8ef1698 100644 --- a/backend/src/WebSocket/MonadWebSocketSession.hs +++ b/backend/src/WebSocket/MonadWebSocketSession.hs @@ -15,6 +15,7 @@ import Data.Aeson import Data.UUID (UUID) import State.ConnectedClientsState ( MonadConnectedClientsModify, + MonadConnectedClientsRead (getConnctedClients), removeWSClient, ) import State.RoomDataState (MonadRoomDataStateRead) @@ -23,9 +24,10 @@ import Types.WebSocketMessages.WebSocketMessages (SetClientInfo (..)) import WebSocket.Messages import WebSocket.WSReaderTApp -class Monad m => MonadWebSocketSession m where +class MonadConnectedClientsRead m => MonadWebSocketSession m where getTypedWSMessage :: FromJSON a => m a getSesssionId :: m UUID + getClient :: m (Maybe Client) instance MonadWebSocketSession (WSApp WSEnv) where getTypedWSMessage = do @@ -36,6 +38,9 @@ instance MonadWebSocketSession (WSApp WSEnv) where sendMessage $ "Bad message: " <> pack err getTypedWSMessage getSesssionId = getClientId <$> ask + getClient = do + id' <- getSesssionId + find ((== id') . uuid) <$> getConnctedClients class (Monad m) => MonadWebSocketSessionInit m where newClient :: SetClientInfo -> m Client diff --git a/backend/src/WebSocket/WSApp.hs b/backend/src/WebSocket/WSApp.hs index d2eb9f7..aea7ad3 100644 --- a/backend/src/WebSocket/WSApp.hs +++ b/backend/src/WebSocket/WSApp.hs @@ -13,6 +13,7 @@ import Types.WebSocketMessages.WebSocketMessages ( SetClientInfo (displayName), WebSocketMessage (..), ) +import WebSocket.AllChat (broadCastAllChatMessage) import WebSocket.MonadWebSocketSession import WebSocket.WSReaderTApp @@ -35,7 +36,8 @@ wsApp = do handleWSAction :: ( MonadWebSocketSession m, - MonadConnectedClientsModify m + MonadConnectedClientsModify m, + MonadBroadcast m ) => m () handleWSAction = do @@ -45,6 +47,8 @@ handleWSAction = do joinRoom ClientInfoMessage clientInfo -> do updateClientName clientInfo + AllChatMessageIncomingMessage incomingMessage -> do + broadCastAllChatMessage incomingMessage joinRoom :: ( MonadConnectedClientsModify m, diff --git a/backend/test/Spec.hs b/backend/test/Spec.hs index cd4753f..e69de29 100644 --- a/backend/test/Spec.hs +++ b/backend/test/Spec.hs @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented"