Web Errorhandling with ExceptT

backend/package.yaml

@@ -31,6 +31,7 @@ dependencies:
   - bytestring
   - uuid
   - lifted-base
+  - mtl
 
 ghc-options:
   - -Wall

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
+import Control.Monad.Except (MonadError, throwError)
-  ( decode,
+import Data.Aeson (eitherDecodeStrict)
-    decodeStrict,
+import Data.Aeson.Types (FromJSON)
-    eitherDecodeStrict,
-    encode,
-  )
 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
+    Left errorMessage -> do
-    Right newState -> do
+      response <- badRequest errorMessage
-      respond' <- getRespond <$> ask
+      throwError response
-      shouldAct <- roomStateDiffers newState
+    Right newState -> return 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,
@@ -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")]
+        ""

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
+  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 ::

backend/src/WebSocket.hs

@@ -1,20 +1,16 @@
 {-# 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 qualified Network.WebSockets    as WS
-import Types.AppTypes
+import           Types.AppTypes        (Env (connectedClientsState),
-  ( Env (connectedClientsState),
+                                        HasConnectedClientState (getConnectedClientState))
-    HasConnectedClientState (getConnectedClientState),
-  )
 import           Types.ConnectionState (Client (..), ConnectedClients)
 
 data WSEnv = WSEnv