Keep track of rooms & users not in rooms

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

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)
+        )

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
+  currentData <- ask >>= readMVar . getRoomsState
-  current <- readMVar state
+  return $ not $ eqIgnoreOrdering newData currentData
-  return $ eqIgnoreOrdering newData current
 
 eqIgnoreOrdering :: (Eq a) => [a] -> [a] -> Bool
 eqIgnoreOrdering a b = length a == length b && all (`elem` b) a

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]

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

backend/src/WebServer.hs

@@ -1,9 +1,7 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# LANGUAGE LambdaCase #-}
-
-{-# HLINT ignore "Redundant bracket" #-}
 
 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
+getRequestPath ::
-  { 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 ::
   ( MonadIO m,
     HasWebEnv env,
     MonadReader env m
   ) =>
-  m Text
+  m [Text]
-getRequestBody = do
+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 =
+app = requestPathHandler
-  do
+
-    liftIO $ putStrLn "I've done some IO here"
+requestPathHandler ::
-    getRequestBody >>= broadCastToClients
+  ( MonadIO m,
-    respond' <- getRespond <$> ask
+    HasWebEnv env,
-    shouldAct <- roomStateDiffers []
+    HasConnectedClientState env,
-    case shouldAct of
+    MonadReader env m,
-      True -> do
+    HasRoomsState env
-        updateRoomState []
+  ) =>
-        ans respond'
+  m ResponseReceived
-      False -> ans respond'
+requestPathHandler = do
-  where
+  getRequestPath >>= \case
-    ans respond' = liftIO $ respond' $ responseLBS status200 [("Content-Type", "text/plain")] ""
+    ["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,

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 ::