All Chat Backend

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
-

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

backend/src/BroadcastUserData.hs

@@ -7,12 +7,11 @@ where
 
 import ClassyPrelude
 import Data.Aeson (encode)
-import qualified Network.WebSockets          as WS
+import Network.WebSockets qualified 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.User (User, clientToUser)
 import Types.UsersData (UsersData (..))
 
 class (Monad m, MonadConnectedClientsRead m) => MonadBroadcast m where
@@ -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

@@ -8,6 +8,7 @@ where
 import ClassyPrelude
 import Data.Aeson (ToJSON)
 import Types.RoomData (RoomsData)
+import Types.User (User)
 
 data UsersData = UsersData
   { roomsData :: RoomsData,
@@ -17,4 +18,4 @@ data UsersData = UsersData
 
 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,

backend/test/Spec.hs

@@ -1,2 +0,0 @@
-main :: IO ()
-main = putStrLn "Test suite not yet implemented"