Start with keeping roomsstate

This commit is contained in:
qvalentin 2023-01-27 19:53:34 +01:00
parent 839f6df5f8
commit f0e0d93b05
8 changed files with 161 additions and 81 deletions

View File

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

View File

@ -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,

View File

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

View File

@ -11,7 +11,7 @@ data Participant = Participant
displayName :: Text,
avatarURL :: Text
}
deriving (Generic, Show)
deriving (Generic, Show, Eq)
instance ToJSON Participant

View File

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

View File

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

View File

@ -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,

View File

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