jitsi-roomsv2/backend/src/WebServer.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DerivingVia         #-}
{-# LANGUAGE FlexibleContexts    #-}


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)

newtype WebApp env a = WebApp {unWebApp :: env -> IO a}
  deriving
    ( Functor,
      Applicative,
      Monad,
      MonadReader env,
      MonadIO
    )
    via ReaderT env IO

data WebEnv = WebEnv
  { appEnv  :: Env,
    request :: Request,
    respond :: Response -> IO ResponseReceived
  }

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