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
+  roomsData <- ask >>= readMVar . getRoomsState
-  let usersData = UsersData {userWithOutRoom = userWithOutRoom, roomsData = roomsData}
+  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

@@ -11,7 +11,7 @@ import Types.RoomData (RoomsData)
 
 data UsersData = UsersData
   { roomsData        :: RoomsData,
-    userWithOutRoom :: UsersWithoutRoom
+    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

@@ -2,16 +2,19 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE UndecidableInstances #-}
 
+module WebSocket (runWebSocketServer) where
 
-module WebSocket (broadCastToClients, runWebSocketServer) where
+import BroadcastUserData (broadcastUserData)
-
 import ClassyPrelude
 import Data.UUID (UUID)
 import Data.UUID.V4 (nextRandom)
-import qualified Network.WebSockets    as WS
+import Network.WebSockets qualified as WS
-import           Types.AppTypes        (Env (connectedClientsState),
+import Types.AppTypes
-                                        HasConnectedClientState (getConnectedClientState))
+  ( Env (..),
+    HasConnectedClientState (getConnectedClientState),
+  )
 import Types.ConnectionState (Client (..), ConnectedClients)
+import Types.RoomsState (HasRoomsState (..))
 
 data WSEnv = WSEnv
   { appEnv :: Env,
@@ -22,6 +25,9 @@ data WSEnv = WSEnv
 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)
+  if toUpdate == uuid client
-    then (return $ f 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
+        WS.withPingThread conn 30 (return ()) $ unWSApp wsApp wsEnv
-          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,10 +151,11 @@ wsApp = do
   putStrLn msg
   client <- newClient msg
   addWSClient client
-  flip finally disconnectWsClient $ do
+  broadcastUserData
-    forever $ do
+  flip finally disconnectWsClient $ forever $ do
     currentMsg <- getMessage
     joinRoom
+    broadcastUserData
     putStrLn currentMsg
 
 getMessage ::
@@ -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