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 GHC.IO.Exception (ExitCode (ExitSuccess))
import Network.HTTP.Types (status200, status500)
import Network.Wai
  ( ResponseReceived,
    consumeRequestBodyStrict,
    responseLBS,
  )
import State.RoomDataState
  ( MonadRoomDataStateModify (setRoomDataState),
    MonadRoomDataStateRead,
  )
import State.RoomsState
  ( roomStateDiffInOpenRooms,
    roomStateDiffers,
  )
import System.Process
import Text.Printf (printf)
import Types.RoomData (RoomData, prettyPrintOpenedRoom)
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
    (openedRooms, closedRooms) <- roomStateDiffInOpenRooms newRoomData

    mapM_ notifyRoomOpend openedRooms
    mapM_ notifyRoomClosed closedRooms

    setRoomDataState newRoomData
    broadcastUserData
  success

parseBodyOrBadRequest ::
  ( MonadIO m,
    HasWebEnv env,
    MonadReader env m,
    MonadError ResponseReceived m,
    FromJSON a
  ) =>
  m a
parseBodyOrBadRequest = do
  liftIO $ putStrLn "Parsing body"
  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")]
        ""

notifyRoomOpend :: (MonadIO m) => RoomData -> m ()
notifyRoomOpend room = do
  let (name, user) = prettyPrintOpenedRoom room
  liftIO $ printf "Room %s opened by %s\n" name user
  exitCode <- liftIO $ system $ printf "/nix/store/23nz5mjk3dj7027byc6g5avx3mfwwnqm-libnotify-0.8.3/bin/notify-send 'Room %s opened by %s'" name user
  when (exitCode /= ExitSuccess) $ liftIO $ printf "Failed to notify room %s opened by %s\n" name user

notifyRoomClosed :: (MonadIO m) => RoomData -> m ()
notifyRoomClosed room = do
  let (name, _) = prettyPrintOpenedRoom room
  liftIO $ printf "Room %s closed\n" name
  exitCode <- liftIO $ system $ printf "/nix/store/23nz5mjk3dj7027byc6g5avx3mfwwnqm-libnotify-0.8.3/bin/notify-send 'Room %s closed'" name
  when (exitCode /= ExitSuccess) $ liftIO $ printf "Failed to notify room %s closed\n" name