Print unhandled exception to stdout depending on verbosity (#374)

* Print unhandled exception to stdout depending on verbosity

---------

Co-authored-by: Marco Z <[email protected]>

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
 

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'.
 --

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 )
 
 

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

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 ()

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 ()