diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 845bcb60..9ec7a9c3 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} +{-# language ScopedTypeVariables #-} {-# options_ghc -Wno-unused-imports #-} module Web.Scotty.Action ( addHeader @@ -92,33 +93,26 @@ import Web.Scotty.Exceptions (Handler(..), catch, catches, catchesOptionally, ca import Network.Wai.Internal (ResponseReceived(..)) --- | Nothing indicates route failed (due to Next) and pattern matching should continue. --- Just indicates a successful response. +-- | Evaluate a route, catch all exceptions (user-defined ones, internal and all remaining, in this order) +-- and construct the 'Response' +-- +-- '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) -- ^ if present, this handler is in charge of user-defined exceptions - -> ActionEnv -> ActionT m () -> m (Maybe Response) + 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 let handlers = [ - scottyExceptionHandler - , actionErrorHandler + actionErrorHandler -- ActionError e.g. Next, Redirect + , someExceptionHandler -- all remaining exceptions ] ok <- flip runReaderT env $ runAM $ tryNext (catchesOptionally action mh handlers ) res <- getResponse env return $ bool Nothing (Just $ mkResponse res) ok - -{-| -* ActionError should only be caught by runAction -* handlers should not throw ActionError (= do not export ActionError constructors) --} - -tryNext :: MonadUnliftIO m => m a -> m Bool -tryNext io = catch (io >> pure True) $ \e -> - case e of - Next -> pure False - _ -> pure True - -- | Exception handler in charge of 'ActionError'. Rethrowing 'Next' here is caught by 'tryNext' actionErrorHandler :: MonadIO m => ErrorHandler m actionErrorHandler = Handler $ \case @@ -133,31 +127,16 @@ actionErrorHandler = Handler $ \case Next -> next Finish -> return () --- | Exception handler in charge of 'ScottyException' -scottyExceptionHandler :: MonadIO m => ErrorHandler m -scottyExceptionHandler = Handler $ \case - RequestException ebody s -> do - raiseStatus s (strictByteStringToLazyText ebody) - --- -- defH :: (Monad m) => ErrorHandler e m -> ActionError -> ActionT e m () --- defH :: MonadUnliftIO m => Maybe (AErr -> ActionT m ()) -> ActionError -> ActionT m () --- defH _ (Redirect url) = do --- status status302 --- setHeader "Location" url --- defH Nothing (ActionError s e) = do --- status s --- let code = T.pack $ show $ statusCode s --- let msg = T.fromStrict $ STE.decodeUtf8 $ statusMessage s --- html $ mconcat ["

", code, " ", msg, "

", T.pack (show e)] --- defH h@(Just f) (ActionError _ e) = f e `catch` (defH h) -- so handlers can throw exceptions themselves -- TODO --- defH _ Next = next -- rethrow 'Next' --- defH _ Finish = return () -- stop +-- | Uncaught exceptions turn into HTTP 500 Server Error codes +someExceptionHandler :: MonadIO m => ErrorHandler m +someExceptionHandler = Handler $ \case + (_ :: E.SomeException) -> status status500 + -- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions -- turn into HTTP 500 responses. --- raise :: (Monad m) => AErr -> ActionT m a raise :: (MonadIO m, E.Exception e) => e -> ActionT m a -raise = E.throw -- raiseStatus status500 +raise = E.throw -- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions turn into HTTP responses corresponding to the given status. raiseStatus :: (Monad m) => Status -> T.Text -> ActionT m a diff --git a/Web/Scotty/Body.hs b/Web/Scotty/Body.hs index a2839d85..4535f416 100644 --- a/Web/Scotty/Body.hs +++ b/Web/Scotty/Body.hs @@ -20,7 +20,7 @@ import Network.Wai (Request(..), getRequestBodyChunk) import qualified Network.Wai.Parse as W (File, Param, getRequestBodyType, BackEnd, lbsBackEnd, sinkRequestBody) import Web.Scotty.Action import Web.Scotty.Internal.Types (BodyInfo(..), BodyChunkBuffer(..), BodyPartiallyStreamed(..), RouteOptions(..)) -import Web.Scotty.Util +import Web.Scotty.Util (readRequestBody, strictByteStringToLazyText) -- | Make a new BodyInfo with readProgress at 0 and an empty BodyChunkBuffer. newBodyInfo :: (MonadIO m) => Request -> m BodyInfo diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs index 6810ce52..49fd52f6 100644 --- a/Web/Scotty/Internal/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -29,7 +29,7 @@ import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Unlift (MonadUnliftIO(..)) import Control.Monad.Reader (MonadReader(..), ReaderT, mapReaderT, asks) -import Control.Monad.State.Strict (MonadState(..), State, StateT, mapStateT) +import Control.Monad.State.Strict (MonadState(..), State, StateT(..), mapStateT, execState) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Control (MonadBaseControl, StM, liftBaseWith, restoreM, ComposeSt, defaultLiftBaseWith, defaultRestoreM, MonadTransControl, StT, liftWith, restoreT) import Control.Monad.Trans.Except @@ -49,7 +49,7 @@ import qualified Network.Wai as Wai import Network.Wai.Handler.Warp (Settings, defaultSettings) import Network.Wai.Parse (FileInfo) -import Web.Scotty.Exceptions (Handler, tryAny) +import Web.Scotty.Exceptions (Handler, catch) import Prelude () import "base-compat-batteries" Prelude.Compat @@ -136,6 +136,14 @@ data ActionError deriving (Show, Typeable) instance E.Exception ActionError +tryNext :: MonadUnliftIO m => m a -> m Bool +tryNext io = catch (io >> pure True) $ \e -> + case e of + Next -> pure False + _ -> pure True + + + -- | Specializes a 'Handler' to the 'ActionT' monad type ErrorHandler m = Handler (ActionT m) () @@ -199,10 +207,15 @@ newtype ActionT m a = ActionT { runAM :: ReaderT ActionEnv m a } instance (MonadUnliftIO m) => Alternative (ActionT m) where empty = E.throw Next a <|> b = do - e <- tryAny a - case e of - Left _ -> b - Right ra -> pure ra + ok <- tryActionError a + if ok then a else b +instance (MonadUnliftIO m) => MonadPlus (ActionT m) where + mzero = empty + mplus = (<|>) + +-- | an ActionError is thrown if e.g. a query parameter is not found, or 'next' is called +tryActionError :: MonadUnliftIO m => m a -> m Bool +tryActionError io = catch (io >> pure True) (\(_ :: ActionError) -> pure False) instance (Semigroup a) => Semigroup (ScottyT m a) where x <> y = (<>) <$> x <*> y diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 73388d48..65ea63db 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -7,7 +7,7 @@ module Web.Scotty.Route ) where import Control.Arrow ((***)) -import Control.Concurrent.STM (STM, TVar, atomically, newTVarIO) +import Control.Concurrent.STM (newTVarIO) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Unlift (MonadUnliftIO(..)) import qualified Control.Monad.State as MS diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 64435c0c..0f26392a 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings, RankNTypes #-} +{-# language LambdaCase #-} -- | It should be noted that most of the code snippets below depend on the -- OverloadedStrings language pragma. -- @@ -11,7 +12,7 @@ -- the comments on each of these functions for more information. module Web.Scotty.Trans ( -- * scotty-to-WAI - scottyT, scottyAppT, scottyOptsT, scottySocketT, Options(..), Scotty.defaultOptions + scottyT, scottyAppT, scottyOptsT, scottySocketT, Options(..), defaultOptions -- * Defining Middleware and Routes -- -- | 'Middleware' and routes are run in the order in which they @@ -50,26 +51,23 @@ import Control.Monad (when) import Control.Monad.State.Strict (execState, modify) import Control.Monad.IO.Class --- import Data.Default.Class (def) - -import Network.HTTP.Types (status404, status500) +import Network.HTTP.Types (status404) import Network.Socket (Socket) -import Network.Wai +import qualified Network.Wai as W (Application, Middleware, Response, responseBuilder) import Network.Wai.Handler.Warp (Port, runSettings, runSettingsSocket, setPort, getPort) import Web.Scotty.Action import Web.Scotty.Route -import Web.Scotty.Internal.Types hiding (Application, Middleware) +import Web.Scotty.Internal.Types (ActionT(..), ScottyT(..), defaultScottyState, Application, RoutePattern, Options(..), defaultOptions, RouteOptions(..), defaultRouteOptions, ErrorHandler, Kilobytes, File, addMiddleware, setHandler, updateMaxRequestBodySize, routes, middlewares, ScottyException(..)) import Web.Scotty.Util (socketDescription) -import qualified Web.Scotty.Internal.Types as Scotty import Web.Scotty.Body (newBodyInfo) -import Web.Scotty.Exceptions (Handler(..)) +import Web.Scotty.Exceptions (Handler(..), catches) -- | Run a scotty application using the warp server. -- NB: scotty p === scottyT p id scottyT :: (Monad m, MonadIO n) => Port - -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. + -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action. -> ScottyT m () -> n () scottyT p = scottyOptsT $ defaultOptions { settings = setPort p (settings defaultOptions) } @@ -78,7 +76,7 @@ scottyT p = scottyOptsT $ defaultOptions { settings = setPort p (settings defaul -- NB: scottyOpts opts === scottyOptsT opts id scottyOptsT :: (Monad m, MonadIO n) => Options - -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. + -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action. -> ScottyT m () -> n () scottyOptsT opts runActionToIO s = do @@ -92,7 +90,7 @@ scottyOptsT opts runActionToIO s = do scottySocketT :: (Monad m, MonadIO n) => Options -> Socket - -> (m Response -> IO Response) + -> (m W.Response -> IO W.Response) -> ScottyT m () -> n () scottySocketT opts sock runActionToIO s = do @@ -105,35 +103,44 @@ scottySocketT opts sock runActionToIO s = do -- run with any WAI handler. -- NB: scottyApp === scottyAppT id scottyAppT :: (Monad m, Monad n) - => (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. + => (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action. -> ScottyT m () - -> n Application + -> n W.Application scottyAppT runActionToIO defs = do let s = execState (runS defs) defaultScottyState let rapp req callback = do bodyInfo <- newBodyInfo req - runActionToIO (applyAll notFoundApp ([midd bodyInfo | midd <- routes s]) req) >>= callback + resp <- runActionToIO (applyAll notFoundApp ([midd bodyInfo | midd <- routes s]) req) `catches` [scottyExceptionHandler] + callback resp return $ applyAll rapp (middlewares s) applyAll :: Foldable t => a -> t (a -> a) -> a applyAll = foldl (flip ($)) -notFoundApp :: Monad m => Scotty.Application m -notFoundApp _ = return $ responseBuilder status404 [("Content-Type","text/html")] +notFoundApp :: Monad m => Application m +notFoundApp _ = return $ W.responseBuilder status404 [("Content-Type","text/html")] $ fromByteString "

404: File Not Found!

" -- | Global handler for user-defined exceptions. -defaultHandler :: (Monad m) => (ErrorHandler m) -> ScottyT m () +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 [] (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. -middleware :: Middleware -> ScottyT m () +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, --- otherwise the application will terminate on start. -setMaxRequestBodySize :: Kilobytes -> ScottyT m () -setMaxRequestBodySize i = assert (i > 0) $ ScottyT . modify . updateMaxRequestBodySize $ defaultRouteOptions { maxRequestBodySize = Just i } +-- otherwise the application will terminate on start. +setMaxRequestBodySize :: Kilobytes -- ^ Request size limit + -> ScottyT m () +setMaxRequestBodySize i = assert (i > 0) $ ScottyT . modify . updateMaxRequestBodySize $ defaultRouteOptions { maxRequestBodySize = Just i } diff --git a/changelog.md b/changelog.md index 09b0ce9c..c99047cd 100644 --- a/changelog.md +++ b/changelog.md @@ -6,11 +6,11 @@ * Change body parsing behaviour such that calls to `next` don't result in POST request bodies disappearing (#147). * (Internal) Remove unused type `RequestBodyState` (#313) -### Breaking: +Breaking: * Get rid of data-default-class (#316) https://markkarpov.com/post/data-default.html -* (#314) Rewrite `ActionT` as a `ReaderT`-over-`IO` (using the "ReaderT pattern" : https://www.fpcomplete.com/blog/readert-design-pattern/ ) -* (#314) Introduce `unliftio-core` as a dependency, and base exception handling on methods copied from `unliftio` e.g. `catch`. -* (#314) All ActionT methods (`text`, `html` etc.) have now a MonadIO constraint on the base monad rather than Monad. `rescue` has a MonadUnliftIO constraint. The Alternative instance of ActionT also is based on MonadIO because `next` is implemented in terms of `throw`. +* (#310) Rewrite `ActionT` as a `ReaderT`-over-`IO` (using the "ReaderT pattern" : https://www.fpcomplete.com/blog/readert-design-pattern/ ) +* (#310) Introduce `unliftio-core` as a dependency, and base exception handling on methods copied from `unliftio` e.g. `catch`. +* (#310) All ActionT methods (`text`, `html` etc.) have now a MonadIO constraint on the base monad rather than Monad. `rescue` has a MonadUnliftIO constraint. The Alternative instance of ActionT also is based on MonadIO because `next` is implemented in terms of `throw`. ## 0.12.1 [2022.11.17] * Fix CPP bug that prevented tests from building on Windows. diff --git a/examples/basic.hs b/examples/basic.hs index bb91f496..5b54f631 100644 --- a/examples/basic.hs +++ b/examples/basic.hs @@ -37,7 +37,7 @@ main = scotty 3000 $ do get "/" $ text "foobar" get "/" $ text "barfoo" - -- Using a parameter in the query string. If it has + -- Using a parameter in the query string. Since it has -- not been given, a 500 page is generated. get "/foo" $ do v <- captureParam "fooparam" @@ -72,7 +72,7 @@ main = scotty 3000 $ do -- Files are streamed directly to the client. get "/404" $ file "404.html" - -- You can stop execution of this action and keep pattern matching routes. + -- 'next' stops execution of the current action and keeps pattern matching routes. get "/random" $ do void next redirect "http://www.we-never-go-here.com" @@ -106,6 +106,8 @@ main = scotty 3000 $ do -- Make a request to this URI, then type a line in the terminal, which -- will be the response. Using ctrl-c will cause getLine to fail. -- This demonstrates that IO exceptions are lifted into ActionM exceptions. + -- + -- (#310) we don't catch async exceptions, so ctrl-c just exits the program get "/iofail" $ do msg <- liftIO $ liftM fromString getLine text msg diff --git a/examples/globalstate.hs b/examples/globalstate.hs index 900744b3..7a433e0b 100644 --- a/examples/globalstate.hs +++ b/examples/globalstate.hs @@ -13,9 +13,7 @@ import Control.Concurrent.STM import Control.Monad.IO.Unlift (MonadUnliftIO(..)) import Control.Monad.Reader -import Data.Default.Class import Data.String -import Data.Text.Lazy (Text) import Network.Wai.Middleware.RequestLogger @@ -26,8 +24,8 @@ import Web.Scotty.Trans newtype AppState = AppState { tickCount :: Int } -instance Default AppState where - def = AppState 0 +defaultAppState :: AppState +defaultAppState = AppState 0 -- Why 'ReaderT (TVar AppState)' rather than 'StateT AppState'? -- With a state transformer, 'runActionToIO' (below) would have @@ -57,7 +55,7 @@ modify f = ask >>= liftIO . atomically . flip modifyTVar' f main :: IO () main = do - sync <- newTVarIO def + sync <- newTVarIO defaultAppState -- 'runActionToIO' is called once per action. let runActionToIO m = runReaderT (runWebM m) sync diff --git a/examples/reader.hs b/examples/reader.hs index 2b363039..b1f67258 100644 --- a/examples/reader.hs +++ b/examples/reader.hs @@ -9,7 +9,7 @@ module Main where import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, asks, lift, runReaderT) import Control.Monad.IO.Unlift (MonadUnliftIO(..)) -import Data.Text.Lazy (Text, pack) +import Data.Text.Lazy (pack) import Prelude () import Prelude.Compat import Web.Scotty.Trans (ScottyT, defaultOptions, get, scottyOptsT, text) diff --git a/examples/scotty-examples.cabal b/examples/scotty-examples.cabal index 524c5654..de36659e 100644 --- a/examples/scotty-examples.cabal +++ b/examples/scotty-examples.cabal @@ -82,7 +82,6 @@ executable scotty-globalstate hs-source-dirs: . build-depends: base >= 4.6 && < 5, base-compat >= 0.11 && < 0.13, - data-default-class, mtl, scotty, stm, @@ -106,7 +105,6 @@ executable scotty-options default-language: Haskell2010 hs-source-dirs: . build-depends: base >= 4.6 && < 5, - data-default-class, scotty, wai-extra, warp diff --git a/examples/urlshortener.hs b/examples/urlshortener.hs index 6dc6f5ce..2aebcf08 100644 --- a/examples/urlshortener.hs +++ b/examples/urlshortener.hs @@ -28,7 +28,7 @@ import Text.Blaze.Html5.Attributes import Text.Blaze.Html.Renderer.Text (renderHtml) -- TODO: --- Implement some kind of session and/or cookies +-- Implement some kind of session (#317) and/or cookies -- Add links data SessionError = UrlHashNotFound Int deriving (Typeable, Exception) diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index 65c7b1bb..2496c0cd 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -5,7 +5,6 @@ import Test.Hspec import Test.Hspec.Wai import Control.Applicative -import qualified Control.Exception as E import Control.Monad import Data.Char import Data.String @@ -85,33 +84,28 @@ spec = do describe "defaultHandler" $ do withApp (do - let h = Handler (\(e :: E.ArithException) -> text (TL.pack $ show e)) + let h = Handler (\(e :: E.ArithException) -> status status500 >> text (TL.pack $ show e)) defaultHandler h - Scotty.get "/" (liftAndCatchIO $ E.throwIO E.DivideByZero)) $ do + Scotty.get "/" (raise E.DivideByZero)) $ do it "sets custom exception handler" $ do get "/" `shouldRespondWith` "divide by zero" {matchStatus = 500} withApp (do - let h = Handler (\(e :: E.ArithException) -> status status503) + let h = Handler (\(_ :: E.ArithException) -> status status503) defaultHandler h Scotty.get "/" (liftAndCatchIO $ E.throwIO E.DivideByZero)) $ do it "allows to customize the HTTP status code" $ do get "/" `shouldRespondWith` "" {matchStatus = 503} context "when not specified" $ do - withApp (Scotty.get "/" $ liftAndCatchIO $ E.throwIO E.DivideByZero) $ do + withApp (Scotty.get "/" $ raise E.DivideByZero) $ do it "returns 500 on exceptions" $ do - get "/" `shouldRespondWith` "

500 Internal Server Error

divide by zero" {matchStatus = 500} + get "/" `shouldRespondWith` "" {matchStatus = 500} describe "setMaxRequestBodySize" $ do let large = TLE.encodeUtf8 . TL.pack . concat $ [show c | c <- ([1..4500]::[Integer])] smol = TLE.encodeUtf8 . TL.pack . concat $ [show c | c <- ([1..50]::[Integer])] - context "(counterexample)" $ - withApp (Scotty.post "/" $ status status200) $ do - it "doesn't throw an uncaught exception if the body is large" $ do - request "POST" "/" [("Content-Type","multipart/form-data; boundary=--33")] - large `shouldRespondWith` 200 withApp (Scotty.setMaxRequestBodySize 1 >> Scotty.matchAny "/upload" (do status status200)) $ do it "should return 200 OK if the request body size is below 1 KB" $ do request "POST" "/upload" [("Content-Type","multipart/form-data; boundary=--33")] @@ -119,6 +113,12 @@ spec = do it "should return 413 (Content Too Large) if the request body size is above 1 KB" $ do request "POST" "/upload" [("Content-Type","multipart/form-data; boundary=--33")] large `shouldRespondWith` 413 + context "(counterexample)" $ + withApp (Scotty.post "/" $ status status200) $ do + it "doesn't throw an uncaught exception if the body is large" $ do + request "POST" "/" [("Content-Type","multipart/form-data; boundary=--33")] + large `shouldRespondWith` 200 + describe "ActionM" $ do context "MonadBaseControl instance" $ do @@ -127,13 +127,16 @@ spec = do get "/" `shouldRespondWith` 200 withApp (Scotty.get "/" $ EL.throwIO E.DivideByZero) $ do it "returns 500 on uncaught exceptions" $ do - get "/" `shouldRespondWith` "

500 Internal Server Error

divide by zero" {matchStatus = 500} - - withApp (Scotty.get "/dictionary" $ empty <|> queryParam "word1" <|> empty <|> queryParam "word2" >>= text) $ - it "has an Alternative instance" $ do - get "/dictionary?word1=haskell" `shouldRespondWith` "haskell" - get "/dictionary?word2=scotty" `shouldRespondWith` "scotty" - get "/dictionary?word1=a&word2=b" `shouldRespondWith` "a" + get "/" `shouldRespondWith` "" {matchStatus = 500} + + context "Alternative instance" $ do + withApp (Scotty.get "/dictionary" $ empty <|> queryParam "word1" >>= text) $ + it "empty throws Next" $ do + get "/dictionary?word1=x" `shouldRespondWith` "x" + withApp (Scotty.get "/dictionary" $ queryParam "word1" <|> empty <|> queryParam "word2" >>= text) $ + it "<|> skips the left route if that fails" $ do + get "/dictionary?word2=y" `shouldRespondWith` "y" + get "/dictionary?word1=a&word2=b" `shouldRespondWith` "a" describe "captureParam" $ do withApp (