jitsi-roomsv2/backend/src/RoomDataHandler.hs

{-# LANGUAGE FlexibleContexts #-}

module RoomDataHandler
  ( roomDataHandler,
  )
where

import BroadcastUserData (MonadBroadcast, broadcastUserData)
import ClassyPrelude
import Control.Monad.Except (MonadError, throwError)
import Data.Aeson (eitherDecodeStrict)
import Data.Aeson.Types (FromJSON)
import Network.HTTP.Types (status200, status500)
import Network.Wai
  ( ResponseReceived,
    consumeRequestBodyStrict,
    responseLBS,
  )
import State.RoomDataState
  ( MonadRoomDataStateModify (setRoomDataState),
    MonadRoomDataStateRead,
  )
import Types.RoomsState
  ( roomStateDiffers,
  )
import Types.WebEnv
  ( HasWebEnv (getRequest),
    getRespond,
  )

roomDataHandler ::
  ( MonadIO m,
    HasWebEnv env,
    MonadReader env m,
    MonadError ResponseReceived m,
    MonadRoomDataStateRead m,
    MonadRoomDataStateModify m,
    MonadBroadcast m
  ) =>
  m ResponseReceived
roomDataHandler = do
  newRoomData <- parseBodyOrBadRequest
  liftIO $ putStrLn "Got triggered from prosody"
  whenM (roomStateDiffers newRoomData) $ do
    setRoomDataState newRoomData
    broadcastUserData
  success

parseBodyOrBadRequest ::
  ( MonadIO m,
    HasWebEnv env,
    MonadReader env m,
    MonadError ResponseReceived m,
    FromJSON a
  ) =>
  m a
parseBodyOrBadRequest = do
  body <- getRequestBody
  case eitherDecodeStrict body of
    Left errorMessage -> do
      response <- badRequest errorMessage
      throwError response
    Right newState -> return newState

getRequestBody ::
  ( MonadIO m,
    HasWebEnv env,
    MonadReader env m
  ) =>
  m ByteString
getRequestBody = do
  request <- getRequest <$> ask
  liftIO $ toStrict <$> consumeRequestBodyStrict request

badRequest ::
  ( MonadIO m,
    HasWebEnv env,
    MonadReader env m
  ) =>
  String ->
  m ResponseReceived
badRequest errorMessage = do
  respond' <- getRespond <$> ask
  liftIO $ print errorMessage
  liftIO $
    respond' $
      responseLBS
        status500
        [("Content-Type", "text/plain")]
        (fromString ("Bad request. Reason: " <> errorMessage))

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