jitsi-roomsv2/backend/src/WebServer.hs

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

module WebServer (runWebServer) where

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 Types.AppTypes
  ( Env (..),
    HasConnectedClientState (..),
  )
import Types.RoomsState
  ( HasRoomsState (getRoomsState),
    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)

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

app ::
  ( MonadIO m,
    HasWebEnv env,
    HasConnectedClientState env,
    MonadReader env m,
    HasRoomsState env,
    MonadError ResponseReceived m
  ) =>
  m ResponseReceived
app = requestPathHandler

requestPathHandler ::
  ( MonadIO m,
    HasWebEnv env,
    HasConnectedClientState env,
    MonadReader env m,
    HasRoomsState env,
    MonadError ResponseReceived 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 ()