ReaderT

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`

backend/package.yaml

@@ -26,6 +26,11 @@ dependencies:
   - http-types
   - warp
   - websockets
+  - aeson
+  - text
+  - bytestring
+  - uuid
+  - lifted-base
 
 ghc-options:
   - -Wall

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

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

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]

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

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

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

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