diff --git a/backend/src/BroadcastUserData.hs b/backend/src/BroadcastUserData.hs index d62c6d1..629e37b 100644 --- a/backend/src/BroadcastUserData.hs +++ b/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 diff --git a/backend/src/RoomDataHandler.hs b/backend/src/RoomDataHandler.hs index 303131b..2fd2732 100644 --- a/backend/src/RoomDataHandler.hs +++ b/backend/src/RoomDataHandler.hs @@ -75,6 +75,7 @@ badRequest :: m ResponseReceived badRequest errorMessage = do respond' <- getRespond <$> ask + liftIO $ print errorMessage liftIO $ respond' $ responseLBS diff --git a/backend/src/Types/UsersData.hs b/backend/src/Types/UsersData.hs index 5d59653..04ffe1a 100644 --- a/backend/src/Types/UsersData.hs +++ b/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) diff --git a/backend/src/WebServer.hs b/backend/src/WebServer.hs index 4e0cba4..9ed68b0 100644 --- a/backend/src/WebServer.hs +++ b/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 diff --git a/backend/src/WebSocket.hs b/backend/src/WebSocket.hs index d80d740..dde6a6a 100644 --- a/backend/src/WebSocket.hs +++ b/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