jitsi-roomsv2/backend/src/RoomDataHandler.hs

{-# LANGUAGE FlexibleContexts #-}

module RoomDataHandler
  ( roomDataHandler,
  )
where

import BroadcastUserData (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 Types.AppTypes (HasConnectedClientState)
import Types.RoomsState
  ( HasRoomsState,
    roomStateDiffers,
    updateRoomState,
  )
import Types.WebEnv (HasWebEnv (getRequest), getRespond)

roomDataHandler ::
  ( MonadIO m,
    HasWebEnv env,
    HasConnectedClientState env,
    MonadReader env m,
    MonadError ResponseReceived m,
    HasRoomsState env
  ) =>
  m ResponseReceived
roomDataHandler = do
  newRoomData <- parseBodyOrBadRequest
  whenM (roomStateDiffers newRoomData) $ do
    updateRoomState 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 $
    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")]
        ""