diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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 ["Scotty, ", beam, " me up!
"]
```
@@ -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
+
+
+ 
+
+
+
+# Copyright
+(c) 2012-Present, Andrew Farmer and Scotty contributors
diff --git a/Web/Scotty.hs b/Web/Scotty.hs
--- a/Web/Scotty.hs
+++ b/Web/Scotty.hs
@@ -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 ()
diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs
--- a/Web/Scotty/Action.hs
+++ b/Web/Scotty/Action.hs
@@ -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 ["", code, " ", msg, "
", 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 ["", code, " ", msg, "
", 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
diff --git a/Web/Scotty/Body.hs b/Web/Scotty/Body.hs
new file mode 100644
--- /dev/null
+++ b/Web/Scotty/Body.hs
@@ -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
diff --git a/Web/Scotty/Cookie.hs b/Web/Scotty/Cookie.hs
new file mode 100644
--- /dev/null
+++ b/Web/Scotty/Cookie.hs
@@ -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 [ \"\\\"
+ , 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
+ }
+
diff --git a/Web/Scotty/Exceptions.hs b/Web/Scotty/Exceptions.hs
new file mode 100644
--- /dev/null
+++ b/Web/Scotty/Exceptions.hs
@@ -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)
diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs
--- a/Web/Scotty/Internal/Types.hs
+++ b/Web/Scotty/Internal/Types.hs
@@ -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
+
+
diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs
--- a/Web/Scotty/Route.hs
+++ b/Web/Scotty/Route.hs
@@ -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
diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs
--- a/Web/Scotty/Trans.hs
+++ b/Web/Scotty/Trans.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings, RankNTypes #-}
+{-# language LambdaCase #-}
-- | It should be noted that most of the code snippets below depend on the
-- OverloadedStrings language pragma.
--
@@ -11,7 +12,7 @@
-- the comments on each of these functions for more information.
module Web.Scotty.Trans
( -- * scotty-to-WAI
- scottyT, scottyAppT, scottyOptsT, scottySocketT, Options(..)
+ 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 "404: File Not Found!
"
--- | 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 }
diff --git a/Web/Scotty/Util.hs b/Web/Scotty/Util.hs
--- a/Web/Scotty/Util.hs
+++ b/Web/Scotty/Util.hs
@@ -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
+
+
+
diff --git a/bench/Main.hs b/bench/Main.hs
--- a/bench/Main.hs
+++ b/bench/Main.hs
@@ -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)
diff --git a/changelog.md b/changelog.md
--- a/changelog.md
+++ b/changelog.md
@@ -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
diff --git a/examples/basic.hs b/examples/basic.hs
--- a/examples/basic.hs
+++ b/examples/basic.hs
@@ -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 ["", v, "
"]
-- 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 ["", v, "
"]
-- 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 @@
,""
]
+ -- 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
diff --git a/examples/cookies.hs b/examples/cookies.hs
--- a/examples/cookies.hs
+++ b/examples/cookies.hs
@@ -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 "/"
diff --git a/examples/exceptions.hs b/examples/exceptions.hs
--- a/examples/exceptions.hs
+++ b/examples/exceptions.hs
@@ -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 "Scotty Says No
"
-handleEx (NotFound i) = do
+ NotFound i -> do
status status404
html $ fromString $ "Can't find " ++ show i ++ ".
"
-handleEx (StringEx s) = do
+ StringEx s -> do
status status500
html $ fromString $ "" ++ s ++ "
"
@@ -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 "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
diff --git a/examples/globalstate.hs b/examples/globalstate.hs
--- a/examples/globalstate.hs
+++ b/examples/globalstate.hs
@@ -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
diff --git a/examples/nested.hs b/examples/nested.hs
new file mode 100644
--- /dev/null
+++ b/examples/nested.hs
@@ -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 ["Scotty, beam me up!
"]
+
+ get "/other/test/:word" $ do
+ beam <- param "word"
+ html $ mconcat ["Scotty, ", beam, " me up!
"]
+
+ get "/test/:word" $ do
+ beam <- param "word"
+ html $ mconcat ["Scotty, ", beam, " me up!
"]
+
+ 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 ["Scotty, beam me up!
"]
+
+ get "/test/:word" $ do
+ beam <- param "word"
+ html $ mconcat ["Scotty, ", beam, " me up!
"]
+
+ get "/simple" $ nested simpleApp
+
+ get "/other" $ nested otherApp
+
+ get (regex "/other/.*") $ nested otherApp
+
+
diff --git a/examples/options.hs b/examples/options.hs
--- a/examples/options.hs
+++ b/examples/options.hs
@@ -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 ()
diff --git a/examples/reader.hs b/examples/reader.hs
--- a/examples/reader.hs
+++ b/examples/reader.hs
@@ -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
diff --git a/examples/urlshortener.hs b/examples/urlshortener.hs
--- a/examples/urlshortener.hs
+++ b/examples/urlshortener.hs
@@ -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.
diff --git a/scotty.cabal b/scotty.cabal
--- a/scotty.cabal
+++ b/scotty.cabal
@@ -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
-Maintainer: Andrew Farmer
-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]
.
[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
diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs
--- a/test/Web/ScottySpec.hs
+++ b/test/Web/ScottySpec.hs
@@ -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` "404: File Not Found!
" {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` "500 Internal Server Error
divide by zero" {matchStatus = 500}
+ get "/" `shouldRespondWith` "" {matchStatus = 500}
+
+ describe "setMaxRequestBodySize" $ do
+ let
+ large = TLE.encodeUtf8 . TL.pack . concat $ [show c | c <- ([1..4500]::[Integer])]
+ smol = TLE.encodeUtf8 . TL.pack . concat $ [show c | c <- ([1..50]::[Integer])]
+ 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
+