From 59dcb2a2e75e1ef5badc20f267f172562c4a6087 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sat, 28 Jan 2023 19:08:33 +0100 Subject: [PATCH] Keep track of rooms & users not in rooms --- backend/src/BroadcastUserData.hs | 40 +++++++++++++++ backend/src/RoomDataHandler.hs | 83 ++++++++++++++++++++++++++++++++ backend/src/Types/RoomsState.hs | 8 +-- backend/src/Types/UsersData.hs | 20 ++++++++ backend/src/Types/WebEnv.hs | 33 +++++++++++++ backend/src/WebServer.hs | 76 ++++++++++++++--------------- backend/src/WebSocket.hs | 28 ++++++++++- 7 files changed, 242 insertions(+), 46 deletions(-) create mode 100644 backend/src/BroadcastUserData.hs create mode 100644 backend/src/RoomDataHandler.hs create mode 100644 backend/src/Types/UsersData.hs create mode 100644 backend/src/Types/WebEnv.hs diff --git a/backend/src/BroadcastUserData.hs b/backend/src/BroadcastUserData.hs new file mode 100644 index 0000000..d62c6d1 --- /dev/null +++ b/backend/src/BroadcastUserData.hs @@ -0,0 +1,40 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Redundant <$>" #-} +{-# HLINT ignore "Redundant $" #-} +{-# HLINT ignore "Redundant bracket" #-} +module BroadcastUserData + ( broadcastUserData, + ) +where + +import ClassyPrelude +import Data.Aeson (encode) +import Types.AppTypes (HasConnectedClientState (..)) +import Types.ConnectionState (Client (..)) +import Types.RoomsState (HasRoomsState (..)) +import Types.UsersData (UsersData (..)) +import WebSocket (broadCastToClients) + +broadcastUserData :: + ( MonadIO m, + HasConnectedClientState env, + HasRoomsState env, + MonadReader env m + ) => + m () +broadcastUserData = do + userWithOutRoom <- getUsersWithoutRoom + roomsData <- (getRoomsState <$> ask) >>= readMVar + let usersData = UsersData {userWithOutRoom = userWithOutRoom, roomsData = roomsData} + broadCastToClients $ (decodeUtf8 . toStrict . encode) usersData + +getUsersWithoutRoom :: + ( MonadIO m, + HasConnectedClientState env, + MonadReader env m + ) => + m [Text] +getUsersWithoutRoom = do + state <- (getConnectedClientState <$> ask) >>= readMVar + return $ map name $ filter (not . joinedRoom) state diff --git a/backend/src/RoomDataHandler.hs b/backend/src/RoomDataHandler.hs new file mode 100644 index 0000000..3f361bf --- /dev/null +++ b/backend/src/RoomDataHandler.hs @@ -0,0 +1,83 @@ +module RoomDataHandler + ( roomDataHandler, + ) +where + +import BroadcastUserData (broadcastUserData) +import ClassyPrelude +import Data.Aeson + ( decode, + decodeStrict, + eitherDecodeStrict, + encode, + ) +import Network.HTTP.Types (status200, status500) +import Network.Wai + ( ResponseReceived, + consumeRequestBodyStrict, + responseLBS, + ) +import Types.AppTypes (HasConnectedClientState) +import Types.RoomsState + ( HasRoomsState, + roomStateDiffers, + updateRoomState, + ) +import Types.WebEnv (HasWebEnv (getRequest), getRespond) +import WebSocket (broadCastToClients) + +roomDataHandler :: + ( MonadIO m, + HasWebEnv env, + HasConnectedClientState env, + MonadReader env m, + HasRoomsState env + ) => + m ResponseReceived +roomDataHandler = do + body <- getRequestBody + case eitherDecodeStrict body of + Left errorMessage -> badRequest errorMessage + Right newState -> do + respond' <- getRespond <$> ask + shouldAct <- roomStateDiffers newState + ( if shouldAct + then + ( do + putStrLn "b1" + updateRoomState newState + broadcastUserData + putStrLn "b2" + ans respond' + ) + else ans respond' + ) + where + ans respond' = liftIO $ respond' $ responseLBS status200 [("Content-Type", "text/plain")] "" + +getRequestBody :: + ( MonadIO m, + HasWebEnv env, + MonadReader env m + ) => + m ByteString +getRequestBody = do + request <- getRequest <$> ask + liftIO $ toStrict <$> consumeRequestBodyStrict request + +badRequest :: + ( MonadIO m, + HasWebEnv env, + MonadReader env m + ) => + String -> + m ResponseReceived +badRequest errorMessage = do + respond' <- getRespond <$> ask + liftIO $ + respond' $ + responseLBS + status500 + [("Content-Type", "text/plain")] + ( fromString ("Bad request. Reason: " <> errorMessage) + ) diff --git a/backend/src/Types/RoomsState.hs b/backend/src/Types/RoomsState.hs index a61bf0b..3d3fe98 100644 --- a/backend/src/Types/RoomsState.hs +++ b/backend/src/Types/RoomsState.hs @@ -27,7 +27,8 @@ updateRoomState :: m () updateRoomState newData = do state <- getRoomsState <$> ask - putMVar state newData + _ <- swapMVar state newData + return () roomStateDiffers :: ( HasRoomsState env, @@ -37,9 +38,8 @@ roomStateDiffers :: RoomsData -> m Bool roomStateDiffers newData = do - state <- getRoomsState <$> ask - current <- readMVar state - return $ eqIgnoreOrdering newData current + currentData <- ask >>= readMVar . getRoomsState + return $ not $ eqIgnoreOrdering newData currentData eqIgnoreOrdering :: (Eq a) => [a] -> [a] -> Bool eqIgnoreOrdering a b = length a == length b && all (`elem` b) a diff --git a/backend/src/Types/UsersData.hs b/backend/src/Types/UsersData.hs new file mode 100644 index 0000000..5d59653 --- /dev/null +++ b/backend/src/Types/UsersData.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Types.UsersData + ( UsersData (..), + ) +where + +import ClassyPrelude +import Data.Aeson (ToJSON) +import Types.RoomData (RoomsData) + +data UsersData = UsersData + { roomsData :: RoomsData, + userWithOutRoom :: UsersWithoutRoom + } + deriving (Generic, Show) + +instance ToJSON UsersData + +type UsersWithoutRoom = [Text] diff --git a/backend/src/Types/WebEnv.hs b/backend/src/Types/WebEnv.hs new file mode 100644 index 0000000..eff4d4d --- /dev/null +++ b/backend/src/Types/WebEnv.hs @@ -0,0 +1,33 @@ +module Types.WebEnv + ( HasWebEnv (..), + WebEnv (..), + ) +where + +import ClassyPrelude +import Network.Wai (Request, Response, ResponseReceived) +import Types.AppTypes + ( Env (..), + HasConnectedClientState (getConnectedClientState), + ) +import Types.RoomsState (HasRoomsState (getRoomsState)) + +class HasWebEnv a where + getRequest :: a -> Request + getRespond :: a -> (Response -> IO ResponseReceived) + +data WebEnv = WebEnv + { appEnv :: Env, + request :: Request, + respond :: Response -> IO ResponseReceived + } + +instance HasConnectedClientState WebEnv where + getConnectedClientState = connectedClientsState . appEnv + +instance HasRoomsState WebEnv where + getRoomsState = roomsState . appEnv + +instance HasWebEnv WebEnv where + getRequest = request + getRespond = respond diff --git a/backend/src/WebServer.hs b/backend/src/WebServer.hs index 1d34237..7d224ba 100644 --- a/backend/src/WebServer.hs +++ b/backend/src/WebServer.hs @@ -1,9 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Redundant bracket" #-} +{-# LANGUAGE LambdaCase #-} module WebServer (runWebServer) where @@ -12,6 +10,7 @@ import Data.Text.Encoding import Network.HTTP.Types import Network.Wai import Network.Wai.Handler.Warp (run) +import RoomDataHandler (roomDataHandler) import Types.AppTypes ( Env (..), HasConnectedClientState (..), @@ -21,6 +20,7 @@ import Types.RoomsState roomStateDiffers, updateRoomState, ) +import Types.WebEnv import WebSocket (broadCastToClients) newtype WebApp env a = WebApp {unWebApp :: env -> IO a} @@ -33,35 +33,15 @@ newtype WebApp env a = WebApp {unWebApp :: env -> IO a} ) via ReaderT env IO -data WebEnv = WebEnv - { appEnv :: Env, - request :: Request, - respond :: Response -> IO ResponseReceived - } - -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) - -instance HasWebEnv WebEnv where - getRequest = request - getRespond = respond - -getRequestBody :: +getRequestPath :: ( MonadIO m, HasWebEnv env, MonadReader env m ) => - m Text -getRequestBody = do + m [Text] +getRequestPath = do request <- getRequest <$> ask - liftIO $ (decodeUtf8 . toStrict) <$> consumeRequestBodyStrict request + return $ pathInfo request app :: ( MonadIO m, @@ -71,19 +51,35 @@ app :: HasRoomsState env ) => m ResponseReceived -app = - do - liftIO $ putStrLn "I've done some IO here" - getRequestBody >>= broadCastToClients - respond' <- getRespond <$> ask - shouldAct <- roomStateDiffers [] - case shouldAct of - True -> do - updateRoomState [] - ans respond' - False -> ans respond' - where - ans respond' = liftIO $ respond' $ responseLBS status200 [("Content-Type", "text/plain")] "" +app = requestPathHandler + +requestPathHandler :: + ( MonadIO m, + HasWebEnv env, + HasConnectedClientState env, + MonadReader env m, + HasRoomsState env + ) => + m ResponseReceived +requestPathHandler = do + getRequestPath >>= \case + ["roomdata"] -> roomDataHandler + _ -> notFound + +notFound :: + ( MonadIO m, + HasWebEnv env, + MonadReader env m + ) => + m ResponseReceived +notFound = do + respond' <- getRespond <$> ask + liftIO $ + respond' $ + responseLBS + status404 + [("Content-Type", "text/plain")] + "404 - Not Found" runWebApp :: ( MonadIO m, diff --git a/backend/src/WebSocket.hs b/backend/src/WebSocket.hs index 3c5f4ac..b7b8fc3 100644 --- a/backend/src/WebSocket.hs +++ b/backend/src/WebSocket.hs @@ -1,6 +1,9 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Redundant bracket" #-} module WebSocket (broadCastToClients, runWebSocketServer) where @@ -61,9 +64,30 @@ disconnectWsClient = do let s' = removeClient clientId s in return s' +joinRoom :: + ( HasWSEnv env, + HasConnectedClientState env, + MonadReader env m, + MonadUnliftIO m + ) => + m () +joinRoom = do + clientId <- getClientId <$> ask + state <- getConnectedClientState <$> ask + modifyMVar_ state $ \s -> + let s' = updateClient clientId (\c -> c {joinedRoom = True}) s + in return s' + removeClient :: UUID -> ConnectedClients -> ConnectedClients 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) + else return client + broadcast :: Text -> ConnectedClients -> IO () broadcast message clients = do putStrLn message @@ -88,7 +112,6 @@ runWSApp = do env <- ask return ( \pending -> do - putStrLn "pending request" conn <- WS.acceptRequest pending uuid <- nextRandom let wsEnv = WSEnv {appEnv = env, connection = conn, clientId = uuid} @@ -105,7 +128,7 @@ newClient :: m Client newClient name = do env <- ask - return $ Client {uuid = getClientId env, name = name, conn = getConn env} + return $ Client {uuid = getClientId env, name = name, conn = getConn env, joinedRoom = False} newtype WSApp env a = WSApp {unWSApp :: env -> IO a} deriving @@ -133,6 +156,7 @@ wsApp = do flip finally disconnectWsClient $ do forever $ do currentMsg <- getMessage + joinRoom putStrLn currentMsg getMessage ::