Keep state in monad

backend/src/State/ConnectedClientsState.hs

@@ -0,0 +1,89 @@
+module State.ConnectedClientsState
+  ( MonadConnectedClientsModify (..),
+    MonadConnectedClientsRead (..),
+    addWSClientGeneric,
+    updateWSClientGeneric,
+    removeWSClientGeneric,
+    getConnctedClientsGeneric,
+  )
+where
+
+import ClassyPrelude
+import Data.UUID
+import Types.AppTypes
+import Types.ConnectionState
+
+class Monad m => MonadConnectedClientsModify m where
+  addWSClient :: Client -> m ()
+  removeWSClient :: UUID -> m ()
+  updateWSClient :: UUID -> (Client -> Client) -> m ()
+
+addWSClientGeneric ::
+  ( HasConnectedClientState env,
+    MonadReader env m,
+    MonadUnliftIO m
+  ) =>
+  Client ->
+  m ()
+addWSClientGeneric client = do
+  modifyState $ addClient client
+
+addClient :: Client -> ConnectedClients -> ConnectedClients
+addClient client clients = client : clients
+
+updateWSClientGeneric ::
+  ( HasConnectedClientState env,
+    MonadReader env m,
+    MonadUnliftIO m
+  ) =>
+  UUID ->
+  (Client -> Client) ->
+  m
+    ()
+updateWSClientGeneric clientId patchFunction = do
+  modifyState $ updateClient clientId patchFunction
+
+updateClient :: UUID -> (Client -> Client) -> ConnectedClients -> ConnectedClients
+updateClient toUpdate f allClients = do
+  client <- allClients
+  if toUpdate == uuid client
+    then return $ f client
+    else return client
+
+removeWSClientGeneric ::
+  ( HasConnectedClientState env,
+    MonadReader env m,
+    MonadUnliftIO m
+  ) =>
+  UUID ->
+  m ()
+removeWSClientGeneric clientId = do
+  modifyState $ removeClient clientId
+
+removeClient :: UUID -> ConnectedClients -> ConnectedClients
+removeClient toRemove = filter ((/= toRemove) . uuid)
+
+modifyState ::
+  ( HasConnectedClientState env,
+    MonadReader env m,
+    MonadUnliftIO m
+  ) =>
+  (ConnectedClients -> ConnectedClients) ->
+  m ()
+modifyState modifyFunc = do
+  state <- getConnectedClientState <$> ask
+  modifyMVar_ state $ \s ->
+    let s' = modifyFunc s
+     in return s'
+
+class Monad m => MonadConnectedClientsRead m where
+  getConnctedClients :: m ConnectedClients
+
+getConnctedClientsGeneric ::
+  ( HasConnectedClientState env,
+    MonadReader env m,
+    MonadUnliftIO m
+  ) =>
+  m ConnectedClients
+getConnctedClientsGeneric = do
+  ask >>= readMVar . getConnectedClientState

backend/src/WebSocket.hs

@@ -11,6 +11,14 @@ import Data.Aeson
 import Data.UUID (UUID)
 import Data.UUID.V4 (nextRandom)
 import Network.WebSockets qualified as WS
+import State.ConnectedClientsState
+  ( MonadConnectedClientsModify (..),
+    MonadConnectedClientsRead (getConnctedClients),
+    addWSClientGeneric,
+    getConnctedClientsGeneric,
+    removeWSClientGeneric,
+    updateWSClientGeneric,
+  )
 import Types.AppTypes
   ( Env (..),
     HasConnectedClientState (getConnectedClientState),
@@ -45,75 +53,36 @@ 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'
-
 joinRoom ::
-  ( HasWSEnv env,
+  ( MonadReader env m,
-    HasConnectedClientState env,
+    MonadConnectedClientsModify m,
-    MonadReader env m,
+    HasWSEnv env
-    MonadUnliftIO m
   ) =>
   m ()
 joinRoom = do
   clientId <- getClientId <$> ask
-  state <- getConnectedClientState <$> ask
+  updateWSClient clientId (\c -> c {joinedRoom = True})
-  liftIO $ putStrLn "joinedRoom"
-  modifyMVar_ state $ \s ->
-    let s' = updateClient clientId (\c -> c {joinedRoom = True}) s
-     in return s'
 
 updateClientName ::
   ( HasWSEnv env,
-    HasConnectedClientState env,
     MonadReader env m,
-    MonadUnliftIO m
+    MonadConnectedClientsModify m
   ) =>
   SetClientInfo ->
   m ()
 updateClientName clientInfo = do
   clientId <- getClientId <$> ask
-  state <- getConnectedClientState <$> ask
+  updateWSClient clientId (\c -> c {name = displayName clientInfo})
-  modifyMVar_ state $ \s ->
-    let s' = updateClient clientId (\c -> c {name = displayName clientInfo}) s
-     in return s'
 
-removeClient :: UUID -> ConnectedClients -> ConnectedClients
+disconnectWsClient ::
-removeClient toRemove = filter ((/= toRemove) . uuid)
+  ( HasWSEnv env,
-
+    MonadConnectedClientsModify m,
-updateClient :: UUID -> (Client -> Client) -> ConnectedClients -> ConnectedClients
+    MonadReader env m
-updateClient toUpdate f allClients = do
+  ) =>
-  client <- allClients
+  m ()
-  if toUpdate == uuid client
+disconnectWsClient = do
-    then return $ f client
+  clientId <- getClientId <$> ask
-    else return client
+  removeWSClient clientId
 
 runWebSocketServer ::
   ( MonadIO m,
@@ -174,13 +143,22 @@ instance MonadWebSocket (WSApp WSEnv) where
         sendMessage $ "Bad message: " <> pack err
         getTypedWSMessage
 
+instance MonadConnectedClientsModify (WSApp WSEnv) where
+  addWSClient = addWSClientGeneric
+  updateWSClient = updateWSClientGeneric
+  removeWSClient = removeWSClientGeneric
+
+instance MonadConnectedClientsRead (WSApp WSEnv) where
+  getConnctedClients = getConnctedClientsGeneric
+
 wsApp ::
   ( HasWSEnv env,
     HasConnectedClientState env,
     HasRoomsState env,
     MonadReader env m,
     MonadUnliftIO m,
-    MonadWebSocket m
+    MonadWebSocket m,
+    MonadConnectedClientsModify m
   ) =>
   m ()
 wsApp = do
@@ -195,11 +173,9 @@ wsApp = do
 
 handleWSAction ::
   ( HasWSEnv env,
-    HasConnectedClientState env,
-    HasRoomsState env,
     MonadReader env m,
-    MonadUnliftIO m,
+    MonadWebSocket m,
-    MonadWebSocket m
+    MonadConnectedClientsModify m
   ) =>
   m ()
 handleWSAction = do