This commit is contained in:
parent
8c82cd81bd
commit
2159e273fa
|
@ -29,12 +29,13 @@ library
|
||||||
Lib
|
Lib
|
||||||
RoomDataHandler
|
RoomDataHandler
|
||||||
State.ConnectedClientsState
|
State.ConnectedClientsState
|
||||||
|
State.GenericTVarState
|
||||||
State.RoomDataState
|
State.RoomDataState
|
||||||
|
State.RoomsState
|
||||||
Types.AppTypes
|
Types.AppTypes
|
||||||
Types.ConnectionState
|
Types.ConnectionState
|
||||||
Types.Participant
|
Types.Participant
|
||||||
Types.RoomData
|
Types.RoomData
|
||||||
Types.RoomsState
|
|
||||||
Types.User
|
Types.User
|
||||||
Types.UsersData
|
Types.UsersData
|
||||||
Types.WebEnv
|
Types.WebEnv
|
||||||
|
|
|
@ -8,9 +8,9 @@ where
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
import Data.Aeson (encode)
|
import Data.Aeson (encode)
|
||||||
import Network.WebSockets qualified as WS
|
import Network.WebSockets qualified as WS
|
||||||
import State.ConnectedClientsState (MonadConnectedClientsRead (getConnctedClients))
|
import State.ConnectedClientsState (ConnectedClients, MonadConnectedClientsRead (getConnctedClients))
|
||||||
import State.RoomDataState (MonadRoomDataStateRead (getRoomDataState))
|
import State.RoomDataState (MonadRoomDataStateRead (getRoomDataState))
|
||||||
import Types.ConnectionState (Client (..), ConnectedClients)
|
import Types.ConnectionState (Client (..))
|
||||||
import Types.User (User, clientToUser)
|
import Types.User (User, clientToUser)
|
||||||
import Types.UsersData (UsersData (..))
|
import Types.UsersData (UsersData (..))
|
||||||
|
|
||||||
|
|
|
@ -6,9 +6,9 @@ module Lib
|
||||||
where
|
where
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
|
import State.ConnectedClientsState (initConnectionsState)
|
||||||
|
import State.RoomsState (initRoomsState)
|
||||||
import Types.AppTypes
|
import Types.AppTypes
|
||||||
import Types.ConnectionState (initConnectionsState)
|
|
||||||
import Types.RoomsState (initRoomsState)
|
|
||||||
import WebServer (runWebServer)
|
import WebServer (runWebServer)
|
||||||
import WebSocket.Server (runWebSocketServer)
|
import WebSocket.Server (runWebSocketServer)
|
||||||
|
|
||||||
|
|
|
@ -20,7 +20,7 @@ import State.RoomDataState
|
||||||
( MonadRoomDataStateModify (setRoomDataState),
|
( MonadRoomDataStateModify (setRoomDataState),
|
||||||
MonadRoomDataStateRead,
|
MonadRoomDataStateRead,
|
||||||
)
|
)
|
||||||
import Types.RoomsState
|
import State.RoomsState
|
||||||
( roomStateDiffers,
|
( roomStateDiffers,
|
||||||
)
|
)
|
||||||
import Types.WebEnv
|
import Types.WebEnv
|
||||||
|
|
|
@ -1,6 +1,10 @@
|
||||||
module State.ConnectedClientsState
|
module State.ConnectedClientsState
|
||||||
( MonadConnectedClientsModify (..),
|
( MonadConnectedClientsModify (..),
|
||||||
MonadConnectedClientsRead (..),
|
MonadConnectedClientsRead (..),
|
||||||
|
ConnectedClients,
|
||||||
|
ConnectedClientsState,
|
||||||
|
HasConnectedClientState (..),
|
||||||
|
initConnectionsState,
|
||||||
addWSClientGeneric,
|
addWSClientGeneric,
|
||||||
updateWSClientGeneric,
|
updateWSClientGeneric,
|
||||||
removeWSClientGeneric,
|
removeWSClientGeneric,
|
||||||
|
@ -10,14 +14,24 @@ where
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
import Data.UUID
|
import Data.UUID
|
||||||
import Types.AppTypes
|
|
||||||
import Types.ConnectionState
|
import Types.ConnectionState
|
||||||
|
|
||||||
|
type ConnectedClientsState = TVar ConnectedClients
|
||||||
|
|
||||||
|
initConnectionsState :: IO ConnectedClientsState
|
||||||
|
initConnectionsState = newTVarIO newConnectedClients
|
||||||
|
|
||||||
|
newConnectedClients :: ConnectedClients
|
||||||
|
newConnectedClients = []
|
||||||
|
|
||||||
class Monad m => MonadConnectedClientsModify m where
|
class Monad m => MonadConnectedClientsModify m where
|
||||||
addWSClient :: Client -> m ()
|
addWSClient :: Client -> m ()
|
||||||
removeWSClient :: UUID -> m ()
|
removeWSClient :: UUID -> m ()
|
||||||
updateWSClient :: UUID -> (Client -> Client) -> m ()
|
updateWSClient :: UUID -> (Client -> Client) -> m ()
|
||||||
|
|
||||||
|
class HasConnectedClientState a where
|
||||||
|
getConnectedClientState :: a -> ConnectedClientsState
|
||||||
|
|
||||||
addWSClientGeneric ::
|
addWSClientGeneric ::
|
||||||
( HasConnectedClientState env,
|
( HasConnectedClientState env,
|
||||||
MonadReader env m,
|
MonadReader env m,
|
||||||
|
|
11
backend/src/State/GenericTVarState.hs
Normal file
11
backend/src/State/GenericTVarState.hs
Normal file
|
@ -0,0 +1,11 @@
|
||||||
|
module State.GenericTVarState (GenericTVarState, updateGenericTVarState, getGenericTVarState) where
|
||||||
|
|
||||||
|
import ClassyPrelude
|
||||||
|
|
||||||
|
type GenericTVarState a = TVar a
|
||||||
|
|
||||||
|
updateGenericTVarState :: (MonadIO m) => GenericTVarState a -> a -> m ()
|
||||||
|
updateGenericTVarState tv a = atomically $ writeTVar tv a
|
||||||
|
|
||||||
|
getGenericTVarState :: (MonadIO m) => GenericTVarState a -> m a
|
||||||
|
getGenericTVarState = readTVarIO
|
|
@ -1,4 +1,4 @@
|
||||||
module Types.RoomsState
|
module State.RoomsState
|
||||||
( RoomsState,
|
( RoomsState,
|
||||||
initRoomsState,
|
initRoomsState,
|
||||||
HasRoomsState (..),
|
HasRoomsState (..),
|
||||||
|
@ -9,10 +9,11 @@ module Types.RoomsState
|
||||||
where
|
where
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
|
import State.GenericTVarState
|
||||||
import State.RoomDataState (MonadRoomDataStateRead (getRoomDataState))
|
import State.RoomDataState (MonadRoomDataStateRead (getRoomDataState))
|
||||||
import Types.RoomData (RoomsData)
|
import Types.RoomData (RoomsData)
|
||||||
|
|
||||||
type RoomsState = TVar RoomsData
|
type RoomsState = GenericTVarState RoomsData
|
||||||
|
|
||||||
initRoomsState :: IO RoomsState
|
initRoomsState :: IO RoomsState
|
||||||
initRoomsState = newTVarIO []
|
initRoomsState = newTVarIO []
|
||||||
|
@ -30,7 +31,7 @@ updateRoomState ::
|
||||||
updateRoomState newData = do
|
updateRoomState newData = do
|
||||||
state <- getRoomsState <$> ask
|
state <- getRoomsState <$> ask
|
||||||
liftIO $ putStrLn "Upating room state"
|
liftIO $ putStrLn "Upating room state"
|
||||||
atomically $ writeTVar state newData
|
updateGenericTVarState state newData
|
||||||
liftIO $ putStrLn "Done Upating room state"
|
liftIO $ putStrLn "Done Upating room state"
|
||||||
|
|
||||||
getRoomState ::
|
getRoomState ::
|
||||||
|
@ -41,7 +42,7 @@ getRoomState ::
|
||||||
m RoomsData
|
m RoomsData
|
||||||
getRoomState = do
|
getRoomState = do
|
||||||
state <- getRoomsState <$> ask
|
state <- getRoomsState <$> ask
|
||||||
readTVarIO state
|
getGenericTVarState state
|
||||||
|
|
||||||
roomStateDiffers ::
|
roomStateDiffers ::
|
||||||
( MonadRoomDataStateRead m
|
( MonadRoomDataStateRead m
|
|
@ -1,10 +1,10 @@
|
||||||
{-# LANGUAGE DerivingVia #-}
|
{-# LANGUAGE DerivingVia #-}
|
||||||
|
|
||||||
module Types.AppTypes (Env (..), App (..), getConnectedClientState, HasConnectedClientState, AppProfile (Prod, Dev)) where
|
module Types.AppTypes (Env (..), App (..), getConnectedClientState, AppProfile (Prod, Dev)) where
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
import Types.ConnectionState (ConnectedClientsState)
|
import State.ConnectedClientsState
|
||||||
import Types.RoomsState
|
import State.RoomsState
|
||||||
( HasRoomsState (getRoomsState),
|
( HasRoomsState (getRoomsState),
|
||||||
RoomsState,
|
RoomsState,
|
||||||
)
|
)
|
||||||
|
@ -17,9 +17,6 @@ data Env = Env
|
||||||
profile :: AppProfile
|
profile :: AppProfile
|
||||||
}
|
}
|
||||||
|
|
||||||
class HasConnectedClientState a where
|
|
||||||
getConnectedClientState :: a -> ConnectedClientsState
|
|
||||||
|
|
||||||
instance HasConnectedClientState Env where
|
instance HasConnectedClientState Env where
|
||||||
getConnectedClientState = connectedClientsState
|
getConnectedClientState = connectedClientsState
|
||||||
|
|
||||||
|
|
|
@ -1,8 +1,6 @@
|
||||||
module Types.ConnectionState
|
module Types.ConnectionState
|
||||||
( Client (..),
|
( Client (..),
|
||||||
ConnectedClientsState,
|
|
||||||
ConnectedClients,
|
ConnectedClients,
|
||||||
initConnectionsState,
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -17,12 +15,4 @@ data Client = Client
|
||||||
joinedRoom :: Bool
|
joinedRoom :: Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
type ConnectedClientsState = TVar ConnectedClients
|
|
||||||
|
|
||||||
type ConnectedClients = [Client]
|
type ConnectedClients = [Client]
|
||||||
|
|
||||||
initConnectionsState :: IO ConnectedClientsState
|
|
||||||
initConnectionsState = newTVarIO newConnectedClients
|
|
||||||
|
|
||||||
newConnectedClients :: ConnectedClients
|
|
||||||
newConnectedClients = []
|
|
||||||
|
|
|
@ -6,11 +6,11 @@ where
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
import Network.Wai (Request, Response, ResponseReceived)
|
import Network.Wai (Request, Response, ResponseReceived)
|
||||||
|
import State.ConnectedClientsState (HasConnectedClientState (getConnectedClientState))
|
||||||
|
import State.RoomsState (HasRoomsState (getRoomsState))
|
||||||
import Types.AppTypes
|
import Types.AppTypes
|
||||||
( Env (..),
|
( Env (..),
|
||||||
HasConnectedClientState (getConnectedClientState),
|
|
||||||
)
|
)
|
||||||
import Types.RoomsState (HasRoomsState (getRoomsState))
|
|
||||||
|
|
||||||
class HasWebEnv a where
|
class HasWebEnv a where
|
||||||
getRequest :: a -> Request
|
getRequest :: a -> Request
|
||||||
|
|
|
@ -29,23 +29,22 @@ data WebSocketMessage = ClientInfoMessage SetClientInfo | JoinRoomMessage JoinRo
|
||||||
instance FromJSON WebSocketMessage where
|
instance FromJSON WebSocketMessage where
|
||||||
parseJSON = genericParseJSON defaultOptions {sumEncoding = UntaggedValue}
|
parseJSON = genericParseJSON defaultOptions {sumEncoding = UntaggedValue}
|
||||||
|
|
||||||
data SetClientInfo = SetClientInfo
|
data SetClientInfo where
|
||||||
{ displayName :: Text
|
SetClientInfo :: {displayName :: Text} -> SetClientInfo
|
||||||
}
|
|
||||||
deriving (Generic, Show)
|
deriving (Generic, Show)
|
||||||
|
|
||||||
instance FromJSON SetClientInfo
|
instance FromJSON SetClientInfo
|
||||||
|
|
||||||
data JoinRoom = JoinRoom
|
data JoinRoom where
|
||||||
{ roomName :: Text
|
JoinRoom :: {roomName :: Text} -> JoinRoom
|
||||||
}
|
|
||||||
deriving (Generic, Show)
|
deriving (Generic, Show)
|
||||||
|
|
||||||
instance FromJSON JoinRoom
|
instance FromJSON JoinRoom
|
||||||
|
|
||||||
data AllChatMessageIncoming = AllChatMessageIncoming
|
data AllChatMessageIncoming where
|
||||||
{ content :: Text
|
AllChatMessageIncoming ::
|
||||||
}
|
{content :: Text} ->
|
||||||
|
AllChatMessageIncoming
|
||||||
deriving (Generic, Show)
|
deriving (Generic, Show)
|
||||||
|
|
||||||
instance FromJSON AllChatMessageIncoming
|
instance FromJSON AllChatMessageIncoming
|
||||||
|
|
|
@ -25,11 +25,11 @@ import State.RoomDataState
|
||||||
( MonadRoomDataStateModify (..),
|
( MonadRoomDataStateModify (..),
|
||||||
MonadRoomDataStateRead (getRoomDataState),
|
MonadRoomDataStateRead (getRoomDataState),
|
||||||
)
|
)
|
||||||
import Types.AppTypes (Env (..))
|
import State.RoomsState
|
||||||
import Types.RoomsState
|
|
||||||
( getRoomState,
|
( getRoomState,
|
||||||
updateRoomState,
|
updateRoomState,
|
||||||
)
|
)
|
||||||
|
import Types.AppTypes (Env (..))
|
||||||
import Types.WebEnv
|
import Types.WebEnv
|
||||||
|
|
||||||
newtype ExceptTApp e a = E {unExceptTApp :: IO (Either e a)}
|
newtype ExceptTApp e a = E {unExceptTApp :: IO (Either e a)}
|
||||||
|
|
|
@ -17,7 +17,8 @@ import ClassyPrelude
|
||||||
import Data.UUID
|
import Data.UUID
|
||||||
import Network.WebSockets qualified as WS
|
import Network.WebSockets qualified as WS
|
||||||
import State.ConnectedClientsState
|
import State.ConnectedClientsState
|
||||||
( MonadConnectedClientsModify (..),
|
( HasConnectedClientState,
|
||||||
|
MonadConnectedClientsModify (..),
|
||||||
MonadConnectedClientsRead (..),
|
MonadConnectedClientsRead (..),
|
||||||
addWSClientGeneric,
|
addWSClientGeneric,
|
||||||
getConnctedClientsGeneric,
|
getConnctedClientsGeneric,
|
||||||
|
@ -25,8 +26,8 @@ import State.ConnectedClientsState
|
||||||
updateWSClientGeneric,
|
updateWSClientGeneric,
|
||||||
)
|
)
|
||||||
import State.RoomDataState
|
import State.RoomDataState
|
||||||
|
import State.RoomsState (HasRoomsState (..), getRoomState)
|
||||||
import Types.AppTypes
|
import Types.AppTypes
|
||||||
import Types.RoomsState (HasRoomsState (..), getRoomState)
|
|
||||||
|
|
||||||
data WSEnv = WSEnv
|
data WSEnv = WSEnv
|
||||||
{ appEnv :: Env,
|
{ appEnv :: Env,
|
||||||
|
|
Loading…
Reference in a new issue