84 lines
1.9 KiB
Haskell
84 lines
1.9 KiB
Haskell
|
module RoomDataHandler
|
||
|
|
( roomDataHandler,
|
||
|
|
)
|
||
|
|
where
|
||
|
|
|
||
|
|
import BroadcastUserData (broadcastUserData)
|
||
|
|
import ClassyPrelude
|
||
|
|
import Data.Aeson
|
||
|
|
( decode,
|
||
|
|
decodeStrict,
|
||
|
|
eitherDecodeStrict,
|
||
|
|
encode,
|
||
|
|
)
|
||
|
|
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)
|
||
|
|
import WebSocket (broadCastToClients)
|
||
|
|
|
||
|
|
roomDataHandler ::
|
||
|
|
( MonadIO m,
|
||
|
|
HasWebEnv env,
|
||
|
|
HasConnectedClientState env,
|
||
|
|
MonadReader env m,
|
||
|
|
HasRoomsState env
|
||
|
|
) =>
|
||
|
|
m ResponseReceived
|
||
|
|
roomDataHandler = do
|
||
|
|
body <- getRequestBody
|
||
|
|
case eitherDecodeStrict body of
|
||
|
|
Left errorMessage -> badRequest errorMessage
|
||
|
|
Right newState -> do
|
||
|
|
respond' <- getRespond <$> ask
|
||
|
|
shouldAct <- roomStateDiffers newState
|
||
|
|
( if shouldAct
|
||
|
|
then
|
||
|
|
( do
|
||
|
|
putStrLn "b1"
|
||
|
|
updateRoomState newState
|
||
|
|
broadcastUserData
|
||
|
|
putStrLn "b2"
|
||
|
|
ans respond'
|
||
|
|
)
|
||
|
|
else ans respond'
|
||
|
|
)
|
||
|
|
where
|
||
|
|
ans respond' = liftIO $ respond' $ responseLBS status200 [("Content-Type", "text/plain")] ""
|
||
|
|
|
||
|
|
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)
|
||
|
|
)
|