Handle exceptions from scotty as ScottyException (#345)

Web/Scotty.hs

@@ -36,6 +36,7 @@ module Web.Scotty
     , raise, raiseStatus, throw, rescue, next, finish, defaultHandler, liftAndCatchIO
     , liftIO, catch
     , StatusError(..)
+    , ScottyException(..)
       -- * Parsing Parameters
     , Param, Trans.Parsable(..), Trans.readEither
       -- * Types
@@ -57,8 +58,7 @@ import Network.Socket (Socket)
 import Network.Wai (Application, Middleware, Request, StreamingBody)
 import Network.Wai.Handler.Warp (Port)
 
-import Web.Scotty.Internal.Types (ScottyT, ActionT, ErrorHandler, Param, RoutePattern, Options, defaultOptions, File, Kilobytes, ScottyState, defaultScottyState, StatusError(..), Content(..))
-
+import Web.Scotty.Internal.Types (ScottyT, ActionT, ErrorHandler, Param, RoutePattern, Options, defaultOptions, File, Kilobytes, ScottyState, defaultScottyState, ScottyException, StatusError(..), Content(..))
 import UnliftIO.Exception (Handler(..), catch)
 
 

Web/Scotty/Action.hs

@@ -93,7 +93,7 @@ import           Numeric.Natural
 
 import           Web.Scotty.Internal.Types
 import           Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, decodeUtf8Lenient)
-import           UnliftIO.Exception (Handler(..), catch, catches)
+import           UnliftIO.Exception (Handler(..), catch, catches, throwIO)
 
 import Network.Wai.Internal (ResponseReceived(..))
 
@@ -111,7 +111,7 @@ runAction mh env action = do
   ok <- flip runReaderT env $ runAM $ tryNext $ action `catches` concat
     [ [actionErrorHandler]
     , maybeToList mh
-    , [statusErrorHandler, someExceptionHandler]
+    , [statusErrorHandler, scottyExceptionHandler, someExceptionHandler]
     ]
   res <- getResponse env
   return $ bool Nothing (Just $ mkResponse res) ok
@@ -135,6 +135,39 @@ actionErrorHandler = Handler $ \case
   AENext -> next
   AEFinish -> return ()
 
+-- | Default handler for exceptions from scotty
+scottyExceptionHandler :: MonadIO m => ErrorHandler m
+scottyExceptionHandler = Handler $ \case
+  RequestTooLarge -> do
+    status status413
+    text "Request body is too large"
+  MalformedJSON bs err -> do
+    status status400
+    raw $ BL.unlines
+      [ "jsonData: malformed"
+      , "Body: " <> bs
+      , "Error: " <> BL.fromStrict (encodeUtf8 err)
+      ]
+  FailedToParseJSON bs err -> do
+    status status422
+    raw $ BL.unlines
+      [ "jsonData: failed to parse"
+      , "Body: " <> bs
+      , "Error: " <> BL.fromStrict (encodeUtf8 err)
+      ]
+  PathParameterNotFound k -> do
+    status status500
+    text $ T.unwords [ "Path parameter", k, "not found"]
+  QueryParameterNotFound k -> do
+    status status400
+    text $ T.unwords [ "Query parameter", k, "not found"]
+  FormFieldNotFound k -> do
+    status status400
+    text $ T.unwords [ "Query parameter", k, "not found"]
+  FailedToParseParameter k v e -> do
+    status status400
+    text $ T.unwords [ "Failed to parse parameter", k, v, ":", e]
+
 -- | Uncaught exceptions turn into HTTP 500 Server Error codes
 someExceptionHandler :: MonadIO m => ErrorHandler m
 someExceptionHandler = Handler $ \case
@@ -256,23 +289,12 @@ bodyReader = ActionT $ envBodyChunk <$> ask
 jsonData :: (A.FromJSON a, MonadIO m) => ActionT m a
 jsonData = do
     b <- body
-    when (b == "") $ do
-      let htmlError = "jsonData - No data was provided."
-      raiseStatus status400 $ T.pack htmlError
+    when (b == "") $ throwIO $ MalformedJSON b "no data"
     case A.eitherDecode b of
-      Left err -> do
-        let htmlError = "jsonData - malformed."
-              `mappend` " Data was: " `mappend` BL.unpack b
-              `mappend` " Error was: " `mappend` err
-        raiseStatus status400 $ T.pack htmlError
+      Left err -> throwIO $ MalformedJSON b $ T.pack err
       Right value -> case A.fromJSON value of
-        A.Error err -> do
-          let htmlError = "jsonData - failed parse."
-                `mappend` " Data was: " `mappend` BL.unpack b `mappend` "."
-                `mappend` " Error was: " `mappend` err
-          raiseStatus status422 $ T.pack htmlError
-        A.Success a -> do
-          return a
+        A.Error err -> throwIO $ FailedToParseJSON b $ T.pack err
+        A.Success a -> return a
 
 -- | Get a parameter. First looks in captures, then form data, then query parameters.
 --
@@ -290,7 +312,7 @@ param k = do
 {-# DEPRECATED param "(#204) Not a good idea to treat all parameters identically. Use captureParam, formParam and queryParam instead. "#-}
 
 -- | Synonym for 'pathParam'
-captureParam :: (Parsable a, Monad m) => T.Text -> ActionT m a
+captureParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a
 captureParam = pathParam
 
 -- | Look up a path parameter.
@@ -300,9 +322,14 @@ captureParam = pathParam
 -- * If the parameter is found, but 'parseParam' fails to parse to the correct type, 'next' is called.
 --
 -- /Since: 0.20/
-pathParam :: (Parsable a, Monad m) => T.Text -> ActionT m a
-pathParam = paramWith PathParam envPathParams status500
-
+pathParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a
+pathParam k = do
+  val <- ActionT $ lookup k . envPathParams <$> ask
+  case val of
+    Nothing -> throwIO $ PathParameterNotFound k
+    Just v -> case parseParam $ TL.fromStrict v of
+      Left _ -> next
+      Right a -> pure a
 
 -- | Look up a form parameter.
 --
@@ -311,8 +338,8 @@ pathParam = paramWith PathParam envPathParams status500
 -- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type.
 --
 -- /Since: 0.20/
-formParam :: (Parsable a, Monad m) => T.Text -> ActionT m a
-formParam = paramWith FormParam envFormParams status400
+formParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a
+formParam = paramWith FormFieldNotFound envFormParams
 
 -- | Look up a query parameter.
 --
@@ -321,8 +348,8 @@ formParam = paramWith FormParam envFormParams status400
 -- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type.
 --
 -- /Since: 0.20/
-queryParam :: (Parsable a, Monad m) => T.Text -> ActionT m a
-queryParam = paramWith QueryParam envQueryParams status400
+queryParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a
+queryParam = paramWith QueryParameterNotFound envQueryParams
 
 -- | Look up a path parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.
 --
@@ -367,21 +394,18 @@ instance Show ParamType where
     FormParam -> "form"
     QueryParam -> "query"
 
-paramWith :: (Monad m, Parsable b) =>
-             ParamType
+paramWith :: (MonadIO m, Parsable b) =>
+             (T.Text -> ScottyException)
           -> (ActionEnv -> [Param])
-          -> Status -- ^ HTTP status to return if parameter is not found
           -> T.Text -- ^ parameter name
           -> ActionT m b
-paramWith ty f err k = do
+paramWith toError f k = do
     val <- ActionT $ (lookup k . f) <$> ask
     case val of
-      Nothing -> raiseStatus err (T.unwords [T.pack (show ty), "parameter:", k, "not found!"])
-      Just v ->
-        let handleParseError = \case
-              PathParam -> next
-              _ -> raiseStatus err (T.unwords ["Cannot parse", v, "as a", T.pack (show ty), "parameter"])
-        in either (const $ handleParseError ty) return $ parseParam $ TL.fromStrict v
+      Nothing -> throwIO $ toError k
+      Just v -> case parseParam $ TL.fromStrict v of
+        Left e -> throwIO $ FailedToParseParameter k v (TL.toStrict e)
+        Right a -> pure a
 
 -- | Look up a parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.
 --

Web/Scotty/Internal/Types.hs

@@ -147,7 +147,15 @@ instance E.Exception StatusError
 type ErrorHandler m = Handler (ActionT m) ()
 
 -- | Thrown e.g. when a request is too large
-data ScottyException = RequestException BS.ByteString Status deriving (Show, Typeable)
+data ScottyException
+  = RequestTooLarge
+  | MalformedJSON LBS8.ByteString Text
+  | FailedToParseJSON LBS8.ByteString Text
+  | PathParameterNotFound Text
+  | QueryParameterNotFound Text
+  | FormFieldNotFound Text
+  | FailedToParseParameter Text Text Text
+  deriving (Show, Typeable)
 instance E.Exception ScottyException
 
 ------------------ Scotty Actions -------------------
@@ -233,12 +241,15 @@ instance (MonadUnliftIO m) => MonadPlus (ActionT m) where
   mzero = empty
   mplus = (<|>)
 
--- | catches either ActionError (thrown by 'next') or 'StatusError' (thrown if e.g. a query parameter is not found)
+-- | catches either ActionError (thrown by 'next'),
+-- 'ScottyException' (thrown if e.g. a query parameter is not found)
+-- or 'StatusError' (via 'raiseStatus')
 tryAnyStatus :: MonadUnliftIO m => m a -> m Bool
-tryAnyStatus io = (io >> pure True) `catches` [h1, h2]
+tryAnyStatus io = (io >> pure True) `catches` [h1, h2, h3]
   where
     h1 = Handler $ \(_ :: ActionError) -> pure False
     h2 = Handler $ \(_ :: StatusError) -> pure False
+    h3 = Handler $ \(_ :: ScottyException) -> pure False
 
 instance (Semigroup a) => Semigroup (ScottyT m a) where
   x <> y = (<>) <$> x <*> y

Web/Scotty/Trans.hs

@@ -41,6 +41,7 @@ module Web.Scotty.Trans
     , Lazy.raise, Lazy.raiseStatus, throw, rescue, next, finish, defaultHandler, liftAndCatchIO
     , liftIO, catch
     , StatusError(..)
+    , ScottyException(..)
       -- * Parsing Parameters
     , Param, Parsable(..), readEither
       -- * Types
@@ -51,13 +52,14 @@ module Web.Scotty.Trans
     ) where
 
 import Blaze.ByteString.Builder (fromByteString)
+import Blaze.ByteString.Builder.Char8 (fromString)
 
 import Control.Exception (assert)
 import Control.Monad (when)
 import Control.Monad.State.Strict (execState, modify)
 import Control.Monad.IO.Class
 
-import Network.HTTP.Types (status404)
+import Network.HTTP.Types (status404, status413, status500)
 import Network.Socket (Socket)
 import qualified Network.Wai as W (Application, Middleware, Response, responseBuilder)
 import Network.Wai.Handler.Warp (Port, runSettings, runSettingsSocket, setPort, getPort)
@@ -69,7 +71,7 @@ import Web.Scotty.Trans.Lazy as Lazy
 import Web.Scotty.Util (socketDescription)
 import Web.Scotty.Body (newBodyInfo)
 
-import UnliftIO.Exception (Handler(..), catch, catches)
+import UnliftIO.Exception (Handler(..), catch)
 
 
 -- | Run a scotty application using the warp server.
@@ -119,10 +121,19 @@ scottyAppT runActionToIO defs = do
     let s = execState (runS defs) defaultScottyState
     let rapp req callback = do
           bodyInfo <- newBodyInfo req
-          resp <- runActionToIO (applyAll notFoundApp ([midd bodyInfo | midd <- routes s]) req) `catches` [scottyExceptionHandler]
+          resp <- runActionToIO (applyAll notFoundApp ([midd bodyInfo | midd <- routes s]) req)
+            `catch` unhandledExceptionHandler
           callback resp
     return $ applyAll rapp (middlewares s)
 
+--- | Exception handler in charge of 'ScottyException' that's not caught by 'scottyExceptionHandler'
+unhandledExceptionHandler :: MonadIO m => ScottyException -> m W.Response
+unhandledExceptionHandler = \case
+  RequestTooLarge -> return $ W.responseBuilder status413 ct "Request is too big Jim!"
+  e -> return $ W.responseBuilder status500 ct $ "Internal Server Error: " <> fromString (show e)
+  where
+    ct = [("Content-Type", "text/plain")]
+
 applyAll :: Foldable t => a -> t (a -> a) -> a
 applyAll = foldl (flip ($))
 
@@ -134,13 +145,6 @@ notFoundApp _ = return $ W.responseBuilder status404 [("Content-Type","text/html
 defaultHandler :: (Monad m) => ErrorHandler m -> ScottyT m ()
 defaultHandler f = ScottyT $ modify $ setHandler $ Just f
 
--- | Exception handler in charge of 'ScottyException'
-scottyExceptionHandler :: MonadIO m => Handler m W.Response
-scottyExceptionHandler = Handler $ \case
-  RequestException ebody s -> do
-    return $ W.responseBuilder s [("Content-Type", "text/plain")] (fromByteString ebody)
-
-
 -- | Use given middleware. Middleware is nested such that the first declared
 -- is the outermost middleware (it has first dibs on the request and last action
 -- on the response). Every middleware is run on each request.

Web/Scotty/Trans/Strict.hs

@@ -43,6 +43,7 @@ module Web.Scotty.Trans.Strict
       -- ** Exceptions
     , Base.raise, Base.raiseStatus, throw, rescue, next, finish, defaultHandler, liftAndCatchIO
     , StatusError(..)
+    , ScottyException(..)
       -- * Parsing Parameters
     , Param, Parsable(..), readEither
       -- * Types

Web/Scotty/Util.hs

@@ -15,12 +15,8 @@ module Web.Scotty.Util
 import Network.Socket (SockAddr(..), Socket, getSocketName, socketPort)
 import Network.Wai
 
+import Control.Exception
 import Control.Monad (when)
-import qualified Control.Exception as EUnsafe (throw)
-
-
-import Network.HTTP.Types
-
 import qualified Data.ByteString as B
 import qualified Data.Text as TP (Text, pack)
 import qualified Data.Text.Lazy as TL
@@ -97,7 +93,7 @@ readRequestBody rbody prefix maxSize = do
           readUntilEmpty = do
             b <- rbody
             if B.null b
-              then EUnsafe.throw (RequestException (ES.encodeUtf8 . TP.pack $ "Request is too big Jim!") status413)
+              then throwIO RequestTooLarge
               else readUntilEmpty
 
 

changelog.md

@@ -6,6 +6,8 @@
 * add `Web.Scotty.Trans.Strict` and `Web.Scotty.Trans.Lazy`
 * Reverted the `MonadReader` instance of `ActionT` so that it inherits the base monad
 * renamed `captureParam`, `captureParamMaybe`, and `captureParams` to `pathParam`, `pathParamMaybe`, `pathParams` respectively, keeping the old names as their synonyms
+* Scotty's API such as `queryParam` now throws `ScottyException` rather than `StatusException`.
+  Uncaught exceptions are handled by `scottyExceptionHandler`, resembling the existing behaviour
 
 ## 0.20.1 [2023.10.03]
 

test/Web/ScottySpec.hs

@@ -188,7 +188,7 @@ spec = do
           get "/search/potato" `shouldRespondWith` 500
       context "recover from missing parameter exception" $ do
         withApp (Scotty.get "/search/:q" $
-                 (captureParam "z" >>= text) `catch` (\(_::StatusError) -> text "z")
+                 (captureParam "z" >>= text) `catch` (\(_::ScottyException) -> text "z")
                 ) $ do
           it "catches a StatusError" $ do
             get "/search/xxx" `shouldRespondWith` 200 { matchBody = "z"}
@@ -206,9 +206,9 @@ spec = do
           get "/search?query=potato" `shouldRespondWith` 400
       context "recover from type mismatch parameter exception" $ do
         withApp (Scotty.get "/search" $
-                 (queryParam "z" >>= (\v -> json (v :: Int))) `catch` (\(_::StatusError) -> text "z")
+                 (queryParam "z" >>= (\v -> json (v :: Int))) `catch` (\(_::ScottyException) -> text "z")
                 ) $ do
-          it "catches a StatusError" $ do
+          it "catches a ScottyException" $ do
             get "/search?query=potato" `shouldRespondWith` 200 { matchBody = "z"}
 
     describe "formParam" $ do
@@ -238,7 +238,7 @@ spec = do
           postForm "/" "p=42" `shouldRespondWith` "42"
       context "recover from type mismatch parameter exception" $ do
         withApp (Scotty.post "/search" $
-                 (formParam "z" >>= (\v -> json (v :: Int))) `catch` (\(_::StatusError) -> text "z")
+                 (formParam "z" >>= (\v -> json (v :: Int))) `catch` (\(_::ScottyException) -> text "z")
                 ) $ do
           it "catches a StatusError" $ do
             postForm "/search" "z=potato" `shouldRespondWith` 200 { matchBody = "z"}