From 8107e163f506a9c2a0744a784240259fdeda24f2 Mon Sep 17 00:00:00 2001 From: Fumiaki Kinoshita Date: Sun, 5 Nov 2023 17:58:23 +0900 Subject: [PATCH] Handle exceptions from scotty as ScottyException --- Web/Scotty.hs | 4 +- Web/Scotty/Action.hs | 94 ++++++++++++++++++++++-------------- Web/Scotty/Internal/Types.hs | 17 +++++-- Web/Scotty/Trans.hs | 24 +++++---- Web/Scotty/Trans/Strict.hs | 1 + Web/Scotty/Util.hs | 8 +-- changelog.md | 2 + test/Web/ScottySpec.hs | 8 +-- 8 files changed, 98 insertions(+), 60 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 479bb229..7c6b81b3 100644 --- a/Web/Scotty.hs +++ b/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) diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 6e205289..3d576b03 100644 --- a/Web/Scotty/Action.hs +++ b/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. -- diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs index f397e707..38fab71d 100644 --- a/Web/Scotty/Internal/Types.hs +++ b/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 diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 65dda7be..117accad 100644 --- a/Web/Scotty/Trans.hs +++ b/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. diff --git a/Web/Scotty/Trans/Strict.hs b/Web/Scotty/Trans/Strict.hs index 8829b444..a835b78d 100644 --- a/Web/Scotty/Trans/Strict.hs +++ b/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 diff --git a/Web/Scotty/Util.hs b/Web/Scotty/Util.hs index 58093073..7a04135e 100644 --- a/Web/Scotty/Util.hs +++ b/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 diff --git a/changelog.md b/changelog.md index a92f7ca6..35f15736 100644 --- a/changelog.md +++ b/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] diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index 04389bc6..bddac248 100644 --- a/test/Web/ScottySpec.hs +++ b/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"}