diff --git a/backend/package.yaml b/backend/package.yaml index f1aeabe..2444dbe 100644 --- a/backend/package.yaml +++ b/backend/package.yaml @@ -31,6 +31,7 @@ dependencies: - bytestring - uuid - lifted-base + - mtl ghc-options: - -Wall diff --git a/backend/src/RoomDataHandler.hs b/backend/src/RoomDataHandler.hs index 3f361bf..303131b 100644 --- a/backend/src/RoomDataHandler.hs +++ b/backend/src/RoomDataHandler.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module RoomDataHandler ( roomDataHandler, ) @@ -5,12 +7,9 @@ where import BroadcastUserData (broadcastUserData) import ClassyPrelude -import Data.Aeson - ( decode, - decodeStrict, - eitherDecodeStrict, - encode, - ) +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, @@ -24,36 +23,38 @@ import Types.RoomsState updateRoomState, ) import Types.WebEnv (HasWebEnv (getRequest), getRespond) -import WebSocket (broadCastToClients) 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 -> 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")] "" + Left errorMessage -> do + response <- badRequest errorMessage + throwError response + Right newState -> return newState getRequestBody :: ( MonadIO m, @@ -79,5 +80,19 @@ badRequest errorMessage = do responseLBS status500 [("Content-Type", "text/plain")] - ( fromString ("Bad request. Reason: " <> errorMessage) - ) + (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")] + "" diff --git a/backend/src/WebServer.hs b/backend/src/WebServer.hs index 7d224ba..4e0cba4 100644 --- a/backend/src/WebServer.hs +++ b/backend/src/WebServer.hs @@ -6,6 +6,7 @@ module WebServer (runWebServer) where import ClassyPrelude hiding (decodeUtf8) +import Control.Monad.Except import Data.Text.Encoding import Network.HTTP.Types import Network.Wai @@ -23,15 +24,28 @@ import Types.RoomsState import Types.WebEnv import WebSocket (broadCastToClients) -newtype WebApp env a = WebApp {unWebApp :: env -> IO a} +newtype ExceptTApp e a = E {unExceptTApp :: IO (Either e a)} + deriving + ( Functor, + Applicative, + Monad, + MonadIO, + MonadError e + ) + via ExceptT e IO + +newtype WebApp env a = WebApp {unWebApp :: env -> IO (Either ResponseReceived a)} deriving ( Functor, Applicative, Monad, MonadReader env, - MonadIO + MonadIO, + MonadError ResponseReceived ) - via ReaderT env IO + via ReaderT env (ExceptTApp ResponseReceived) + +-- via ExceptT ResponseReceived (ReaderT env IO) getRequestPath :: ( MonadIO m, @@ -48,7 +62,8 @@ app :: HasWebEnv env, HasConnectedClientState env, MonadReader env m, - HasRoomsState env + HasRoomsState env, + MonadError ResponseReceived m ) => m ResponseReceived app = requestPathHandler @@ -58,7 +73,8 @@ requestPathHandler :: HasWebEnv env, HasConnectedClientState env, MonadReader env m, - HasRoomsState env + HasRoomsState env, + MonadError ResponseReceived m ) => m ResponseReceived requestPathHandler = do @@ -69,17 +85,20 @@ requestPathHandler = do notFound :: ( MonadIO m, HasWebEnv env, - MonadReader env m + MonadReader env m, + MonadError ResponseReceived m ) => m ResponseReceived notFound = do respond' <- getRespond <$> ask - liftIO $ - respond' $ - responseLBS - status404 - [("Content-Type", "text/plain")] - "404 - Not Found" + response <- + liftIO $ + respond' $ + responseLBS + status404 + [("Content-Type", "text/plain")] + "404 - Not Found" + throwError response runWebApp :: ( MonadIO m, @@ -91,7 +110,13 @@ runWebApp = do return ( \req res -> do let webEnv = WebEnv {appEnv = env, request = req, respond = res} - unWebApp app webEnv + eitherResult <- unWebApp app webEnv + case eitherResult of + Left result -> do + liftIO $ putStrLn "Some error occured" + return result + Right result -> do + return result ) runWebServer :: diff --git a/backend/src/WebSocket.hs b/backend/src/WebSocket.hs index b7b8fc3..d80d740 100644 --- a/backend/src/WebSocket.hs +++ b/backend/src/WebSocket.hs @@ -1,26 +1,22 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Redundant bracket" #-} module WebSocket (broadCastToClients, runWebSocketServer) where -import ClassyPrelude -import Data.UUID (UUID) -import Data.UUID.V4 (nextRandom) -import Network.WebSockets qualified as WS -import Types.AppTypes - ( Env (connectedClientsState), - HasConnectedClientState (getConnectedClientState), - ) -import Types.ConnectionState (Client (..), ConnectedClients) +import ClassyPrelude +import Data.UUID (UUID) +import Data.UUID.V4 (nextRandom) +import qualified Network.WebSockets as WS +import Types.AppTypes (Env (connectedClientsState), + HasConnectedClientState (getConnectedClientState)) +import Types.ConnectionState (Client (..), ConnectedClients) data WSEnv = WSEnv - { appEnv :: Env, + { appEnv :: Env, connection :: WS.Connection, - clientId :: UUID + clientId :: UUID } instance HasConnectedClientState WSEnv where