From 910ca3dd247d1b6672791b2394966c619ec62bd6 Mon Sep 17 00:00:00 2001 From: Yuriy Syrovetskiy Date: Mon, 12 Feb 2024 00:11:21 +0100 Subject: [PATCH 1/3] Print unhandled exception to stdout depending on verbosity --- Web/Scotty.hs | 6 +++--- Web/Scotty/Action.hs | 19 +++++++++++++------ Web/Scotty/Internal/Types.hs | 3 ++- Web/Scotty/Route.hs | 26 ++++++++++++++++++++------ Web/Scotty/Trans.hs | 14 ++++++++------ bench/Main.hs | 5 ++++- 6 files changed, 50 insertions(+), 23 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index fae5180f..c71ec082 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -118,7 +118,7 @@ scottySocket opts sock = Trans.scottySocketT opts sock id -- | Turn a scotty application into a WAI 'Application', which can be -- run with any WAI handler. scottyApp :: ScottyM () -> IO Application -scottyApp = Trans.scottyAppT id +scottyApp = Trans.scottyAppT defaultOptions id -- | Global handler for user-defined exceptions. defaultHandler :: ErrorHandler IO -> ScottyM () @@ -141,8 +141,8 @@ nested :: Application -> ActionM () nested = Trans.nested -- | Set global size limit for the request body. Requests with body size exceeding the limit will not be --- processed and an HTTP response 413 will be returned to the client. Size limit needs to be greater than 0, --- otherwise the application will terminate on start. +-- processed and an HTTP response 413 will be returned to the client. Size limit needs to be greater than 0, +-- otherwise the application will terminate on start. setMaxRequestBodySize :: Kilobytes -> ScottyM () setMaxRequestBodySize = Trans.setMaxRequestBodySize diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index f625d6cf..4805e569 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} @@ -82,6 +83,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE import Data.Time (UTCTime) import Data.Time.Format (parseTimeM, defaultTimeLocale) +import Data.Typeable (typeOf) import Data.Word import Network.HTTP.Types @@ -105,15 +107,16 @@ import Network.Wai.Internal (ResponseReceived(..)) -- 'Nothing' indicates route failed (due to Next) and pattern matching should try the next available route. -- 'Just' indicates a successful response. runAction :: MonadUnliftIO m => - Maybe (ErrorHandler m) -- ^ this handler (if present) is in charge of user-defined exceptions + Options + -> Maybe (ErrorHandler m) -- ^ this handler (if present) is in charge of user-defined exceptions -> ActionEnv -> ActionT m () -- ^ Route action to be evaluated -> m (Maybe Response) -runAction mh env action = do +runAction options mh env action = do ok <- flip runReaderT env $ runAM $ tryNext $ action `catches` concat [ [actionErrorHandler] , maybeToList mh - , [statusErrorHandler, scottyExceptionHandler, someExceptionHandler] + , [statusErrorHandler, scottyExceptionHandler, someExceptionHandler options] ] res <- getResponse env return $ bool Nothing (Just $ mkResponse res) ok @@ -171,9 +174,13 @@ scottyExceptionHandler = Handler $ \case 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 - (_ :: E.SomeException) -> status status500 +someExceptionHandler :: MonadIO m => Options -> ErrorHandler m +someExceptionHandler Options{verbose} = + Handler $ \(E.SomeException e) -> do + when (verbose > 0) $ + liftIO $ + putStrLn $ "Caught and exception of " <> show (typeOf e) <> ": " <> show e + status status500 -- | Throw a "500 Server Error" 'StatusError', which can be caught with 'catch'. -- diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs index 4de097c4..33d9cf88 100644 --- a/Web/Scotty/Internal/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -116,7 +116,8 @@ updateMaxRequestBodySize RouteOptions { .. } s@ScottyState { routeOptions = ro } let ro' = ro { maxRequestBodySize = maxRequestBodySize } in s { routeOptions = ro' } -newtype ScottyT m a = ScottyT { runS :: State (ScottyState m) a } +newtype ScottyT m a = + ScottyT { runS :: ReaderT Options (State (ScottyState m)) a } deriving ( Functor, Applicative, Monad ) diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 9c4bd951..e8bb7a3a 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -9,6 +9,7 @@ import Control.Arrow ((***)) import Control.Concurrent.STM (newTVarIO) import Control.Monad.IO.Class (MonadIO(..)) import UnliftIO (MonadUnliftIO(..)) +import qualified Control.Monad.Reader as MR import qualified Control.Monad.State as MS import Data.String (fromString) @@ -20,7 +21,7 @@ import Network.Wai (Request(..)) import qualified Text.Regex as Regex import Web.Scotty.Action -import Web.Scotty.Internal.Types (RoutePattern(..), RouteOptions, ActionEnv(..), ActionT, ScottyState(..), ScottyT(..), ErrorHandler, Middleware, BodyInfo, handler, addRoute, defaultScottyResponse) +import Web.Scotty.Internal.Types (Options, RoutePattern(..), RouteOptions, ActionEnv(..), ActionT, ScottyState(..), ScottyT(..), ErrorHandler, Middleware, BodyInfo, handler, addRoute, defaultScottyResponse) import Web.Scotty.Util (decodeUtf8Lenient) import Web.Scotty.Body (cloneBodyInfo, getBodyAction, getBodyChunkAction, getFormParamsAndFilesAction) @@ -78,7 +79,13 @@ options = addroute OPTIONS -- | Add a route that matches regardless of the HTTP verb. matchAny :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () -matchAny pat action = ScottyT $ MS.modify $ \s -> addRoute (route (routeOptions s) (handler s) Nothing pat action) s +matchAny pat action = + ScottyT $ do + serverOptions <- MR.ask + MS.modify $ \s -> + addRoute + (route serverOptions (routeOptions s) (handler s) Nothing pat action) + s -- | Specify an action to take if nothing else is found. Note: this _always_ matches, -- so should generally be the last route specified. @@ -101,12 +108,19 @@ let server = S.get "/foo/:bar" (S.pathParam "bar" >>= S.text) "something" -} addroute :: (MonadUnliftIO m) => StdMethod -> RoutePattern -> ActionT m () -> ScottyT m () -addroute method pat action = ScottyT $ MS.modify $ \s -> addRoute (route (routeOptions s) (handler s) (Just method) pat action) s +addroute method pat action = + ScottyT $ do + serverOptions <- MR.ask + MS.modify $ \s -> + addRoute + (route serverOptions (routeOptions s) (handler s) (Just method) pat action) + s route :: (MonadUnliftIO m) => - RouteOptions + Options + -> RouteOptions -> Maybe (ErrorHandler m) -> Maybe StdMethod -> RoutePattern -> ActionT m () -> BodyInfo -> Middleware m -route opts h method pat action bodyInfo app req = +route serverOpts opts h method pat action bodyInfo app req = let tryNext = app req -- We match all methods in the case where 'method' is 'Nothing'. -- See https://github.com/scotty-web/scotty/issues/196 and 'matchAny' @@ -125,7 +139,7 @@ route opts h method pat action bodyInfo app req = clonedBodyInfo <- cloneBodyInfo bodyInfo env <- mkEnv clonedBodyInfo req captures opts - res <- runAction h env action + res <- runAction serverOpts h env action maybe tryNext return res Nothing -> tryNext else tryNext diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 4bdc5c29..bf739125 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -64,6 +64,7 @@ import Blaze.ByteString.Builder.Char8 (fromString) import Control.Exception (assert) import Control.Monad (when) +import Control.Monad.Reader (runReaderT) import Control.Monad.State.Strict (execState, modify) import Control.Monad.IO.Class @@ -101,7 +102,7 @@ scottyOptsT :: (Monad m, MonadIO n) scottyOptsT opts runActionToIO s = do when (verbose opts > 0) $ liftIO $ putStrLn $ "Setting phasers to stun... (port " ++ show (getPort (settings opts)) ++ ") (ctrl-c to quit)" - liftIO . runSettings (settings opts) =<< scottyAppT runActionToIO s + liftIO . runSettings (settings opts) =<< scottyAppT opts runActionToIO s -- | Run a scotty application using the warp server, passing extra options, and -- listening on the provided socket. @@ -116,17 +117,18 @@ scottySocketT opts sock runActionToIO s = do when (verbose opts > 0) $ do d <- liftIO $ socketDescription sock liftIO $ putStrLn $ "Setting phasers to stun... (" ++ d ++ ") (ctrl-c to quit)" - liftIO . runSettingsSocket (settings opts) sock =<< scottyAppT runActionToIO s + liftIO . runSettingsSocket (settings opts) sock =<< scottyAppT opts runActionToIO s -- | Turn a scotty application into a WAI 'Application', which can be -- run with any WAI handler. -- NB: scottyApp === scottyAppT id scottyAppT :: (Monad m, Monad n) - => (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action. + => Options + -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action. -> ScottyT m () -> n W.Application -scottyAppT runActionToIO defs = do - let s = execState (runS defs) defaultScottyState +scottyAppT options runActionToIO defs = do + let s = execState (runReaderT (runS defs) options) defaultScottyState let rapp req callback = do bodyInfo <- newBodyInfo req resp <- runActionToIO (applyAll notFoundApp ([midd bodyInfo | midd <- routes s]) req) @@ -160,7 +162,7 @@ middleware :: W.Middleware -> ScottyT m () middleware = ScottyT . modify . addMiddleware -- | Set global size limit for the request body. Requests with body size exceeding the limit will not be --- processed and an HTTP response 413 will be returned to the client. Size limit needs to be greater than 0, +-- processed and an HTTP response 413 will be returned to the client. Size limit needs to be greater than 0, -- otherwise the application will terminate on start. setMaxRequestBodySize :: Kilobytes -- ^ Request size limit -> ScottyT m () diff --git a/bench/Main.hs b/bench/Main.hs index 19a0fc49..8589b8ed 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -11,6 +11,7 @@ import Lucid.Base import Lucid.Html5 import Web.Scotty import Web.Scotty.Internal.Types +import qualified Control.Monad.Reader as R import qualified Control.Monad.State.Lazy as SL import qualified Control.Monad.State.Strict as SS import qualified Data.ByteString.Lazy as BL @@ -23,7 +24,9 @@ main = do setColumns [Case,Allocated,GCs,Live,Check,Max,MaxOS] setFormat Markdown io "ScottyM Strict" BL.putStr - (SS.evalState (runS $ renderBST htmlScotty) defaultScottyState) + (SS.evalState + (R.runReaderT (runS $ renderBST htmlScotty) defaultOptions) + defaultScottyState) io "ScottyM Lazy" BL.putStr (SL.evalState (runScottyLazy $ renderBST htmlScottyLazy) defaultScottyState) io "Identity" BL.putStr From b098474255e2080cf58198c093339a4555730df5 Mon Sep 17 00:00:00 2001 From: Yuriy Syrovetskiy Date: Tue, 13 Feb 2024 08:57:05 +0100 Subject: [PATCH 2/3] fixup! Print unhandled exception to stdout depending on verbosity --- Web/Scotty/Action.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 4805e569..4ebf42b9 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -98,6 +98,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, throwIO) +import System.IO (hPutStrLn, stderr) import Network.Wai.Internal (ResponseReceived(..)) @@ -179,7 +180,8 @@ someExceptionHandler Options{verbose} = Handler $ \(E.SomeException e) -> do when (verbose > 0) $ liftIO $ - putStrLn $ "Caught and exception of " <> show (typeOf e) <> ": " <> show e + hPutStrLn stderr $ + "Unhandled exception of " <> show (typeOf e) <> ": " <> show e status status500 -- | Throw a "500 Server Error" 'StatusError', which can be caught with 'catch'. From 62e56ebed8e9d6ebb14ff2e261c966436fc4e851 Mon Sep 17 00:00:00 2001 From: Marco Z Date: Sat, 9 Mar 2024 21:29:42 +0100 Subject: [PATCH 3/3] Update Route.hs add File import --- Web/Scotty/Route.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index ff6de6ea..1f05390a 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -23,7 +23,7 @@ import qualified Text.Regex as Regex import Web.Scotty.Action -import Web.Scotty.Internal.Types (Options, RoutePattern(..), RouteOptions, ActionEnv(..), ActionT, ScottyState(..), ScottyT(..), ErrorHandler, Middleware, BodyInfo, handler, addRoute, defaultScottyResponse) +import Web.Scotty.Internal.Types (Options, RoutePattern(..), RouteOptions, ActionEnv(..), ActionT, ScottyState(..), ScottyT(..), ErrorHandler, Middleware, BodyInfo, File, handler, addRoute, defaultScottyResponse) import Web.Scotty.Util (decodeUtf8Lenient) import Web.Scotty.Body (cloneBodyInfo, getBodyAction, getBodyChunkAction, getFormParamsAndFilesAction)