jitsi-roomsv2/backend/src/WebServer.hs

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

module WebServer (runWebServer) where

import BroadcastUserData
  ( MonadBroadcast (..),
    broadCastToClientsGeneric,
  )
import ClassyPrelude hiding (decodeUtf8)
import Control.Monad.Except
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Handler.Warp (run)
import RoomDataHandler (roomDataHandler)
import State.ConnectedClientsState
  ( MonadConnectedClientsRead (..),
    getConnctedClientsGeneric,
  )
import State.RoomDataState
  ( MonadRoomDataStateModify (..),
    MonadRoomDataStateRead (getRoomDataState),
  )
import Types.AppTypes (Env (..))
import Types.RoomsState
  ( HasRoomsState (getRoomsState),
    getRoomState,
    roomStateDiffers,
    updateRoomState,
  )
import Types.WebEnv

newtype ExceptTApp e a = E {unExceptTApp :: IO (Either e a)}
  deriving
    ( Functor,
      Applicative,
      Monad,
      MonadIO,
      MonadError e
    )
    via ExceptT e IO

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

instance MonadConnectedClientsRead (WebApp WebEnv) where
  getConnctedClients = getConnctedClientsGeneric

instance MonadRoomDataStateModify (WebApp WebEnv) where
  setRoomDataState = updateRoomState

instance MonadRoomDataStateRead (WebApp WebEnv) where
  getRoomDataState = getRoomState

instance MonadBroadcast (WebApp WebEnv) where
  broadCastToClients = broadCastToClientsGeneric

getRequestPath ::
  ( MonadIO m,
    HasWebEnv env,
    MonadReader env m
  ) =>
  m [Text]
getRequestPath = do
  request <- getRequest <$> ask
  return $ pathInfo request

app ::
  ( MonadIO m,
    HasWebEnv env,
    MonadReader env m,
    MonadError ResponseReceived m,
    MonadRoomDataStateModify m,
    MonadRoomDataStateRead m,
    MonadBroadcast m
  ) =>
  m ResponseReceived
app = requestPathHandler

requestPathHandler ::
  ( MonadIO m,
    HasWebEnv env,
    MonadReader env m,
    MonadError ResponseReceived m,
    MonadRoomDataStateModify m,
    MonadRoomDataStateRead m,
    MonadBroadcast m
  ) =>
  m ResponseReceived
requestPathHandler = do
  getRequestPath >>= \case
    ["roomdata"] -> roomDataHandler
    _ -> notFound

notFound ::
  ( MonadIO m,
    HasWebEnv env,
    MonadReader env m,
    MonadError ResponseReceived m
  ) =>
  m ResponseReceived
notFound = do
  respond' <- getRespond <$> ask
  response <-
    liftIO $
      respond' $
        responseLBS
          status404
          [("Content-Type", "text/plain")]
          "404 - Not Found"
  throwError response

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}
        eitherResult <- unWebApp app webEnv
        case eitherResult of
          Left result -> do
            liftIO $ putStrLn "Some error occured"
            return result
          Right result -> do
            return result
    )

runWebServer ::
  ( MonadIO m,
    MonadReader Env m
  ) =>
  m ()
runWebServer = do
  putStrLn "http://localhost:8081/"
  runWebApp >>= liftIO . run 8081
  return ()