jitsi-roomsv2/backend/src/WebServer.hs

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

module WebServer (runWebServer) where

import ClassyPrelude hiding (decodeUtf8)
import Data.Text.Encoding
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
import WebSocket (broadCastToClients)

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

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
  ) =>
  m ResponseReceived
app = requestPathHandler

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

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

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