Broadcasting works

backend/src/BroadcastUserData.hs

@@ -1,8 +1,3 @@
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-
-{-# HLINT ignore "Redundant <$>" #-}
-{-# HLINT ignore "Redundant $" #-}
-{-# HLINT ignore "Redundant bracket" #-}
 module BroadcastUserData
   ( broadcastUserData,
   )
@@ -10,11 +5,11 @@ where
 
 import ClassyPrelude
 import Data.Aeson (encode)
+import Network.WebSockets qualified as WS
 import Types.AppTypes (HasConnectedClientState (..))
-import Types.ConnectionState (Client (..))
+import Types.ConnectionState (Client (..), ConnectedClients)
 import Types.RoomsState (HasRoomsState (..))
 import Types.UsersData (UsersData (..))
-import WebSocket (broadCastToClients)
 
 broadcastUserData ::
   ( MonadIO m,
@@ -24,9 +19,10 @@ broadcastUserData ::
   ) =>
   m ()
 broadcastUserData = do
+  putStrLn "broadcasting"
   userWithOutRoom <- getUsersWithoutRoom
-  roomsData <- (getRoomsState <$> ask) >>= readMVar
-  let usersData = UsersData {userWithOutRoom = userWithOutRoom, roomsData = roomsData}
+  roomsData <- ask >>= readMVar . getRoomsState
+  let usersData = UsersData {usersWithOutRoom = userWithOutRoom, roomsData = roomsData}
   broadCastToClients $ (decodeUtf8 . toStrict . encode) usersData
 
 getUsersWithoutRoom ::
@@ -36,5 +32,21 @@ getUsersWithoutRoom ::
   ) =>
   m [Text]
 getUsersWithoutRoom = do
-  state <- (getConnectedClientState <$> ask) >>= readMVar
+  state <- ask >>= readMVar . getConnectedClientState
   return $ map name $ filter (not . joinedRoom) state
+
+broadcast :: Text -> ConnectedClients -> IO ()
+broadcast message clients = do
+  putStrLn message
+  forM_ clients $ \client -> WS.sendTextData (conn client) message
+
+broadCastToClients ::
+  ( MonadIO m,
+    HasConnectedClientState env,
+    MonadReader env m
+  ) =>
+  Text ->
+  m ()
+broadCastToClients message = do
+  state <- getConnectedClientState <$> ask
+  liftIO $ withMVar state $ \currenState -> broadcast message currenState

backend/src/RoomDataHandler.hs

@@ -75,6 +75,7 @@ badRequest ::
   m ResponseReceived
 badRequest errorMessage = do
   respond' <- getRespond <$> ask
+  liftIO $ print errorMessage
   liftIO $
     respond' $
       responseLBS

backend/src/Types/UsersData.hs

@@ -5,13 +5,13 @@ module Types.UsersData
   )
 where
 
-import ClassyPrelude
-import Data.Aeson (ToJSON)
-import Types.RoomData (RoomsData)
+import           ClassyPrelude
+import           Data.Aeson     (ToJSON)
+import           Types.RoomData (RoomsData)
 
 data UsersData = UsersData
-  { roomsData :: RoomsData,
-    userWithOutRoom :: UsersWithoutRoom
+  { roomsData        :: RoomsData,
+    usersWithOutRoom :: UsersWithoutRoom
   }
   deriving (Generic, Show)
 

backend/src/WebServer.hs

@@ -22,7 +22,6 @@ import Types.RoomsState
     updateRoomState,
   )
 import Types.WebEnv
-import WebSocket (broadCastToClients)
 
 newtype ExceptTApp e a = E {unExceptTApp :: IO (Either e a)}
   deriving

backend/src/WebSocket.hs

@@ -1,27 +1,33 @@
-{-# LANGUAGE DerivingVia          #-}
-{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE UndecidableInstances #-}
 
+module WebSocket (runWebSocketServer) where
 
-module WebSocket (broadCastToClients, runWebSocketServer) where
-
-import           ClassyPrelude
-import           Data.UUID             (UUID)
-import           Data.UUID.V4          (nextRandom)
-import qualified Network.WebSockets    as WS
-import           Types.AppTypes        (Env (connectedClientsState),
-                                        HasConnectedClientState (getConnectedClientState))
-import           Types.ConnectionState (Client (..), ConnectedClients)
+import BroadcastUserData (broadcastUserData)
+import ClassyPrelude
+import Data.UUID (UUID)
+import Data.UUID.V4 (nextRandom)
+import Network.WebSockets qualified as WS
+import Types.AppTypes
+  ( Env (..),
+    HasConnectedClientState (getConnectedClientState),
+  )
+import Types.ConnectionState (Client (..), ConnectedClients)
+import Types.RoomsState (HasRoomsState (..))
 
 data WSEnv = WSEnv
-  { appEnv     :: Env,
+  { appEnv :: Env,
     connection :: WS.Connection,
-    clientId   :: UUID
+    clientId :: UUID
   }
 
 instance HasConnectedClientState WSEnv where
   getConnectedClientState = connectedClientsState . appEnv
 
+instance HasRoomsState WSEnv where
+  getRoomsState = roomsState . appEnv
+
 class HasWSEnv a where
   getConn :: a -> WS.Connection
   getClientId :: a -> UUID
@@ -70,6 +76,7 @@ joinRoom ::
 joinRoom = do
   clientId <- getClientId <$> ask
   state <- getConnectedClientState <$> ask
+  liftIO $ putStrLn "joinedRoom"
   modifyMVar_ state $ \s ->
     let s' = updateClient clientId (\c -> c {joinedRoom = True}) s
      in return s'
@@ -80,15 +87,10 @@ removeClient toRemove = filter ((/= toRemove) . uuid)
 updateClient :: UUID -> (Client -> Client) -> ConnectedClients -> ConnectedClients
 updateClient toUpdate f allClients = do
   client <- allClients
-  if (toUpdate == uuid client)
-    then (return $ f client)
+  if toUpdate == uuid client
+    then return $ f client
     else return client
 
-broadcast :: Text -> ConnectedClients -> IO ()
-broadcast message clients = do
-  putStrLn message
-  forM_ clients $ \client -> WS.sendTextData (conn client) message
-
 runWebSocketServer ::
   ( MonadIO m,
     MonadReader Env m
@@ -111,8 +113,7 @@ runWSApp = do
         conn <- WS.acceptRequest pending
         uuid <- nextRandom
         let wsEnv = WSEnv {appEnv = env, connection = conn, clientId = uuid}
-        WS.withPingThread conn 30 (return ()) $ do
-          unWSApp wsApp wsEnv
+        WS.withPingThread conn 30 (return ()) $ unWSApp wsApp wsEnv
     )
 
 newClient ::
@@ -140,6 +141,7 @@ newtype WSApp env a = WSApp {unWSApp :: env -> IO a}
 wsApp ::
   ( HasWSEnv env,
     HasConnectedClientState env,
+    HasRoomsState env,
     MonadReader env m,
     MonadUnliftIO m
   ) =>
@@ -149,11 +151,12 @@ wsApp = do
   putStrLn msg
   client <- newClient msg
   addWSClient client
-  flip finally disconnectWsClient $ do
-    forever $ do
-      currentMsg <- getMessage
-      joinRoom
-      putStrLn currentMsg
+  broadcastUserData
+  flip finally disconnectWsClient $ forever $ do
+    currentMsg <- getMessage
+    joinRoom
+    broadcastUserData
+    putStrLn currentMsg
 
 getMessage ::
   ( HasWSEnv env,
@@ -164,14 +167,3 @@ getMessage ::
 getMessage = do
   conn' <- getConn <$> ask
   liftIO $ WS.receiveData conn'
-
-broadCastToClients ::
-  ( MonadIO m,
-    HasConnectedClientState env,
-    MonadReader env m
-  ) =>
-  Text ->
-  m ()
-broadCastToClients message = do
-  state <- getConnectedClientState <$> ask
-  liftIO $ withMVar state $ \currenState -> broadcast message currenState