131 lines
3.4 KiB
Haskell
131 lines
3.4 KiB
Haskell
{-# 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
|