diff --git a/backend/README.md b/backend/README.md index 9c83062..3b0a281 100644 --- a/backend/README.md +++ b/backend/README.md @@ -4,3 +4,11 @@ `stack build` `stack stack run` + +## Debug + +Using websocat + +`websocat ws://127.0.0.1:9160` + +`curl --data 'body data' localhost:8081` diff --git a/backend/package.yaml b/backend/package.yaml index 186a455..f1aeabe 100644 --- a/backend/package.yaml +++ b/backend/package.yaml @@ -26,6 +26,11 @@ dependencies: - http-types - warp - websockets + - aeson + - text + - bytestring + - uuid + - lifted-base ghc-options: - -Wall diff --git a/backend/src/Lib.hs b/backend/src/Lib.hs index 006e912..630ed46 100644 --- a/backend/src/Lib.hs +++ b/backend/src/Lib.hs @@ -1,14 +1,24 @@ +{-# LANGUAGE DerivingVia #-} + module Lib ( runBothServers, ) where import ClassyPrelude +import Types.AppTypes import WebServer (runWebServer) import WebSocket (initMVarState, runWebSocketServer) runBothServers :: IO () runBothServers = do - mVarState <- initMVarState - _ <- concurrently (runWebSocketServer mVarState) (runWebServer mVarState) + connectedClientsState <- initMVarState + + let env = + Env + { connectedClientsState = connectedClientsState, + profile = Dev + } + + _ <- concurrently (unApp runWebSocketServer env) (unApp runWebServer env) return () diff --git a/backend/src/Types/AppTypes.hs b/backend/src/Types/AppTypes.hs new file mode 100644 index 0000000..0da4ceb --- /dev/null +++ b/backend/src/Types/AppTypes.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DerivingVia #-} + +module Types.AppTypes (Env (..), App (..), getConnectedClientState, HasConnectedClientState, App, AppProfile (Prod, Dev)) where + +import ClassyPrelude +import Types.ConnectionState (ConnectedClientsState) + +data AppProfile = Prod | Dev + +data Env = Env + { connectedClientsState :: ConnectedClientsState, + profile :: AppProfile + } + +class HasConnectedClientState a where + getConnectedClientState :: a -> ConnectedClientsState + +instance HasConnectedClientState Env where + getConnectedClientState = connectedClientsState + +newtype App env a = App {unApp :: env -> IO a} + deriving + ( Functor, + Applicative, + Monad, + MonadReader env, + MonadIO + ) + via ReaderT env IO diff --git a/backend/src/Types/ConnectionState.hs b/backend/src/Types/ConnectionState.hs new file mode 100644 index 0000000..00c19f1 --- /dev/null +++ b/backend/src/Types/ConnectionState.hs @@ -0,0 +1,21 @@ +module Types.ConnectionState + ( Client (..), + Client, + ConnectedClientsState, + ConnectedClients, + ) +where + +import ClassyPrelude +import Data.UUID (UUID) +import Network.WebSockets qualified as WS + +data Client = Client + { uuid :: UUID, + name :: Text, + conn :: WS.Connection + } + +type ConnectedClientsState = MVar ConnectedClients + +type ConnectedClients = [Client] diff --git a/backend/src/Types/Participant.hs b/backend/src/Types/Participant.hs new file mode 100644 index 0000000..7c41575 --- /dev/null +++ b/backend/src/Types/Participant.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Types.Participant (Participant) where + +import ClassyPrelude +import Data.Aeson (FromJSON, ToJSON) + +data Participant = Participant + { jid :: Text, + email :: Text, + displayName :: Text, + avatarURL :: Text + } + deriving (Generic, Show) + +instance ToJSON Participant + +instance FromJSON Participant diff --git a/backend/src/Types/RoomData.hs b/backend/src/Types/RoomData.hs new file mode 100644 index 0000000..6de972f --- /dev/null +++ b/backend/src/Types/RoomData.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Types.RoomData (RoomData) where + +import ClassyPrelude +import Data.Aeson (FromJSON, ToJSON) +import Types.Participant (Participant) + +data RoomData = RoomData + { roomName :: RoomName, + participants :: [Participant] + } + deriving (Generic, Show) + +type RoomName = Text + +instance ToJSON RoomData + +instance FromJSON RoomData diff --git a/backend/src/WebServer.hs b/backend/src/WebServer.hs index 673a55b..fc66aa9 100644 --- a/backend/src/WebServer.hs +++ b/backend/src/WebServer.hs @@ -1,25 +1,101 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} + + module WebServer (runWebServer) where -import ClassyPrelude -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Handler.Warp (run) -import WebSocket (ServerState, broadcast) +-- 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) --- todo: use ReaderT instead of curring the state --- then add a MVar for storing the room Data, including users that are not in any room yet +newtype WebApp env a = WebApp {unWebApp :: env -> IO a} + deriving + ( Functor, + Applicative, + Monad, + MonadReader env, + MonadIO + ) + via ReaderT env IO -app :: MVar ServerState -> Application -app state req respond = do - putStrLn "I've done some IO here" - withMVar state $ \currenState -> broadcast "body of req" currenState - respond $ - responseLBS - status200 - [("Content-Type", "text/plain")] - "" +data WebEnv = WebEnv + { appEnv :: Env, + request :: Request, + respond :: Response -> IO ResponseReceived + } -runWebServer :: MVar ServerState -> IO () -runWebServer state = do - putStrLn "http://localhost:8080/" - run 8080 $ app state +instance HasConnectedClientState WebEnv where + getConnectedClientState = connectedClientsState . appEnv + +class HasWebEnv a where + getRequest :: a -> Request + getRespond :: a -> (Response -> IO ResponseReceived) + +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, + MonadReader env m + ) => + m Text +getRequestBody = do + request <- getRequest <$> ask + liftIO $ (decodeUtf8 . toStrict) <$> consumeRequestBodyStrict request + +app :: + ( MonadIO m, + HasWebEnv env, + HasConnectedClientState env, + MonadReader env m + ) => + m ResponseReceived +app = + do + liftIO $ putStrLn "I've done some IO here" + getRequestBody >>= broadCastToClients + respond' <- getRespond <$> ask + liftIO $ respond' $ responseLBS status200 [("Content-Type", "text/plain")] "" + +runWebApp :: + ( MonadIO m, + MonadReader Env m + ) => + m Application +runWebApp = do + env <- ask + return + ( \req res -> do + let webEnv = WebEnv {appEnv = env, request = req, respond = res} + unWebApp app webEnv + ) + +runWebServer :: + ( MonadIO m, + MonadReader Env m + ) => + m () +runWebServer = do + putStrLn "http://localhost:8081/" + runWebApp >>= liftIO . run 8081 + return () diff --git a/backend/src/WebSocket.hs b/backend/src/WebSocket.hs index f8da264..856428d 100644 --- a/backend/src/WebSocket.hs +++ b/backend/src/WebSocket.hs @@ -1,52 +1,151 @@ -module WebSocket (broadcast, initMVarState, runWebSocketServer, ServerState, Client) where +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + +module WebSocket (broadcast, initMVarState, runWebSocketServer) where import ClassyPrelude +import Data.UUID (UUID) +import Data.UUID.V4 (nextRandom) import Network.WebSockets qualified as WS +import Types.AppTypes + ( Env (connectedClientsState), + HasConnectedClientState (getConnectedClientState), + ) +import Types.ConnectionState + ( Client (..), + ConnectedClients, + ConnectedClientsState, + ) -type Client = (Text, WS.Connection) - -type ServerState = [Client] - -addClient :: Client -> ServerState -> ServerState +addClient :: Client -> ConnectedClients -> ConnectedClients addClient client clients = client : clients -removeClient :: Client -> ServerState -> ServerState -removeClient client = filter ((/= fst client) . fst) +removeClient :: UUID -> ConnectedClients -> ConnectedClients +removeClient toRemove = filter ((/= toRemove) . uuid) -newServerState :: ServerState -newServerState = [] +newConnectedClients :: ConnectedClients +newConnectedClients = [] -broadcast :: Text -> ServerState -> IO () +broadcast :: Text -> ConnectedClients -> IO () broadcast message clients = do putStrLn message - forM_ clients $ \(_, conn) -> WS.sendTextData conn message + forM_ clients $ \client -> WS.sendTextData (conn client) message -initMVarState :: IO (MVar ServerState) -initMVarState = newMVar newServerState +initMVarState :: IO (MVar ConnectedClients) +initMVarState = newMVar newConnectedClients -runWebSocketServer :: MVar ServerState -> IO () -runWebSocketServer state = do - WS.runServer "127.0.0.1" 9160 $ webSocketApplication state +runWebSocketServer :: + ( MonadIO m, + MonadReader Env m + ) => + 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 -webSocketApplication :: MVar ServerState -> WS.ServerApp -webSocketApplication state pending = do - putStrLn "pending request" - conn <- WS.acceptRequest pending - WS.withPingThread conn 30 (return ()) $ do - msg <- WS.receiveData conn - putStrLn msg - let client = ("hall", conn) - flip finally (disconnect client) $ do - modifyMVar_ state $ \s -> do - let s' = addClient client s - return s' - forever $ do - currentMsg <- WS.receiveData conn - putStrLn currentMsg - where - disconnect client = do - putStrLn "disconnect" - modifyMVar state $ \s -> - let s' = removeClient client s - in return - (s', s') +runWSApp :: + ( MonadIO m, + MonadReader Env m + ) => + m WS.ServerApp +runWSApp = do + env <- ask + return + ( \pending -> do + putStrLn "pending request" + conn <- WS.acceptRequest pending + uuid <- nextRandom + let wsEnv = WSEnv {appEnv = env, connection = conn, clientId = uuid} + WS.withPingThread conn 30 (return ()) $ do + unWSApp wsApp wsEnv + ) + +newClient :: + ( MonadIO m, + HasWSEnv env, + MonadReader env m + ) => + Text -> + m Client +newClient name = do + env <- ask + return $ Client {uuid = getClientId env, name = name, conn = getConn env} + +newtype WSApp env a = WSApp {unWSApp :: env -> IO a} + deriving + ( Functor, + Applicative, + Monad, + MonadReader env, + MonadIO, + MonadUnliftIO + ) + via ReaderT env IO + +-- instance MonadBaseControl IO m => MonadBaseControl IO (WSApp env n) +-- where + +wsApp :: + ( HasWSEnv env, + HasConnectedClientState env, + MonadReader env m, + MonadUnliftIO m + ) => + m () +wsApp = do + state <- getConnectedClientState <$> ask + msg <- getMessage + putStrLn msg + client <- newClient msg + modifyMVar_ state $ \s -> do + let s' = addClient client s + return s' + flip finally disconnectWsClient $ do + forever $ do + currentMsg <- getMessage + putStrLn currentMsg + +getMessage :: + ( HasWSEnv env, + MonadIO m, + MonadReader env m + ) => + m Text +getMessage = do + conn' <- getConn <$> ask + liftIO $ WS.receiveData conn' + +disconnectWsClient :: + ( MonadIO m, + HasWSEnv env, + HasConnectedClientState env, + MonadReader env m + ) => + m () +disconnectWsClient = do + clientId <- getClientId <$> ask + 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