From f0e0d93b05cc67106183414c320a13dcf173ef37 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Fri, 27 Jan 2023 19:53:34 +0100 Subject: [PATCH] Start with keeping roomsstate --- backend/src/Lib.hs | 10 ++- backend/src/Types/AppTypes.hs | 10 ++- backend/src/Types/ConnectionState.hs | 11 ++- backend/src/Types/Participant.hs | 2 +- backend/src/Types/RoomData.hs | 6 +- backend/src/Types/RoomsState.hs | 45 ++++++++++++ backend/src/WebServer.hs | 58 +++++++++------- backend/src/WebSocket.hs | 100 ++++++++++++++------------- 8 files changed, 161 insertions(+), 81 deletions(-) create mode 100644 backend/src/Types/RoomsState.hs diff --git a/backend/src/Lib.hs b/backend/src/Lib.hs index 630ed46..9945c0a 100644 --- a/backend/src/Lib.hs +++ b/backend/src/Lib.hs @@ -7,17 +7,21 @@ where import ClassyPrelude import Types.AppTypes +import Types.ConnectionState (initConnectionsState) +import Types.RoomsState (initRoomsState) import WebServer (runWebServer) -import WebSocket (initMVarState, runWebSocketServer) +import WebSocket (runWebSocketServer) runBothServers :: IO () runBothServers = do - connectedClientsState <- initMVarState + connectedClientsState <- initConnectionsState + roomsState <- initRoomsState let env = Env { connectedClientsState = connectedClientsState, - profile = Dev + profile = Dev, + roomsState = roomsState } _ <- concurrently (unApp runWebSocketServer env) (unApp runWebServer env) diff --git a/backend/src/Types/AppTypes.hs b/backend/src/Types/AppTypes.hs index 0da4ceb..49338c5 100644 --- a/backend/src/Types/AppTypes.hs +++ b/backend/src/Types/AppTypes.hs @@ -1,14 +1,19 @@ {-# LANGUAGE DerivingVia #-} -module Types.AppTypes (Env (..), App (..), getConnectedClientState, HasConnectedClientState, App, AppProfile (Prod, Dev)) where +module Types.AppTypes (Env (..), App (..), getConnectedClientState, HasConnectedClientState, AppProfile (Prod, Dev)) where import ClassyPrelude import Types.ConnectionState (ConnectedClientsState) +import Types.RoomsState + ( HasRoomsState (getRoomsState), + RoomsState, + ) data AppProfile = Prod | Dev data Env = Env { connectedClientsState :: ConnectedClientsState, + roomsState :: RoomsState, profile :: AppProfile } @@ -18,6 +23,9 @@ class HasConnectedClientState a where instance HasConnectedClientState Env where getConnectedClientState = connectedClientsState +instance HasRoomsState Env where + getRoomsState = roomsState + newtype App env a = App {unApp :: env -> IO a} deriving ( Functor, diff --git a/backend/src/Types/ConnectionState.hs b/backend/src/Types/ConnectionState.hs index 00c19f1..a787c9e 100644 --- a/backend/src/Types/ConnectionState.hs +++ b/backend/src/Types/ConnectionState.hs @@ -1,8 +1,8 @@ module Types.ConnectionState ( Client (..), - Client, ConnectedClientsState, ConnectedClients, + initConnectionsState, ) where @@ -13,9 +13,16 @@ import Network.WebSockets qualified as WS data Client = Client { uuid :: UUID, name :: Text, - conn :: WS.Connection + conn :: WS.Connection, + joinedRoom :: Bool } type ConnectedClientsState = MVar ConnectedClients type ConnectedClients = [Client] + +initConnectionsState :: IO ConnectedClientsState +initConnectionsState = newMVar newConnectedClients + +newConnectedClients :: ConnectedClients +newConnectedClients = [] diff --git a/backend/src/Types/Participant.hs b/backend/src/Types/Participant.hs index 7c41575..70dbbce 100644 --- a/backend/src/Types/Participant.hs +++ b/backend/src/Types/Participant.hs @@ -11,7 +11,7 @@ data Participant = Participant displayName :: Text, avatarURL :: Text } - deriving (Generic, Show) + deriving (Generic, Show, Eq) instance ToJSON Participant diff --git a/backend/src/Types/RoomData.hs b/backend/src/Types/RoomData.hs index 6de972f..6186ae1 100644 --- a/backend/src/Types/RoomData.hs +++ b/backend/src/Types/RoomData.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} -module Types.RoomData (RoomData) where +module Types.RoomData (RoomData, RoomsData) where import ClassyPrelude import Data.Aeson (FromJSON, ToJSON) @@ -10,10 +10,12 @@ data RoomData = RoomData { roomName :: RoomName, participants :: [Participant] } - deriving (Generic, Show) + deriving (Generic, Show, Eq) type RoomName = Text +type RoomsData = [RoomData] + instance ToJSON RoomData instance FromJSON RoomData diff --git a/backend/src/Types/RoomsState.hs b/backend/src/Types/RoomsState.hs new file mode 100644 index 0000000..a61bf0b --- /dev/null +++ b/backend/src/Types/RoomsState.hs @@ -0,0 +1,45 @@ +module Types.RoomsState + ( RoomsState, + initRoomsState, + HasRoomsState (..), + roomStateDiffers, + updateRoomState, + ) +where + +import ClassyPrelude +import Types.RoomData (RoomsData) + +type RoomsState = MVar RoomsData + +initRoomsState :: IO RoomsState +initRoomsState = newMVar [] + +class HasRoomsState a where + getRoomsState :: a -> RoomsState + +updateRoomState :: + ( HasRoomsState env, + MonadIO m, + MonadReader env m + ) => + RoomsData -> + m () +updateRoomState newData = do + state <- getRoomsState <$> ask + putMVar state newData + +roomStateDiffers :: + ( HasRoomsState env, + MonadIO m, + MonadReader env m + ) => + RoomsData -> + m Bool +roomStateDiffers newData = do + state <- getRoomsState <$> ask + current <- readMVar state + return $ eqIgnoreOrdering newData current + +eqIgnoreOrdering :: (Eq a) => [a] -> [a] -> Bool +eqIgnoreOrdering a b = length a == length b && all (`elem` b) a diff --git a/backend/src/WebServer.hs b/backend/src/WebServer.hs index fc66aa9..1d34237 100644 --- a/backend/src/WebServer.hs +++ b/backend/src/WebServer.hs @@ -1,19 +1,27 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Redundant bracket" #-} module WebServer (runWebServer) where --- import AppTypes (HasConnectedClientState) -import ClassyPrelude hiding (decodeUtf8) -import Data.Text.Encoding -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Handler.Warp (run) -import Types.AppTypes (Env (connectedClientsState), - HasConnectedClientState (..), unApp) -import WebSocket (broadcast) +import ClassyPrelude hiding (decodeUtf8) +import Data.Text.Encoding +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Handler.Warp (run) +import Types.AppTypes + ( Env (..), + HasConnectedClientState (..), + ) +import Types.RoomsState + ( HasRoomsState (getRoomsState), + roomStateDiffers, + updateRoomState, + ) +import WebSocket (broadCastToClients) newtype WebApp env a = WebApp {unWebApp :: env -> IO a} deriving @@ -26,7 +34,7 @@ newtype WebApp env a = WebApp {unWebApp :: env -> IO a} via ReaderT env IO data WebEnv = WebEnv - { appEnv :: Env, + { appEnv :: Env, request :: Request, respond :: Response -> IO ResponseReceived } @@ -34,6 +42,9 @@ data WebEnv = WebEnv instance HasConnectedClientState WebEnv where getConnectedClientState = connectedClientsState . appEnv +instance HasRoomsState WebEnv where + getRoomsState = roomsState . appEnv + class HasWebEnv a where getRequest :: a -> Request getRespond :: a -> (Response -> IO ResponseReceived) @@ -42,17 +53,6 @@ instance HasWebEnv WebEnv where getRequest = request getRespond = respond -broadCastToClients :: - ( MonadIO m, - HasConnectedClientState env, - MonadReader env m - ) => - Text -> - m () -broadCastToClients message = do - state <- getConnectedClientState <$> ask - liftIO $ withMVar state $ \currenState -> broadcast message currenState - getRequestBody :: ( MonadIO m, HasWebEnv env, @@ -67,7 +67,8 @@ app :: ( MonadIO m, HasWebEnv env, HasConnectedClientState env, - MonadReader env m + MonadReader env m, + HasRoomsState env ) => m ResponseReceived app = @@ -75,7 +76,14 @@ app = liftIO $ putStrLn "I've done some IO here" getRequestBody >>= broadCastToClients respond' <- getRespond <$> ask - liftIO $ respond' $ responseLBS status200 [("Content-Type", "text/plain")] "" + shouldAct <- roomStateDiffers [] + case shouldAct of + True -> do + updateRoomState [] + ans respond' + False -> ans respond' + where + ans respond' = liftIO $ respond' $ responseLBS status200 [("Content-Type", "text/plain")] "" runWebApp :: ( MonadIO m, diff --git a/backend/src/WebSocket.hs b/backend/src/WebSocket.hs index 856428d..3c5f4ac 100644 --- a/backend/src/WebSocket.hs +++ b/backend/src/WebSocket.hs @@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -module WebSocket (broadcast, initMVarState, runWebSocketServer) where +module WebSocket (broadCastToClients, runWebSocketServer) where import ClassyPrelude import Data.UUID (UUID) @@ -12,29 +12,63 @@ import Types.AppTypes ( Env (connectedClientsState), HasConnectedClientState (getConnectedClientState), ) -import Types.ConnectionState - ( Client (..), - ConnectedClients, - ConnectedClientsState, - ) +import Types.ConnectionState (Client (..), ConnectedClients) + +data WSEnv = WSEnv + { appEnv :: Env, + connection :: WS.Connection, + clientId :: UUID + } + +instance HasConnectedClientState WSEnv where + getConnectedClientState = connectedClientsState . appEnv + +class HasWSEnv a where + getConn :: a -> WS.Connection + getClientId :: a -> UUID + +instance HasWSEnv WSEnv where + getConn = connection + getClientId = clientId + +addWSClient :: + ( HasConnectedClientState env, + MonadReader env m, + MonadUnliftIO m + ) => + Client -> + m () +addWSClient client = do + state <- getConnectedClientState <$> ask + modifyMVar_ state $ \s -> do + let s' = addClient client s + return s' addClient :: Client -> ConnectedClients -> ConnectedClients addClient client clients = client : clients +disconnectWsClient :: + ( HasWSEnv env, + HasConnectedClientState env, + MonadReader env m, + MonadUnliftIO m + ) => + m () +disconnectWsClient = do + clientId <- getClientId <$> ask + state <- getConnectedClientState <$> ask + modifyMVar_ state $ \s -> + let s' = removeClient clientId s + in return s' + removeClient :: UUID -> ConnectedClients -> ConnectedClients removeClient toRemove = filter ((/= toRemove) . uuid) -newConnectedClients :: ConnectedClients -newConnectedClients = [] - broadcast :: Text -> ConnectedClients -> IO () broadcast message clients = do putStrLn message forM_ clients $ \client -> WS.sendTextData (conn client) message -initMVarState :: IO (MVar ConnectedClients) -initMVarState = newMVar newConnectedClients - runWebSocketServer :: ( MonadIO m, MonadReader Env m @@ -42,9 +76,8 @@ runWebSocketServer :: m () runWebSocketServer = do putStrLn "Websocket up at 127.0.0.1:9160" - state <- getConnectedClientState <$> ask - wsApp <- runWSApp - liftIO $ WS.runServer "127.0.0.1" 9160 $ wsApp + wsApp' <- runWSApp + liftIO $ WS.runServer "127.0.0.1" 9160 wsApp' runWSApp :: ( MonadIO m, @@ -85,9 +118,6 @@ newtype WSApp env a = WSApp {unWSApp :: env -> IO a} ) via ReaderT env IO --- instance MonadBaseControl IO m => MonadBaseControl IO (WSApp env n) --- where - wsApp :: ( HasWSEnv env, HasConnectedClientState env, @@ -96,13 +126,10 @@ wsApp :: ) => m () wsApp = do - state <- getConnectedClientState <$> ask msg <- getMessage putStrLn msg client <- newClient msg - modifyMVar_ state $ \s -> do - let s' = addClient client s - return s' + addWSClient client flip finally disconnectWsClient $ do forever $ do currentMsg <- getMessage @@ -118,34 +145,13 @@ getMessage = do conn' <- getConn <$> ask liftIO $ WS.receiveData conn' -disconnectWsClient :: +broadCastToClients :: ( MonadIO m, - HasWSEnv env, HasConnectedClientState env, MonadReader env m ) => + Text -> m () -disconnectWsClient = do - clientId <- getClientId <$> ask +broadCastToClients message = do state <- getConnectedClientState <$> ask - liftIO $ modifyMVar state $ \s -> - let s' = removeClient clientId s - in return - (s', ()) - -data WSEnv = WSEnv - { appEnv :: Env, - connection :: WS.Connection, - clientId :: UUID - } - -instance HasConnectedClientState WSEnv where - getConnectedClientState = connectedClientsState . appEnv - -class HasWSEnv a where - getConn :: a -> WS.Connection - getClientId :: a -> UUID - -instance HasWSEnv WSEnv where - getConn = connection - getClientId = clientId + liftIO $ withMVar state $ \currenState -> broadcast message currenState