All Chat Backend

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,

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

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]

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

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

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

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,