Start with keeping roomsstate

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)

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,

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 = []

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
 

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

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

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,

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