scotty 0.12.1 → 0.20
raw patch · 22 files changed
+1221/−593 lines, 22 filesdep +cookiedep +stmdep +timedep ~basedep ~data-default-classdep ~weighnew-uploader
Dependencies added: cookie, stm, time, unliftio
Dependency ranges changed: base, data-default-class, weigh
Files
- README.md +22/−9
- Web/Scotty.hs +90/−30
- Web/Scotty/Action.hs +228/−97
- Web/Scotty/Body.hs +101/−0
- Web/Scotty/Cookie.hs +133/−0
- Web/Scotty/Exceptions.hs +25/−0
- Web/Scotty/Internal/Types.hs +129/−135
- Web/Scotty/Route.hs +59/−118
- Web/Scotty/Trans.hs +53/−41
- Web/Scotty/Util.hs +32/−26
- bench/Main.hs +3/−5
- changelog.md +15/−0
- examples/basic.hs +22/−10
- examples/cookies.hs +6/−30
- examples/exceptions.hs +16/−17
- examples/globalstate.hs +6/−7
- examples/nested.hs +63/−0
- examples/options.hs +3/−4
- examples/reader.hs +6/−6
- examples/urlshortener.hs +16/−6
- scotty.cabal +20/−22
- test/Web/ScottySpec.hs +173/−30
README.md view
@@ -1,4 +1,4 @@-# Scotty [](https://travis-ci.org/scotty-web/scotty)+# Scotty [](https://hackage.haskell.org/package/scotty) [](https://github.com/scotty-web/scotty/actions/workflows/haskell-ci.yml) A Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp. @@ -6,11 +6,9 @@ {-# LANGUAGE OverloadedStrings #-} import Web.Scotty -import Data.Monoid (mconcat)- main = scotty 3000 $ get "/:word" $ do- beam <- param "word"+ beam <- captureParam "word" html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"] ``` @@ -31,18 +29,23 @@ As for the name: Sinatra + Warp = Scotty. -### More Information+## More Information Tutorials and related projects can be found in the [Scotty wiki](https://github.com/scotty-web/scotty/wiki). -### Development & Support+## Contributing -Open an issue on GitHub.+Feel free to ask questions or report bugs on the [Github issue tracker](https://github.com/scotty-web/scotty/issues/). -Copyright (c) 2012-2019 Andrew Farmer+Github issues are now (September 2023) labeled, so newcomers to the Haskell language can start with `easy fix` ones and gradually progress to `new feature`s, `bug`s and `R&D` :) -### FAQ+## Package versions +Scotty adheres to the [Package Versioning Policy](https://pvp.haskell.org/).+++## FAQ+ * Fails to compile regex-posix on Windows * If you are using stack, add the following parameters to `stack.yaml`: * ```yaml@@ -57,3 +60,13 @@ constraints: regex-posix +_regex-posix-clib ```++### Contributors++<a href="https://github.com/scotty-web/scotty/graphs/contributors">+ <img src="https://contrib.rocks/image?repo=scotty-web/scotty" />+</a>+++# Copyright +(c) 2012-Present, Andrew Farmer and Scotty contributors
Web/Scotty.hs view
@@ -7,17 +7,21 @@ -- the comments on each of these functions for more information. module Web.Scotty ( -- * scotty-to-WAI- scotty, scottyApp, scottyOpts, scottySocket, Options(..)+ scotty, scottyApp, scottyOpts, scottySocket, Options(..), defaultOptions -- * Defining Middleware and Routes -- -- | 'Middleware' and routes are run in the order in which they -- are defined. All middleware is run first, followed by the first -- route that matches. If no route matches, a 404 response is given.- , middleware, get, post, put, delete, patch, options, addroute, matchAny, notFound, setMaxRequestBodySize+ , middleware, get, post, put, delete, patch, options, addroute, matchAny, notFound, nested, setMaxRequestBodySize -- ** Route Patterns , capture, regex, function, literal -- ** Accessing the Request, Captures, and Query Parameters- , request, header, headers, body, bodyReader, param, params, jsonData, files+ , request, header, headers, body, bodyReader+ , param, params+ , captureParam, formParam, queryParam+ , captureParams, formParams, queryParams+ , jsonData, files -- ** Modifying the Response and Redirecting , status, addHeader, setHeader, redirect -- ** Setting Response Body@@ -26,16 +30,18 @@ -- definition, as they completely replace the current 'Response' body. , text, html, file, json, stream, raw -- ** Exceptions- , raise, raiseStatus, rescue, next, finish, defaultHandler, liftAndCatchIO+ , raise, raiseStatus, throw, rescue, next, finish, defaultHandler, liftAndCatchIO+ , StatusError(..) -- * Parsing Parameters , Param, Trans.Parsable(..), Trans.readEither -- * Types- , ScottyM, ActionM, RoutePattern, File, Kilobytes+ , ScottyM, ActionM, RoutePattern, File, Kilobytes, Handler(..)+ , ScottyState, defaultScottyState ) where --- With the exception of this, everything else better just import types. import qualified Web.Scotty.Trans as Trans +import qualified Control.Exception as E import Data.Aeson (FromJSON, ToJSON) import qualified Data.ByteString as BS import Data.ByteString.Lazy.Char8 (ByteString)@@ -46,10 +52,11 @@ import Network.Wai (Application, Middleware, Request, StreamingBody) import Network.Wai.Handler.Warp (Port) -import Web.Scotty.Internal.Types (ScottyT, ActionT, Param, RoutePattern, Options, File, Kilobytes)+import Web.Scotty.Internal.Types (ScottyT, ActionT, ErrorHandler, Param, RoutePattern, Options, defaultOptions, File, Kilobytes, ScottyState, defaultScottyState, StatusError(..))+import Web.Scotty.Exceptions (Handler(..)) -type ScottyM = ScottyT Text IO-type ActionM = ActionT Text IO+type ScottyM = ScottyT IO+type ActionM = ActionT IO -- | Run a scotty application using the warp server. scotty :: Port -> ScottyM () -> IO ()@@ -71,16 +78,8 @@ scottyApp :: ScottyM () -> IO Application scottyApp = Trans.scottyAppT id --- | Global handler for uncaught exceptions.------ Uncaught exceptions normally become 500 responses.--- You can use this to selectively override that behavior.------ Note: IO exceptions are lifted into Scotty exceptions by default.--- This has security implications, so you probably want to provide your--- own defaultHandler in production which does not send out the error--- strings as 500 responses.-defaultHandler :: (Text -> ActionM ()) -> ScottyM ()+-- | Global handler for user-defined exceptions.+defaultHandler :: ErrorHandler IO -> ScottyM () defaultHandler = Trans.defaultHandler -- | Use given middleware. Middleware is nested such that the first declared@@ -89,36 +88,60 @@ middleware :: Middleware -> ScottyM () middleware = Trans.middleware +-- | Nest a whole WAI application inside a Scotty handler.+-- Note: You will want to ensure that this route fully handles the response,+-- as there is no easy delegation as per normal Scotty actions.+-- Also, you will have to carefully ensure that you are expecting the correct routes,+-- this could require stripping the current prefix, or adding the prefix to your+-- application's handlers if it depends on them. One potential use-case for this+-- is hosting a web-socket handler under a specific route.+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. setMaxRequestBodySize :: Kilobytes -> ScottyM () setMaxRequestBodySize = Trans.setMaxRequestBodySize --- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions--- turn into HTTP 500 responses.+-- | Throw a "500 Server Error" 'StatusError', which can be caught with 'rescue'.+--+-- Uncaught exceptions turn into HTTP 500 responses. raise :: Text -> ActionM a raise = Trans.raise --- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions turn into HTTP responses corresponding to the given status.+-- | Throw a 'StatusError' exception that has an associated HTTP error code and can be caught with 'rescue'.+--+-- Uncaught exceptions turn into HTTP responses corresponding to the given status. raiseStatus :: Status -> Text -> ActionM a raiseStatus = Trans.raiseStatus +-- | Throw an exception which can be caught within the scope of the current Action with 'rescue' or 'catch'.+--+-- If the exception is not caught locally, another option is to implement a global 'Handler' (with 'defaultHandler') that defines its interpretation and a translation to HTTP error codes.+--+-- Uncaught exceptions turn into HTTP 500 responses.+throw :: (E.Exception e) => e -> ActionM a+throw = Trans.throw+ -- | Abort execution of this action and continue pattern matching routes. -- Like an exception, any code after 'next' is not executed. --+-- NB : Internally, this is implemented with an exception that can only be+-- caught by the library, but not by the user.+-- -- As an example, these two routes overlap. The only way the second one will -- ever run is if the first one calls 'next'. -- -- > get "/foo/:bar" $ do--- > w :: Text <- param "bar"+-- > w :: Text <- captureParam "bar" -- > unless (w == "special") next -- > text "You made a request to /foo/special" -- > -- > get "/foo/:baz" $ do--- > w <- param "baz"+-- > w <- captureParam "baz" -- > text $ "You made a request to: " <> w-next :: ActionM a+next :: ActionM () next = Trans.next -- | Abort execution of this action. Like an exception, any code after 'finish'@@ -128,7 +151,7 @@ -- content the text message. -- -- > get "/foo/:bar" $ do--- > w :: Text <- param "bar"+-- > w :: Text <- captureParam "bar" -- > unless (w == "special") finish -- > text "You made a request to /foo/special" --@@ -136,10 +159,10 @@ finish :: ActionM a finish = Trans.finish --- | Catch an exception thrown by 'raise'.+-- | Catch an exception e.g. a 'StatusError' or a user-defined exception. ----- > raise "just kidding" `rescue` (\msg -> text msg)-rescue :: ActionM a -> (Text -> ActionM a) -> ActionM a+-- > raise JustKidding `rescue` (\msg -> text msg)+rescue :: E.Exception e => ActionM a -> (e -> ActionM a) -> ActionM a rescue = Trans.rescue -- | Like 'liftIO', but catch any IO exceptions and turn them into Scotty exceptions.@@ -191,15 +214,52 @@ -- -- * Raises an exception which can be caught by 'rescue' if parameter is not found. ----- * If parameter is found, but 'read' fails to parse to the correct type, 'next' is called.+-- * If parameter is found, but 'parseParam' fails to parse to the correct type, 'next' is called. -- This means captures are somewhat typed, in that a route won't match if a correctly typed -- capture cannot be parsed. param :: Trans.Parsable a => Text -> ActionM a param = Trans.param+{-# DEPRECATED param "(#204) Not a good idea to treat all parameters identically. Use captureParam, formParam and queryParam instead. "#-} +-- | Get a capture parameter.+--+-- * Raises an exception which can be caught by 'rescue' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 500 ("Internal Server Error") to the client.+--+-- * If the parameter is found, but 'parseParam' fails to parse to the correct type, 'next' is called.+captureParam :: Trans.Parsable a => Text -> ActionM a+captureParam = Trans.captureParam++-- | Get a form parameter.+--+-- * Raises an exception which can be caught by 'rescue' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client.+--+-- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type.+formParam :: Trans.Parsable a => Text -> ActionM a+formParam = Trans.formParam++-- | Get a query parameter.+--+-- * Raises an exception which can be caught by 'rescue' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client.+--+-- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type.+queryParam :: Trans.Parsable a => Text -> ActionM a+queryParam = Trans.queryParam+ -- | Get all parameters from capture, form and query (in that order). params :: ActionM [Param] params = Trans.params+{-# DEPRECATED params "(#204) Not a good idea to treat all parameters identically. Use captureParams, formParams and queryParams instead. "#-}++-- | Get capture parameters+captureParams :: ActionM [Param]+captureParams = Trans.captureParams+-- | Get form parameters+formParams :: ActionM [Param]+formParams = Trans.formParams+-- | Get query parameters+queryParams :: ActionM [Param]+queryParams = Trans.queryParams+ -- | Set the HTTP response status. Default is 200. status :: Status -> ActionM ()
Web/Scotty/Action.hs view
@@ -1,11 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# language ScopedTypeVariables #-} module Web.Scotty.Action ( addHeader , body , bodyReader , file+ , rawResponse , files , finish , header@@ -16,10 +22,18 @@ , jsonData , next , param+ , captureParam+ , formParam+ , queryParam , params+ , captureParams+ , formParams+ , queryParams , raise , raiseStatus+ , throw , raw+ , nested , readEither , redirect , request@@ -37,18 +51,18 @@ import Blaze.ByteString.Builder (fromLazyByteString) import qualified Control.Exception as E-import Control.Monad (liftM, when)-import Control.Monad.Error.Class+import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..))+import UnliftIO (MonadUnliftIO(..)) import Control.Monad.Reader (MonadReader(..), ReaderT(..))-import qualified Control.Monad.State.Strict as MS-import Control.Monad.Trans.Except +import Control.Concurrent.MVar+ import qualified Data.Aeson as A+import Data.Bool (bool) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI-import Data.Default.Class (def) import Data.Int import qualified Data.Text as ST import qualified Data.Text.Encoding as STE@@ -61,81 +75,119 @@ #if !MIN_VERSION_http_types(0,11,0) import Network.HTTP.Types.Status #endif-import Network.Wai+import Network.Wai (Request, Response, StreamingBody, Application, requestHeaders) import Numeric.Natural import Prelude ()-import Prelude.Compat+import "base-compat-batteries" Prelude.Compat import Web.Scotty.Internal.Types-import Web.Scotty.Util+import Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, strictByteStringToLazyText)+import Web.Scotty.Exceptions (Handler(..), catch, catchesOptionally, tryAny) --- Nothing indicates route failed (due to Next) and pattern matching should continue.--- Just indicates a successful response.-runAction :: (ScottyError e, Monad m) => ErrorHandler e m -> ActionEnv -> ActionT e m () -> m (Maybe Response)-runAction h env action = do- (e,r) <- flip MS.runStateT def- $ flip runReaderT env- $ runExceptT- $ runAM- $ action `catchError` (defH h)- return $ either (const Nothing) (const $ Just $ mkResponse r) e+import Network.Wai.Internal (ResponseReceived(..)) --- | Default error handler for all actions.-defH :: (ScottyError e, Monad m) => ErrorHandler e m -> ActionError e -> ActionT e m ()-defH _ (Redirect url) = do- status status302- setHeader "Location" url-defH Nothing (ActionError s e) = do+-- | 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) -- ^ 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 = [+ statusErrorHandler, -- StatusError+ actionErrorHandler, -- ActionError i.e. Next, Finish, 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++-- | Catches 'StatusError' and produces an appropriate HTTP response.+statusErrorHandler :: MonadIO m => ErrorHandler m+statusErrorHandler = Handler $ \case+ StatusError s e -> do status s let code = T.pack $ show $ statusCode s let msg = T.fromStrict $ STE.decodeUtf8 $ statusMessage s- html $ mconcat ["<h1>", code, " ", msg, "</h1>", showError e]-defH h@(Just f) (ActionError _ e) = f e `catchError` (defH h) -- so handlers can throw exceptions themselves-defH _ Next = next-defH _ Finish = return ()+ html $ mconcat ["<h1>", code, " ", msg, "</h1>", e] --- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions--- turn into HTTP 500 responses.-raise :: (ScottyError e, Monad m) => e -> ActionT e m a-raise = raiseStatus status500+-- | Exception handler in charge of 'ActionError'. Rethrowing 'Next' here is caught by 'tryNext'.+-- All other cases of 'ActionError' are converted to HTTP responses.+actionErrorHandler :: MonadIO m => ErrorHandler m+actionErrorHandler = Handler $ \case+ AERedirect url -> do+ status status302+ setHeader "Location" url+ AENext -> next+ AEFinish -> return () --- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions turn into HTTP responses corresponding to the given status.-raiseStatus :: (ScottyError e, Monad m) => Status -> e -> ActionT e m a-raiseStatus s = throwError . ActionError s+-- | Uncaught exceptions turn into HTTP 500 Server Error codes+someExceptionHandler :: MonadIO m => ErrorHandler m+someExceptionHandler = Handler $ \case+ (_ :: E.SomeException) -> status status500 +-- | Throw a "500 Server Error" 'StatusError', which can be caught with 'rescue'.+--+-- Uncaught exceptions turn into HTTP 500 responses.+raise :: (MonadIO m) =>+ T.Text -- ^ Error text+ -> ActionT m a+raise = raiseStatus status500++-- | Throw a 'StatusError' exception that has an associated HTTP error code and 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+raiseStatus s = E.throw . StatusError s++-- | Throw an exception which can be caught within the scope of the current Action with 'rescue' or 'catch'.+--+-- If the exception is not caught locally, another option is to implement a global 'Handler' (with 'defaultHandler') that defines its interpretation and a translation to HTTP error codes.+--+-- Uncaught exceptions turn into HTTP 500 responses.+throw :: (MonadIO m, E.Exception e) => e -> ActionT m a+throw = E.throw+ -- | Abort execution of this action and continue pattern matching routes. -- Like an exception, any code after 'next' is not executed. --+-- NB : Internally, this is implemented with an exception that can only be+-- caught by the library, but not by the user.+-- -- As an example, these two routes overlap. The only way the second one will -- ever run is if the first one calls 'next'. -- -- > get "/foo/:bar" $ do--- > w :: Text <- param "bar"+-- > w :: Text <- captureParam "bar" -- > unless (w == "special") next -- > text "You made a request to /foo/special" -- > -- > get "/foo/:baz" $ do--- > w <- param "baz"+-- > w <- captureParam "baz" -- > text $ "You made a request to: " <> w-next :: (ScottyError e, Monad m) => ActionT e m a-next = throwError Next+next :: Monad m => ActionT m a+next = E.throw AENext --- | Catch an exception thrown by 'raise'.+-- | Catch an exception e.g. a 'StatusError' or a user-defined exception. ----- > raise "just kidding" `rescue` (\msg -> text msg)-rescue :: (ScottyError e, Monad m) => ActionT e m a -> (e -> ActionT e m a) -> ActionT e m a-rescue action h = catchError action $ \e -> case e of- ActionError _ err -> h err -- handle errors- other -> throwError other -- rethrow internal error types+-- > raise JustKidding `rescue` (\msg -> text msg)+rescue :: (MonadUnliftIO m, E.Exception e) => ActionT m a -> (e -> ActionT m a) -> ActionT m a+rescue = catch --- | Like 'liftIO', but catch any IO exceptions and turn them into 'ScottyError's.-liftAndCatchIO :: (ScottyError e, MonadIO m) => IO a -> ActionT e m a-liftAndCatchIO io = ActionT $ do- r <- liftIO $ liftM Right io `E.catch` (\ e -> return $ Left $ stringError $ show (e :: E.SomeException))- either throwError return r+-- | Catch any synchronous IO exceptions+liftAndCatchIO :: MonadIO m => IO a -> ActionT m a+liftAndCatchIO io = liftIO $ do+ r <- tryAny io+ either E.throwIO pure r + -- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect -- will not be run. --@@ -144,47 +196,47 @@ -- OR -- -- > redirect "/foo/bar"-redirect :: (ScottyError e, Monad m) => T.Text -> ActionT e m a-redirect = throwError . Redirect+redirect :: (Monad m) => T.Text -> ActionT m a+redirect = E.throw . AERedirect -- | Finish the execution of the current action. Like throwing an uncatchable -- exception. Any code after the call to finish will not be run. -- -- /Since: 0.10.3/-finish :: (ScottyError e, Monad m) => ActionT e m a-finish = throwError Finish+finish :: (Monad m) => ActionT m a+finish = E.throw AEFinish -- | Get the 'Request' object.-request :: Monad m => ActionT e m Request-request = ActionT $ liftM getReq ask+request :: Monad m => ActionT m Request+request = ActionT $ envReq <$> ask -- | Get list of uploaded files.-files :: Monad m => ActionT e m [File]-files = ActionT $ liftM getFiles ask+files :: Monad m => ActionT m [File]+files = ActionT $ envFiles <$> ask -- | Get a request header. Header name is case-insensitive.-header :: (ScottyError e, Monad m) => T.Text -> ActionT e m (Maybe T.Text)+header :: (Monad m) => T.Text -> ActionT m (Maybe T.Text) header k = do- hs <- liftM requestHeaders request+ hs <- requestHeaders <$> request return $ fmap strictByteStringToLazyText $ lookup (CI.mk (lazyTextToStrictByteString k)) hs -- | Get all the request headers. Header names are case-insensitive.-headers :: (ScottyError e, Monad m) => ActionT e m [(T.Text, T.Text)]+headers :: (Monad m) => ActionT m [(T.Text, T.Text)] headers = do- hs <- liftM requestHeaders request+ hs <- requestHeaders <$> request return [ ( strictByteStringToLazyText (CI.original k) , strictByteStringToLazyText v) | (k,v) <- hs ] -- | Get the request body.-body :: (ScottyError e, MonadIO m) => ActionT e m BL.ByteString-body = ActionT ask >>= (liftIO . getBody)+body :: (MonadIO m) => ActionT m BL.ByteString+body = ActionT ask >>= (liftIO . envBody) -- | Get an IO action that reads body chunks -- -- * This is incompatible with 'body' since 'body' consumes all chunks.-bodyReader :: Monad m => ActionT e m (IO B.ByteString)-bodyReader = ActionT $ getBodyChunk `liftM` ask+bodyReader :: Monad m => ActionT m (IO B.ByteString)+bodyReader = ActionT $ envBodyChunk <$> ask -- | Parse the request body as a JSON object and return it. --@@ -195,24 +247,24 @@ -- 422 Unprocessable Entity. -- -- These status codes are as per https://www.restapitutorial.com/httpstatuscodes.html.-jsonData :: (A.FromJSON a, ScottyError e, MonadIO m) => ActionT e m a+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 $ stringError htmlError+ raiseStatus status400 $ T.pack htmlError 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 $ stringError htmlError+ raiseStatus status400 $ T.pack htmlError 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 $ stringError htmlError+ raiseStatus status422 $ T.pack htmlError A.Success a -> do return a @@ -220,20 +272,88 @@ -- -- * Raises an exception which can be caught by 'rescue' if parameter is not found. ----- * If parameter is found, but 'read' fails to parse to the correct type, 'next' is called.+-- * If parameter is found, but 'parseParam' fails to parse to the correct type, 'next' is called. -- This means captures are somewhat typed, in that a route won't match if a correctly typed -- capture cannot be parsed.-param :: (Parsable a, ScottyError e, Monad m) => T.Text -> ActionT e m a+param :: (Parsable a, MonadIO m) => T.Text -> ActionT m a param k = do- val <- ActionT $ liftM (lookup k . getParams) ask+ val <- ActionT $ (lookup k . getParams) <$> ask case val of- Nothing -> raise $ stringError $ "Param: " ++ T.unpack k ++ " not found!"+ Nothing -> raiseStatus status500 $ "Param: " <> k <> " not found!" -- FIXME Just v -> either (const next) return $ parseParam v+{-# DEPRECATED param "(#204) Not a good idea to treat all parameters identically. Use captureParam, formParam and queryParam instead. "#-} +-- | Get a capture parameter.+--+-- * Raises an exception which can be caught by 'rescue' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 500 ("Internal Server Error") to the client.+--+-- * If the parameter is found, but 'parseParam' fails to parse to the correct type, 'next' is called.+captureParam :: (Parsable a, Monad m) => T.Text -> ActionT m a+captureParam = paramWith CaptureParam envCaptureParams status500++-- | Get a form parameter.+--+-- * Raises an exception which can be caught by 'rescue' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client.+--+-- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type.+formParam :: (Parsable a, Monad m) => T.Text -> ActionT m a+formParam = paramWith FormParam envFormParams status400++-- | Get a query parameter.+--+-- * Raises an exception which can be caught by 'rescue' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client.+--+-- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type.+queryParam :: (Parsable a, Monad m) => T.Text -> ActionT m a+queryParam = paramWith QueryParam envQueryParams status400++data ParamType = CaptureParam+ | FormParam+ | QueryParam+instance Show ParamType where+ show = \case+ CaptureParam -> "capture"+ FormParam -> "form"+ QueryParam -> "query"++paramWith :: (Monad m, Parsable b) =>+ ParamType+ -> (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+ 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+ CaptureParam -> next+ _ -> raiseStatus err (T.unwords ["Cannot parse", v, "as a", T.pack (show ty), "parameter"])+ in either (const $ handleParseError ty) return $ parseParam v+ -- | Get all parameters from capture, form and query (in that order).-params :: Monad m => ActionT e m [Param]-params = ActionT $ liftM getParams ask+params :: Monad m => ActionT m [Param]+params = paramsWith getParams+{-# DEPRECATED params "(#204) Not a good idea to treat all parameters identically. Use captureParams, formParams and queryParams instead. "#-} +-- | Get capture parameters+captureParams :: Monad m => ActionT m [Param]+captureParams = paramsWith envCaptureParams+-- | Get form parameters+formParams :: Monad m => ActionT m [Param]+formParams = paramsWith envFormParams+-- | Get query parameters+queryParams :: Monad m => ActionT m [Param]+queryParams = paramsWith envQueryParams++paramsWith :: Monad m => (ActionEnv -> a) -> ActionT m a+paramsWith f = ActionT (f <$> ask)++{-# DEPRECATED getParams "(#204) Not a good idea to treat all parameters identically" #-}+getParams :: ActionEnv -> [Param]+getParams e = envCaptureParams e <> envFormParams e <> envQueryParams e+ -- | Minimum implemention: 'parseParam' class Parsable a where -- | Take a 'T.Text' value and parse it as 'a', or fail with a message.@@ -297,39 +417,36 @@ [] -> Left "readEither: no parse" _ -> Left "readEither: ambiguous parse" --- | Set the HTTP response status. Default is 200.-status :: Monad m => Status -> ActionT e m ()-status = ActionT . MS.modify . setStatus+-- | Set the HTTP response status.+status :: MonadIO m => Status -> ActionT m ()+status = modifyResponse . setStatus -- Not exported, but useful in the functions below.-changeHeader :: Monad m+changeHeader :: MonadIO m => (CI.CI B.ByteString -> B.ByteString -> [(HeaderName, B.ByteString)] -> [(HeaderName, B.ByteString)])- -> T.Text -> T.Text -> ActionT e m ()-changeHeader f k = ActionT- . MS.modify- . setHeaderWith- . f (CI.mk $ lazyTextToStrictByteString k)- . lazyTextToStrictByteString+ -> T.Text -> T.Text -> ActionT m ()+changeHeader f k =+ modifyResponse . setHeaderWith . f (CI.mk $ lazyTextToStrictByteString k) . lazyTextToStrictByteString -- | Add to the response headers. Header names are case-insensitive.-addHeader :: Monad m => T.Text -> T.Text -> ActionT e m ()+addHeader :: MonadIO m => T.Text -> T.Text -> ActionT m () addHeader = changeHeader add -- | Set one of the response headers. Will override any previously set value for that header. -- Header names are case-insensitive.-setHeader :: Monad m => T.Text -> T.Text -> ActionT e m ()+setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m () setHeader = changeHeader replace -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" -- header to \"text/plain; charset=utf-8\" if it has not already been set.-text :: (ScottyError e, Monad m) => T.Text -> ActionT e m ()+text :: (MonadIO m) => T.Text -> ActionT m () text t = do changeHeader addIfNotPresent "Content-Type" "text/plain; charset=utf-8" raw $ encodeUtf8 t -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" -- header to \"text/html; charset=utf-8\" if it has not already been set.-html :: (ScottyError e, Monad m) => T.Text -> ActionT e m ()+html :: (MonadIO m) => T.Text -> ActionT m () html t = do changeHeader addIfNotPresent "Content-Type" "text/html; charset=utf-8" raw $ encodeUtf8 t@@ -337,12 +454,15 @@ -- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably -- want to do that on your own with 'setHeader'. Setting a status code will have no effect -- because Warp will overwrite that to 200 (see 'Network.Wai.Handler.Warp.Internal.sendResponse').-file :: Monad m => FilePath -> ActionT e m ()-file = ActionT . MS.modify . setContent . ContentFile+file :: MonadIO m => FilePath -> ActionT m ()+file = modifyResponse . setContent . ContentFile +rawResponse :: MonadIO m => Response -> ActionT m ()+rawResponse = modifyResponse . setContent . ContentResponse+ -- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\" -- header to \"application/json; charset=utf-8\" if it has not already been set.-json :: (A.ToJSON a, ScottyError e, Monad m) => a -> ActionT e m ()+json :: (A.ToJSON a, MonadIO m) => a -> ActionT m () json v = do changeHeader addIfNotPresent "Content-Type" "application/json; charset=utf-8" raw $ A.encode v@@ -350,11 +470,22 @@ -- | Set the body of the response to a Source. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'setHeader'.-stream :: Monad m => StreamingBody -> ActionT e m ()-stream = ActionT . MS.modify . setContent . ContentStream+stream :: MonadIO m => StreamingBody -> ActionT m ()+stream = modifyResponse . setContent . ContentStream -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'setHeader'.-raw :: Monad m => BL.ByteString -> ActionT e m ()-raw = ActionT . MS.modify . setContent . ContentBuilder . fromLazyByteString+raw :: MonadIO m => BL.ByteString -> ActionT m ()+raw = modifyResponse . setContent . ContentBuilder . fromLazyByteString++-- | Nest a whole WAI application inside a Scotty handler.+-- See Web.Scotty for further documentation+nested :: (MonadIO m) => Network.Wai.Application -> ActionT m ()+nested app = do+ -- Is MVar really the best choice here? Not sure.+ r <- request+ ref <- liftIO $ newEmptyMVar+ _ <- liftAndCatchIO $ app r (\res -> putMVar ref res >> return ResponseReceived)+ res <- liftAndCatchIO $ readMVar ref+ rawResponse res
+ Web/Scotty/Body.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, RecordWildCards,+ OverloadedStrings, MultiWayIf #-}+module Web.Scotty.Body (+ newBodyInfo,+ cloneBodyInfo++ , getFormParamsAndFilesAction+ , getBodyAction+ , getBodyChunkAction+ ) where++import Control.Concurrent.MVar+import Control.Monad.IO.Class+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL+import Data.Maybe+import qualified GHC.Exception as E (throw)+import Network.Wai (Request(..), getRequestBodyChunk)+import qualified Network.Wai.Parse as W (File, Param, getRequestBodyType, BackEnd, lbsBackEnd, sinkRequestBody)+import Web.Scotty.Action (Param)+import Web.Scotty.Internal.Types (BodyInfo(..), BodyChunkBuffer(..), BodyPartiallyStreamed(..), RouteOptions(..))+import Web.Scotty.Util (readRequestBody, strictByteStringToLazyText)++-- | Make a new BodyInfo with readProgress at 0 and an empty BodyChunkBuffer.+newBodyInfo :: (MonadIO m) => Request -> m BodyInfo+newBodyInfo req = liftIO $ do+ readProgress <- newMVar 0+ chunkBuffer <- newMVar (BodyChunkBuffer False [])+ return $ BodyInfo readProgress chunkBuffer (getRequestBodyChunk req)++-- | Make a copy of a BodyInfo, sharing the previous BodyChunkBuffer but with the+-- readProgress MVar reset to 0.+cloneBodyInfo :: (MonadIO m) => BodyInfo -> m BodyInfo+cloneBodyInfo (BodyInfo _ chunkBufferVar getChunk) = liftIO $ do+ cleanReadProgressVar <- newMVar 0+ return $ BodyInfo cleanReadProgressVar chunkBufferVar getChunk++-- | Get the form params and files from the request. Requires reading the whole body.+getFormParamsAndFilesAction :: Request -> BodyInfo -> RouteOptions -> IO ([Param], [W.File BL.ByteString])+getFormParamsAndFilesAction req bodyInfo opts = do+ let shouldParseBody = isJust $ W.getRequestBodyType req++ if shouldParseBody+ then+ do+ bs <- getBodyAction bodyInfo opts+ let wholeBody = BL.toChunks bs+ (formparams, fs) <- parseRequestBody wholeBody W.lbsBackEnd req -- NB this loads the whole body into memory+ let convert (k, v) = (strictByteStringToLazyText k, strictByteStringToLazyText v)+ return (convert <$> formparams, fs)+ else+ return ([], [])++-- | Retrieve the entire body, using the cached chunks in the BodyInfo and reading any other+-- chunks if they still exist.+-- Mimic the previous behavior by throwing BodyPartiallyStreamed if the user has already+-- started reading the body by chunks.+getBodyAction :: BodyInfo -> RouteOptions -> IO (BL.ByteString)+getBodyAction (BodyInfo readProgress chunkBufferVar getChunk) opts =+ modifyMVar readProgress $ \index ->+ modifyMVar chunkBufferVar $ \bcb@(BodyChunkBuffer hasFinished chunks) -> do+ if | index > 0 -> E.throw BodyPartiallyStreamed+ | hasFinished -> return (bcb, (index, BL.fromChunks chunks))+ | otherwise -> do+ newChunks <- readRequestBody getChunk return (maxRequestBodySize opts)+ return $ (BodyChunkBuffer True (chunks ++ newChunks), (index, BL.fromChunks (chunks ++ newChunks)))++-- | Retrieve a chunk from the body at the index stored in the readProgress MVar.+-- Serve the chunk from the cached array if it's already present; otherwise read another+-- chunk from WAI and advance the index.+getBodyChunkAction :: BodyInfo -> IO BS.ByteString+getBodyChunkAction (BodyInfo readProgress chunkBufferVar getChunk) =+ modifyMVar readProgress $ \index ->+ modifyMVar chunkBufferVar $ \bcb@(BodyChunkBuffer hasFinished chunks) -> do+ if | index < length chunks -> return (bcb, (index + 1, chunks !! index))+ | hasFinished -> return (bcb, (index, mempty))+ | otherwise -> do+ newChunk <- getChunk+ return (BodyChunkBuffer (newChunk == mempty) (chunks ++ [newChunk]), (index + 1, newChunk))+++-- Stolen from wai-extra's Network.Wai.Parse, modified to accept body as list of Bytestrings.+-- Reason: WAI's requestBody is an IO action that returns the body as chunks. Once read,+-- they can't be read again. We read them into a lazy Bytestring, so Scotty user can get+-- the raw body, even if they also want to call wai-extra's parsing routines.+parseRequestBody :: MonadIO m+ => [B.ByteString]+ -> W.BackEnd y+ -> Request+ -> m ([W.Param], [W.File y])+parseRequestBody bl s r =+ case W.getRequestBodyType r of+ Nothing -> return ([], [])+ Just rbt -> do+ mvar <- liftIO $ newMVar bl -- MVar is a bit of a hack so we don't have to inline+ -- large portions of Network.Wai.Parse+ let provider = modifyMVar mvar $ \bsold -> case bsold of+ [] -> return ([], B.empty)+ (b:bs) -> return (bs, b)+ liftIO $ W.sinkRequestBody s rbt provider
+ Web/Scotty/Cookie.hs view
@@ -0,0 +1,133 @@+{-|+Module : Web.Scotty.Cookie+Copyright : (c) 2014, 2015 Mārtiņš Mačs,+ (c) 2023 Marco Zocca++License : BSD-3-Clause+Maintainer :+Stability : experimental+Portability : GHC++This module provides utilities for adding cookie support inside @scotty@ applications. Most code has been adapted from 'scotty-cookie'.++== Example++A simple hit counter that stores the number of page visits in a cookie:++@+\{\-\# LANGUAGE OverloadedStrings \#\-\}++import Control.Monad+import Data.Monoid+import Data.Maybe+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Read as TL (decimal)+import Web.Scotty (scotty, html)+import Web.Scotty.Cookie (getCookie, setSimpleCookie)++main :: IO ()+main = scotty 3000 $+ get \"/\" $ do+ hits <- liftM (fromMaybe \"0\") $ 'getCookie' \"hits\"+ let hits' =+ case TL.decimal hits of+ Right n -> TL.pack . show . (+1) $ (fst n :: Integer)+ Left _ -> \"1\"+ 'setSimpleCookie' \"hits\" $ TL.toStrict hits'+ html $ mconcat [ \"\<html\>\<body\>\"+ , hits'+ , \"\<\/body\>\<\/html\>\"+ ]+@+-}+{-# LANGUAGE OverloadedStrings #-}+module Web.Scotty.Cookie (+ -- * Set cookie+ setCookie+ , setSimpleCookie+ -- * Get cookie(s)+ , getCookie+ , getCookies+ -- * Delete a cookie+ , deleteCookie+ -- * Helpers and advanced interface (re-exported from 'cookie')+ , CookiesText+ , makeSimpleCookie+ -- ** cookie configuration+ , SetCookie+ , defaultSetCookie+ , setCookieName+ , setCookieValue+ , setCookiePath+ , setCookieExpires+ , setCookieMaxAge+ , setCookieDomain+ , setCookieHttpOnly+ , setCookieSecure+ , setCookieSameSite+ , SameSiteOption+ , sameSiteNone+ , sameSiteLax+ , sameSiteStrict+ ) where++import Control.Monad.IO.Class (MonadIO(..))++-- bytestring+import Data.ByteString.Builder (toLazyByteString)+import qualified Data.ByteString.Lazy as BSL (toStrict)+-- cookie+import Web.Cookie (SetCookie, setCookieName , setCookieValue, setCookiePath, setCookieExpires, setCookieMaxAge, setCookieDomain, setCookieHttpOnly, setCookieSecure, setCookieSameSite, renderSetCookie, defaultSetCookie, CookiesText, parseCookiesText, SameSiteOption, sameSiteStrict, sameSiteNone, sameSiteLax)+-- scotty+import Web.Scotty.Trans (ActionT, addHeader, header)+-- time+import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )+-- text+import Data.Text (Text)+import qualified Data.Text.Encoding as T (encodeUtf8)+import qualified Data.Text.Lazy.Encoding as TL (encodeUtf8, decodeUtf8)++++-- | Set a cookie, with full access to its options (see 'SetCookie')+setCookie :: (MonadIO m)+ => SetCookie+ -> ActionT m ()+setCookie c = addHeader "Set-Cookie" (TL.decodeUtf8 . toLazyByteString $ renderSetCookie c)+++-- | 'makeSimpleCookie' and 'setCookie' combined.+setSimpleCookie :: (MonadIO m)+ => Text -- ^ name+ -> Text -- ^ value+ -> ActionT m ()+setSimpleCookie n v = setCookie $ makeSimpleCookie n v++-- | Lookup one cookie name+getCookie :: (Monad m)+ => Text -- ^ name+ -> ActionT m (Maybe Text)+getCookie c = lookup c <$> getCookies+++-- | Returns all cookies+getCookies :: (Monad m)+ => ActionT m CookiesText+getCookies = (maybe [] parse) <$> header "Cookie"+ where parse = parseCookiesText . BSL.toStrict . TL.encodeUtf8++-- | Browsers don't directly delete a cookie, but setting its expiry to a past date (e.g. the UNIX epoch) ensures that the cookie will be invalidated (whether and when it will be actually deleted by the browser seems to be browser-dependent).+deleteCookie :: (MonadIO m)+ => Text -- ^ name+ -> ActionT m ()+deleteCookie c = setCookie $ (makeSimpleCookie c "") { setCookieExpires = Just $ posixSecondsToUTCTime 0 }+++-- | Construct a simple cookie (an UTF-8 string pair with default cookie options)+makeSimpleCookie :: Text -- ^ name+ -> Text -- ^ value+ -> SetCookie+makeSimpleCookie n v = defaultSetCookie { setCookieName = T.encodeUtf8 n+ , setCookieValue = T.encodeUtf8 v+ }+
+ Web/Scotty/Exceptions.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE ExistentialQuantification #-}+module Web.Scotty.Exceptions (+ Handler(..)+ -- * catching+ , catch+ , catchAny+ , catches+ , catchesOptionally+ -- * trying+ , try+ , tryAny+ ) where++import Data.Maybe (maybeToList)++import UnliftIO (MonadUnliftIO(..), catch, catchAny, catches, try, tryAny, Handler(..))+++-- | Handlers are tried sequentially+catchesOptionally :: MonadUnliftIO m =>+ m a+ -> Maybe (Handler m a) -- ^ if present, this 'Handler' is tried first+ -> [Handler m a] -- ^ these are tried in order+ -> m a+catchesOptionally io mh handlers = io `catches` (maybeToList mh <> handlers)
Web/Scotty/Internal/Types.hs view
@@ -1,34 +1,35 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# language DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# language ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE RecordWildCards #-}- module Web.Scotty.Internal.Types where import Blaze.ByteString.Builder (Builder) import Control.Applicative-import Control.Exception (Exception)+import Control.Concurrent.MVar+import Control.Concurrent.STM (TVar, atomically, readTVarIO, modifyTVar') import qualified Control.Exception as E-import qualified Control.Monad as Monad import Control.Monad (MonadPlus(..))-import Control.Monad.Base (MonadBase, liftBase, liftBaseDefault)-import Control.Monad.Catch (MonadCatch, catch, MonadThrow, throwM)-import Control.Monad.Error.Class-import qualified Control.Monad.Fail as Fail-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Reader (MonadReader(..), ReaderT, mapReaderT)-import Control.Monad.State.Strict (MonadState(..), State, StateT, mapStateT)+import Control.Monad.Base (MonadBase)+import Control.Monad.Catch (MonadCatch, MonadThrow)+import Control.Monad.IO.Class (MonadIO(..))+import UnliftIO (MonadUnliftIO(..))+import Control.Monad.Reader (MonadReader(..), ReaderT, asks)+import Control.Monad.State.Strict (State, StateT(..)) 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+import Control.Monad.Trans.Control (MonadBaseControl, MonadTransControl) import qualified Data.ByteString as BS-import Data.ByteString.Lazy.Char8 (ByteString)+import qualified Data.ByteString.Lazy.Char8 as LBS8 (ByteString) import Data.Default.Class (Default, def) import Data.String (IsString(..)) import Data.Text.Lazy (Text, pack)@@ -41,8 +42,10 @@ import Network.Wai.Handler.Warp (Settings, defaultSettings) import Network.Wai.Parse (FileInfo) +import Web.Scotty.Exceptions (Handler(..), catch, catches)+ import Prelude ()-import Prelude.Compat+import "base-compat-batteries" Prelude.Compat --------------------- Options ----------------------- data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner@@ -56,185 +59,174 @@ } instance Default Options where- def = Options 1 defaultSettings+ def = defaultOptions +defaultOptions :: Options+defaultOptions = Options 1 defaultSettings+ newtype RouteOptions = RouteOptions { maxRequestBodySize :: Maybe Kilobytes -- max allowed request size in KB } instance Default RouteOptions where- def = RouteOptions Nothing+ def = defaultRouteOptions +defaultRouteOptions :: RouteOptions+defaultRouteOptions = RouteOptions Nothing+ type Kilobytes = Int ----- Transformer Aware Applications/Middleware ----- type Middleware m = Application m -> Application m type Application m = Request -> m Response +------------------ Scotty Request Body --------------------++data BodyChunkBuffer = BodyChunkBuffer { hasFinishedReadingChunks :: Bool -- ^ whether we've reached the end of the stream yet+ , chunksReadSoFar :: [BS.ByteString]+ }+-- | The key part of having two MVars is that we can "clone" the BodyInfo to create a copy where the index is reset to 0, but the chunk cache is the same. Passing a cloned BodyInfo into each matched route allows them each to start from the first chunk if they call bodyReader.+--+-- Introduced in (#308)+data BodyInfo = BodyInfo { bodyInfoReadProgress :: MVar Int -- ^ index into the stream read so far+ , bodyInfoChunkBuffer :: MVar BodyChunkBuffer+ , bodyInfoDirectChunkRead :: IO BS.ByteString -- ^ can be called to get more chunks+ }+ --------------- Scotty Applications ------------------data ScottyState e m =++data ScottyState m = ScottyState { middlewares :: [Wai.Middleware]- , routes :: [Middleware m]- , handler :: ErrorHandler e m+ , routes :: [BodyInfo -> Middleware m]+ , handler :: Maybe (ErrorHandler m) , routeOptions :: RouteOptions } -instance Default (ScottyState e m) where- def = ScottyState [] [] Nothing def+instance Default (ScottyState m) where+ def = defaultScottyState -addMiddleware :: Wai.Middleware -> ScottyState e m -> ScottyState e m+defaultScottyState :: ScottyState m+defaultScottyState = ScottyState [] [] Nothing defaultRouteOptions++addMiddleware :: Wai.Middleware -> ScottyState m -> ScottyState m addMiddleware m s@(ScottyState {middlewares = ms}) = s { middlewares = m:ms } -addRoute :: Middleware m -> ScottyState e m -> ScottyState e m+addRoute :: (BodyInfo -> Middleware m) -> ScottyState m -> ScottyState m addRoute r s@(ScottyState {routes = rs}) = s { routes = r:rs } -addHandler :: ErrorHandler e m -> ScottyState e m -> ScottyState e m-addHandler h s = s { handler = h }+setHandler :: Maybe (ErrorHandler m) -> ScottyState m -> ScottyState m+setHandler h s = s { handler = h } -updateMaxRequestBodySize :: RouteOptions -> ScottyState e m -> ScottyState e m+updateMaxRequestBodySize :: RouteOptions -> ScottyState m -> ScottyState m updateMaxRequestBodySize RouteOptions { .. } s@ScottyState { routeOptions = ro } = let ro' = ro { maxRequestBodySize = maxRequestBodySize } in s { routeOptions = ro' } -newtype ScottyT e m a = ScottyT { runS :: State (ScottyState e m) a }+newtype ScottyT m a = ScottyT { runS :: State (ScottyState m) a } deriving ( Functor, Applicative, Monad ) ------------------ Scotty Errors ---------------------data ActionError e- = Redirect Text- | Next- | Finish- | ActionError Status e --- | In order to use a custom exception type (aside from 'Text'), you must--- define an instance of 'ScottyError' for that type.-class ScottyError e where- stringError :: String -> e- showError :: e -> Text+-- | Internal exception mechanism used to modify the request processing flow.+--+-- The exception constructor is not exposed to the user and all exceptions of this type are caught+-- and processed within the 'runAction' function.+data ActionError+ = AERedirect Text -- ^ Redirect+ | AENext -- ^ Stop processing this route and skip to the next one+ | AEFinish -- ^ Stop processing the request+ deriving (Show, Typeable)+instance E.Exception ActionError -instance ScottyError Text where- stringError = pack- showError = id+tryNext :: MonadUnliftIO m => m a -> m Bool+tryNext io = catch (io >> pure True) $ \e ->+ case e of+ AENext -> pure False+ _ -> pure True -instance ScottyError e => ScottyError (ActionError e) where- stringError = ActionError status500 . stringError- showError (Redirect url) = url- showError Next = pack "Next"- showError Finish = pack "Finish"- showError (ActionError _ e) = showError e+-- | E.g. when a parameter is not found in a query string (400 Bad Request) or when parsing a JSON body fails (422 Unprocessable Entity)+data StatusError = StatusError Status Text deriving (Show, Typeable)+instance E.Exception StatusError -type ErrorHandler e m = Maybe (e -> ActionT e m ())+-- | Specializes a 'Handler' to the 'ActionT' monad+type ErrorHandler m = Handler (ActionT m) () +-- | Thrown e.g. when a request is too large data ScottyException = RequestException BS.ByteString Status deriving (Show, Typeable)--instance Exception ScottyException+instance E.Exception ScottyException ------------------ Scotty Actions ------------------- type Param = (Text, Text) -type File = (Text, FileInfo ByteString)+type File = (Text, FileInfo LBS8.ByteString) -data ActionEnv = Env { getReq :: Request- , getParams :: [Param]- , getBody :: IO ByteString- , getBodyChunk :: IO BS.ByteString- , getFiles :: [File]+data ActionEnv = Env { envReq :: Request+ , envCaptureParams :: [Param]+ , envFormParams :: [Param]+ , envQueryParams :: [Param]+ , envBody :: IO LBS8.ByteString+ , envBodyChunk :: IO BS.ByteString+ , envFiles :: [File]+ , envResponse :: TVar ScottyResponse } -data RequestBodyState = BodyUntouched- | BodyCached ByteString [BS.ByteString] -- whole body, chunks left to stream- | BodyCorrupted+getResponse :: MonadIO m => ActionEnv -> m ScottyResponse+getResponse ae = liftIO $ readTVarIO (envResponse ae) +modifyResponse :: (MonadIO m) => (ScottyResponse -> ScottyResponse) -> ActionT m ()+modifyResponse f = do+ tv <- asks envResponse+ liftIO $ atomically $ modifyTVar' tv f+ data BodyPartiallyStreamed = BodyPartiallyStreamed deriving (Show, Typeable) instance E.Exception BodyPartiallyStreamed -data Content = ContentBuilder Builder- | ContentFile FilePath- | ContentStream StreamingBody+data Content = ContentBuilder Builder+ | ContentFile FilePath+ | ContentStream StreamingBody+ | ContentResponse Response data ScottyResponse = SR { srStatus :: Status , srHeaders :: ResponseHeaders , srContent :: Content } -instance Default ScottyResponse where- def = SR status200 [] (ContentBuilder mempty)--newtype ActionT e m a = ActionT { runAM :: ExceptT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) a }- deriving ( Functor, Applicative, MonadIO )--instance (Monad m, ScottyError e) => Monad.Monad (ActionT e m) where- return = ActionT . return- ActionT m >>= k = ActionT (m >>= runAM . k)-#if !(MIN_VERSION_base(4,13,0))- fail = Fail.fail-#endif--instance (Monad m, ScottyError e) => Fail.MonadFail (ActionT e m) where- fail = ActionT . throwError . stringError--instance ( Monad m, ScottyError e-#if !(MIN_VERSION_base(4,8,0))- , Functor m-#endif- ) => Alternative (ActionT e m) where- empty = mzero- (<|>) = mplus--instance (Monad m, ScottyError e) => MonadPlus (ActionT e m) where- mzero = ActionT . ExceptT . return $ Left Next- ActionT m `mplus` ActionT n = ActionT . ExceptT $ do- a <- runExceptT m- case a of- Left _ -> runExceptT n- Right r -> return $ Right r--instance ScottyError e => MonadTrans (ActionT e) where- lift = ActionT . lift . lift . lift+setContent :: Content -> ScottyResponse -> ScottyResponse+setContent c sr = sr { srContent = c } -instance (ScottyError e, Monad m) => MonadError (ActionError e) (ActionT e m) where- throwError = ActionT . throwError+setHeaderWith :: ([(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)]) -> ScottyResponse -> ScottyResponse+setHeaderWith f sr = sr { srHeaders = f (srHeaders sr) } - catchError (ActionT m) f = ActionT (catchError m (runAM . f))+setStatus :: Status -> ScottyResponse -> ScottyResponse+setStatus s sr = sr { srStatus = s } +instance Default ScottyResponse where+ def = defaultScottyResponse -instance (MonadBase b m, ScottyError e) => MonadBase b (ActionT e m) where- liftBase = liftBaseDefault+-- | The default response has code 200 OK and empty body+defaultScottyResponse :: ScottyResponse+defaultScottyResponse = SR status200 [] (ContentBuilder mempty) -instance (MonadThrow m, ScottyError e) => MonadThrow (ActionT e m) where- throwM = ActionT . throwM--instance (MonadCatch m, ScottyError e) => MonadCatch (ActionT e m) where- catch (ActionT m) f = ActionT (m `catch` (runAM . f))--instance ScottyError e => MonadTransControl (ActionT e) where- type StT (ActionT e) a = StT (StateT ScottyResponse) (StT (ReaderT ActionEnv) (StT (ExceptT (ActionError e)) a))- liftWith = \f ->- ActionT $ liftWith $ \run ->- liftWith $ \run' ->- liftWith $ \run'' ->- f $ run'' . run' . run . runAM- restoreT = ActionT . restoreT . restoreT . restoreT--instance (ScottyError e, MonadBaseControl b m) => MonadBaseControl b (ActionT e m) where- type StM (ActionT e m) a = ComposeSt (ActionT e) m a- liftBaseWith = defaultLiftBaseWith- restoreM = defaultRestoreM--instance (MonadReader r m, ScottyError e) => MonadReader r (ActionT e m) where- {-# INLINE ask #-}- ask = lift ask- {-# INLINE local #-}- local f = ActionT . mapExceptT (mapReaderT (mapStateT $ local f)) . runAM+newtype ActionT m a = ActionT { runAM :: ReaderT ActionEnv m a }+ deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader ActionEnv, MonadTrans, MonadThrow, MonadCatch, MonadBase b, MonadBaseControl b, MonadTransControl, MonadUnliftIO)+instance (MonadUnliftIO m) => Alternative (ActionT m) where+ empty = E.throw AENext+ a <|> b = do+ ok <- tryAnyStatus a+ if ok then a else b+instance (MonadUnliftIO m) => MonadPlus (ActionT m) where+ mzero = empty+ mplus = (<|>) -instance (MonadState s m, ScottyError e) => MonadState s (ActionT e m) where- {-# INLINE get #-}- get = lift get- {-# INLINE put #-}- put = lift . put+-- | catches either ActionError (thrown by 'next') or 'StatusError' (thrown if e.g. a query parameter is not found)+tryAnyStatus :: MonadUnliftIO m => m a -> m Bool+tryAnyStatus io = (io >> pure True) `catches` [h1, h2]+ where+ h1 = Handler $ \(_ :: ActionError) -> pure False+ h2 = Handler $ \(_ :: StatusError) -> pure False -instance (Semigroup a) => Semigroup (ScottyT e m a) where+instance (Semigroup a) => Semigroup (ScottyT m a) where x <> y = (<>) <$> x <*> y instance@@ -245,7 +237,7 @@ #if !(MIN_VERSION_base(4,8,0)) , Functor m #endif- ) => Monoid (ScottyT e m a) where+ ) => Monoid (ScottyT m a) where mempty = return mempty #if !(MIN_VERSION_base(4,11,0)) mappend = (<>)@@ -257,18 +249,18 @@ , Functor m #endif , Semigroup a- ) => Semigroup (ActionT e m a) where+ ) => Semigroup (ActionT m a) where x <> y = (<>) <$> x <*> y instance- ( Monad m, ScottyError e, Monoid a+ ( Monad m, Monoid a #if !(MIN_VERSION_base(4,11,0)) , Semigroup a #endif #if !(MIN_VERSION_base(4,8,0)) , Functor m #endif- ) => Monoid (ActionT e m a) where+ ) => Monoid (ActionT m a) where mempty = return mempty #if !(MIN_VERSION_base(4,11,0)) mappend = (<>)@@ -281,3 +273,5 @@ instance IsString RoutePattern where fromString = Capture . pack++
Web/Scotty/Route.hs view
@@ -1,72 +1,68 @@-{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances,+{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, RankNTypes, ScopedTypeVariables #-}+{-# language PackageImports #-} module Web.Scotty.Route ( get, post, put, delete, patch, options, addroute, matchAny, notFound, capture, regex, function, literal ) where- -import Blaze.ByteString.Builder (fromByteString)+ import Control.Arrow ((***))-import Control.Concurrent.MVar-import Control.Exception (throw, catch)-import Control.Monad.IO.Class+import Control.Concurrent.STM (newTVarIO)+import Control.Monad.IO.Class (MonadIO(..))+import UnliftIO (MonadUnliftIO(..)) import qualified Control.Monad.State as MS import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as BL -import Data.Maybe (fromMaybe, isJust)+import Data.Maybe (fromMaybe) import Data.String (fromString) import qualified Data.Text.Lazy as T import qualified Data.Text as TS import Network.HTTP.Types-import Network.Wai (Request(..), Response, responseBuilder)-#if MIN_VERSION_wai(3,2,2)-import Network.Wai.Internal (getRequestBodyChunk)-#endif-import qualified Network.Wai.Parse as Parse hiding (parseRequestBody)+import Network.Wai (Request(..)) import Prelude ()-import Prelude.Compat+import "base-compat-batteries" Prelude.Compat import qualified Text.Regex as Regex import Web.Scotty.Action-import Web.Scotty.Internal.Types-import Web.Scotty.Util+import Web.Scotty.Internal.Types (RoutePattern(..), RouteOptions, ActionEnv(..), ActionT, ScottyState(..), ScottyT(..), ErrorHandler, Middleware, BodyInfo, handler, addRoute, defaultScottyResponse)+import Web.Scotty.Util (strictByteStringToLazyText)+import Web.Scotty.Body (cloneBodyInfo, getBodyAction, getBodyChunkAction, getFormParamsAndFilesAction) -- | get = 'addroute' 'GET'-get :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()+get :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () get = addroute GET -- | post = 'addroute' 'POST'-post :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()+post :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () post = addroute POST -- | put = 'addroute' 'PUT'-put :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()+put :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () put = addroute PUT -- | delete = 'addroute' 'DELETE'-delete :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()+delete :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () delete = addroute DELETE -- | patch = 'addroute' 'PATCH'-patch :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()+patch :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () patch = addroute PATCH -- | options = 'addroute' 'OPTIONS'-options :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()+options :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () options = addroute OPTIONS -- | Add a route that matches regardless of the HTTP verb.-matchAny :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()-matchAny pattern action = ScottyT $ MS.modify $ \s -> addRoute (route (routeOptions s) (handler s) Nothing pattern action) s+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 -- | Specify an action to take if nothing else is found. Note: this _always_ matches, -- so should generally be the last route specified.-notFound :: (ScottyError e, MonadIO m) => ActionT e m () -> ScottyT e m ()+notFound :: (MonadUnliftIO m) => ActionT m () -> ScottyT m () notFound action = matchAny (Function (\req -> Just [("path", path req)])) (status status404 >> action) -- | Define a route with a 'StdMethod', 'T.Text' value representing the path spec,@@ -75,42 +71,49 @@ -- > addroute GET "/" $ text "beam me up!" -- -- The path spec can include values starting with a colon, which are interpreted--- as /captures/. These are named wildcards that can be looked up with 'param'.+-- as /captures/. These are named wildcards that can be looked up with 'captureParam'. -- -- > addroute GET "/foo/:bar" $ do--- > v <- param "bar"+-- > v <- captureParam "bar" -- > text v -- -- >>> curl http://localhost:3000/foo/something -- something-addroute :: (ScottyError e, MonadIO m) => StdMethod -> RoutePattern -> ActionT e m () -> ScottyT e m ()+--+-- NB: the 'RouteOptions' and the exception handler of the newly-created route will be+-- copied from the previously-created routes.+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 -route :: (ScottyError e, MonadIO m) => RouteOptions -> ErrorHandler e m -> Maybe StdMethod -> RoutePattern -> ActionT e m () -> Middleware m-route opts h method pat action app req =- let tryNext = app req+route :: (MonadUnliftIO m) =>+ RouteOptions+ -> Maybe (ErrorHandler m) -> Maybe StdMethod -> RoutePattern -> ActionT m () -> BodyInfo -> Middleware m+route 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+ See https://github.com/scotty-web/scotty/issues/196 and 'matchAny' -}- methodMatches :: Bool- methodMatches =- case method of- Nothing -> True- Just m -> Right m == parseMethod (requestMethod req)- in if methodMatches- then case matchRoute pat req of+ methodMatches :: Bool+ methodMatches = maybe True (\x -> (Right x == parseMethod (requestMethod req))) method++ in if methodMatches+ then case matchRoute pat req of Just captures -> do- env <- liftIO $ catch (Right <$> mkEnv req captures opts) (\ex -> return . Left $ ex)- res <- evalAction h env action- maybe tryNext return res+ -- The user-facing API for "body" and "bodyReader" involve an IO action that+ -- reads the body/chunks thereof only once, so we shouldn't pass in our BodyInfo+ -- directly; otherwise, the body might get consumed and then it would be unavailable+ -- if `next` is called and we try to match further routes.+ -- Instead, make a "cloned" copy of the BodyInfo that allows the IO actions to be called+ -- without messing up the state of the original BodyInfo.+ clonedBodyInfo <- cloneBodyInfo bodyInfo++ env <- mkEnv clonedBodyInfo req captures opts+ res <- runAction h env action+ maybe tryNext return res Nothing -> tryNext- else tryNext+ else tryNext -evalAction :: (ScottyError e, Monad m) => ErrorHandler e m -> (Either ScottyException ActionEnv) -> ActionT e m () -> m (Maybe Response)-evalAction _ (Left (RequestException msg s)) _ = return . Just $ responseBuilder s [("Content-Type","text/html")] $ fromByteString msg-evalAction h (Right env) action = runAction h env action- matchRoute :: RoutePattern -> Request -> Maybe [Param] matchRoute (Literal pat) req | pat == path req = Just [] | otherwise = Nothing@@ -133,74 +136,17 @@ path :: Request -> T.Text path = T.fromStrict . TS.cons '/' . TS.intercalate "/" . pathInfo --- Stolen from wai-extra's Network.Wai.Parse, modified to accept body as list of Bytestrings.--- Reason: WAI's getRequestBodyChunk is an IO action that returns the body as chunks.--- Once read, they can't be read again. We read them into a lazy Bytestring, so Scotty--- user can get the raw body, even if they also want to call wai-extra's parsing routines.-parseRequestBody :: MonadIO m- => [B.ByteString]- -> Parse.BackEnd y- -> Request- -> m ([Parse.Param], [Parse.File y])-parseRequestBody bl s r =- case Parse.getRequestBodyType r of- Nothing -> return ([], [])- Just rbt -> do- mvar <- liftIO $ newMVar bl -- MVar is a bit of a hack so we don't have to inline- -- large portions of Network.Wai.Parse- let provider = modifyMVar mvar $ \bsold -> case bsold of- [] -> return ([], B.empty)- (b:bs) -> return (bs, b)- liftIO $ Parse.sinkRequestBody s rbt provider+-- | Parse the request and construct the initial 'ActionEnv' with a default 200 OK response+mkEnv :: MonadIO m => BodyInfo -> Request -> [Param] -> RouteOptions -> m ActionEnv+mkEnv bodyInfo req captureps opts = do+ (formps, bodyFiles) <- liftIO $ getFormParamsAndFilesAction req bodyInfo opts+ let+ queryps = parseEncodedParams $ rawQueryString req+ bodyFiles' = [ (strictByteStringToLazyText k, fi) | (k,fi) <- bodyFiles ]+ responseInit <- liftIO $ newTVarIO defaultScottyResponse+ return $ Env req captureps formps queryps (getBodyAction bodyInfo opts) (getBodyChunkAction bodyInfo) bodyFiles' responseInit -mkEnv :: forall m. MonadIO m => Request -> [Param] -> RouteOptions ->m ActionEnv-mkEnv req captures opts = do- bodyState <- liftIO $ newMVar BodyUntouched - let rbody = getRequestBodyChunk req-- safeBodyReader :: IO B.ByteString- safeBodyReader = do- state <- takeMVar bodyState- let direct = putMVar bodyState BodyCorrupted >> rbody- case state of- s@(BodyCached _ []) ->- do putMVar bodyState s- return B.empty- BodyCached b (chunk:rest) ->- do putMVar bodyState $ BodyCached b rest- return chunk- BodyUntouched -> direct- BodyCorrupted -> direct-- bs :: IO BL.ByteString- bs = do- state <- takeMVar bodyState- case state of- s@(BodyCached b _) ->- do putMVar bodyState s- return b- BodyCorrupted -> throw BodyPartiallyStreamed- BodyUntouched ->- do chunks <- readRequestBody rbody return (maxRequestBodySize opts)- let b = BL.fromChunks chunks- putMVar bodyState $ BodyCached b chunks- return b-- shouldParseBody = isJust $ Parse.getRequestBodyType req-- (formparams, fs) <- if shouldParseBody- then liftIO $ do wholeBody <- BL.toChunks `fmap` bs- parseRequestBody wholeBody Parse.lbsBackEnd req- else return ([], [])-- let- convert (k, v) = (strictByteStringToLazyText k, strictByteStringToLazyText v)- parameters = captures ++ map convert formparams ++ queryparams- queryparams = parseEncodedParams $ rawQueryString req-- return $ Env req parameters bs safeBodyReader [ (strictByteStringToLazyText k, fi) | (k,fi) <- fs ]- parseEncodedParams :: B.ByteString -> [Param] parseEncodedParams bs = [ (T.fromStrict k, T.fromStrict $ fromMaybe "" v) | (k,v) <- parseQueryText bs ] @@ -255,8 +201,3 @@ -- | Build a route that requires the requested path match exactly, without captures. literal :: String -> RoutePattern literal = Literal . T.pack--#if !(MIN_VERSION_wai(3,2,2))-getRequestBodyChunk :: Request -> IO B.ByteString-getRequestBodyChunk = requestBody-#endif
Web/Scotty/Trans.hs view
@@ -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(..)+ scottyT, scottyAppT, scottyOptsT, scottySocketT, Options(..), defaultOptions -- * Defining Middleware and Routes -- -- | 'Middleware' and routes are run in the order in which they@@ -21,22 +22,28 @@ -- ** Route Patterns , capture, regex, function, literal -- ** Accessing the Request, Captures, and Query Parameters- , request, header, headers, body, bodyReader, param, params, jsonData, files+ , request, header, headers, body, bodyReader+ , param, params+ , captureParam, formParam, queryParam+ , captureParams, formParams, queryParams+ , jsonData, files -- ** Modifying the Response and Redirecting , status, addHeader, setHeader, redirect -- ** Setting Response Body -- -- | Note: only one of these should be present in any given route -- definition, as they completely replace the current 'Response' body.- , text, html, file, json, stream, raw+ , text, html, file, json, stream, raw, nested -- ** Exceptions- , raise, raiseStatus, rescue, next, finish, defaultHandler, ScottyError(..), liftAndCatchIO+ , raise, raiseStatus, throw, rescue, next, finish, defaultHandler, liftAndCatchIO+ , StatusError(..) -- * Parsing Parameters , Param, Parsable(..), readEither -- * Types- , RoutePattern, File, Kilobytes+ , RoutePattern, File, Kilobytes, ErrorHandler, Handler(..) -- * Monad Transformers , ScottyT, ActionT+ , ScottyState, defaultScottyState ) where import Blaze.ByteString.Builder (fromByteString)@@ -46,34 +53,33 @@ 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(..), ScottyState, defaultScottyState, StatusError(..)) import Web.Scotty.Util (socketDescription)-import qualified Web.Scotty.Internal.Types as Scotty+import Web.Scotty.Body (newBodyInfo)+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.- -> ScottyT e m ()+ -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action.+ -> ScottyT m () -> n ()-scottyT p = scottyOptsT $ def { settings = setPort p (settings def) }+scottyT p = scottyOptsT $ defaultOptions { settings = setPort p (settings defaultOptions) } -- | Run a scotty application using the warp server, passing extra options. -- 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.- -> ScottyT e m ()+ -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action.+ -> ScottyT m () -> n () scottyOptsT opts runActionToIO s = do when (verbose opts > 0) $@@ -86,8 +92,8 @@ scottySocketT :: (Monad m, MonadIO n) => Options -> Socket- -> (m Response -> IO Response)- -> ScottyT e m ()+ -> (m W.Response -> IO W.Response)+ -> ScottyT m () -> n () scottySocketT opts sock runActionToIO s = do when (verbose opts > 0) $ do@@ -99,38 +105,44 @@ -- 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.- -> ScottyT e m ()- -> n Application+ => (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) def- let rapp req callback = runActionToIO (foldl (flip ($)) notFoundApp (routes s) req) >>= callback- return $ foldl (flip ($)) rapp (middlewares s)+ 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]+ callback resp+ return $ applyAll rapp (middlewares s) -notFoundApp :: Monad m => Scotty.Application m-notFoundApp _ = return $ responseBuilder status404 [("Content-Type","text/html")]+applyAll :: Foldable t => a -> t (a -> a) -> a+applyAll = foldl (flip ($))++notFoundApp :: Monad m => Application m+notFoundApp _ = return $ W.responseBuilder status404 [("Content-Type","text/html")] $ fromByteString "<h1>404: File Not Found!</h1>" --- | Global handler for uncaught exceptions.------ Uncaught exceptions normally become 500 responses.--- You can use this to selectively override that behavior.------ Note: IO exceptions are lifted into 'ScottyError's by 'stringError'.--- This has security implications, so you probably want to provide your--- own defaultHandler in production which does not send out the error--- strings as 500 responses.-defaultHandler :: (ScottyError e, Monad m) => (e -> ActionT e m ()) -> ScottyT e m ()-defaultHandler f = ScottyT $ modify $ addHandler $ Just (\e -> status status500 >> f e)+-- | Global handler for user-defined exceptions.+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.-middleware :: Middleware -> ScottyT e 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 e m ()-setMaxRequestBodySize i = assert (i > 0) $ ScottyT . modify . updateMaxRequestBodySize $ def { 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 }
Web/Scotty/Util.hs view
@@ -1,9 +1,7 @@+{-# LANGUAGE LambdaCase #-} module Web.Scotty.Util ( lazyTextToStrictByteString , strictByteStringToLazyText- , setContent- , setHeaderWith- , setStatus , mkResponse , replace , add@@ -16,41 +14,36 @@ import Network.Wai import Control.Monad (when)-import Control.Exception (throw)+import qualified Control.Exception as EUnsafe (throw) + import Network.HTTP.Types import qualified Data.ByteString as B import qualified Data.Text as TP (pack)-import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy as TL import qualified Data.Text.Encoding as ES import qualified Data.Text.Encoding.Error as ES import Web.Scotty.Internal.Types -lazyTextToStrictByteString :: T.Text -> B.ByteString-lazyTextToStrictByteString = ES.encodeUtf8 . T.toStrict+lazyTextToStrictByteString :: TL.Text -> B.ByteString+lazyTextToStrictByteString = ES.encodeUtf8 . TL.toStrict -strictByteStringToLazyText :: B.ByteString -> T.Text-strictByteStringToLazyText = T.fromStrict . ES.decodeUtf8With ES.lenientDecode+strictByteStringToLazyText :: B.ByteString -> TL.Text+strictByteStringToLazyText = TL.fromStrict . ES.decodeUtf8With ES.lenientDecode -setContent :: Content -> ScottyResponse -> ScottyResponse-setContent c sr = sr { srContent = c } -setHeaderWith :: ([(HeaderName, B.ByteString)] -> [(HeaderName, B.ByteString)]) -> ScottyResponse -> ScottyResponse-setHeaderWith f sr = sr { srHeaders = f (srHeaders sr) } -setStatus :: Status -> ScottyResponse -> ScottyResponse-setStatus s sr = sr { srStatus = s }- -- Note: we currently don't support responseRaw, which may be useful -- for websockets. However, we always read the request body, which -- is incompatible with responseRaw responses. mkResponse :: ScottyResponse -> Response mkResponse sr = case srContent sr of- ContentBuilder b -> responseBuilder s h b- ContentFile f -> responseFile s h f Nothing- ContentStream str -> responseStream s h str+ ContentBuilder b -> responseBuilder s h b+ ContentFile f -> responseFile s h f Nothing+ ContentStream str -> responseStream s h str+ ContentResponse res -> res where s = srStatus sr h = srHeaders sr @@ -76,18 +69,31 @@ SockAddrUnix u -> return $ "unix socket " ++ u _ -> fmap (\port -> "port " ++ show port) $ socketPort sock --- return request body or throw an exception if request body too big-readRequestBody :: IO B.ByteString -> ([B.ByteString] -> IO [B.ByteString]) -> Maybe Kilobytes ->IO [B.ByteString]+-- | return request body or throw a 'RequestException' if request body too big+readRequestBody :: IO B.ByteString -- ^ body chunk reader+ -> ([B.ByteString] -> IO [B.ByteString])+ -> Maybe Kilobytes -- ^ max body size+ -> IO [B.ByteString] readRequestBody rbody prefix maxSize = do b <- rbody if B.null b then prefix [] else do- checkBodyLength maxSize + checkBodyLength maxSize readRequestBody rbody (prefix . (b:)) maxSize where checkBodyLength :: Maybe Kilobytes -> IO ()- checkBodyLength (Just maxSize') = prefix [] >>= \bodySoFar -> when (isBigger bodySoFar maxSize') readUntilEmpty- checkBodyLength Nothing = return ()- isBigger bodySoFar maxSize' = (B.length . B.concat $ bodySoFar) > maxSize' * 1024- readUntilEmpty = rbody >>= \b -> if B.null b then throw (RequestException (ES.encodeUtf8 . TP.pack $ "Request is too big Jim!") status413) else readUntilEmpty+ checkBodyLength = \case+ Just maxSize' -> do+ bodySoFar <- prefix []+ when (bodySoFar `isBigger` maxSize') readUntilEmpty+ Nothing -> return ()+ isBigger bodySoFar maxSize' = (B.length . B.concat $ bodySoFar) > maxSize' * 1024 -- XXX this looks both inefficient and wrong+ readUntilEmpty = do+ b <- rbody+ if B.null b+ then EUnsafe.throw (RequestException (ES.encodeUtf8 . TP.pack $ "Request is too big Jim!") status413)+ else readUntilEmpty+++
bench/Main.hs view
@@ -6,9 +6,7 @@ module Main (main) where import Control.Monad-import Data.Default.Class (def) import Data.Functor.Identity-import Data.Text (Text) import Lucid.Base import Lucid.Html5 import Web.Scotty@@ -25,9 +23,9 @@ setColumns [Case,Allocated,GCs,Live,Check,Max,MaxOS] setFormat Markdown io "ScottyM Strict" BL.putStr- (SS.evalState (runS $ renderBST htmlScotty) def)+ (SS.evalState (runS $ renderBST htmlScotty) defaultScottyState) io "ScottyM Lazy" BL.putStr- (SL.evalState (runScottyLazy $ renderBST htmlScottyLazy) def)+ (SL.evalState (runScottyLazy $ renderBST htmlScottyLazy) defaultScottyState) io "Identity" BL.putStr (runIdentity $ renderBST htmlIdentity) @@ -49,6 +47,6 @@ {-# noinline htmlScottyLazy #-} newtype ScottyLazy a = ScottyLazy- { runScottyLazy:: SL.State (ScottyState Text IO) a }+ { runScottyLazy:: SL.State (ScottyState IO) a } deriving (Functor,Applicative,Monad)
changelog.md view
@@ -1,5 +1,20 @@ ## next [????.??.??] +## 0.20 [2023.10.02]+* Drop support for GHC < 8.10 and modernise the CI pipeline (#300).+* Adds a new `nested` handler that allows you to place an entire WAI Application under a Scotty route (#233).+* Disambiguate request parameters (#204). Adjust the `Env` type to have three `[Param]` fields instead of one, add `captureParam`, `formParam`, `queryParam` and the associated `captureParams`, `formParams`, `queryParams`. Add deprecation notices to `param` and `params`.+* Add `Scotty.Cookie` module (#293).+* Change body parsing behaviour such that calls to `next` don't result in POST request bodies disappearing (#147).+* (Internal) Remove unused type `RequestBodyState` (#313)+* Rewrite `ActionT` using the "ReaderT pattern" (#310) https://www.fpcomplete.com/blog/readert-design-pattern/++Breaking:++* (#310) Introduce `unliftio` as a dependency, and base exception handling on `catch`.+** Clarify the exception handling mechanism of ActionT, ScottyT. `rescue` changes signature to use proper `Exception` types rather than strings.+** All ActionT methods (`text`, `html` etc.) have now a MonadIO constraint on the base monad rather than Monad because the response is constructed in a TVar inside ActionEnv. `rescue` has a MonadUnliftIO constraint. The Alternative instance of ActionT also is based on MonadUnliftIO because `<|>` is implemented in terms of `catch`. `ScottyT` and `ActionT` do not have an exception type parameter anymore.+ ## 0.12.1 [2022.11.17] * Fix CPP bug that prevented tests from building on Windows. * Allow building with `transformers-0.6.*` and `mtl-2.3.*`. Because the
examples/basic.hs view
@@ -1,21 +1,29 @@ {-# LANGUAGE OverloadedStrings #-}+{-# language DeriveAnyClass #-}+{-# language ScopedTypeVariables #-} module Main (main) where import Web.Scotty import Network.Wai.Middleware.RequestLogger -- install wai-extra if you don't have this +import Control.Exception (Exception(..)) import Control.Monad import Control.Monad.Trans import System.Random (newStdGen, randomRs) import Network.HTTP.Types (status302) +import Data.Text.Lazy (pack) import Data.Text.Lazy.Encoding (decodeUtf8) import Data.String (fromString)+import Data.Typeable (Typeable) import Prelude () import Prelude.Compat +data Err = Boom | UserAgentNotFound | NeverReached deriving (Show, Typeable, Exception)++ main :: IO () main = scotty 3000 $ do -- Add any WAI middleware, they are run top-down.@@ -29,14 +37,14 @@ 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 <- param "fooparam"+ v <- captureParam "fooparam" html $ mconcat ["<h1>", v, "</h1>"] -- An uncaught error becomes a 500 page.- get "/raise" $ raise "some error here"+ get "/raise" $ throw Boom -- You can set status and headers directly. get "/redirect-custom" $ do@@ -47,24 +55,24 @@ -- redirects preempt execution get "/redirect" $ do void $ redirect "http://www.google.com"- raise "this error is never reached"+ throw NeverReached -- Of course you can catch your own errors. get "/rescue" $ do- (do void $ raise "a rescued error"; redirect "http://www.we-never-go-here.com")- `rescue` (\m -> text $ "we recovered from " `mappend` m)+ (do void $ throw Boom; redirect "http://www.we-never-go-here.com")+ `rescue` (\(e :: Err) -> text $ "we recovered from " `mappend` pack (show e)) -- Parts of the URL that start with a colon match -- any string, and capture that value as a parameter. -- URL captures take precedence over query string parameters. get "/foo/:bar/required" $ do- v <- param "bar"+ v <- captureParam "bar" html $ mconcat ["<h1>", v, "</h1>"] -- 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"@@ -75,7 +83,7 @@ json $ take 20 $ randomRs (1::Int,100) g get "/ints/:is" $ do- is <- param "is"+ is <- captureParam "is" json $ [(1::Int)..10] ++ is get "/setbody" $ do@@ -85,17 +93,21 @@ ,"</form>" ] + -- Read and decode the request body as UTF-8 post "/readbody" $ do b <- body text $ decodeUtf8 b + -- Look up a request header get "/header" $ do agent <- header "User-Agent"- maybe (raise "User-Agent header not found!") text agent+ maybe (throw UserAgentNotFound) text agent -- 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
examples/cookies.hs view
@@ -1,36 +1,14 @@ {-# LANGUAGE OverloadedStrings #-}--- This examples requires you to: cabal install cookie--- and: cabal install blaze-html+-- This examples requires you to: cabal install blaze-html module Main (main) where import Control.Monad (forM_)-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy.Encoding as T-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import qualified Blaze.ByteString.Builder as B import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes import Text.Blaze.Html.Renderer.Text (renderHtml) import Web.Scotty-import Web.Cookie--makeCookie :: BS.ByteString -> BS.ByteString -> SetCookie-makeCookie n v = def { setCookieName = n, setCookieValue = v }--renderSetCookie' :: SetCookie -> Text-renderSetCookie' = T.decodeUtf8 . B.toLazyByteString . renderSetCookie--setCookie :: BS.ByteString -> BS.ByteString -> ActionM ()-setCookie n v = setHeader "Set-Cookie" (renderSetCookie' (makeCookie n v))--getCookies :: ActionM (Maybe CookiesText)-getCookies =- fmap (fmap (parseCookiesText . lazyToStrict . T.encodeUtf8)) $- header "Cookie"- where- lazyToStrict = BS.concat . BSL.toChunks+import Web.Scotty.Cookie (CookiesText, setSimpleCookie, getCookies) renderCookiesTable :: CookiesText -> H.Html renderCookiesTable cs =@@ -48,16 +26,14 @@ get "/" $ do cookies <- getCookies html $ renderHtml $ do- case cookies of- Just cs -> renderCookiesTable cs- Nothing -> return ()+ renderCookiesTable cookies H.form H.! method "post" H.! action "/set-a-cookie" $ do H.input H.! type_ "text" H.! name "name" H.input H.! type_ "text" H.! name "value" H.input H.! type_ "submit" H.! value "set a cookie" post "/set-a-cookie" $ do- name' <- param "name"- value' <- param "value"- setCookie name' value'+ name' <- captureParam "name"+ value' <- captureParam "value"+ setSimpleCookie name' value' redirect "/"
examples/exceptions.hs view
@@ -1,9 +1,13 @@ {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}+{-# language DeriveAnyClass #-}+{-# language LambdaCase #-} module Main (main) where +import Control.Exception (Exception(..)) import Control.Monad.IO.Class import Data.String (fromString)+import Data.Typeable import Network.HTTP.Types import Network.Wai.Middleware.RequestLogger@@ -15,25 +19,20 @@ import Web.Scotty.Trans --- Define a custom exception type.+-- | A custom exception type. data Except = Forbidden | NotFound Int | StringEx String- deriving (Show, Eq)---- The type must be an instance of 'ScottyError'.--- 'ScottyError' is essentially a combination of 'Error' and 'Show'.-instance ScottyError Except where- stringError = StringEx- showError = fromString . show+ deriving (Show, Eq, Typeable, Exception) --- Handler for uncaught exceptions.-handleEx :: Monad m => Except -> ActionT Except m ()-handleEx Forbidden = do+-- | User-defined exceptions should have an associated Handler:+handleEx :: MonadIO m => ErrorHandler m+handleEx = Handler $ \case+ Forbidden -> do status status403 html "<h1>Scotty Says No</h1>"-handleEx (NotFound i) = do+ NotFound i -> do status status404 html $ fromString $ "<h1>Can't find " ++ show i ++ ".</h1>"-handleEx (StringEx s) = do+ StringEx s -> do status status500 html $ fromString $ "<h1>" ++ s ++ "</h1>" @@ -53,13 +52,13 @@ ] get "/switch/:val" $ do- v <- param "val"- _ <- if even v then raise Forbidden else raise (NotFound v)+ v <- captureParam "val"+ _ <- if even v then throw Forbidden else throw (NotFound v) text "this will never be reached" get "/random" $ do rBool <- liftIO randomIO i <- liftIO randomIO let catchOne Forbidden = html "<h1>Forbidden was randomly thrown, but we caught it."- catchOne other = raise other- raise (if rBool then Forbidden else NotFound i) `rescue` catchOne+ catchOne other = throw other+ throw (if rBool then Forbidden else NotFound i) `rescue` catchOne
examples/globalstate.hs view
@@ -10,11 +10,10 @@ module Main (main) where 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 @@ -25,8 +24,8 @@ 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@@ -39,7 +38,7 @@ -- Also note: your monad must be an instance of 'MonadIO' for -- Scotty to use it. newtype WebM a = WebM { runWebM :: ReaderT (TVar AppState) IO a }- deriving (Applicative, Functor, Monad, MonadIO, MonadReader (TVar AppState))+ deriving (Applicative, Functor, Monad, MonadIO, MonadReader (TVar AppState), MonadUnliftIO) -- Scotty's monads are layered on top of our custom monad. -- We define this synonym for lift in order to be explicit@@ -56,7 +55,7 @@ main :: IO () main = do- sync <- newTVarIO def+ sync <- newTVarIO defaultAppState -- 'runActionToIO' is called once per action. let runActionToIO m = runReaderT (runWebM m) sync @@ -66,7 +65,7 @@ -- type is ambiguous. We can fix it by putting a type -- annotation just about anywhere. In this case, we'll -- just do it on the entire app.-app :: ScottyT Text WebM ()+app :: ScottyT WebM () app = do middleware logStdoutDev get "/" $ do
+ examples/nested.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Web.Scotty+import Network.Wai+import qualified Data.Text.Lazy as TL+import Network.HTTP.Types.Status+import Data.Monoid (mconcat)++simpleApp :: Application+simpleApp _ respond = do+ putStrLn "I've done some IO here"+ respond $ responseLBS+ status200+ [("Content-Type", "text/plain")]+ "Hello, Web!"++scottApp :: IO Application+scottApp = scottyApp $ do++ get "/" $ do+ html $ mconcat ["<h1>Scotty, beam me up!</h1>"]++ get "/other/test/:word" $ do+ beam <- param "word"+ html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"]++ get "/test/:word" $ do+ beam <- param "word"+ html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"]++ get "/nested" $ nested simpleApp+ get "/other/nested" $ nested simpleApp++ notFound $ do+ r <- request+ html (TL.pack (show (pathInfo r)))++ -- For example, returns path info: ["other","qwer","adxf","jkashdfljhaslkfh","qwer"]+ -- for request http://localhost:3000/other/qwer/adxf/jkashdfljhaslkfh/qwer++main :: IO ()+main = do++ otherApp <- scottApp++ scotty 3000 $ do++ get "/" $ do+ html $ mconcat ["<h1>Scotty, beam me up!</h1>"]++ get "/test/:word" $ do+ beam <- param "word"+ html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"]++ get "/simple" $ nested simpleApp++ get "/other" $ nested otherApp++ get (regex "/other/.*") $ nested otherApp++
examples/options.hs view
@@ -5,14 +5,13 @@ import Network.Wai.Middleware.RequestLogger -- install wai-extra if you don't have this -import Data.Default.Class (def) import Network.Wai.Handler.Warp (setPort) -- Set some Scotty settings opts :: Options-opts = def { verbose = 0- , settings = setPort 4000 $ settings def- }+opts = defaultOptions { verbose = 0+ , settings = setPort 4000 $ settings defaultOptions+ } -- This won't display anything at startup, and will listen on localhost:4000 main :: IO ()
examples/reader.hs view
@@ -8,11 +8,11 @@ module Main where import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, asks, lift, runReaderT)-import Data.Default.Class (def)-import Data.Text.Lazy (Text, pack)+import Control.Monad.IO.Unlift (MonadUnliftIO(..))+import Data.Text.Lazy (pack) import Prelude () import Prelude.Compat-import Web.Scotty.Trans (ScottyT, get, scottyOptsT, text)+import Web.Scotty.Trans (ScottyT, defaultOptions, get, scottyOptsT, text) data Config = Config { environment :: String@@ -20,16 +20,16 @@ newtype ConfigM a = ConfigM { runConfigM :: ReaderT Config IO a- } deriving (Applicative, Functor, Monad, MonadIO, MonadReader Config)+ } deriving (Applicative, Functor, Monad, MonadIO, MonadReader Config, MonadUnliftIO) -application :: ScottyT Text ConfigM ()+application :: ScottyT ConfigM () application = do get "/" $ do e <- lift $ asks environment text $ pack $ show e main :: IO ()-main = scottyOptsT def runIO application where+main = scottyOptsT defaultOptions runIO application where runIO :: ConfigM a -> IO a runIO m = runReaderT (runConfigM m) config
examples/urlshortener.hs view
@@ -1,12 +1,17 @@ {-# LANGUAGE OverloadedStrings #-}+{-# language DeriveAnyClass #-}+{-# language LambdaCase #-}+-- {-# language ScopedTypeVariables #-} module Main (main) where import Web.Scotty import Control.Concurrent.MVar+import Control.Exception (Exception(..)) import Control.Monad.IO.Class import qualified Data.Map as M import qualified Data.Text.Lazy as T+import Data.Typeable (Typeable) import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.Static@@ -23,12 +28,17 @@ 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)+instance Show SessionError where+ show = \case+ UrlHashNotFound hash -> unwords ["URL hash #", show hash, " not found in database!"]+ main :: IO () main = do- m <- newMVar (0::Int,M.empty :: M.Map Int T.Text)+ m <- newMVar (0::Int, M.empty :: M.Map Int T.Text) scotty 3000 $ do middleware logStdoutDev middleware static@@ -42,20 +52,20 @@ H.input H.! type_ "submit" post "/shorten" $ do- url <- param "url"+ url <- captureParam "url" liftIO $ modifyMVar_ m $ \(i,db) -> return (i+1, M.insert i (T.pack url) db) redirect "/list" -- We have to be careful here, because this route can match pretty much anything. -- Thankfully, the type system knows that 'hash' must be an Int, so this route- -- only matches if 'read' can successfully parse the hash capture as an Int.+ -- only matches if 'parseParam' can successfully parse the hash capture as an Int. -- Otherwise, the pattern match will fail and Scotty will continue matching -- subsequent routes. get "/:hash" $ do- hash <- param "hash"+ hash <- captureParam "hash" (_,db) <- liftIO $ readMVar m case M.lookup hash db of- Nothing -> raise $ mconcat ["URL hash #", T.pack $ show $ hash, " not found in database!"]+ Nothing -> throw $ UrlHashNotFound hash Just url -> redirect url -- We put /list down here to show that it will not match the '/:hash' route above.
scotty.cabal view
@@ -1,13 +1,13 @@ Name: scotty-Version: 0.12.1+Version: 0.20 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues License: BSD3 License-file: LICENSE Author: Andrew Farmer <xichekolas@gmail.com>-Maintainer: Andrew Farmer <xichekolas@gmail.com>-Copyright: (c) 2012-Present Andrew Farmer+Maintainer: The Scotty maintainers+Copyright: (c) 2012-Present, Andrew Farmer and the Scotty contributors Category: Web Stability: experimental Build-type: Simple@@ -20,11 +20,9 @@ . import Web.Scotty .- import Data.Monoid (mconcat)- . main = scotty 3000 $   get "/:word" $ do-     beam <- param "word"+     beam <- captureParam "word"     html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"] @ .@@ -44,16 +42,11 @@ [WAI] <http://hackage.haskell.org/package/wai> . [Warp] <http://hackage.haskell.org/package/warp>-tested-with: GHC == 7.6.3- , GHC == 7.8.4- , GHC == 7.10.3- , GHC == 8.0.2- , GHC == 8.2.2- , GHC == 8.4.4- , GHC == 8.6.5- , GHC == 8.8.4- , GHC == 8.10.4- , GHC == 9.0.1+tested-with: GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.6+ , GHC == 9.6.2 Extra-source-files: README.md changelog.md@@ -68,27 +61,34 @@ Exposed-modules: Web.Scotty Web.Scotty.Trans Web.Scotty.Internal.Types+ Web.Scotty.Cookie other-modules: Web.Scotty.Action+ Web.Scotty.Body+ Web.Scotty.Exceptions Web.Scotty.Route Web.Scotty.Util default-language: Haskell2010- build-depends: aeson >= 0.6.2.1 && < 2.2,+ build-depends: aeson >= 0.6.2.1 && < 2.3, base >= 4.6 && < 5,- base-compat-batteries >= 0.10 && < 0.13,+ base-compat-batteries >= 0.10 && < 0.14, blaze-builder >= 0.3.3.0 && < 0.5, bytestring >= 0.10.0.2 && < 0.12, case-insensitive >= 1.0.0.1 && < 1.3,- data-default-class >= 0.0.1 && < 0.2,+ cookie >= 0.4,+ data-default-class >= 0.1, exceptions >= 0.7 && < 0.11, http-types >= 0.9.1 && < 0.13, monad-control >= 1.0.0.3 && < 1.1, mtl >= 2.1.2 && < 2.4, network >= 2.6.0.2 && < 3.2, regex-compat >= 0.95.1 && < 0.96,+ stm, text >= 0.11.3.1 && < 2.1,+ time >= 1.8, transformers >= 0.3.0.0 && < 0.7, transformers-base >= 0.4.1 && < 0.5, transformers-compat >= 0.4 && < 0.8,+ unliftio >= 0.2, wai >= 3.0.0 && < 3.3, wai-extra >= 3.0.0 && < 3.2, warp >= 3.0.13 && < 3.4@@ -110,7 +110,6 @@ build-depends: async, base, bytestring,- data-default-class, directory, hspec == 2.*, hspec-wai >= 0.6.3,@@ -135,8 +134,7 @@ mtl, text, transformers,- data-default-class,- weigh == 0.0.16+ weigh >= 0.0.16 && <0.1 GHC-options: -Wall -O2 -threaded source-repository head
test/Web/ScottySpec.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, CPP #-}+{-# LANGUAGE OverloadedStrings, CPP, ScopedTypeVariables #-} module Web.ScottySpec (main, spec) where import Test.Hspec@@ -11,18 +11,19 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE import Network.HTTP.Types+import Network.Wai (Application, responseLBS) import qualified Control.Exception.Lifted as EL import qualified Control.Exception as E import Web.Scotty as Scotty hiding (get, post, put, patch, delete, request, options) import qualified Web.Scotty as Scotty+import qualified Web.Scotty.Cookie as SC (getCookie, setSimpleCookie, deleteCookie) #if !defined(mingw32_HOST_OS) import Control.Concurrent.Async (withAsync) import Control.Exception (bracketOnError) import qualified Data.ByteString as BS import Data.ByteString (ByteString)-import Data.Default.Class (def) import Network.Socket (Family(..), SockAddr(..), Socket, SocketOption(..), SocketType(..), bind, close, connect, listen, maxListenQueue, setSocketOption, socket) import Network.Socket.ByteString (send, recv) import System.Directory (removeFile)@@ -82,50 +83,158 @@ get "/" `shouldRespondWith` "<h1>404: File Not Found!</h1>" {matchStatus = 404} describe "defaultHandler" $ do- withApp (defaultHandler text >> Scotty.get "/" (liftAndCatchIO $ E.throwIO E.DivideByZero)) $ do+ withApp (do+ let h = Handler (\(e :: E.ArithException) -> status status500 >> text (TL.pack $ show e))+ defaultHandler h+ Scotty.get "/" (throw E.DivideByZero)) $ do it "sets custom exception handler" $ do get "/" `shouldRespondWith` "divide by zero" {matchStatus = 500}-- withApp (defaultHandler (\_ -> status status503) >> Scotty.get "/" (liftAndCatchIO $ E.throwIO E.DivideByZero)) $ do+ withApp (do+ 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 "/" $ throw E.DivideByZero) $ do it "returns 500 on exceptions" $ do- get "/" `shouldRespondWith` "<h1>500 Internal Server Error</h1>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])]+ 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")]+ smol `shouldRespondWith` 200+ 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- withApp (Scotty.get "/" $ (undefined `EL.catch` ((\_ -> html "") :: E.SomeException -> ActionM ()))) $ do- it "has a MonadBaseControl instance" $ do- get "/" `shouldRespondWith` 200+ context "MonadBaseControl instance" $ do+ withApp (Scotty.get "/" $ (undefined `EL.catch` ((\_ -> html "") :: E.SomeException -> ActionM ()))) $ do+ it "catches SomeException and returns 200" $ do+ get "/" `shouldRespondWith` 200+ withApp (Scotty.get "/" $ EL.throwIO E.DivideByZero) $ do+ it "returns 500 on uncaught exceptions" $ do+ get "/" `shouldRespondWith` "" {matchStatus = 500} - withApp (Scotty.get "/dictionary" $ empty <|> param "word1" <|> empty <|> param "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"+ context "Alternative instance" $ do+ withApp (Scotty.get "/" $ empty >>= text) $+ it "empty without any route following returns a 404" $+ get "/" `shouldRespondWith` 404+ 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 "param" $ do- withApp (Scotty.matchAny "/search" $ param "query" >>= text) $ do+ describe "redirect" $ do+ withApp (+ do+ Scotty.get "/a" $ redirect "/b"+ ) $ do+ it "Responds with a 302 Redirect" $ do+ get "/a" `shouldRespondWith` 302 { matchHeaders = ["Location" <:> "/b"] }++ describe "captureParam" $ do+ withApp (+ do+ Scotty.matchAny "/search/:q" $ do+ _ :: Int <- captureParam "q"+ text "int"+ Scotty.matchAny "/search/:q" $ do+ _ :: String <- captureParam "q"+ text "string"+ ) $ do+ it "responds with 200 OK iff at least one route matches at the right type" $ do+ get "/search/42" `shouldRespondWith` 200 { matchBody = "int" }+ get "/search/potato" `shouldRespondWith` 200 { matchBody = "string" }+ withApp (+ do+ Scotty.matchAny "/search/:q" $ do+ v <- captureParam "q"+ json (v :: Int)+ ) $ do+ it "responds with 404 Not Found if no route matches at the right type" $ do+ get "/search/potato" `shouldRespondWith` 404+ withApp (+ do+ Scotty.matchAny "/search/:q" $ do+ v <- captureParam "zzz"+ json (v :: Int)+ ) $ do+ it "responds with 500 Server Error if the parameter cannot be found in the capture" $ do+ get "/search/potato" `shouldRespondWith` 500+ context "recover from missing parameter exception" $ do+ withApp (Scotty.get "/search/:q" $+ (captureParam "z" >>= text) `rescue` (\(_::StatusError) -> text "z")+ ) $ do+ it "catches a StatusError" $ do+ get "/search/xxx" `shouldRespondWith` 200 { matchBody = "z"}++ describe "queryParam" $ do+ withApp (Scotty.matchAny "/search" $ queryParam "query" >>= text) $ do it "returns query parameter with given name" $ do get "/search?query=haskell" `shouldRespondWith` "haskell"+ withApp (Scotty.matchAny "/search" (do+ v <- queryParam "query"+ json (v :: Int) )) $ do+ it "responds with 200 OK if the query parameter can be parsed at the right type" $ do+ get "/search?query=42" `shouldRespondWith` 200+ it "responds with 400 Bad Request if the query parameter cannot be parsed at the right type" $ 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))) `rescue` (\(_::StatusError) -> text "z")+ ) $ do+ it "catches a StatusError" $ do+ get "/search?query=potato" `shouldRespondWith` 200 { matchBody = "z"} - context "when used with application/x-www-form-urlencoded data" $ do- it "returns POST parameter with given name" $ do- request "POST" "/search" [("Content-Type","application/x-www-form-urlencoded")] "query=haskell" `shouldRespondWith` "haskell"+ describe "formParam" $ do+ let+ postForm p bdy = request "POST" p [("Content-Type","application/x-www-form-urlencoded")] bdy+ withApp (Scotty.post "/search" $ formParam "query" >>= text) $ do+ it "returns form parameter with given name" $ do+ postForm "/search" "query=haskell" `shouldRespondWith` "haskell" - it "replaces non UTF-8 bytes with Unicode replacement character" $ do- request "POST" "/search" [("Content-Type","application/x-www-form-urlencoded")] "query=\xe9" `shouldRespondWith` "\xfffd"+ it "replaces non UTF-8 bytes with Unicode replacement character" $ do+ postForm "/search" "query=\xe9" `shouldRespondWith` "\xfffd"+ withApp (Scotty.post "/search" (do+ v <- formParam "query"+ json (v :: Int))) $ do+ it "responds with 200 OK if the form parameter can be parsed at the right type" $ do+ postForm "/search" "query=42" `shouldRespondWith` 200+ it "responds with 400 Bad Request if the form parameter cannot be parsed at the right type" $ do+ postForm "/search" "query=potato" `shouldRespondWith` 400 + withApp (do+ Scotty.post "/" $ next+ Scotty.post "/" $ do+ p :: Int <- formParam "p"+ json p+ ) $ do+ it "preserves the body of a POST request even after 'next' (#147)" $ do+ postForm "/" "p=42" `shouldRespondWith` "42"+ context "recover from type mismatch parameter exception" $ do+ withApp (Scotty.post "/search" $+ (formParam "z" >>= (\v -> json (v :: Int))) `rescue` (\(_::StatusError) -> text "z")+ ) $ do+ it "catches a StatusError" $ do+ postForm "/search" "z=potato" `shouldRespondWith` 200 { matchBody = "z"} - describe "requestLimit" $ do- withApp (Scotty.setMaxRequestBodySize 1 >> Scotty.matchAny "/upload" (do status status200)) $ do- it "upload endpoint for max-size requests, status 413 if request is too big, 200 otherwise" $ do- request "POST" "/upload" [("Content-Type","multipart/form-data; boundary=--33")]- (TLE.encodeUtf8 . TL.pack . concat $ [show c | c <- ([1..4500]::[Integer])]) `shouldRespondWith` 413- request "POST" "/upload" [("Content-Type","multipart/form-data; boundary=--33")]- (TLE.encodeUtf8 . TL.pack . concat $ [show c | c <- ([1..50]::[Integer])]) `shouldRespondWith` 200 describe "text" $ do let modernGreekText :: IsString a => a@@ -171,6 +280,39 @@ it "stops the execution of an action" $ do get "/scotty" `shouldRespondWith` 400 + describe "setSimpleCookie" $ do+ withApp (Scotty.get "/scotty" $ SC.setSimpleCookie "foo" "bar") $ do+ it "responds with a Set-Cookie header" $ do+ get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Set-Cookie" <:> "foo=bar"]}++ describe "getCookie" $ do+ withApp (Scotty.get "/scotty" $ do+ mt <- SC.getCookie "foo"+ case mt of+ Just "bar" -> Scotty.status status200+ _ -> Scotty.status status400 ) $ do+ it "finds the right cookie in the request headers" $ do+ request "GET" "/scotty" [("Cookie", "foo=bar")] "" `shouldRespondWith` 200++ describe "deleteCookie" $ do+ withApp (Scotty.get "/scotty" $ SC.deleteCookie "foo") $ do+ it "responds with a Set-Cookie header with expiry date Jan 1, 1970" $ do+ get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Set-Cookie" <:> "foo=; Expires=Thu, 01-Jan-1970 00:00:00 GMT"]}++ describe "nested" $ do+ let+ simpleApp :: Application+ simpleApp _ respond = do+ putStrLn "I've done some IO here"+ respond $ responseLBS+ status200+ [("Content-Type", "text/plain")]+ "Hello, Web!"++ withApp (Scotty.get "/nested" (nested simpleApp)) $ do+ it "responds with the expected simpleApp response" $ do+ get "/nested" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/plain"], matchBody = "Hello, Web!"}+ -- Unix sockets not available on Windows #if !defined(mingw32_HOST_OS) describe "scottySocket" .@@ -194,7 +336,7 @@ withServer actions inner = E.bracket (listenOn socketPath) (\sock -> close sock >> removeFile socketPath)- (\sock -> withAsync (Scotty.scottySocket def sock actions) $ const inner)+ (\sock -> withAsync (Scotty.scottySocket defaultOptions sock actions) $ const inner) -- See https://github.com/haskell/network/issues/318 listenOn :: String -> IO Socket@@ -209,3 +351,4 @@ return sock ) #endif+