From 5d3dced6f7eb4c4dd8c225feb6819761b32b6348 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sat, 18 Feb 2023 18:25:38 +0100 Subject: [PATCH] Keep state in monad --- backend/src/State/ConnectedClientsState.hs | 89 ++++++++++++++++++++ backend/src/WebSocket.hs | 94 ++++++++-------------- 2 files changed, 124 insertions(+), 59 deletions(-) create mode 100644 backend/src/State/ConnectedClientsState.hs diff --git a/backend/src/State/ConnectedClientsState.hs b/backend/src/State/ConnectedClientsState.hs new file mode 100644 index 0000000..acca4a7 --- /dev/null +++ b/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 diff --git a/backend/src/WebSocket.hs b/backend/src/WebSocket.hs index 2065dcb..455ad16 100644 --- a/backend/src/WebSocket.hs +++ b/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, - HasConnectedClientState env, - MonadReader env m, - MonadUnliftIO m + ( MonadReader env m, + MonadConnectedClientsModify m, + HasWSEnv env ) => m () joinRoom = do clientId <- getClientId <$> ask - state <- getConnectedClientState <$> ask - liftIO $ putStrLn "joinedRoom" - modifyMVar_ state $ \s -> - let s' = updateClient clientId (\c -> c {joinedRoom = True}) s - in return s' + updateWSClient clientId (\c -> c {joinedRoom = True}) updateClientName :: ( HasWSEnv env, - HasConnectedClientState env, MonadReader env m, - MonadUnliftIO m + MonadConnectedClientsModify m ) => SetClientInfo -> m () updateClientName clientInfo = do clientId <- getClientId <$> ask - state <- getConnectedClientState <$> ask - modifyMVar_ state $ \s -> - let s' = updateClient clientId (\c -> c {name = displayName clientInfo}) s - in return s' + updateWSClient clientId (\c -> c {name = displayName clientInfo}) -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 +disconnectWsClient :: + ( HasWSEnv env, + MonadConnectedClientsModify m, + MonadReader env m + ) => + m () +disconnectWsClient = do + clientId <- getClientId <$> ask + 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