diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 68d4a6d..bf22259 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -121,7 +121,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 () @@ -144,8 +144,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 fa541ed..e739224 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 #-} @@ -86,6 +87,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 @@ -102,6 +104,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(..)) @@ -112,15 +115,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 @@ -190,11 +194,15 @@ scottyExceptionHandler = Handler $ \case text $ T.unwords ["resourcet Exception:", T.pack (show rte)] -- | Uncaught exceptions turn into HTTP 500 Server Error codes -someExceptionHandler :: MonadIO m => ErrorHandler m -someExceptionHandler = Handler $ \case - (e :: E.SomeException) -> do +someExceptionHandler :: MonadIO m => Options -> ErrorHandler m +someExceptionHandler Options{verbose} = + Handler $ \(E.SomeException e) -> do + when (verbose > 0) $ + liftIO $ + hPutStrLn stderr $ + "Unhandled exception of " <> show (typeOf e) <> ": " <> show e status status500 - text $ T.unwords ["Uncaught server exception:", T.pack (show e)] + -- | 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 efc40d2..73b6a0f 100644 --- a/Web/Scotty/Internal/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -120,7 +120,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 1baa308..1f05390 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 Control.Monad.Trans.Resource (InternalState) @@ -21,7 +22,9 @@ import Network.Wai (Request(..)) import qualified Text.Regex as Regex import Web.Scotty.Action -import Web.Scotty.Internal.Types (RoutePattern(..), RouteOptions, ActionEnv(..), ScottyState(..), ScottyT(..), File, 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) @@ -80,7 +83,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. @@ -103,13 +112,20 @@ 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' @@ -128,7 +144,8 @@ route opts h method pat action bodyInfo app req = cbi <- cloneBodyInfo bodyInfo env <- mkEnv cbi 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 9616108..8096e7b 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -67,6 +67,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 @@ -104,7 +105,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. @@ -119,17 +120,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) @@ -163,7 +165,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 6658888..89b8ddb 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 @@ -19,15 +20,17 @@ import Weigh main :: IO () main = do - mainWith $ do - setColumns [Case,Allocated,GCs,Live,Check,Max,MaxOS] - setFormat Markdown - io "ScottyM Strict" BL.putStr - (SS.evalState (runS $ renderBST htmlScotty) defaultScottyState) - io "ScottyM Lazy" BL.putStr - (SL.evalState (runScottyLazy $ renderBST htmlScottyLazy) defaultScottyState) - io "Identity" BL.putStr - (runIdentity $ renderBST htmlIdentity) + mainWith $ do + setColumns [Case,Allocated,GCs,Live,Check,Max,MaxOS] + setFormat Markdown + io "ScottyM Strict" BL.putStr + (SS.evalState + (R.runReaderT (runS $ renderBST htmlScotty) defaultOptions) + defaultScottyState) + io "ScottyM Lazy" BL.putStr + (SL.evalState (runScottyLazy $ renderBST htmlScottyLazy) defaultScottyState) + io "Identity" BL.putStr + (runIdentity $ renderBST htmlIdentity) htmlTest :: Monad m => HtmlT m ()