scotty 0.6.2 → 0.30
raw patch · 38 files changed
Files
- LICENSE +1/−1
- README.md +85/−16
- ReleaseNotes.md +0/−42
- Web/Scotty.hs +426/−99
- Web/Scotty/Action.hs +660/−124
- Web/Scotty/Body.hs +126/−0
- Web/Scotty/Cookie.hs +135/−0
- Web/Scotty/Internal/Types.hs +288/−0
- Web/Scotty/Route.hs +168/−108
- Web/Scotty/Session.hs +192/−0
- Web/Scotty/Trans.hs +153/−50
- Web/Scotty/Trans/Lazy.hs +85/−0
- Web/Scotty/Trans/Strict.hs +57/−0
- Web/Scotty/Types.hs +0/−128
- Web/Scotty/Util.hs +76/−26
- bench/Main.hs +56/−0
- changelog.md +296/−0
- doctest/Main.hs +23/−0
- examples/LICENSE +29/−0
- examples/basic.hs +50/−19
- examples/bodyecho.hs +37/−0
- examples/cookies.hs +13/−36
- examples/exceptions.hs +27/−23
- examples/globalstate.hs +12/−15
- examples/gzip.hs +4/−2
- examples/json_mode.hs +55/−0
- examples/middleware.hs +79/−0
- examples/nested.hs +63/−0
- examples/options.hs +6/−5
- examples/reader.hs +37/−0
- examples/session.hs +31/−0
- examples/upload.hs +33/−16
- examples/uploads/.keep +0/−0
- examples/urlshortener.hs +20/−10
- scotty.cabal +111/−35
- test/Spec.hs +1/−0
- test/Test/Hspec/Wai/Extra.hs +65/−0
- test/Web/ScottySpec.hs +770/−0
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2012 Andrew Farmer+Copyright (c) 2012-2017 Andrew Farmer All rights reserved. Redistribution and use in source and binary forms, with or without
README.md view
@@ -1,4 +1,4 @@-# Scotty+# Scotty [](https://hackage.haskell.org/package/scotty) [](http://stackage.org/lts/package/scotty) [](http://stackage.org/nightly/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,29 +6,98 @@ {-# LANGUAGE OverloadedStrings #-} import Web.Scotty -import Data.Monoid (mconcat)--main = scotty 3000 $ do-get "/:word" $ do- beam <- param "word"- html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"]+main = scotty 3000 $+ get "/:word" $ do+ beam <- pathParam "word"+ html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"] ``` Scotty is the cheap and cheerful way to write RESTful, declarative web applications. -* A page is as simple as defining the verb, url pattern, and Text content.+* A page is as simple as defining the verb, URL pattern, and Text content. * It is template-language agnostic. Anything that returns a Text value will do.-* Conforms to WAI Application interface.-* Uses very fast Warp webserver by default.+* Conforms to the [web application interface (WAI)](https://github.com/yesodweb/wai/).+* Uses the very fast Warp webserver by default. -See examples/basic.hs to see Scotty in action. (basic.hs needs the wai-extra package)+As for the name: Sinatra + Warp = Scotty. +## Examples++Run /basic.hs to see Scotty in action:+ ```bash-> runghc examples/basic.hs-Setting phasers to stun... (port 3000) (ctrl-c to quit)-(visit localhost:3000/somepath)+runghc examples/basic.hs ```+`Setting phasers to stun... (port 3000) (ctrl-c to quit)` -As for the name: Sinatra + Warp = Scotty.+Or equivalently with [`stack`](https://docs.haskellstack.org/en/stable/): -Copyright (c) 2012-2013 Andrew Farmer+```bash+stack exec -- scotty-basic+```++Once the server is running you can interact with it with curl or a browser:++```bash+curl localhost:3000+```+`foobar`++```bash+curl localhost:3000/foo_query?p=42+```+`<h1>42</h1>`+++Additionally, the `examples` directory shows a number of concrete use cases, e.g. ++* [exception handling](./examples/exceptions.hs)+* [global state](./examples/globalstate.hs)+* [configuration](./examples/reader.hs)+* [cookies](./examples/cookies.hs)+* [file upload](./examples/upload.hs)+* [session](./examples/session.hs)+* [WAI middlewares (logging, header validation)](./examples/middleware.hs)+* and more++## More Information++Tutorials and related projects can be found in the [Scotty wiki](https://github.com/scotty-web/scotty/wiki).++## Contributing++Feel free to ask questions or report bugs on the [Github issue tracker](https://github.com/scotty-web/scotty/issues/).++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` :)++## 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+ extra-deps:+ - regex-posix-clib-2.7+ flags:+ regex-posix:+ _regex-posix-clib: true+ ```+ * If you are using cabal, update the `constraints` section of `cabal.project.local` as follows:+ * ```+ constraints:+ regex-posix +_regex-posix-clib + ```++### Contributors++<a href="https://github.com/scotty-web/scotty/graphs/contributors">+ <img src="https://contrib.rocks/image?repo=scotty-web/scotty" />+</a>+++# Copyright +(c) 2012-Present, Andrew Farmer and Scotty contributors
− ReleaseNotes.md
@@ -1,42 +0,0 @@-## 0.6.0--* The Scotty transformers (`ScottyT` and `ActionT`) are now parameterized- over a custom exception type, allowing one to extend Scotty's `ErrorT`- layer with something richer than `Text` errors. See the `exceptions`- example for use. `ScottyM` and `ActionM` remain specialized to `Text`- exceptions for simplicity.--* Both monads are now instances of `Functor` and `Applicative`.--* There is a new `cookies` example.--* Internals brought up-to-date with WAI 2.0 and related packages.--## 0.5.0--* The Scotty monads (`ScottyM` and `ActionM`) are now monad transformers,- allowing Scotty applications to be embedded in arbitrary `MonadIO`s.- The old API continues to be exported from `Web.Scotty` where:-- type ScottyM = ScottyT IO- type ActionM = ActionT IO-- The new transformers are found in `Web.Scotty.Trans`. See the- `globalstate` example for use. Special thanks to Dan Frumin (co-dan)- for much of the legwork here.--* Added support for HTTP PATCH method.--* Removed lambda action syntax. This will return when we have a better- story for typesafe routes.--* `reqHeader :: Text -> ActionM Text` ==> - `reqHeader :: Text -> ActionM (Maybe Text)`--* New `raw` method to set body to a raw `ByteString`--* Parse error thrown by `jsonData` now includes the body it couldn't parse.--* `header` split into `setHeader` and `addHeader`. The former replaces- a response header (original behavior). The latter adds a header (useful- for multiple `Set-Cookie`s, for instance).
Web/Scotty.hs view
@@ -1,71 +1,142 @@-{-# LANGUAGE OverloadedStrings, RankNTypes #-}+{-# LANGUAGE RankNTypes #-} -- | It should be noted that most of the code snippets below depend on the -- OverloadedStrings language pragma.+--+-- Scotty is set up by default for development mode. For production servers,+-- you will likely want to modify 'Trans.settings' and the 'defaultHandler'. See+-- the comments on each of these functions for more information.+--+-- Please refer to the @examples@ directory and the @spec@ test suite for concrete use cases, e.g. constructing responses, exception handling and useful implementation details. module Web.Scotty- ( -- * scotty-to-WAI- scotty, scottyApp, scottyOpts, Options(..)+ ( -- * Running 'scotty' servers+ scotty+ , scottyOpts+ , scottySocket+ , Options(..), defaultOptions+ -- ** scotty-to-WAI+ , scottyApp -- * 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, addroute, matchAny, notFound+ , 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, reqHeader, body, param, params, jsonData, files- -- ** Modifying the Response and Redirecting- , status, addHeader, setHeader, redirect+ -- ** Accessing the Request and its fields+ , request, header, headers, body, bodyReader+ , jsonData, formData+ -- ** Accessing Path, Form and Query Parameters+ , pathParam, captureParam, formParam, queryParam+ , pathParamMaybe, captureParamMaybe, formParamMaybe, queryParamMaybe+ , pathParams, captureParams, formParams, queryParams+ -- *** Files+ , files, filesOpts+ -- ** Modifying the Response+ , status, addHeader, setHeader+ -- ** Redirecting+ , redirect, redirect300, redirect301, redirect302, redirect303, redirect304, redirect307, redirect308 -- ** 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, source, raw+ , text, html, file, json, stream, raw+ -- ** Accessing the fields of the Response+ , getResponseHeaders, getResponseStatus, getResponseContent -- ** Exceptions- , raise, rescue, next, defaultHandler+ , throw, next, finish, defaultHandler+ , liftIO, catch+ , ScottyException(..) -- * Parsing Parameters , Param, Trans.Parsable(..), Trans.readEither -- * Types- , ScottyM, ActionM, RoutePattern, File+ , ScottyM, ActionM, RoutePattern, File, Content(..), Kilobytes, ErrorHandler, Handler(..)+ , ScottyState, defaultScottyState+ -- ** Cookie functions+ , setCookie, setSimpleCookie, getCookie, getCookies, deleteCookie, Cookie.makeSimpleCookie+ -- ** Session Management+ , Session (..), SessionId, SessionJar, SessionStatus+ , createSessionJar, createUserSession, createSession, addSession+ , readSession, getUserSession, getSession, readUserSession+ , deleteSession, maintainSessions ) where --- With the exception of this, everything else better just import types. import qualified Web.Scotty.Trans as Trans -import Blaze.ByteString.Builder (Builder)-+import qualified Control.Exception as E+import Control.Monad.IO.Class import Data.Aeson (FromJSON, ToJSON)+import qualified Data.ByteString as BS import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Conduit (Flush, Source)-import Data.Text.Lazy (Text)+import Data.Text.Lazy (Text, toStrict)+import qualified Data.Text as T -import Network.HTTP.Types (Status, StdMethod)-import Network.Wai (Application, Middleware, Request)+import Network.HTTP.Types (Status, StdMethod, ResponseHeaders)+import Network.Socket (Socket)+import Network.Wai (Application, Middleware, Request, StreamingBody) import Network.Wai.Handler.Warp (Port)+import qualified Network.Wai.Parse as W -import Web.Scotty.Types (ScottyT, ActionT, Param, RoutePattern, Options, File)+import Web.FormUrlEncoded (FromForm)+import Web.Scotty.Internal.Types (ScottyT, ActionT, ErrorHandler, Param, RoutePattern, Options, defaultOptions, File, Kilobytes, ScottyState, defaultScottyState, ScottyException, Content(..))+import UnliftIO.Exception (Handler(..), catch)+import qualified Web.Scotty.Cookie as Cookie +import Web.Scotty.Session (Session (..), SessionId, SessionJar, SessionStatus , createSessionJar,+ createSession, addSession, maintainSessions) -type ScottyM = ScottyT Text IO-type ActionM = ActionT Text IO +{- $setup+>>> :{+import Control.Monad.IO.Class (MonadIO(..))+import qualified Network.HTTP.Client as H+import qualified Network.HTTP.Types as H+import qualified Network.Wai as W (httpVersion)+import qualified Data.ByteString.Lazy.Char8 as LBS (unpack)+import qualified Data.Text as T (pack)+import Control.Concurrent (ThreadId, forkIO, killThread)+import Control.Exception (bracket)+import qualified Web.Scotty as S (ScottyM, scottyOpts, get, text, regex, pathParam, Options(..), defaultOptions)+-- | GET an HTTP path+curl :: MonadIO m =>+ String -- ^ path+ -> m String -- ^ response body+curl path = liftIO $ do+ req0 <- H.parseRequest path+ let req = req0 { H.method = "GET"}+ mgr <- H.newManager H.defaultManagerSettings+ (LBS.unpack . H.responseBody) <$> H.httpLbs req mgr+-- | Fork a process, run a Scotty server in it and run an action while the server is running. Kills the scotty thread once the inner action is done.+withScotty :: S.ScottyM ()+ -> IO a -- ^ inner action, e.g. 'curl "localhost:3000/"'+ -> IO a+withScotty serv act = bracket (forkIO $ S.scottyOpts (S.defaultOptions{ S.verbose = 0 }) serv) killThread (\_ -> act)+:}+-} +type ScottyM = ScottyT IO+type ActionM = ActionT IO+ -- | Run a scotty application using the warp server. scotty :: Port -> ScottyM () -> IO ()-scotty p = Trans.scottyT p id id+scotty p = Trans.scottyT p id -- | Run a scotty application using the warp server, passing extra options. scottyOpts :: Options -> ScottyM () -> IO ()-scottyOpts opts = Trans.scottyOptsT opts id id+scottyOpts opts = Trans.scottyOptsT opts id +-- | Run a scotty application using the warp server, passing extra options,+-- and listening on the provided socket. This allows the user to provide, for+-- example, a Unix named socket, which can be used when reverse HTTP proxying+-- into your application.+scottySocket :: Options -> Socket -> ScottyM () -> IO ()+scottySocket opts sock = Trans.scottySocketT opts sock id+ -- | Turn a scotty application into a WAI 'Application', which can be -- run with any WAI handler. scottyApp :: ScottyM () -> IO Application-scottyApp = Trans.scottyAppT id id+scottyApp = Trans.scottyAppT defaultOptions id --- | Global handler for uncaught exceptions. ------ Uncaught exceptions normally become 500 responses. --- You can use this to selectively override that behavior.-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@@ -74,36 +145,67 @@ middleware :: Middleware -> ScottyM () middleware = Trans.middleware --- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions--- turn into HTTP 500 responses.-raise :: Text -> ActionM a-raise = Trans.raise+-- | 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 within the scope of the current Action with '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 <- pathParam "bar" -- > unless (w == "special") next -- > text "You made a request to /foo/special" -- > -- > get "/foo/:baz" $ do--- > w <- param "baz"+-- > w <- pathParam "baz" -- > text $ "You made a request to: " <> w-next :: ActionM a+next :: ActionM () next = Trans.next --- | Catch an exception thrown by 'raise'.+-- | Abort execution of this action. Like an exception, any code after 'finish'+-- is not executed. ----- > raise "just kidding" `rescue` (\msg -> text msg)-rescue :: ActionM a -> (Text -> ActionM a) -> ActionM a-rescue = Trans.rescue+-- As an example only requests to @\/foo\/special@ will include in the response+-- content the text message.+--+-- > get "/foo/:bar" $ do+-- > w :: Text <- pathParam "bar"+-- > unless (w == "special") finish+-- > text "You made a request to /foo/special"+--+-- /Since: 0.10.3/+finish :: ActionM a+finish = Trans.finish --- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect--- will not be run.+-- | Synonym for 'redirect302'.+-- If you are unsure which redirect to use, you probably want this one. -- -- > redirect "http://www.google.com" --@@ -113,40 +215,180 @@ redirect :: Text -> ActionM a redirect = Trans.redirect +-- | Redirect to given URL with status 300 (Multiple Choices). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect300 :: Text -> ActionM a+redirect300 = Trans.redirect300++-- | Redirect to given URL with status 301 (Moved Permanently). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect301 :: Text -> ActionM a+redirect301 = Trans.redirect301++-- | Redirect to given URL with status 302 (Found). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect302 :: Text -> ActionM a+redirect302 = Trans.redirect302++-- | Redirect to given URL with status 303 (See Other). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect303 :: Text -> ActionM a+redirect303 = Trans.redirect303++-- | Redirect to given URL with status 304 (Not Modified). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect304 :: Text -> ActionM a+redirect304 = Trans.redirect304++-- | Redirect to given URL with status 307 (Temporary Redirect). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect307 :: Text -> ActionM a+redirect307 = Trans.redirect307++-- | Redirect to given URL with status 308 (Permanent Redirect). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect308 :: Text -> ActionM a+redirect308 = Trans.redirect308+ -- | Get the 'Request' object. request :: ActionM Request request = Trans.request -- | Get list of uploaded files.-files :: ActionM [File]+--+-- NB: Loads all file contents in memory with options 'W.defaultParseRequestBodyOptions'+files :: ActionM [File ByteString] files = Trans.files +-- | Get list of temp files and form parameters decoded from multipart payloads.+--+-- NB the temp files are deleted when the continuation exits+filesOpts :: W.ParseRequestBodyOptions+ -> ([Param] -> [File FilePath] -> ActionM a) -- ^ temp files validation, storage etc+ -> ActionM a+filesOpts = Trans.filesOpts+ -- | Get a request header. Header name is case-insensitive.-reqHeader :: Text -> ActionM (Maybe Text)-reqHeader = Trans.reqHeader+header :: Text -> ActionM (Maybe Text)+header = Trans.header +-- | Get all the request headers. Header names are case-insensitive.+headers :: ActionM [(Text, Text)]+headers = Trans.headers+ -- | Get the request body.+--+-- NB: loads the entire request body in memory body :: ActionM ByteString body = Trans.body +-- | Get an IO action that reads body chunks+--+-- * This is incompatible with 'body' since 'body' consumes all chunks.+bodyReader :: ActionM (IO BS.ByteString)+bodyReader = Trans.bodyReader+ -- | Parse the request body as a JSON object and return it. Raises an exception if parse is unsuccessful.+--+-- NB: uses 'body' internally jsonData :: FromJSON a => ActionM a jsonData = Trans.jsonData --- | Get a parameter. First looks in captures, then form data, then query parameters.+-- | Parse the request body as @x-www-form-urlencoded@ form data and return it. Raises an exception if parse is unsuccessful. ----- * Raises an exception which can be caught by 'rescue' if parameter is not found.+-- NB: uses 'body' internally+formData :: FromForm a => ActionM a+formData = Trans.formData++-- | Synonym for 'pathParam' ----- * If parameter is found, but 'read' 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+-- /Since: 0.20/+captureParam :: Trans.Parsable a => Text -> ActionM a+captureParam = Trans.captureParam . toStrict --- | Get all parameters from capture, form and query (in that order).-params :: ActionM [Param]-params = Trans.params+-- | Get a path parameter.+--+-- * Raises an exception which can be caught by 'catch' 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.+--+-- /Since: 0.21/+pathParam :: Trans.Parsable a => Text -> ActionM a+pathParam = Trans.pathParam . toStrict +-- | Get a form parameter.+--+-- * Raises an exception which can be caught by 'catch' 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.+--+-- /Since: 0.20/+formParam :: Trans.Parsable a => Text -> ActionM a+formParam = Trans.formParam . toStrict++-- | Get a query parameter.+--+-- * Raises an exception which can be caught by 'catch' 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.+--+-- /Since: 0.20/+queryParam :: Trans.Parsable a => Text -> ActionM a+queryParam = Trans.queryParam . toStrict+++-- | Look up a path parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.+--+-- NB : Doesn't throw exceptions. In particular, route pattern matching will not continue, so developers+-- must 'raiseStatus' or 'throw' to signal something went wrong.+--+-- /Since: 0.21/+pathParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a)+pathParamMaybe = Trans.pathParamMaybe . toStrict++-- | Synonym for 'pathParamMaybe'+--+-- /Since: 0.21/+captureParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a)+captureParamMaybe = Trans.pathParamMaybe . toStrict++-- | Look up a form parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.+--+-- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong.+--+-- /Since: 0.21/+formParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a)+formParamMaybe = Trans.formParamMaybe . toStrict++-- | Look up a query parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.+--+-- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong.+--+-- /Since: 0.21/+queryParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a)+queryParamMaybe = Trans.queryParamMaybe . toStrict++-- | Synonym for 'pathParams'+captureParams :: ActionM [Param]+captureParams = Trans.captureParams+-- | Get path parameters+pathParams :: ActionM [Param]+pathParams = Trans.pathParams+-- | 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 () status = Trans.status@@ -161,12 +403,12 @@ setHeader = Trans.setHeader -- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\"--- header to \"text/plain\".+-- header to \"text/plain; charset=utf-8\" if it has not already been set. text :: Text -> ActionM () text = Trans.text -- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\"--- header to \"text/html\".+-- header to \"text/html; charset=utf-8\" if it has not already been set. html :: Text -> ActionM () html = Trans.html @@ -176,21 +418,39 @@ file = Trans.file -- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\"--- header to \"application/json\".+-- header to \"application/json; charset=utf-8\" if it has not already been set. json :: ToJSON a => a -> ActionM () json = Trans.json --- | Set the body of the response to a Source. Doesn't set the+-- | Set the body of the response to a StreamingBody. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'setHeader'.-source :: Source IO (Flush Builder) -> ActionM ()-source = Trans.source+stream :: StreamingBody -> ActionM ()+stream = Trans.stream -- | 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 :: ByteString -> ActionM () raw = Trans.raw ++-- | Access the HTTP 'Status' of the Response+--+-- /Since: 0.21/+getResponseStatus :: ActionM Status+getResponseStatus = Trans.getResponseStatus+-- | Access the HTTP headers of the Response+--+-- /Since: 0.21/+getResponseHeaders :: ActionM ResponseHeaders+getResponseHeaders = Trans.getResponseHeaders+-- | Access the content of the Response+--+-- /Since: 0.21/+getResponseContent :: ActionM Content+getResponseContent = Trans.getResponseContent++ -- | get = 'addroute' 'GET' get :: RoutePattern -> ActionM () -> ScottyM () get = Trans.get@@ -211,6 +471,10 @@ patch :: RoutePattern -> ActionM () -> ScottyM () patch = Trans.patch +-- | options = 'addroute' 'OPTIONS'+options :: RoutePattern -> ActionM () -> ScottyM ()+options = Trans.options+ -- | Add a route that matches regardless of the HTTP verb. matchAny :: RoutePattern -> ActionM () -> ScottyM () matchAny = Trans.matchAny@@ -220,35 +484,37 @@ notFound :: ActionM () -> ScottyM () notFound = Trans.notFound --- | Define a route with a 'StdMethod', 'Text' value representing the path spec,--- and a body ('Action') which modifies the response.------ > 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'.------ > addroute GET "/foo/:bar" $ do--- > v <- param "bar"--- > text v------ >>> curl http://localhost:3000/foo/something--- something+{- | Define a route with a 'StdMethod', a route pattern representing the path spec,+and an 'Action' which may modify the response.++> get "/" $ text "beam me up!"++The path spec can include values starting with a colon, which are interpreted+as /captures/. These are parameters that can be looked up with 'pathParam'.++>>> :{+let server = S.get "/foo/:bar" (S.pathParam "bar" >>= S.text)+ in do+ withScotty server $ curl "http://localhost:3000/foo/something"+:}+"something"+-} addroute :: StdMethod -> RoutePattern -> ActionM () -> ScottyM () addroute = Trans.addroute --- | Match requests using a regular expression.--- Named captures are not yet supported.------ > get (regex "^/f(.*)r$") $ do--- > path <- param "0"--- > cap <- param "1"--- > text $ mconcat ["Path: ", path, "\nCapture: ", cap]------ >>> curl http://localhost:3000/foo/bar--- Path: /foo/bar--- Capture: oo/ba---++{- | Match requests using a regular expression.+Named captures are not yet supported.++>>> :{+let server = S.get (S.regex "^/f(.*)r$") $ do+ cap <- S.pathParam "1"+ S.text cap+ in do+ withScotty server $ curl "http://localhost:3000/foo/bar"+:}+"oo/ba"+-} regex :: String -> RoutePattern regex = Trans.regex @@ -267,21 +533,82 @@ capture :: String -> RoutePattern capture = Trans.capture --- | Build a route based on a function which can match using the entire 'Request' object.--- 'Nothing' indicates the route does not match. A 'Just' value indicates--- a successful match, optionally returning a list of key-value pairs accessible--- by 'param'.------ > get (function $ \req -> Just [("version", pack $ show $ httpVersion req)]) $ do--- > v <- param "version"--- > text v------ >>> curl http://localhost:3000/--- HTTP/1.1---++{- | Build a route based on a function which can match using the entire 'Request' object.+'Nothing' indicates the route does not match. A 'Just' value indicates+a successful match, optionally returning a list of key-value pairs accessible by 'param'.++>>> :{+let server = S.get (function $ \req -> Just [("version", T.pack $ show $ W.httpVersion req)]) $ do+ v <- S.pathParam "version"+ S.text v+ in do+ withScotty server $ curl "http://localhost:3000/"+:}+"HTTP/1.1"+-} function :: (Request -> Maybe [Param]) -> RoutePattern function = Trans.function -- | Build a route that requires the requested path match exactly, without captures. literal :: String -> RoutePattern literal = Trans.literal+++-- | Retrieves a session by its ID from the session jar.+getSession :: SessionJar a -> SessionId -> ActionM (Either SessionStatus (Session a))+getSession = Trans.getSession+ +-- | Deletes a session by its ID from the session jar.+deleteSession :: SessionJar a -> SessionId -> ActionM ()+deleteSession = Trans.deleteSession+ +{- | Retrieves the current user's session based on the "sess_id" cookie.+| Returns `Left SessionStatus` if the session is expired or does not exist.+-}+getUserSession :: SessionJar a -> ActionM (Either SessionStatus (Session a))+getUserSession = Trans.getUserSession++-- | Reads the content of a session by its ID.+readSession :: SessionJar a -> SessionId -> ActionM (Either SessionStatus a)+readSession = Trans.readSession++-- | Reads the content of the current user's session.+readUserSession ::SessionJar a -> ActionM (Either SessionStatus a)+readUserSession = Trans.readUserSession++-- | Creates a new session for a user, storing the content and setting a cookie.+createUserSession :: + SessionJar a -- ^ SessionJar, which can be created by createSessionJar+ -> Maybe Int -- ^ Optional expiration time (in seconds)+ -> a -- ^ Content+ -> ActionM (Session a)+createUserSession = Trans.createUserSession++-- Cookie functions++-- | Set a cookie, with full access to its options (see 'SetCookie')+setCookie :: Cookie.SetCookie -> ActionM ()+setCookie = Cookie.setCookie++-- | 'makeSimpleCookie' and 'setCookie' combined.+setSimpleCookie :: T.Text -- ^ name+ -> T.Text -- ^ value+ -> ActionM ()+setSimpleCookie = Cookie.setSimpleCookie++-- | Lookup one cookie name+getCookie :: T.Text -- ^ name+ -> ActionM (Maybe T.Text)+getCookie = Cookie.getCookie++-- | Returns all cookies+getCookies :: ActionM Cookie.CookiesText+getCookies = Cookie.getCookies++-- | 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 :: T.Text -- ^ name+ -> ActionM ()+deleteCookie = Cookie.deleteCookie
Web/Scotty/Action.hs view
@@ -1,250 +1,786 @@-{-# LANGUAGE OverloadedStrings, RankNTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# language ScopedTypeVariables #-} module Web.Scotty.Action ( addHeader , body+ , bodyReader , file+ , rawResponse , files+ , filesOpts+ , W.ParseRequestBodyOptions, W.defaultParseRequestBodyOptions+ , finish+ , header+ , headers , html+ , htmlLazy , json , jsonData+ , formData , next- , param- , params- , raise+ , pathParam+ , captureParam+ , formParam+ , queryParam+ , pathParamMaybe+ , captureParamMaybe+ , formParamMaybe+ , queryParamMaybe+ , pathParams+ , captureParams+ , formParams+ , queryParams+ , throw , raw+ , nested , readEither , redirect- , reqHeader+ , redirect300+ , redirect301+ , redirect302+ , redirect303+ , redirect304+ , redirect307+ , redirect308 , request- , rescue , setHeader- , source , status+ , stream , text+ , textLazy+ , getResponseStatus+ , getResponseHeaders+ , getResponseContent , Param , Parsable(..)+ , ActionT -- private to Scotty , runAction ) where -import Blaze.ByteString.Builder (Builder, fromLazyByteString)+import Blaze.ByteString.Builder (fromLazyByteString) -import Control.Monad.Error-import Control.Monad.Reader-import qualified Control.Monad.State as MS+import qualified Control.Exception as E+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO(..))+import UnliftIO (MonadUnliftIO(..))+import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)+import Control.Monad.Trans.Resource (withInternalState, runResourceT) -import qualified Data.Aeson as A-import qualified Data.ByteString.Char8 as B+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.Conduit (Flush, Source)-import Data.Default (def)-import Data.Monoid (mconcat)-import qualified Data.Text as ST-import qualified Data.Text.Lazy as T-import Data.Text.Lazy.Encoding (encodeUtf8)+import qualified Data.CaseInsensitive as CI+import Data.Traversable (for)+import qualified Data.Map.Strict as Map+import qualified Data.HashMap.Strict as HM+import Data.Int+import Data.List (foldl')+import Data.Maybe (maybeToList)+import qualified Data.Text as T+import Data.Text.Encoding as STE+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE+import Data.Time (UTCTime)+import Data.Time.Format (parseTimeM, defaultTimeLocale)+import Data.Typeable (typeOf)+import Data.Word -import Network.HTTP.Types-import Network.Wai+import Network.HTTP.Types+-- not re-exported until version 0.11+#if !MIN_VERSION_http_types(0,11,0)+import Network.HTTP.Types.Status+#endif+import Network.Wai (Request, Response, StreamingBody, Application, requestHeaders)+import Network.Wai.Handler.Warp (InvalidRequest(..))+import qualified Network.Wai.Parse as W (FileInfo(..), ParseRequestBodyOptions, defaultParseRequestBodyOptions) -import Web.Scotty.Types-import Web.Scotty.Util+import Numeric.Natural --- 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- $ runErrorT- $ runAM- $ action `catchError` (defH h)- return $ either (const Nothing) (const $ Just $ mkResponse r) e+import Web.FormUrlEncoded (Form(..), FromForm(..))+import Web.Scotty.Internal.Types+import Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, decodeUtf8Lenient)+import UnliftIO.Exception (Handler(..), catches, throwIO)+import System.IO (hPutStrLn, stderr) --- | 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+import Network.Wai.Internal (ResponseReceived(..))+++-- | 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 =>+ Options+ -> Maybe (ErrorHandler m) -- ^ this handler (if present) is in charge of user-defined exceptions+ -> ActionEnv+ -> ActionT m () -- ^ Route action to be evaluated+ -> m (Maybe Response)+runAction options mh env action = do+ ok <- flip runReaderT env $ runAM $ tryNext $ action `catches` concat+ [ [actionErrorHandler]+ , maybeToList mh+ , [scottyExceptionHandler options, someExceptionHandler options]+ ]+ res <- getResponse env+ return $ bool Nothing (Just $ mkResponse res) ok++-- | 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 s url -> do+ status s setHeader "Location" url-defH Nothing (ActionError e) = do+ AENext -> next+ AEFinish -> return ()++-- | Default handler for exceptions from scotty+scottyExceptionHandler :: MonadIO m => Options -> ErrorHandler m+scottyExceptionHandler Options{jsonMode} = Handler $ \case+ RequestTooLarge -> do+ status status413+ if jsonMode+ then json $ A.object ["status" A..= (413 :: Int), "description" A..= ("Request body is too large" :: T.Text)]+ else text "Request body is too large"+ MalformedJSON bs err -> do+ status status400+ if jsonMode+ then json $ A.object+ [ "status" A..= (400 :: Int)+ , "description" A..= ("jsonData: malformed" :: T.Text)+ , "body" A..= decodeUtf8Lenient (BL.toStrict bs)+ , "error" A..= err+ ]+ else raw $ BL.unlines+ [ "jsonData: malformed"+ , "Body: " <> bs+ , "Error: " <> BL.fromStrict (encodeUtf8 err)+ ]+ FailedToParseJSON bs err -> do+ status status422+ if jsonMode+ then json $ A.object+ [ "status" A..= (422 :: Int)+ , "description" A..= ("jsonData: failed to parse" :: T.Text)+ , "body" A..= decodeUtf8Lenient (BL.toStrict bs)+ , "error" A..= err+ ]+ else raw $ BL.unlines+ [ "jsonData: failed to parse"+ , "Body: " <> bs+ , "Error: " <> BL.fromStrict (encodeUtf8 err)+ ]+ MalformedForm err -> do+ status status400+ if jsonMode+ then json $ A.object+ [ "status" A..= (400 :: Int)+ , "description" A..= ("formData: malformed" :: T.Text)+ , "error" A..= err+ ]+ else raw $ BL.unlines+ [ "formData: malformed"+ , "Error: " <> BL.fromStrict (encodeUtf8 err)+ ]+ PathParameterNotFound k -> do status status500- html $ mconcat ["<h1>500 Internal Server Error</h1>", showError e]-defH h@(Just f) (ActionError e) = f e `catchError` (defH h) -- so handlers can throw exceptions themselves-defH _ Next = next+ if jsonMode+ then json $ A.object+ [ "status" A..= (500 :: Int)+ , "description" A..= T.unwords [ "Path parameter", k, "not found"]+ ]+ else text $ T.unwords [ "Path parameter", k, "not found"]+ QueryParameterNotFound k -> do+ status status400+ if jsonMode+ then json $ A.object+ [ "status" A..= (400 :: Int)+ , "description" A..= T.unwords [ "Query parameter", k, "not found"]+ ]+ else text $ T.unwords [ "Query parameter", k, "not found"]+ FormFieldNotFound k -> do+ status status400+ if jsonMode+ then json $ A.object+ [ "status" A..= (400 :: Int)+ , "description" A..= T.unwords [ "Form field", k, "not found"]+ ]+ else text $ T.unwords [ "Form field", k, "not found"]+ FailedToParseParameter k v e -> do+ status status400+ if jsonMode+ then json $ A.object+ [ "status" A..= (400 :: Int)+ , "description" A..= T.unwords [ "Failed to parse parameter", k, v, ":", e]+ ]+ else text $ T.unwords [ "Failed to parse parameter", k, v, ":", e]+ WarpRequestException we -> case we of+ RequestHeaderFieldsTooLarge -> do+ status status413+ if jsonMode+ then json $ A.object+ [ "status" A..= (413 :: Int)+ , "description" A..= ("Request header fields too large" :: T.Text)+ ]+ else text "Request header fields too large"+ weo -> do -- FIXME fall-through case on InvalidRequest, it would be nice to return more specific error messages and codes here+ status status400+ if jsonMode+ then json $ A.object+ [ "status" A..= (400 :: Int)+ , "description" A..= T.unwords ["Request Exception:", T.pack (show weo)]+ ]+ else text $ T.unwords ["Request Exception:", T.pack (show weo)]+ WaiRequestParseException we -> do+ status status413 -- 413 Content Too Large https://developer.mozilla.org/en-US/docs/Web/HTTP/Status/413+ if jsonMode+ then json $ A.object+ [ "status" A..= (413 :: Int)+ , "description" A..= T.unwords ["wai-extra Exception:", T.pack (show we)]+ ]+ else text $ T.unwords ["wai-extra Exception:", T.pack (show we)]+ ResourceTException rte -> do+ status status500+ if jsonMode+ then json $ A.object+ [ "status" A..= (500 :: Int)+ , "description" A..= T.unwords ["resourcet Exception:", T.pack (show rte)]+ ]+ else text $ T.unwords ["resourcet Exception:", T.pack (show rte)] --- | 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 = throwError . ActionError+-- | Uncaught exceptions turn into HTTP 500 Server Error codes+someExceptionHandler :: MonadIO m => Options -> ErrorHandler m+someExceptionHandler Options{verbose, jsonMode} =+ Handler $ \(E.SomeException e) -> do+ when (verbose > 0) $+ liftIO $+ hPutStrLn stderr $+ "Unhandled exception of " <> show (typeOf e) <> ": " <> show e+ status status500+ if jsonMode+ then json $ A.object+ [ "status" A..= (500 :: Int)+ , "description" A..= ("Internal Server Error" :: T.Text)+ ]+ else text "Internal Server Error" +-- | Throw an exception which can be caught within the scope of the current Action with '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 <- pathParam "bar" -- > unless (w == "special") next -- > text "You made a request to /foo/special" -- > -- > get "/foo/:baz" $ do--- > w <- param "baz"+-- > w <- pathParam "baz" -- > text $ "You made a request to: " <> w-next :: (ScottyError e, Monad m) => ActionT e m a-next = throwError Next---- | Catch an exception thrown by 'raise'.------ > 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+next :: Monad m => ActionT m a+next = E.throw AENext --- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect--- will not be run.+-- | Synonym for 'redirect302'.+-- If you are unsure which redirect to use, you probably want this one. -- -- > redirect "http://www.google.com" -- -- 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 = redirect302 +-- | Redirect to given URL with status 300 (Multiple Choices). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect300 :: (Monad m) => T.Text -> ActionT m a+redirect300 = redirectStatus status300++-- | Redirect to given URL with status 301 (Moved Permanently). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect301 :: (Monad m) => T.Text -> ActionT m a+redirect301 = redirectStatus status301++-- | Redirect to given URL with status 302 (Found). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect302 :: (Monad m) => T.Text -> ActionT m a+redirect302 = redirectStatus status302++-- | Redirect to given URL with status 303 (See Other). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect303 :: (Monad m) => T.Text -> ActionT m a+redirect303 = redirectStatus status303++-- | Redirect to given URL with status 304 (Not Modified). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect304 :: (Monad m) => T.Text -> ActionT m a+redirect304 = redirectStatus status304++-- | Redirect to given URL with status 307 (Temporary Redirect). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect307 :: (Monad m) => T.Text -> ActionT m a+redirect307 = redirectStatus status307++-- | Redirect to given URL with status 308 (Permanent Redirect). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect308 :: (Monad m) => T.Text -> ActionT m a+redirect308 = redirectStatus status308++redirectStatus :: (Monad m) => Status -> T.Text -> ActionT m a+redirectStatus s = E.throw . AERedirect s++-- | 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 :: (Monad m) => ActionT m a+finish = E.throw AEFinish+ -- | Get the 'Request' object.-request :: (ScottyError e, 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 :: (ScottyError e, Monad m) => ActionT e m [File]-files = ActionT $ liftM getFiles ask+--+-- NB: Loads all file contents in memory with options 'W.defaultParseRequestBodyOptions'+files :: MonadUnliftIO m => ActionT m [File BL.ByteString]+files = runResourceT $ withInternalState $ \istate -> do+ (_, fs) <- formParamsAndFilesWith istate W.defaultParseRequestBodyOptions+ for fs (\(fname, f) -> do+ bs <- liftIO $ BL.readFile (W.fileContent f)+ pure (fname, f{ W.fileContent = bs})+ ) ++-- | Get list of uploaded temp files and form parameters decoded from multipart payloads.+--+-- NB the temp files are deleted when the continuation exits.+filesOpts :: MonadUnliftIO m =>+ W.ParseRequestBodyOptions+ -> ([Param] -> [File FilePath] -> ActionT m a) -- ^ temp files validation, storage etc+ -> ActionT m a+filesOpts prbo io = runResourceT $ withInternalState $ \istate -> do+ (ps, fs) <- formParamsAndFilesWith istate prbo+ io ps fs+++ -- | Get a request header. Header name is case-insensitive.-reqHeader :: (ScottyError e, Monad m) => T.Text -> ActionT e m (Maybe T.Text)-reqHeader k = do- hs <- liftM requestHeaders request- return $ fmap strictByteStringToLazyText $ lookup (CI.mk (lazyTextToStrictByteString k)) hs+header :: (Monad m) => T.Text -> ActionT m (Maybe T.Text)+header k = do+ hs <- requestHeaders <$> request+ return $ fmap decodeUtf8Lenient $ lookup (CI.mk (encodeUtf8 k)) hs +-- | Get all the request headers. Header names are case-insensitive.+headers :: (Monad m) => ActionT m [(T.Text, T.Text)]+headers = do+ hs <- requestHeaders <$> request+ return [ ( decodeUtf8Lenient (CI.original k)+ , decodeUtf8Lenient v)+ | (k,v) <- hs ]+ -- | Get the request body.-body :: (ScottyError e, Monad m) => ActionT e m BL.ByteString-body = ActionT $ liftM getBody ask+--+-- NB This loads the whole request body in memory at once.+body :: (MonadIO m) => ActionT m BL.ByteString+body = ActionT ask >>= (liftIO . envBody) --- | Parse the request body as a JSON object and return it. Raises an exception if parse is unsuccessful.-jsonData :: (A.FromJSON a, ScottyError e, Monad m) => ActionT e m a+-- | Get an IO action that reads body chunks+--+-- * This is incompatible with 'body' since 'body' consumes all chunks.+bodyReader :: Monad m => ActionT m (IO B.ByteString)+bodyReader = ActionT $ envBodyChunk <$> ask++-- | Parse the request body as a JSON object and return it.+--+-- If the JSON object is malformed, this sets the status to+-- 400 Bad Request, and throws an exception.+--+-- If the JSON fails to parse, this sets the status to+-- 422 Unprocessable Entity.+--+-- These status codes are as per https://www.restapitutorial.com/httpstatuscodes.html.+--+-- NB : Internally this uses 'body'.+jsonData :: (A.FromJSON a, MonadIO m) => ActionT m a jsonData = do b <- body- maybe (raise $ stringError $ "jsonData - no parse: " ++ BL.unpack b) return $ A.decode b+ when (b == "") $ throwIO $ MalformedJSON b "no data"+ case A.eitherDecode b of+ Left err -> throwIO $ MalformedJSON b $ T.pack err+ Right value -> case A.fromJSON value of+ A.Error err -> throwIO $ FailedToParseJSON b $ T.pack err+ A.Success a -> return a --- | Get a parameter. First looks in captures, then form data, then query parameters.+-- | Parse the request body as @x-www-form-urlencoded@ form data and return it. ----- * Raises an exception which can be caught by 'rescue' if parameter is not found.+-- The form is parsed using 'urlDecodeAsForm'. If that returns 'Left', the+-- status is set to 400 and an exception is thrown.+formData :: (FromForm a, MonadUnliftIO m) => ActionT m a+formData = do+ form <- paramListToForm <$> formParams+ case fromForm form of+ Left err -> throwIO $ MalformedForm err+ Right value -> return value+ where+ -- This rather contrived implementation uses cons and reverse to avoid+ -- quadratic complexity when constructing a Form from a list of Param.+ -- It's equivalent to using HashMap.insertWith (++) which does have+ -- quadratic complexity due to appending at the end of list.+ paramListToForm :: [Param] -> Form+ paramListToForm = Form . fmap reverse . foldl' (\f (k, v) -> HM.alter (prependValue v) k f) HM.empty++ prependValue :: a -> Maybe [a] -> Maybe [a]+ prependValue v = Just . maybe [v] (v :)++-- | Synonym for 'pathParam'+captureParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a+captureParam = pathParam++-- | Look up a path parameter. ----- * If parameter is found, but 'read' 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 k = do- val <- ActionT $ liftM (lookup k . getParams) ask+-- * Raises an exception which can be caught by 'catch' 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.+--+-- /Since: 0.20/+pathParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a+pathParam k = do+ val <- ActionT $ lookup k . envPathParams <$> ask+ case val of+ Nothing -> throwIO $ PathParameterNotFound k+ Just v -> case parseParam $ TL.fromStrict v of+ Left _ -> next+ Right a -> pure a++-- | Look up a form parameter.+--+-- * Raises an exception which can be caught by 'catch' 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.+--+-- /Since: 0.20/+formParam :: (MonadUnliftIO m, Parsable b) => T.Text -> ActionT m b+formParam k = runResourceT $ withInternalState $ \istate -> do+ (ps, _) <- formParamsAndFilesWith istate W.defaultParseRequestBodyOptions+ case lookup k ps of+ Nothing -> throwIO $ FormFieldNotFound k+ Just v -> case parseParam $ TL.fromStrict v of+ Left e -> throwIO $ FailedToParseParameter k v (TL.toStrict e)+ Right a -> pure a++-- | Look up a query parameter.+--+-- * Raises an exception which can be caught by 'catch' 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.+--+-- /Since: 0.20/+queryParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a+queryParam = paramWith QueryParameterNotFound envQueryParams++-- | Look up a path parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.+--+-- NB : Doesn't throw exceptions. In particular, route pattern matching will not continue, so developers+-- must 'raiseStatus' or 'throw' to signal something went wrong.+--+-- /Since: 0.21/+pathParamMaybe :: (Parsable a, Monad m) => T.Text -> ActionT m (Maybe a)+pathParamMaybe = paramWithMaybe envPathParams++-- | Look up a capture parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.+--+-- NB : Doesn't throw exceptions. In particular, route pattern matching will not continue, so developers+-- must 'raiseStatus' or 'throw' to signal something went wrong.+--+-- /Since: 0.21/+captureParamMaybe :: (Parsable a, Monad m) => T.Text -> ActionT m (Maybe a)+captureParamMaybe = paramWithMaybe envPathParams++-- | Look up a form parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.+--+-- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong.+--+-- /Since: 0.21/+formParamMaybe :: (MonadUnliftIO m, Parsable a) =>+ T.Text -> ActionT m (Maybe a)+formParamMaybe k = runResourceT $ withInternalState $ \istate -> do+ (ps, _) <- formParamsAndFilesWith istate W.defaultParseRequestBodyOptions+ case lookup k ps of+ Nothing -> pure Nothing+ Just v -> either (const $ pure Nothing) (pure . Just) $ parseParam $ TL.fromStrict v+++-- | Look up a query parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.+--+-- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong.+--+-- /Since: 0.21/+queryParamMaybe :: (Parsable a, Monad m) => T.Text -> ActionT m (Maybe a)+queryParamMaybe = paramWithMaybe envQueryParams++data ParamType = PathParam+ | FormParam+ | QueryParam+instance Show ParamType where+ show = \case+ PathParam -> "path"+ FormParam -> "form"+ QueryParam -> "query"++paramWith :: (MonadIO m, Parsable b) =>+ (T.Text -> ScottyException)+ -> (ActionEnv -> [Param])+ -> T.Text -- ^ parameter name+ -> ActionT m b+paramWith toError f k = do+ val <- ActionT $ (lookup k . f) <$> ask case val of- Nothing -> raise $ stringError $ "Param: " ++ T.unpack k ++ " not found!"- Just v -> either (const next) return $ parseParam v+ Nothing -> throwIO $ toError k+ Just v -> case parseParam $ TL.fromStrict v of+ Left e -> throwIO $ FailedToParseParameter k v (TL.toStrict e)+ Right a -> pure a --- | Get all parameters from capture, form and query (in that order).-params :: (ScottyError e, Monad m) => ActionT e m [Param]-params = ActionT $ liftM getParams ask+-- | Look up a parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.+--+-- NB : Doesn't throw exceptions.+--+-- /Since: 0.21/+paramWithMaybe :: (Monad m, Parsable b) =>+ (ActionEnv -> [Param])+ -> T.Text -- ^ parameter name+ -> ActionT m (Maybe b)+paramWithMaybe f k = do+ val <- ActionT $ asks (lookup k . f)+ case val of+ Nothing -> pure Nothing+ Just v -> either (const $ pure Nothing) (pure . Just) $ parseParam $ TL.fromStrict v +-- | Get path parameters+pathParams :: Monad m => ActionT m [Param]+pathParams = paramsWith envPathParams++-- | Get path parameters+captureParams :: Monad m => ActionT m [Param]+captureParams = paramsWith envPathParams++-- | Get form parameters+formParams :: MonadUnliftIO m => ActionT m [Param]+formParams = runResourceT $ withInternalState $ \istate -> do+ fst <$> formParamsAndFilesWith istate W.defaultParseRequestBodyOptions++-- | Get query parameters+queryParams :: Monad m => ActionT m [Param]+queryParams = paramsWith envQueryParams++paramsWith :: Monad m => (ActionEnv -> a) -> ActionT m a+paramsWith f = ActionT (asks f)++-- === access the fields of the Response being constructed++-- | Access the HTTP 'Status' of the Response+--+-- /SINCE 0.21/+getResponseStatus :: (MonadIO m) => ActionT m Status+getResponseStatus = srStatus <$> getResponseAction+-- | Access the HTTP headers of the Response+--+-- /SINCE 0.21/+getResponseHeaders :: (MonadIO m) => ActionT m ResponseHeaders+getResponseHeaders = srHeaders <$> getResponseAction+-- | Access the content of the Response+--+-- /SINCE 0.21/+getResponseContent :: (MonadIO m) => ActionT m Content+getResponseContent = srContent <$> getResponseAction++ -- | Minimum implemention: 'parseParam' class Parsable a where -- | Take a 'T.Text' value and parse it as 'a', or fail with a message.- parseParam :: T.Text -> Either T.Text a+ parseParam :: TL.Text -> Either TL.Text a -- | Default implementation parses comma-delimited lists. -- -- > parseParamList t = mapM parseParam (T.split (== ',') t)- parseParamList :: T.Text -> Either T.Text [a]- parseParamList t = mapM parseParam (T.split (== ',') t)+ parseParamList :: TL.Text -> Either TL.Text [a]+ parseParamList t = mapM parseParam (TL.split (== ',') t) -- No point using 'read' for Text, ByteString, Char, and String.-instance Parsable T.Text where parseParam = Right-instance Parsable ST.Text where parseParam = Right . T.toStrict+instance Parsable T.Text where parseParam = Right . TL.toStrict+instance Parsable TL.Text where parseParam = Right instance Parsable B.ByteString where parseParam = Right . lazyTextToStrictByteString+instance Parsable BL.ByteString where parseParam = Right . TLE.encodeUtf8 -- | Overrides default 'parseParamList' to parse String. instance Parsable Char where- parseParam t = case T.unpack t of+ parseParam t = case TL.unpack t of [c] -> Right c _ -> Left "parseParam Char: no parse"- parseParamList = Right . T.unpack -- String+ parseParamList = Right . TL.unpack -- String -- | Checks if parameter is present and is null-valued, not a literal '()'. -- If the URI requested is: '/foo?bar=()&baz' then 'baz' will parse as (), where 'bar' will not. instance Parsable () where- parseParam t = if T.null t then Right () else Left "parseParam Unit: no parse"+ parseParam t = if TL.null t then Right () else Left "parseParam Unit: no parse" instance (Parsable a) => Parsable [a] where parseParam = parseParamList -instance Parsable Bool where parseParam = readEither+instance Parsable Bool where+ parseParam t = if t' == TL.toCaseFold "true" || t' == TL.toCaseFold "on"+ then Right True+ else if t' == TL.toCaseFold "false"+ then Right False+ else Left "parseParam Bool: no parse"+ where t' = TL.toCaseFold t+ instance Parsable Double where parseParam = readEither instance Parsable Float where parseParam = readEither+ instance Parsable Int where parseParam = readEither+instance Parsable Int8 where parseParam = readEither+instance Parsable Int16 where parseParam = readEither+instance Parsable Int32 where parseParam = readEither+instance Parsable Int64 where parseParam = readEither instance Parsable Integer where parseParam = readEither +instance Parsable Word where parseParam = readEither+instance Parsable Word8 where parseParam = readEither+instance Parsable Word16 where parseParam = readEither+instance Parsable Word32 where parseParam = readEither+instance Parsable Word64 where parseParam = readEither+instance Parsable Natural where parseParam = readEither++-- | parse a UTCTime timestamp formatted as a ISO 8601 timestamp:+--+-- @yyyy-mm-ddThh:mm:ssZ@ , where the seconds can have a decimal part with up to 12 digits and no trailing zeros.+instance Parsable UTCTime where+ parseParam t =+ let+ fmt = "%FT%T%QZ"+ in+ case parseTimeM True defaultTimeLocale fmt (TL.unpack t) of+ Just d -> Right d+ _ -> Left $ "parseParam UTCTime: no parse of \"" <> t <> "\""+ -- | Useful for creating 'Parsable' instances for things that already implement 'Read'. Ex: -- -- > instance Parsable Int where parseParam = readEither-readEither :: (Read a) => T.Text -> Either T.Text a-readEither t = case [ x | (x,"") <- reads (T.unpack t) ] of+readEither :: Read a => TL.Text -> Either TL.Text a+readEither t = case [ x | (x,"") <- reads (TL.unpack t) ] of [x] -> Right x [] -> Left "readEither: no parse" _ -> Left "readEither: ambiguous parse" --- | Set the HTTP response status. Default is 200.-status :: (ScottyError e, 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 :: MonadIO m+ => (CI.CI B.ByteString -> B.ByteString -> [(HeaderName, B.ByteString)] -> [(HeaderName, B.ByteString)])+ -> T.Text -> T.Text -> ActionT m ()+changeHeader f k =+ modifyResponse . setHeaderWith . f (CI.mk $ encodeUtf8 k) . encodeUtf8+ -- | Add to the response headers. Header names are case-insensitive.-addHeader :: (ScottyError e, Monad m) => T.Text -> T.Text -> ActionT e m ()-addHeader k v = ActionT . MS.modify $ setHeaderWith $ add (CI.mk $ lazyTextToStrictByteString k) (lazyTextToStrictByteString v)+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 :: (ScottyError e, Monad m) => T.Text -> T.Text -> ActionT e m ()-setHeader k v = ActionT . MS.modify $ setHeaderWith $ replace (CI.mk $ lazyTextToStrictByteString k) (lazyTextToStrictByteString v)+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\".-text :: (ScottyError e, Monad m) => T.Text -> ActionT e m ()+-- header to \"text/plain; charset=utf-8\" if it has not already been set.+text :: (MonadIO m) => T.Text -> ActionT m () text t = do- setHeader "Content-Type" "text/plain"- raw $ encodeUtf8 t+ changeHeader addIfNotPresent "Content-Type" "text/plain; charset=utf-8"+ raw $ BL.fromStrict $ encodeUtf8 t -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\"--- header to \"text/html\".-html :: (ScottyError e, Monad m) => T.Text -> ActionT e m ()+-- header to \"text/plain; charset=utf-8\" if it has not already been set.+textLazy :: (MonadIO m) => TL.Text -> ActionT m ()+textLazy t = do+ changeHeader addIfNotPresent "Content-Type" "text/plain; charset=utf-8"+ raw $ TLE.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 :: (MonadIO m) => T.Text -> ActionT m () html t = do- setHeader "Content-Type" "text/html"- raw $ encodeUtf8 t+ changeHeader addIfNotPresent "Content-Type" "text/html; charset=utf-8"+ raw $ BL.fromStrict $ 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.+htmlLazy :: (MonadIO m) => TL.Text -> ActionT m ()+htmlLazy t = do+ changeHeader addIfNotPresent "Content-Type" "text/html; charset=utf-8"+ raw $ TLE.encodeUtf8 t+ -- | 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'.-file :: (ScottyError e, Monad m) => FilePath -> ActionT e m ()-file = ActionT . MS.modify . setContent . ContentFile+-- 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 :: 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\".-json :: (A.ToJSON a, ScottyError e, Monad m) => a -> ActionT e m ()+-- header to \"application/json; charset=utf-8\" if it has not already been set.+json :: (A.ToJSON a, MonadIO m) => a -> ActionT m () json v = do- setHeader "Content-Type" "application/json"+ changeHeader addIfNotPresent "Content-Type" "application/json; charset=utf-8" raw $ A.encode v -- | 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'.-source :: (ScottyError e, Monad m) => Source IO (Flush Builder) -> ActionT e m ()-source = ActionT . MS.modify . setContent . ContentSource+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 :: (ScottyError e, 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+ _ <- liftIO $ app r (\res -> putMVar ref res >> return ResponseReceived)+ res <- liftIO $ readMVar ref+ rawResponse res
+ Web/Scotty/Body.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# language OverloadedStrings #-}+{-# language ScopedTypeVariables #-}+module Web.Scotty.Body (+ newBodyInfo,+ cloneBodyInfo++ , getFormParamsAndFilesAction+ , getBodyAction+ , getBodyChunkAction+ -- wai-extra+ , W.RequestParseException(..)+ ) where++import Control.Concurrent.MVar+import Control.Monad.IO.Class+import Control.Monad.Trans.Resource (InternalState)+import Data.Bifunctor (first, bimap)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified GHC.Exception as E (throw)+import Network.Wai (Request(..), getRequestBodyChunk)+import qualified Network.Wai.Handler.Warp as Warp (InvalidRequest(..))+import qualified Network.Wai.Parse as W (File, Param, getRequestBodyType, tempFileBackEnd, RequestBodyType(..), sinkRequestBodyEx, RequestParseException(..), ParseRequestBodyOptions)+-- import UnliftIO (MonadUnliftIO(..))+import UnliftIO.Exception (Handler(..), catches, throwIO)++import Web.Scotty.Internal.Types (BodyInfo(..), BodyChunkBuffer(..), BodyPartiallyStreamed(..), RouteOptions(..), File, ScottyException(..), Param)+import Web.Scotty.Util (readRequestBody, decodeUtf8Lenient)+++-- | 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.+--+-- NB : catches exceptions from 'warp' and 'wai-extra' and wraps them into 'ScottyException'+getFormParamsAndFilesAction ::+ InternalState+ -> W.ParseRequestBodyOptions+ -> Request -- ^ only used for its body type+ -> BodyInfo -- ^ the request body contents are read from here+ -> RouteOptions+ -> IO ([Param], [File FilePath])+getFormParamsAndFilesAction istate prbo req bodyInfo opts = do+ let+ bs2t = decodeUtf8Lenient+ convertBoth = bimap bs2t bs2t+ convertKey = first bs2t+ bs <- getBodyAction bodyInfo opts+ let+ wholeBody = BL.toChunks bs+ (formparams, fs) <- parseRequestBodyExBS istate prbo wholeBody (W.getRequestBodyType req) `catches` handleWaiParseSafeExceptions+ return (convertBoth <$> formparams, convertKey <$> fs)++-- | Wrap exceptions from upstream libraries into 'ScottyException'+handleWaiParseSafeExceptions :: MonadIO m => [Handler m a]+handleWaiParseSafeExceptions = [h1, h2]+ where+ h1 = Handler (\ (e :: W.RequestParseException ) -> throwIO $ WaiRequestParseException e)+ h2 = Handler (\(e :: Warp.InvalidRequest) -> throwIO $ WarpRequestException e)++-- | Adapted 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.+parseRequestBodyExBS :: MonadIO m =>+ InternalState+ -> W.ParseRequestBodyOptions+ -> [B.ByteString]+ -> Maybe W.RequestBodyType+ -> m ([W.Param], [W.File FilePath])+parseRequestBodyExBS istate o bl rty =+ case rty 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.sinkRequestBodyEx o (W.tempFileBackEnd istate) rbt provider+++-- | 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.+--+-- throw 'ScottyException' if request body too big+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 (B.null newChunk) (chunks ++ [newChunk]), (index + 1, newChunk))+
+ Web/Scotty/Cookie.hs view
@@ -0,0 +1,135 @@+{-|+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, get)+import Web.Scotty.Cookie (getCookie, setSimpleCookie)++main :: IO ()+main = scotty 3000 $+ get \"/\" $ do+ hits <- liftM (fromMaybe \"0\") $ 'getCookie' \"hits\"+ let hits' =+ case TL.decimal $ TL.fromStrict hits of+ Right n -> TL.pack . show . (+1) $ (fst n :: Integer)+ Left _ -> \"1\"+ 'setSimpleCookie' \"hits\" $ TL.toStrict hits'+ html $ mconcat [ \"\<html\>\<body\>\"+ , hits'+ , \"\<\/body\>\<\/html\>\"+ ]+@+-}+{-# LANGUAGE OverloadedStrings #-}+module Web.Scotty.Cookie (+ -- * Set cookie+ setCookie+ , setSimpleCookie+ -- * Get cookie(s)+ , getCookie+ , getCookies+ -- * Delete a cookie+ , deleteCookie+ -- * Helpers and advanced interface (re-exported from 'cookie')+ , CookiesText+ , makeSimpleCookie+ -- ** cookie configuration+ , SetCookie+ , defaultSetCookie+ , setCookieName+ , setCookieValue+ , setCookiePath+ , setCookieExpires+ , setCookieMaxAge+ , setCookieDomain+ , setCookieHttpOnly+ , setCookieSecure+ , setCookieSameSite+ , SameSiteOption+ , sameSiteNone+ , sameSiteLax+ , sameSiteStrict+ ) where++import Control.Monad.IO.Class (MonadIO(..))++-- bytestring+import Data.ByteString.Builder (toLazyByteString)+import qualified Data.ByteString.Lazy as BSL (toStrict)+-- cookie+import Web.Cookie (SetCookie, setCookieName , setCookieValue, setCookiePath, setCookieExpires, setCookieMaxAge, setCookieDomain, setCookieHttpOnly, setCookieSecure, setCookieSameSite, renderSetCookie, defaultSetCookie, CookiesText, parseCookiesText, SameSiteOption, sameSiteStrict, sameSiteNone, sameSiteLax)+-- scotty+import Web.Scotty.Action (ActionT, addHeader, header)+-- time+import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )+-- text+import Data.Text (Text)+import qualified Data.Text.Encoding as T (encodeUtf8)+import Web.Scotty.Util (decodeUtf8Lenient)++-- | Set a cookie, with full access to its options (see 'SetCookie')+setCookie :: (MonadIO m)+ => SetCookie+ -> ActionT m ()+setCookie c = addHeader "Set-Cookie"+ $ decodeUtf8Lenient+ $ BSL.toStrict+ $ 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 . T.encodeUtf8++-- | Browsers don't directly delete a cookie, but setting its expiry to a past date (e.g. the UNIX epoch) ensures that the cookie will be invalidated (whether and when it will be actually deleted by the browser seems to be browser-dependent).+deleteCookie :: (MonadIO m)+ => Text -- ^ name+ -> ActionT m ()+deleteCookie c = setCookie $ (makeSimpleCookie c "") { setCookieExpires = Just $ posixSecondsToUTCTime 0 }+++-- | Construct a simple cookie (an UTF-8 string pair with default cookie options)+makeSimpleCookie :: Text -- ^ name+ -> Text -- ^ value+ -> SetCookie+makeSimpleCookie n v = defaultSetCookie { setCookieName = T.encodeUtf8 n+ , setCookieValue = T.encodeUtf8 v+ }+
+ Web/Scotty/Internal/Types.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# language ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+module Web.Scotty.Internal.Types where++import Blaze.ByteString.Builder (Builder)++import Control.Applicative+import Control.Concurrent.MVar+import Control.Concurrent.STM (TVar, atomically, readTVarIO, modifyTVar')+import qualified Control.Exception as E+import Control.Monad (MonadPlus(..))+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, mapReaderT)+import Control.Monad.State.Strict (State)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Control (MonadBaseControl, MonadTransControl)+import qualified Control.Monad.Trans.Resource as RT (InternalState, InvalidAccess)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy.Char8 as LBS8 (ByteString)+import Data.String (IsString(..))+import qualified Data.Text as T (Text, pack)+import GHC.Stack (callStack)+import Network.HTTP.Types++import Network.Wai hiding (Middleware, Application)+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as W (Settings, defaultSettings, InvalidRequest(..))+import Network.Wai.Parse (FileInfo)+import qualified Network.Wai.Parse as WPS (ParseRequestBodyOptions, RequestParseException(..))++import UnliftIO.Exception (Handler(..), catch, catches, StringException(..))+++++--------------------- Options -----------------------+data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner+ , settings :: W.Settings -- ^ Warp 'Settings'+ -- Note: to work around an issue in warp,+ -- the default FD cache duration is set to 0+ -- so changes to static files are always picked+ -- up. This likely has performance implications,+ -- so you may want to modify this for production+ -- servers using `setFdCacheDuration`.+ , jsonMode :: Bool -- ^ If True, return JSON error responses instead of HTML+ }++defaultOptions :: Options+defaultOptions = Options 1 W.defaultSettings False++newtype RouteOptions = RouteOptions { maxRequestBodySize :: Maybe Kilobytes -- max allowed request size in KB+ }++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 m =+ ScottyState { middlewares :: [Wai.Middleware]+ , routes :: [BodyInfo -> Middleware m]+ , handler :: Maybe (ErrorHandler m)+ , routeOptions :: RouteOptions+ }++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 :: (BodyInfo -> Middleware m) -> ScottyState m -> ScottyState m+addRoute r s@(ScottyState {routes = rs}) = s { routes = r:rs }++setHandler :: Maybe (ErrorHandler m) -> ScottyState m -> ScottyState m+setHandler h s = s { handler = h }++updateMaxRequestBodySize :: RouteOptions -> ScottyState m -> ScottyState m+updateMaxRequestBodySize RouteOptions { .. } s@ScottyState { routeOptions = ro } =+ let ro' = ro { maxRequestBodySize = maxRequestBodySize }+ in s { routeOptions = ro' }++newtype ScottyT m a =+ ScottyT { runS :: ReaderT Options (State (ScottyState m)) a }+ deriving ( Functor, Applicative, Monad )+++------------------ Scotty Errors --------------------++-- | 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 Status T.Text -- ^ Redirect+ | AENext -- ^ Stop processing this route and skip to the next one+ | AEFinish -- ^ Stop processing the request+ deriving (Show)+instance E.Exception ActionError++tryNext :: MonadUnliftIO m => m a -> m Bool+tryNext io = catch (io >> pure True) $+ \case+ AENext -> pure False+ _ -> pure True++-- | Specializes a 'Handler' to the 'ActionT' monad+type ErrorHandler m = Handler (ActionT m) ()++-- | Thrown e.g. when a request is too large+data ScottyException+ = RequestTooLarge+ | MalformedJSON LBS8.ByteString T.Text+ | FailedToParseJSON LBS8.ByteString T.Text+ | MalformedForm T.Text+ | PathParameterNotFound T.Text+ | QueryParameterNotFound T.Text+ | FormFieldNotFound T.Text+ | FailedToParseParameter T.Text T.Text T.Text+ | WarpRequestException W.InvalidRequest+ | WaiRequestParseException WPS.RequestParseException -- request parsing+ | ResourceTException RT.InvalidAccess -- use after free+ deriving (Show)+instance E.Exception ScottyException++------------------ Scotty Actions -------------------+type Param = (T.Text, T.Text)++-- | Type parameter @t@ is the file content. Could be @()@ when not needed or a @FilePath@ for temp files instead.+type File t = (T.Text, FileInfo t)++data ActionEnv = Env { envReq :: Request+ , envPathParams :: [Param]+ , envQueryParams :: [Param]+ , envFormDataAction :: RT.InternalState -> WPS.ParseRequestBodyOptions -> IO ([Param], [File FilePath])+ , envBody :: IO LBS8.ByteString+ , envBodyChunk :: IO BS.ByteString+ , envResponse :: TVar ScottyResponse+ }+++++formParamsAndFilesWith :: MonadUnliftIO m =>+ RT.InternalState+ -> WPS.ParseRequestBodyOptions+ -> ActionT m ([Param], [File FilePath])+formParamsAndFilesWith istate prbo = action `catch` (\(e :: RT.InvalidAccess) -> E.throw $ ResourceTException e)+ where+ action = do+ act <- ActionT $ asks envFormDataAction+ liftIO $ act istate prbo++getResponse :: MonadIO m => ActionEnv -> m ScottyResponse+getResponse ae = liftIO $ readTVarIO (envResponse ae)++getResponseAction :: (MonadIO m) => ActionT m ScottyResponse+getResponseAction = do+ ae <- ActionT ask+ getResponse ae++modifyResponse :: (MonadIO m) => (ScottyResponse -> ScottyResponse) -> ActionT m ()+modifyResponse f = do+ tv <- ActionT $ asks envResponse+ liftIO $ atomically $ modifyTVar' tv f++data BodyPartiallyStreamed = BodyPartiallyStreamed deriving (Show)++instance E.Exception BodyPartiallyStreamed++data Content = ContentBuilder Builder+ | ContentFile FilePath+ | ContentStream StreamingBody+ | ContentResponse Response++data ScottyResponse = SR { srStatus :: Status+ , srHeaders :: ResponseHeaders+ , srContent :: Content+ }++setContent :: Content -> ScottyResponse -> ScottyResponse+setContent c sr = sr { srContent = c }++setHeaderWith :: ([(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)]) -> ScottyResponse -> ScottyResponse+setHeaderWith f sr = sr { srHeaders = f (srHeaders sr) }++setStatus :: Status -> ScottyResponse -> ScottyResponse+setStatus s sr = sr { srStatus = s }+++-- | The default response has code 200 OK and empty body+defaultScottyResponse :: ScottyResponse+defaultScottyResponse = SR status200 [] (ContentBuilder mempty)+++newtype ActionT m a = ActionT { runAM :: ReaderT ActionEnv m a }+ deriving newtype (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadThrow, MonadCatch, MonadBase b, MonadBaseControl b, MonadTransControl, MonadUnliftIO)++withActionEnv :: Monad m =>+ (ActionEnv -> ActionEnv) -> ActionT m a -> ActionT m a+withActionEnv f (ActionT r) = ActionT $ local f r++instance MonadReader r m => MonadReader r (ActionT m) where+ ask = ActionT $ lift ask+ local f = ActionT . mapReaderT (local f) . runAM++-- | MonadFail instance for ActionT that converts 'fail' calls into Scotty exceptions+-- which allows these failures to be caught by Scotty's error handling system+-- and properly returned as HTTP 500 responses. The instance throws a 'StringException'+-- containing both the failure message and a call stack for debugging purposes.+instance (MonadIO m) => MonadFail (ActionT m) where+ fail msg = E.throw $ StringException msg callStack++-- | 'empty' throws 'ActionError' 'AENext', whereas '(<|>)' catches any 'ActionError's or 'StatusError's in the first action and proceeds to the second one.+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 = (<|>)++-- | catches either ActionError (thrown by 'next'),+-- 'ScottyException' (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 $ \(_ :: ScottyException) -> pure False++instance (Semigroup a) => Semigroup (ScottyT m a) where+ x <> y = (<>) <$> x <*> y++instance+ ( Monoid a+ ) => Monoid (ScottyT m a) where+ mempty = return mempty++instance+ ( Monad m+ , Semigroup a+ ) => Semigroup (ActionT m a) where+ x <> y = (<>) <$> x <*> y++instance+ ( Monad m, Monoid a+ ) => Monoid (ActionT m a) where+ mempty = return mempty++------------------ Scotty Routes --------------------+data RoutePattern = Capture T.Text+ | Literal T.Text+ | Function (Request -> Maybe [Param])++instance IsString RoutePattern where+ fromString = Capture . T.pack++
Web/Scotty/Route.hs view
@@ -1,154 +1,213 @@-{-# LANGUAGE OverloadedStrings, FlexibleContexts, FlexibleInstances, RankNTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances,+ OverloadedStrings, RankNTypes, ScopedTypeVariables #-} module Web.Scotty.Route- ( get, post, put, delete, patch, addroute, matchAny, notFound,+ ( get, post, put, delete, patch, options, addroute, matchAny, notFound, capture, regex, function, literal ) where -import Control.Arrow ((***))-import Control.Monad.Error+import Control.Arrow ((***))+import Control.Concurrent.STM (newTVarIO)+import Control.Monad.IO.Class (MonadIO(..))+import UnliftIO (MonadUnliftIO(..))+import qualified Control.Monad.Reader as MR import qualified Control.Monad.State as MS+import Control.Monad.Trans.Resource (InternalState) -import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as BL-import Data.Conduit (($$), (=$))-import Data.Conduit.Binary (sourceLbs)-import Data.Conduit.Lazy (lazyConsume)-import Data.Conduit.List (consume)-import Data.Either (partitionEithers)-import Data.Maybe (fromMaybe)-import Data.Monoid (mconcat)-import qualified Data.Text.Lazy as T-import qualified Data.Text as TS+import Data.String (fromString)+import qualified Data.Text as T -import Network.HTTP.Types-import Network.Wai (Request(..))-import qualified Network.Wai.Parse as Parse hiding (parseRequestBody)+import Network.HTTP.Types+import Network.Wai (Request(..)) import qualified Text.Regex as Regex -import Web.Scotty.Action-import Web.Scotty.Types-import Web.Scotty.Util+import Web.Scotty.Action +import Web.Scotty.Internal.Types (Options, RoutePattern(..), RouteOptions, ActionEnv(..), ScottyState(..), ScottyT(..), ErrorHandler, Middleware, BodyInfo, File, handler, addRoute, defaultScottyResponse)++import Web.Scotty.Util (decodeUtf8Lenient)+import Web.Scotty.Body (cloneBodyInfo, getBodyAction, getBodyChunkAction, getFormParamsAndFilesAction)+++{- $setup+>>> :{+import Control.Monad.IO.Class (MonadIO(..))+import qualified Network.HTTP.Client as H+import qualified Network.HTTP.Types as H+import qualified Network.Wai as W (httpVersion)+import qualified Data.ByteString.Lazy.Char8 as LBS (unpack)+import qualified Data.Text as T (pack)+import Control.Concurrent (ThreadId, forkIO, killThread)+import Control.Exception (bracket)+import qualified Web.Scotty as S (ScottyM, scottyOpts, get, text, regex, pathParam, Options(..), defaultOptions)+-- | GET an HTTP path+curl :: MonadIO m =>+ String -- ^ path+ -> m String -- ^ response body+curl path = liftIO $ do+ req0 <- H.parseRequest path+ let req = req0 { H.method = "GET"}+ mgr <- H.newManager H.defaultManagerSettings+ (LBS.unpack . H.responseBody) <$> H.httpLbs req mgr+-- | Fork a process, run a Scotty server in it and run an action while the server is running. Kills the scotty thread once the inner action is done.+withScotty :: S.ScottyM ()+ -> IO a -- ^ inner action, e.g. 'curl "localhost:3000/"'+ -> IO a+withScotty serv act = bracket (forkIO $ S.scottyOpts (S.defaultOptions{ S.verbose = 0 }) serv) killThread (\_ -> act)+:}+-}+ -- | 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 :: (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 = mapM_ (\v -> addroute v pattern action) [minBound..maxBound]+matchAny :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m ()+matchAny pat action =+ ScottyT $ do+ serverOptions <- MR.ask+ MS.modify $ \s ->+ addRoute+ (route serverOptions (routeOptions s) (handler s) Nothing pat action)+ s -- | Specify an action to take if nothing else is found. Note: this _always_ matches, -- so should generally be the last route specified.-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,--- and a body ('Action') which modifies the response.------ > 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'.------ > addroute GET "/foo/:bar" $ do--- > v <- param "bar"--- > text v------ >>> curl http://localhost:3000/foo/something--- something-addroute :: (ScottyError e, MonadIO m) => StdMethod -> RoutePattern -> ActionT e m () -> ScottyT e m ()-addroute method pat action = ScottyT $ MS.modify $ \s -> addRoute (route (handler s) method pat action) s+{- | Define a route with a 'StdMethod', a route pattern representing the path spec,+and an 'Action' which may modify the response. -route :: (ScottyError e, MonadIO m) => ErrorHandler e m -> StdMethod -> RoutePattern -> ActionT e m () -> Middleware m-route h method pat action app req =- let tryNext = app req- in if Right method == parseMethod (requestMethod req)- then case matchRoute pat req of+> get "/" $ text "beam me up!"++The path spec can include values starting with a colon, which are interpreted+as /captures/. These are parameters that can be looked up with 'pathParam'.++>>> :{+let server = S.get "/foo/:bar" (S.pathParam "bar" >>= S.text)+ in do+ withScotty server $ curl "http://localhost:3000/foo/something"+:}+"something"+-}+addroute :: (MonadUnliftIO m) => StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()+addroute method pat action =+ ScottyT $ do+ serverOptions <- MR.ask+ MS.modify $ \s ->+ addRoute+ (route serverOptions (routeOptions s) (handler s) (Just method) pat action)+ s+++route :: (MonadUnliftIO m) =>+ Options+ -> RouteOptions+ -> Maybe (ErrorHandler m) -> Maybe StdMethod -> RoutePattern -> ActionT m () -> BodyInfo -> Middleware m+route serverOpts opts h method pat action bodyInfo app req =+ let tryNext = app req+ -- We match all methods in the case where 'method' is 'Nothing'.+ -- See https://github.com/scotty-web/scotty/issues/196 and 'matchAny'+ 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 <- mkEnv req captures- res <- runAction 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.+ cbi <- cloneBodyInfo bodyInfo++ env <- mkEnv cbi req captures opts+ res <- runAction serverOpts h env action+ + maybe tryNext return res Nothing -> tryNext- else tryNext+ else tryNext matchRoute :: RoutePattern -> Request -> Maybe [Param] matchRoute (Literal pat) req | pat == path req = Just [] | otherwise = Nothing matchRoute (Function fun) req = fun req-matchRoute (Capture pat) req = go (T.split (=='/') pat) (T.split (=='/') $ path req) []+matchRoute (Capture pat) req = go (T.split (=='/') pat) (compress $ "":pathInfo req) [] -- add empty segment to simulate being at the root where go [] [] prs = Just prs -- request string and pattern match! go [] r prs | T.null (mconcat r) = Just prs -- in case request has trailing slashes | otherwise = Nothing -- request string is longer than pattern go p [] prs | T.null (mconcat p) = Just prs -- in case pattern has trailing slashes | otherwise = Nothing -- request string is not long enough- go (p:ps) (r:rs) prs | p == r = go ps rs prs -- equal literals, keeping checking- | T.null p = Nothing -- p is null, but r is not, fail- | T.head p == ':' = go ps rs $ (T.tail p, r) : prs -- p is a capture, add to params- | otherwise = Nothing -- both literals, but unequal, fail+ go (p:ps) (r:rs) prs = case T.uncons p of+ Just (':', name) -> go ps rs $ (name, r) : prs -- p is a capture, add to params+ _ | p == r -> go ps rs prs -- equal literals, keeping checking+ | otherwise -> Nothing -- both literals, but unequal, fail+ compress ("":rest@("":_)) = compress rest+ compress (x:xs) = x : compress xs+ compress [] = [] -- Pretend we are at the top level. path :: Request -> T.Text-path = T.fromStrict . TS.cons '/' . TS.intercalate "/" . pathInfo+path = T.cons '/' . T.intercalate "/" . pathInfo --- Stolen from wai-extra, modified to accept body as lazy ByteString-parseRequestBody :: MonadIO m- => BL.ByteString- -> Parse.BackEnd y- -> Request- -> m ([Parse.Param], [Parse.File y])-parseRequestBody b s r =- case Parse.getRequestBodyType r of- Nothing -> return ([], [])- Just rbt -> liftIO $ liftM partitionEithers $ sourceLbs b $$ Parse.conduitRequestBody s rbt =$ consume+-- | 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 pathps opts = do+ let+ getFormData :: InternalState -> ParseRequestBodyOptions -> IO ([Param], [File FilePath])+ getFormData istate prbo = getFormParamsAndFilesAction istate prbo req bodyInfo opts+ queryps = parseEncodedParams $ queryString req+ responseInit <- liftIO $ newTVarIO defaultScottyResponse+ return $ Env req pathps queryps getFormData (getBodyAction bodyInfo opts) (getBodyChunkAction bodyInfo) responseInit -mkEnv :: MonadIO m => Request -> [Param] -> m ActionEnv-mkEnv req captures = do- b <- liftIO $ liftM BL.fromChunks $ lazyConsume (requestBody req) - (formparams, fs) <- liftIO $ parseRequestBody b Parse.lbsBackEnd req - let convert (k, v) = (strictByteStringToLazyText k, strictByteStringToLazyText v)- parameters = captures ++ map convert formparams ++ queryparams- queryparams = parseEncodedParams $ rawQueryString req-- return $ Env req parameters b [ (strictByteStringToLazyText k, fi) | (k,fi) <- fs ]+parseEncodedParams :: Query -> [Param]+parseEncodedParams qs = [ ( decodeUtf8Lenient k, maybe "" decodeUtf8Lenient v) | (k,v) <- qs ] -parseEncodedParams :: B.ByteString -> [Param]-parseEncodedParams bs = [ (T.fromStrict k, T.fromStrict $ fromMaybe "" v) | (k,v) <- parseQueryText bs ]+{- | Match requests using a regular expression.+Named captures are not yet supported. --- | Match requests using a regular expression.--- Named captures are not yet supported.------ > get (regex "^/f(.*)r$") $ do--- > path <- param "0"--- > cap <- param "1"--- > text $ mconcat ["Path: ", path, "\nCapture: ", cap]------ >>> curl http://localhost:3000/foo/bar--- Path: /foo/bar--- Capture: oo/ba---+>>> :{+let server = S.get (S.regex "^/f(.*)r$") $ do+ cap <- S.pathParam "1"+ S.text cap+ in do+ withScotty server $ curl "http://localhost:3000/foo/bar"+:}+"oo/ba"+-} regex :: String -> RoutePattern-regex pattern = Function $ \ req -> fmap (map (T.pack . show *** T.pack) . zip [0 :: Int ..] . strip)+regex pat = Function $ \ req -> fmap (map (T.pack . show *** T.pack) . zip [0 :: Int ..] . strip) (Regex.matchRegexAll rgx $ T.unpack $ path req)- where rgx = Regex.mkRegex pattern+ where rgx = Regex.mkRegex pat strip (_, match, _, subs) = match : subs -- | Standard Sinatra-style route. Named captures are prepended with colons.@@ -164,20 +223,21 @@ -- -- are equivalent. capture :: String -> RoutePattern-capture = Capture . T.pack+capture = fromString --- | Build a route based on a function which can match using the entire 'Request' object.--- 'Nothing' indicates the route does not match. A 'Just' value indicates--- a successful match, optionally returning a list of key-value pairs accessible--- by 'param'.------ > get (function $ \req -> Just [("version", T.pack $ show $ httpVersion req)]) $ do--- > v <- param "version"--- > text v------ >>> curl http://localhost:3000/--- HTTP/1.1---+{- | Build a route based on a function which can match using the entire 'Request' object.+'Nothing' indicates the route does not match. A 'Just' value indicates+a successful match, optionally returning a list of key-value pairs accessible by 'param'.++>>> :{+let server = S.get (function $ \req -> Just [("version", T.pack $ show $ W.httpVersion req)]) $ do+ v <- S.pathParam "version"+ S.text v+ in do+ withScotty server $ curl "http://localhost:3000/"+:}+"HTTP/1.1"+-} function :: (Request -> Maybe [Param]) -> RoutePattern function = Function
+ Web/Scotty/Session.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++{- |+Module : Web.Scotty.Session+Copyright : (c) 2025 Tushar Adhatrao,+ (c) 2025 Marco Zocca++License : BSD-3-Clause+Maintainer :+Stability : experimental+Portability : GHC++This module provides session management functionality for Scotty web applications.++==Example usage:++@+\{\-\# LANGUAGE OverloadedStrings \#\-\}++import Web.Scotty+import Web.Scotty.Session+import Control.Monad.IO.Class (liftIO)+main :: IO ()+main = do+ -- Create a session jar+ sessionJar <- createSessionJar+ scotty 3000 $ do+ -- Route to create a session+ get "/create" $ do+ sess <- createUserSession sessionJar "user data"+ html $ "Session created with ID: " <> sessId sess+ -- Route to read a session+ get "/read" $ do+ eSession <- getUserSession sessionJar+ case eSession of+ Left _-> html "No session found or session expired."+ Right sess -> html $ "Session content: " <> sessContent sess+@+-}+module Web.Scotty.Session (+ Session (..),+ SessionId,+ SessionJar,+ SessionStatus,++ -- * Create Session Jar+ createSessionJar,++ -- * Create session+ createUserSession,+ createSession,++ -- * Read session+ readUserSession,+ readSession,+ getUserSession,+ getSession,++ -- * Add session+ addSession,++ -- * Delte session+ deleteSession,++ -- * Helper functions+ maintainSessions,+) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.IO.Class (MonadIO (..))+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import Data.Time (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)+import System.Random (randomRIO)+import Web.Scotty.Action (ActionT)+import Web.Scotty.Cookie++-- | Type alias for session identifiers.+type SessionId = T.Text++-- | Status of a session lookup.+data SessionStatus = SessionNotFound | SessionExpired+ deriving (Show, Eq)++-- | Represents a session containing an ID, expiration time, and content.+data Session a = Session+ { sessId :: SessionId+ -- ^ Unique identifier for the session.+ , sessExpiresAt :: UTCTime+ -- ^ Expiration time of the session.+ , sessContent :: a+ -- ^ Content stored in the session.+ }+ deriving (Eq, Show)++-- | Type for session storage, a transactional variable containing a map of session IDs to sessions.+type SessionJar a = TVar (HM.HashMap SessionId (Session a))++-- | Creates a new session jar and starts a background thread to maintain it.+createSessionJar :: IO (SessionJar a)+createSessionJar = do+ storage <- newTVarIO HM.empty+ _ <- forkIO $ maintainSessions storage+ return storage++-- | Continuously removes expired sessions from the session jar.+maintainSessions :: SessionJar a -> IO ()+maintainSessions sessionJar =+ forever $ do+ now <- getCurrentTime+ let stillValid sess = sessExpiresAt sess > now+ atomically $ modifyTVar sessionJar $ \m -> HM.filter stillValid m+ threadDelay 1000000+ ++-- | Adds or overwrites a new session to the session jar.+addSession :: SessionJar a -> Session a -> IO ()+addSession sessionJar sess =+ atomically $ modifyTVar sessionJar $ \m -> HM.insert (sessId sess) sess m++-- | Retrieves a session by its ID from the session jar.+getSession :: (MonadIO m) => SessionJar a -> SessionId -> ActionT m (Either SessionStatus (Session a))+getSession sessionJar sId =+ do+ s <- liftIO $ readTVarIO sessionJar+ case HM.lookup sId s of+ Nothing -> pure $ Left SessionNotFound+ Just sess -> do + now <- liftIO getCurrentTime+ if sessExpiresAt sess < now+ then deleteSession sessionJar (sessId sess) >> pure (Left SessionExpired)+ else pure $ Right sess++-- | Deletes a session by its ID from the session jar.+deleteSession :: (MonadIO m) => SessionJar a -> SessionId -> ActionT m ()+deleteSession sessionJar sId =+ liftIO $+ atomically $+ modifyTVar sessionJar $+ HM.delete sId++{- | Retrieves the current user's session based on the "sess_id" cookie.+| Returns `Left SessionStatus` if the session is expired or does not exist.+-}+getUserSession :: (MonadIO m) => SessionJar a -> ActionT m (Either SessionStatus (Session a))+getUserSession sessionJar = do+ getCookie "sess_id" >>= \case+ Nothing -> pure $ Left SessionNotFound+ Just sid -> lookupSession sid+ where+ lookupSession = getSession sessionJar++-- | Reads the content of a session by its ID.+readSession :: (MonadIO m) => SessionJar a -> SessionId -> ActionT m (Either SessionStatus a)+readSession sessionJar sId = do+ res <- getSession sessionJar sId+ return $ sessContent <$> res++-- | Reads the content of the current user's session.+readUserSession :: (MonadIO m) => SessionJar a -> ActionT m (Either SessionStatus a)+readUserSession sessionJar = do+ res <- getUserSession sessionJar+ return $ sessContent <$> res++-- | The time-to-live for sessions, in seconds.+sessionTTL :: NominalDiffTime+sessionTTL = 36000 -- in seconds++-- | Creates a new session for a user, storing the content and setting a cookie.+createUserSession :: (MonadIO m) => + SessionJar a -- ^ SessionJar, which can be created by createSessionJar+ -> Maybe Int -- ^ Optional expiration time (in seconds)+ -> a -- ^ Content+ -> ActionT m (Session a)+createUserSession sessionJar mbExpirationTime content = do+ sess <- liftIO $ createSession sessionJar mbExpirationTime content+ setSimpleCookie "sess_id" (sessId sess)+ return sess++-- | Creates a new session with a generated ID, sets its expiration, +-- | and adds it to the session jar.+createSession :: SessionJar a -> Maybe Int -> a -> IO (Session a)+createSession sessionJar mbExpirationTime content = do+ sId <- liftIO $ T.pack <$> replicateM 32 (randomRIO ('a', 'z'))+ now <- getCurrentTime+ let expiresAt = addUTCTime (maybe sessionTTL fromIntegral mbExpirationTime) now+ sess = Session sId expiresAt content+ liftIO $ addSession sessionJar sess+ return $ Session sId expiresAt content
Web/Scotty/Trans.hs view
@@ -1,106 +1,209 @@ {-# LANGUAGE OverloadedStrings, RankNTypes #-}+{-# language LambdaCase #-} -- | It should be noted that most of the code snippets below depend on the -- OverloadedStrings language pragma. -- -- The functions in this module allow an arbitrary monad to be embedded--- in Scotty's monad transformer stack in order that Scotty be combined--- with other DSLs.+-- in Scotty's monad transformer stack, e.g. for complex endpoint configuration,+-- interacting with databases etc.+--+-- Scotty is set up by default for development mode. For production servers,+-- you will likely want to modify 'settings' and the 'defaultHandler'. See+-- the comments on each of these functions for more information.+--+-- Please refer to the @examples@ directory and the @spec@ test suite for concrete use cases, e.g. constructing responses, exception handling and useful implementation details. module Web.Scotty.Trans- ( -- * scotty-to-WAI- scottyT, scottyAppT, scottyOptsT, Options(..)+ ( -- * Running 'scotty' servers+ scottyT+ , scottyOptsT+ , scottySocketT+ , Options(..), defaultOptions+ -- ** scotty-to-WAI+ , scottyAppT -- * 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, addroute, matchAny, notFound+ , middleware, get, post, put, delete, patch, options, addroute, matchAny, notFound, setMaxRequestBodySize -- ** Route Patterns , capture, regex, function, literal- -- ** Accessing the Request, Captures, and Query Parameters- , request, reqHeader, body, param, params, jsonData, files- -- ** Modifying the Response and Redirecting- , status, addHeader, setHeader, redirect+ -- ** Accessing the Request and its fields+ , request, Lazy.header, Lazy.headers, body, bodyReader+ , jsonData, formData++ -- ** Accessing Path, Form and Query Parameters+ , pathParam, captureParam, formParam, queryParam+ , pathParamMaybe, captureParamMaybe, formParamMaybe, queryParamMaybe+ , pathParams, captureParams, formParams, queryParams+ -- *** Files+ , files, filesOpts+ -- ** Modifying the Response+ , status, Lazy.addHeader, Lazy.setHeader+ -- ** Redirecting+ , Lazy.redirect, Lazy.redirect300, Lazy.redirect301, Lazy.redirect302, Lazy.redirect303+ , Lazy.redirect304, Lazy.redirect307, Lazy.redirect308 -- ** 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, source, raw+ , Lazy.text, Lazy.html, file, json, stream, raw, nested+ -- ** Accessing the fields of the Response+ , getResponseHeaders, getResponseStatus, getResponseContent -- ** Exceptions- , raise, rescue, next, defaultHandler, ScottyError(..)+ , throw, next, finish, defaultHandler+ , liftIO, catch+ , ScottyException(..) -- * Parsing Parameters , Param, Parsable(..), readEither -- * Types- , RoutePattern, File+ , RoutePattern, File, Content(..), Kilobytes, ErrorHandler, Handler(..) -- * Monad Transformers , ScottyT, ActionT+ , ScottyState, defaultScottyState+ -- ** Functions from Cookie module+ , setSimpleCookie, getCookie, getCookies, deleteCookie, makeSimpleCookie+ -- ** Session Management+ , Session (..), SessionId, SessionJar, createSessionJar,+ createUserSession, createSession, readUserSession,+ readSession, getUserSession, getSession, addSession, deleteSession, maintainSessions ) where -import Blaze.ByteString.Builder (fromByteString)+import Blaze.ByteString.Builder (fromByteString, fromLazyByteString)+import Blaze.ByteString.Builder.Char8 (fromString) +import Control.Exception (assert) import Control.Monad (when)-import Control.Monad.State (execStateT, modify)+import Control.Monad.Reader (runReaderT)+import Control.Monad.State.Strict (execState, modify) import Control.Monad.IO.Class -import Data.Default (def)+import qualified Data.Aeson as A+import qualified Data.Text as T -import Network.HTTP.Types (status404)-import Network.Wai-import Network.Wai.Handler.Warp (Port, runSettings, settingsPort)+import Network.HTTP.Types (status404, status413, status500)+import Network.Socket (Socket)+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.Types hiding (Application, Middleware)-import qualified Web.Scotty.Types as Scotty+import Web.Scotty.Internal.Types (ScottyT(..), defaultScottyState, Application, RoutePattern, Options(..), defaultOptions, RouteOptions(..), defaultRouteOptions, ErrorHandler, Kilobytes, File, addMiddleware, setHandler, updateMaxRequestBodySize, routes, middlewares, ScottyException(..), ScottyState, defaultScottyState, Content(..))+import Web.Scotty.Trans.Lazy as Lazy+import Web.Scotty.Util (socketDescription)+import Web.Scotty.Body (newBodyInfo) +import UnliftIO.Exception (Handler(..), catch)+import Web.Scotty.Cookie (setSimpleCookie,getCookie,getCookies,deleteCookie,makeSimpleCookie)+import Web.Scotty.Session (Session (..), SessionId, SessionJar, createSessionJar,+ createUserSession, createSession, readUserSession,+ readSession, getUserSession, getSession, addSession, deleteSession, maintainSessions)++ -- | Run a scotty application using the warp server.--- NB: 'scotty p' === 'scottyT p id id'+-- NB: scotty p === scottyT p id scottyT :: (Monad m, MonadIO n) => Port- -> (forall a. m a -> n a) -- ^ Run monad 'm' into monad 'n', called once at 'ScottyT' level.- -> (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 = (settings def) { settingsPort = p } }+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 id'+-- NB: scottyOpts opts === scottyOptsT opts id scottyOptsT :: (Monad m, MonadIO n) => Options- -> (forall a. m a -> n a) -- ^ Run monad 'm' into monad 'n', called once at 'ScottyT' level.- -> (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 runM runActionToIO s = do+scottyOptsT opts runActionToIO s = do when (verbose opts > 0) $- liftIO $ putStrLn $ "Setting phasers to stun... (port " ++ show (settingsPort (settings opts)) ++ ") (ctrl-c to quit)"- liftIO . runSettings (settings opts) =<< scottyAppT runM runActionToIO s+ liftIO $ putStrLn $ "Setting phasers to stun... (port " ++ show (getPort (settings opts)) ++ ") (ctrl-c to quit)"+ liftIO . runSettings (settings opts) =<< scottyAppT opts runActionToIO s +-- | Run a scotty application using the warp server, passing extra options, and+-- listening on the provided socket.+-- NB: scottySocket opts sock === scottySocketT opts sock id+scottySocketT :: (Monad m, MonadIO n)+ => Options+ -> Socket+ -> (m W.Response -> IO W.Response)+ -> ScottyT m ()+ -> n ()+scottySocketT opts sock runActionToIO s = do+ when (verbose opts > 0) $ do+ d <- liftIO $ socketDescription sock+ liftIO $ putStrLn $ "Setting phasers to stun... (" ++ d ++ ") (ctrl-c to quit)"+ liftIO . runSettingsSocket (settings opts) sock =<< scottyAppT opts runActionToIO s+ -- | Turn a scotty application into a WAI 'Application', which can be -- run with any WAI handler.--- NB: 'scottyApp' === 'scottyAppT id id'+-- NB: scottyApp === scottyAppT id scottyAppT :: (Monad m, Monad n)- => (forall a. m a -> n a) -- ^ Run monad 'm' into monad 'n', called once at 'ScottyT' level.- -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action.- -> ScottyT e m ()- -> n Application-scottyAppT runM runActionToIO defs = do- s <- runM $ execStateT (runS defs) def- let rapp = runActionToIO . foldl (flip ($)) notFoundApp (routes s)- return $ foldl (flip ($)) rapp (middlewares s)+ => Options+ -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action.+ -> ScottyT m ()+ -> n W.Application+scottyAppT opts runActionToIO defs = do+ let s = execState (runReaderT (runS defs) opts) defaultScottyState+ let rapp req callback = do+ bodyInfo <- newBodyInfo req+ resp <- runActionToIO (applyAll (notFoundApp opts) ([midd bodyInfo | midd <- routes s]) req)+ `catch` unhandledExceptionHandler opts+ callback resp+ return $ applyAll rapp (middlewares s) -notFoundApp :: Monad m => Scotty.Application m-notFoundApp _ = return $ responseBuilder status404 [("Content-Type","text/html")]+-- | Exception handler in charge of 'ScottyException' that's not caught by 'scottyExceptionHandler'+unhandledExceptionHandler :: MonadIO m => Options -> ScottyException -> m W.Response+unhandledExceptionHandler opts = \case+ RequestTooLarge ->+ if jsonMode opts+ then return $ W.responseBuilder status413 ctJson $ + fromLazyByteString $ A.encode $ A.object+ [ "status" A..= (413 :: Int)+ , "description" A..= ("Request is too big Jim!" :: T.Text)+ ]+ else return $ W.responseBuilder status413 ctText "Request is too big Jim!"+ e ->+ if jsonMode opts+ then return $ W.responseBuilder status500 ctJson $ + fromLazyByteString $ A.encode $ A.object+ [ "status" A..= (500 :: Int)+ , "description" A..= ("Internal Server Error: " <> T.pack (show e))+ ]+ else return $ W.responseBuilder status500 ctText $ "Internal Server Error: " <> fromString (show e)+ where+ ctText = [("Content-Type", "text/plain")]+ ctJson = [("Content-Type", "application/json; charset=utf-8")]++applyAll :: Foldable t => a -> t (a -> a) -> a+applyAll = foldl (flip ($))++notFoundApp :: Monad m => Options -> Application m+notFoundApp opts _ =+ if jsonMode opts+ then return $ W.responseBuilder status404 [("Content-Type","application/json; charset=utf-8")]+ $ fromLazyByteString $ A.encode $ A.object+ [ "status" A..= (404 :: Int)+ , "description" A..= ("File Not Found!" :: T.Text)+ ]+ else return $ W.responseBuilder status404 [("Content-Type","text/html")] $ fromByteString "<h1>404: File Not Found!</h1>" --- | Global handler for uncaught exceptions. ------ Uncaught exceptions normally become 500 responses. --- You can use this to selectively override that behavior.-defaultHandler :: Monad m => (e -> ActionT e m ()) -> ScottyT e m ()-defaultHandler f = ScottyT $ modify $ addHandler $ Just f+-- | Global handler for user-defined exceptions.+defaultHandler :: (Monad m) => ErrorHandler m -> ScottyT m ()+defaultHandler f = ScottyT $ modify $ setHandler $ Just f -- | 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 :: Monad m => 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 -- ^ Request size limit+ -> ScottyT m ()+setMaxRequestBodySize i = assert (i > 0) $ ScottyT . modify . updateMaxRequestBodySize $ defaultRouteOptions { maxRequestBodySize = Just i }+
+ Web/Scotty/Trans/Lazy.hs view
@@ -0,0 +1,85 @@+module Web.Scotty.Trans.Lazy where++import Control.Monad (join)+import Control.Monad.IO.Class+import Data.Bifunctor (bimap)+import qualified Data.Text.Lazy as T+ +import qualified Web.Scotty.Action as Base+import Web.Scotty.Internal.Types++-- | Synonym for 'redirect302'.+-- If you are unsure which redirect to use, you probably want this one.+--+-- > redirect "http://www.google.com"+--+-- OR+--+-- > redirect "/foo/bar"+redirect :: (Monad m) => T.Text -> ActionT m a+redirect = redirect302++-- | Redirect to given URL with status 300 (Multiple Choices). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect300 :: (Monad m) => T.Text -> ActionT m a+redirect300 = Base.redirect300 . T.toStrict++-- | Redirect to given URL with status 301 (Moved Permanently). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect301 :: (Monad m) => T.Text -> ActionT m a+redirect301 = Base.redirect301 . T.toStrict++-- | Redirect to given URL with status 302 (Found). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect302 :: (Monad m) => T.Text -> ActionT m a+redirect302 = Base.redirect302 . T.toStrict++-- | Redirect to given URL with status 303 (See Other). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect303 :: (Monad m) => T.Text -> ActionT m a+redirect303 = Base.redirect303 . T.toStrict++-- | Redirect to given URL with status 304 (Not Modified). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect304 :: (Monad m) => T.Text -> ActionT m a+redirect304 = Base.redirect304 . T.toStrict++-- | Redirect to given URL with status 307 (Temporary Redirect). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect307 :: (Monad m) => T.Text -> ActionT m a+redirect307 = Base.redirect307 . T.toStrict++-- | Redirect to given URL with status 308 (Permanent Redirect). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect308 :: (Monad m) => T.Text -> ActionT m a+redirect308 = Base.redirect308 . T.toStrict++-- | Get a request header. Header name is case-insensitive.+header :: (Monad m) => T.Text -> ActionT m (Maybe T.Text)+header h = fmap T.fromStrict <$> Base.header (T.toStrict h)++-- | Get all the request headers. Header names are case-insensitive.+headers :: (Monad m) => ActionT m [(T.Text, T.Text)]+headers = map (join bimap T.fromStrict) <$> Base.headers++-- | Add to the response headers. Header names are case-insensitive.+addHeader :: MonadIO m => T.Text -> T.Text -> ActionT m ()+addHeader k v = Base.addHeader (T.toStrict k) (T.toStrict v)++-- | Set one of the response headers. Will override any previously set value for that header.+-- Header names are case-insensitive.+setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m ()+setHeader k v = Base.addHeader (T.toStrict k) (T.toStrict v)++text :: (MonadIO m) => T.Text -> ActionT m ()+text = Base.textLazy++html :: (MonadIO m) => T.Text -> ActionT m ()+html = Base.htmlLazy
+ Web/Scotty/Trans/Strict.hs view
@@ -0,0 +1,57 @@+-- | This module is essentially identical to 'Web.Scotty.Trans', except that +-- some functions take/return strict Text instead of the lazy ones.+--+-- It should be noted that most of the code snippets below depend on the+-- OverloadedStrings language pragma.+--+-- The functions in this module allow an arbitrary monad to be embedded+-- in Scotty's monad transformer stack in order that Scotty be combined+-- with other DSLs.+--+-- Scotty is set up by default for development mode. For production servers,+-- you will likely want to modify 'settings' and the 'defaultHandler'. See+-- the comments on each of these functions for more information.+module Web.Scotty.Trans.Strict+ ( -- * scotty-to-WAI+ scottyT, scottyAppT, scottyOptsT, scottySocketT, 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+ -- ** Route Patterns+ , capture, regex, function, literal+ -- ** Accessing the Request, Captures, and Query Parameters+ , request, Base.header, Base.headers, body, bodyReader+ , captureParam, formParam, queryParam+ , captureParamMaybe, formParamMaybe, queryParamMaybe+ , captureParams, formParams, queryParams+ , jsonData, files+ -- ** Modifying the Response + , status, Base.addHeader, Base.setHeader+ -- ** Redirecting+ , Base.redirect, Base.redirect300, Base.redirect301, Base.redirect302, Base.redirect303+ , Base.redirect304, Base.redirect307, Base.redirect308+ -- ** Setting Response Body+ --+ -- | Note: only one of these should be present in any given route+ -- definition, as they completely replace the current 'Response' body.+ , Base.text, Base.html, file, json, stream, raw, nested+ , textLazy+ , htmlLazy+ -- ** Accessing the fields of the Response+ , getResponseHeaders, getResponseStatus, getResponseContent+ -- ** Exceptions+ , throw, next, finish, defaultHandler+ , ScottyException(..)+ -- * Parsing Parameters+ , Param, Parsable(..), readEither+ -- * Types+ , RoutePattern, File, Content(..), Kilobytes, ErrorHandler, Handler(..)+ -- * Monad Transformers+ , ScottyT, ActionT+ , ScottyState, defaultScottyState+ ) where+import Web.Scotty.Action as Base+import Web.Scotty.Trans
− Web/Scotty/Types.hs
@@ -1,128 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses #-}-module Web.Scotty.Types where--import Blaze.ByteString.Builder (Builder)--import Control.Applicative-import Control.Monad.Error-import Control.Monad.Reader-import Control.Monad.State--import Data.ByteString.Lazy.Char8 (ByteString)-import qualified Data.Conduit as C-import Data.Default (Default, def)-import Data.Monoid (mempty)-import Data.String (IsString(..))-import Data.Text.Lazy (Text, pack)--import Network.HTTP.Types--import Network.Wai hiding (Middleware, Application)-import qualified Network.Wai as Wai-import Network.Wai.Handler.Warp (Settings, defaultSettings)-import Network.Wai.Parse (FileInfo)----------------------- Options ------------------------data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner- , settings :: Settings -- ^ Warp 'Settings'- }--instance Default Options where- def = Options 1 defaultSettings------- Transformer Aware Applications/Middleware ------type Middleware m = Application m -> Application m-type Application m = Request -> m Response----------------- Scotty Applications ------------------data ScottyState e m = - ScottyState { middlewares :: [Wai.Middleware]- , routes :: [Middleware m]- , handler :: ErrorHandler e m- }--instance Monad m => Default (ScottyState e m) where- def = ScottyState [] [] Nothing--addMiddleware :: Wai.Middleware -> ScottyState e m -> ScottyState e m-addMiddleware m s@(ScottyState {middlewares = ms}) = s { middlewares = m:ms }--addRoute :: Monad m => Middleware m -> ScottyState e m -> ScottyState e 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 }--newtype ScottyT e m a = ScottyT { runS :: StateT (ScottyState e m) m a }- deriving ( Functor, Applicative, Monad, MonadIO )--instance MonadTrans (ScottyT e) where- lift = ScottyT . lift-------------------- Scotty Errors ---------------------data ActionError e = Redirect Text- | Next- | ActionError 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--instance ScottyError Text where- stringError = pack- showError = id--instance ScottyError e => ScottyError (ActionError e) where- stringError = ActionError . stringError- showError (Redirect url) = url- showError Next = pack "Next"- showError (ActionError e) = showError e--instance ScottyError e => Error (ActionError e) where - strMsg = stringError--type ErrorHandler e m = Maybe (e -> ActionT e m ())-------------------- Scotty Actions --------------------type Param = (Text, Text)--type File = (Text, FileInfo ByteString)--data ActionEnv = Env { getReq :: Request- , getParams :: [Param]- , getBody :: ByteString- , getFiles :: [File] - }--data Content = ContentBuilder Builder- | ContentFile FilePath- | ContentSource (C.Source IO (C.Flush Builder))--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 :: ErrorT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) a }- deriving ( Functor, Applicative, Monad, MonadIO )--instance ScottyError e => MonadTrans (ActionT e) where- lift = ActionT . lift . lift . lift--instance (ScottyError e, Monad m) => MonadError (ActionError e) (ActionT e m) where- throwError = ActionT . throwError-- catchError (ActionT m) f = ActionT (catchError m (runAM . f))-------------------- Scotty Routes ---------------------data RoutePattern = Capture Text- | Literal Text- | Function (Request -> Maybe [Param])--instance IsString RoutePattern where - fromString = Capture . pack
Web/Scotty/Util.hs view
@@ -1,50 +1,100 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# options_ghc -Wno-unused-imports #-} module Web.Scotty.Util ( lazyTextToStrictByteString , strictByteStringToLazyText- , setContent- , setHeaderWith- , setStatus+ , decodeUtf8Lenient , mkResponse , replace , add+ , addIfNotPresent+ , socketDescription+ , readRequestBody ) where +import Network.Socket (SockAddr(..), Socket, getSocketName, socketPort) import Network.Wai -import Network.HTTP.Types-+import Control.Exception+import Control.Monad (when) import qualified Data.ByteString as B-import qualified Data.Text.Lazy as T-import qualified Data.Text.Encoding as ES--import Web.Scotty.Types--lazyTextToStrictByteString :: T.Text -> B.ByteString-lazyTextToStrictByteString = ES.encodeUtf8 . T.toStrict+import qualified Data.Text as TP (Text, pack)+import qualified Data.Text.Lazy as TL+import Data.Text.Encoding as ES+import qualified Data.Text.Encoding.Error as ES -strictByteStringToLazyText :: B.ByteString -> T.Text-strictByteStringToLazyText = T.fromStrict . ES.decodeUtf8+import Web.Scotty.Internal.Types -setContent :: Content -> ScottyResponse -> ScottyResponse-setContent c sr = sr { srContent = c }+lazyTextToStrictByteString :: TL.Text -> B.ByteString+lazyTextToStrictByteString = ES.encodeUtf8 . TL.toStrict -setHeaderWith :: ([(HeaderName, B.ByteString)] -> [(HeaderName, B.ByteString)]) -> ScottyResponse -> ScottyResponse-setHeaderWith f sr = sr { srHeaders = f (srHeaders sr) }+strictByteStringToLazyText :: B.ByteString -> TL.Text+strictByteStringToLazyText = TL.fromStrict . ES.decodeUtf8With ES.lenientDecode -setStatus :: Status -> ScottyResponse -> ScottyResponse-setStatus s sr = sr { srStatus = s }+#if !MIN_VERSION_text(2,0,0)+decodeUtf8Lenient :: B.ByteString -> TP.Text+decodeUtf8Lenient = ES.decodeUtf8With ES.lenientDecode+#endif +-- 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- ContentSource src -> responseSource s h src+ 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 -- Note: we assume headers are not sensitive to order here (RFC 2616 specifies they are not)-replace :: (Eq a) => a -> b -> [(a,b)] -> [(a,b)]-replace k v m = add k v $ filter ((/= k) . fst) m+replace :: Eq a => a -> b -> [(a,b)] -> [(a,b)]+replace k v = add k v . filter ((/= k) . fst) -add :: (Eq a) => a -> b -> [(a,b)] -> [(a,b)]+add :: a -> b -> [(a,b)] -> [(a,b)] add k v m = (k,v):m++addIfNotPresent :: Eq a => a -> b -> [(a,b)] -> [(a,b)]+addIfNotPresent k v = go+ where go [] = [(k,v)]+ go l@((x,y):r)+ | x == k = l+ | otherwise = (x,y) : go r++-- Assemble a description from the Socket's PortID.+socketDescription :: Socket -> IO String+socketDescription sock = do+ sockName <- getSocketName sock+ case sockName of+ SockAddrUnix u -> return $ "unix socket " ++ u+ _ -> fmap (\port -> "port " ++ show port) $ socketPort sock++-- | return request body or throw a 'ScottyException' 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+ readRequestBody rbody (prefix . (b:)) maxSize+ where checkBodyLength :: Maybe Kilobytes -> IO ()+ 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 throwIO RequestTooLarge+ else readUntilEmpty++
+ bench/Main.hs view
@@ -0,0 +1,56 @@+{-# language+ OverloadedStrings+ , GeneralizedNewtypeDeriving+ #-}++module Main (main) where++import Control.Monad+import Data.Functor.Identity+import Lucid.Base+import Lucid.Html5+import Web.Scotty+import Web.Scotty.Internal.Types+import qualified Control.Monad.Reader as R+import qualified Control.Monad.State.Lazy as SL+import qualified Control.Monad.State.Strict as SS+import qualified Data.ByteString.Lazy as BL++import Weigh++main :: IO ()+main = do+ mainWith $ do+ setColumns [Case,Allocated,GCs,Live,Check,Max,MaxOS]+ setFormat Markdown+ io "ScottyM Strict" BL.putStr+ (SS.evalState+ (R.runReaderT (runS $ renderBST htmlScotty) defaultOptions)+ defaultScottyState)+ io "ScottyM Lazy" BL.putStr+ (SL.evalState (runScottyLazy $ renderBST htmlScottyLazy) defaultScottyState)+ io "Identity" BL.putStr+ (runIdentity $ renderBST htmlIdentity)+++htmlTest :: Monad m => HtmlT m ()+htmlTest = replicateM_ 2 $ div_ $ do+ replicateM_ 1000 $ div_ $ do+ replicateM_ 10000 $ div_ "test"++htmlIdentity :: HtmlT Identity ()+htmlIdentity = htmlTest+{-# noinline htmlIdentity #-}++htmlScotty :: HtmlT ScottyM ()+htmlScotty = htmlTest+{-# noinline htmlScotty #-}++htmlScottyLazy :: HtmlT ScottyLazy ()+htmlScottyLazy = htmlTest+{-# noinline htmlScottyLazy #-}++newtype ScottyLazy a = ScottyLazy+ { runScottyLazy:: SL.State (ScottyState IO) a }+ deriving (Functor,Applicative,Monad)+
+ changelog.md view
@@ -0,0 +1,296 @@+## 0.30 [2026.01.06]++* Added sessions (#317).+* Fixed cookie example from `Cookie` module documentation. `getCookie` Function would return strict variant of `Text`. Will convert it into lazy variant using `fromStrict`. +* Exposed simple functions of `Cookie` module via `Web.Scotty` & `Web.Scotty.Trans`.+* Add tests for URL encoding of query parameters and form parameters. Add `formData` action for decoding `FromForm` instances (#321).+* Add explicit redirect functions for all redirect status codes.+* Added ActionM variants for cookie module functions (#406).+* Updated `Parsable` instance for `Bool` to accept `on` for HTML form checkboxes.+* Add tests demonstrating usage of `Network.Wai.Middleware.ValidateHeaders` from wai-extra for header validation (#359).+* Added `jsonMode` flag to `Options` to return JSON-formatted error responses instead of HTML (#97). When enabled, all default error handlers (404, 500, etc.) return JSON with format `{"status": <code>, "description": "<message>"}`. Content-Type is set to `application/json; charset=utf-8`.+* Added middleware example demonstrating request logging and request header validation using WAI middlewares (#199, #385).++### Breaking changes+* Remove dependency on data-default class (#386). We have been exporting constants for default config values since 0.20, and this dependency was simply unnecessary.+* Remove re-export of `Network.Wai.Parse.ParseRequestBodyOptions` from `Web.Scotty` and `Web.Scotty.Trans`. This is a type from `wai-extra` so exporting it is unnecessary.+* Remove deprecated exports (#408) `liftAndCatchIO`, `param`, `params`, `raise`, `raiseStatus`, `rescue` from `Web.Scotty` and `Web.Scotty.Trans`.+* Remove deprecated `StatusError` type from `Scotty.Internal.Types`.+* Remove typeclass instance `MonadError StatusError (ActionT m)` from `Scotty.Internal.Types`.++## 0.22 [2024.03.09]++### New+* add `instance Parsable UTCTime` (#250)+* add `filesOpts` (#369). Form parameters and files are only parsed from the request body if needed; `filesOpts` introduces options to customize upload limits, a mechanism to back uploads with temporary files based on resourcet, as well as a continuation-based syntax to process such temporary files. ++### Fixes+* `files` does not accept unbounded uploads anymore (see #183, #203), but like `filesOpts` it is backed by temporary files which are read back in memory and removed right away. The limits for `files` are prescribed by `defaultParseBodyOptions` in wai-extra (#369).+* Path parameters with value matching the parameter name prefixed by colon will properly populate `pathParams` with their literal value : `/:param` will match `/:param` and add a `Param` with value `("param", ":param")` (#301)+* Accept text-2.1 (#364)+* Remove dependency upper bounds on `text` and `bytestring` (#371)+* When in 'verbose' mode any unhandled exceptions are printed to stderr as well (#374)++### Breaking changes+* some ActionT API functions have now a MonadIO or MonadUnliftIO constraint rather than Monad reflecting that there is where request reading takes place. E.g. `files` has now a MonadUnliftIO constraint on its base monad. (#369)+* the File type has now a type parameter to reflect whether it carries file contents or just a filepath pointing to the temp file (#369).++++## 0.21 [2023.12.17]+### New+* add `getResponseHeaders`, `getResponseStatus`, `getResponseContent` (#214)+* add `captureParamMaybe`, `formParamMaybe`, `queryParamMaybe` (#322)+* add `Web.Scotty.Trans.Strict` and `Web.Scotty.Trans.Lazy` (#334)+* renamed `captureParam`, `captureParamMaybe`, and `captureParams` to `pathParam`, `pathParamMaybe`, `pathParams` respectively, keeping the old names as their synonyms (#344)++### Deprecated+* deprecate `rescue` and `liftAndCatchIO` (#332)+* Deprecate `StatusError`, `raise` and `raiseStatus` (#351)++### Fixes+* Reverted the `MonadReader` instance of `ActionT` so that it inherits the base monad (#342)+* Scotty's API such as `queryParam` now throws `ScottyException` rather than `StatusException`.+ Uncaught exceptions are handled by `scottyExceptionHandler`, resembling the existing behaviour+ +### Breaking changes+* `File` type: the first component of the tuple is strict text now (used to be lazy prior to 0.21) (#370)++### Documentation+* Add doctest, refactor some inline examples into doctests (#353)+* document "`defaultHandler` only applies to endpoints defined after it" (#237)++++## 0.20.1 [2023.10.03]+* remove dependencies on 'base-compat' and 'base-compat-batteries' (#318)+* re-add MonadFail (ActionT m) instance (#325)+* re-add MonadError (ActionT m) instance, but the error type is now specialized to 'StatusError' (#325)+* raise lower bound on base ( > 4.14 ) to reflect support for GHC >= 8.10 (#325).+++## 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`.+* (#310) Clarify the exception handling mechanism of ActionT, ScottyT. `rescue` changes signature to use proper `Exception` types rather than strings. Remove `ScottyError` typeclass.+* (#310) 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.+* (#310) MonadError e (ActionT m) instance removed+* (#310) MonadFail (ActionT m) instance is missing by mistake.++## 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+ `MonadTrans t` class gained a `forall m. Monad m => Monad (t m)` superclass+ in `transformers-0.6.0.0`, the `MonadTrans` and `MonadTransControl` instances+ for `ActionT e` now have a `ScottyError e` instance context to match the+ `Monad` instance.++## 0.12 [2020.05.16]+* Provide `MonadReader` and `MonadState` instances for `ActionT`.+* Add HTTP Status code as a field to `ActionError`, and add+ a sister function to `raise`, `raiseStatus`. This makes+ throwing a specific error code and exiting much cleaner, and+ avoids the strange defaulting to HTTP 500. This will make internal+ functions easier to implement with the right status codes 'thrown',+ such as `jsonData`.+* Correct http statuses returned by `jsonData` (#228).+* Better error message when no data is provided to `jsonData` (#226).+* Add `Semigroup` and `Monoid` instances for `ActionT` and `ScottyT`+* ScottyT: Use strict StateT instead of lazy+* Handle adjacent slashes in the request path as one (thanks @SkyWriter)++## 0.11.5 [2019.09.07]+* Allow building the test suite with `hspec-wai-0.10`.++## 0.11.4 [2019.05.02]+* Allow building with `base-4.13` (GHC 8.8).++## 0.11.3 [2019.01.08]+* Drop the test suite's dependency on `hpc-coveralls`, which is unmaintained+ and does not build with GHC 8.4 or later.++## 0.11.2 [2018.07.02]+* Migrate from `Network` to `Network.Socket` to avoid deprecation warnings.++## 0.11.1 [2018.04.07]+* Add `MonadThrow` and `MonadCatch` instances for `ActionT` [abhinav]+* Fix `matchAny` so that all methods are matched, not just standard ones+ [taphu]++## 0.11.0+* IO exceptions are no longer automatically turned into ScottyErrors by+ `liftIO`. Use `liftAndCatchIO` to get that behavior.+* New `finish` function.+* Text values are now leniently decoded from ByteStrings.+* Added `MonadFail` instance for `ScottyT`+* Lots of bound bumps on dependencies.++## 0.10.2+* Removed debug statement from routes++## 0.10.1+* `Parsable` instances for `Word`, `Word8`, `Word16`, `Word32`, `Word64`+ [adamflott]+* `Parsable` instances for `Int8`, `Int16`, `Int32`, `Int64`, and `Natural`+* Removed redundant `Monad` constraint on `middleware`++## 0.10.0++* The monad parameters to `ScottyT` have been decoupled, causing the type+ of the `ScottyT` constructor to change. As a result, `ScottyT` is no+ longer a `MonadTrans` instance, and the type signatures of`scottyT`,+ `scottyAppT`, and `scottyOptsT` have been simplified. [ehamberg]++* `socketDescription` no longer uses the deprecated `PortNum` constructor.+ Instead, it uses the `Show` instance for `PortNumber`. This changes the+ bytes from host to network order, so the output of `socketDescription`+ could change. [ehamberg]++* `Alternative`, `MonadPlus` instances for `ActionT`++* `scotty` now depends on `transformers-compat`. As a result, `ActionT` now+ uses `ExceptT`, regardless of which version of `transformers` is used.+ As a result, several functions in `Web.Scotty.Trans` no longer require a+ `ScottyError` constraint, since `ExceptT` does not require an `Error`+ constraint (unlike `ErrorT`).++* Added support for OPTIONS routes via the `options` function [alvare]++* Add `scottySocket` and `scottySocketT`, exposing Warp Unix socket support+ [hakujin]++* `Parsable` instance for lazy `ByteString` [tattsun]++* Added streaming uploads via the `bodyReader` function, which retrieves chunks+ of the request body. [edofic]+ - `ActionEnv` had a `getBodyChunk` field added (in+ `Web.Scotty.Internal.Types`)+ - `RequestBodyState` and `BodyPartiallyStreamed` added to+ `Web.Scotty.Internal.Types`++* `jsonData` uses `aeson`'s `eitherDecode` instead of just `decode` [k-bx]++## 0.9.1++* text/html/json only set Content-Type header when not already set++## 0.9.0++* Add `charset=utf-8` to `Content-Type` for `text`, `html` and `json`++* Assume HTTP status 500 for `defaultHandler`++* Remove deprecated `source` method.++* No longer depend on conduit.++## 0.8.2++* Bump `aeson` upper bound++* Fix `mtl` related deprecation warnings++## 0.8.1++* Export internal types++* Added `MonadBase`, `MonadTransControl` and `MonadBaseControl` instances for+ `ActionT`++## 0.8.0++* Upgrade to wai/wai-extra/warp 3.0++* No longer depend on conduit-extra.++* The `source` response method has been deprecated in favor+ of a new `stream` response, matching changes in WAI 3.0.++* Removed the deprecated `reqHeader` function.++## 0.7.3++* Bump upper bound for case-insensitive, mtl and transformers.++## 0.7.2++* Bump lower bound on conduit, add conduit-extra to cabal build depends.++## 0.7.1++* Default warp settings now use `setFdCacheDuration 0` to work around a warp+ issue where file changes are not getting picked up.++## 0.7.0++* Renamed `reqHeader` to `header`. Added `headers` function to get all headers.++* Changed `MonadIO` instance for `ActionT` such that IO exceptions are lifted+ into `ScottyError`s via `stringError`.++* Make `Bool` parsing case-insensitive. Goal: support both Haskell's True/False+ and Javascript's true/false. Thanks to Ben Gamari for suggesting this.++* Bump `aeson`/`text` upper bounds.++* Bump `wai`/`wai-extra`/`warp` bounds, including new lower bound for `warp`, which fixes a security issue related to Slowloris protection.++## 0.6.2++* Bump upper bound for `text`.++## 0.6.1++* Match changes in `wai-extra`.++## 0.6.0++* The Scotty transformers (`ScottyT` and `ActionT`) are now parameterized+ over a custom exception type, allowing one to extend Scotty's `ErrorT`+ layer with something richer than `Text` errors. See the `exceptions`+ example for use. `ScottyM` and `ActionM` remain specialized to `Text`+ exceptions for simplicity.++* Both monads are now instances of `Functor` and `Applicative`.++* There is a new `cookies` example.++* Internals brought up-to-date with WAI 2.0 and related packages.++## 0.5.0++* The Scotty monads (`ScottyM` and `ActionM`) are now monad transformers,+ allowing Scotty applications to be embedded in arbitrary `MonadIO`s.+ The old API continues to be exported from `Web.Scotty` where:++ type ScottyM = ScottyT IO+ type ActionM = ActionT IO++ The new transformers are found in `Web.Scotty.Trans`. See the+ `globalstate` example for use. Special thanks to Dan Frumin (co-dan)+ for much of the legwork here.++* Added support for HTTP PATCH method.++* Removed lambda action syntax. This will return when we have a better+ story for typesafe routes.++* `reqHeader :: Text -> ActionM Text` ==>+ `reqHeader :: Text -> ActionM (Maybe Text)`++* New `raw` method to set body to a raw `ByteString`++* Parse error thrown by `jsonData` now includes the body it couldn't parse.++* `header` split into `setHeader` and `addHeader`. The former replaces+ a response header (original behavior). The latter adds a header (useful+ for multiple `Set-Cookie`s, for instance).
+ doctest/Main.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE CPP #-}+module Main where++#if __GLASGOW_HASKELL__ >= 946+import Test.DocTest (doctest)++-- 1. Our current doctests require a number of imports that scotty doesn't need+-- 2. declaring doctest helper functions in this module doesn't seem to work+-- 3. cabal tests cannot have exposed modules?+-- 4. GHCi only started supporting multiline imports since 9.4.6 ( https://gitlab.haskell.org/ghc/ghc/-/issues/20473 )+-- so lacking a better option we no-op doctest for older GHCs++main :: IO ()+main = doctest [+ "Web/Scotty.hs"+ , "Web/Scotty/Trans.hs"+ , "-XOverloadedStrings"+ , "-XLambdaCase"+ ]+#else+main :: IO ()+main = pure ()+#endif
+ examples/LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2012-2017 Andrew Farmer+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Andrew Farmer nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
examples/basic.hs view
@@ -1,18 +1,27 @@ {-# 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.Monad.Trans-import Data.Monoid+import Control.Exception (Exception(..))+import Control.Monad+-- import Control.Monad.Trans import System.Random (newStdGen, randomRs) import Network.HTTP.Types (status302)-import Network.Wai-import qualified Data.Text.Lazy as T +import Data.Text.Lazy (pack) import Data.Text.Lazy.Encoding (decodeUtf8)+import Data.String (fromString)+import Data.Typeable (Typeable) +data Err = Boom | UserAgentNotFound | NeverReached deriving (Show, Typeable, Exception)++ main :: IO () main = scotty 3000 $ do -- Add any WAI middleware, they are run top-down.@@ -26,14 +35,24 @@ get "/" $ text "foobar" get "/" $ text "barfoo" - -- Using a parameter in the query string. If it has- -- not been given, a 500 page is generated.- get "/foo" $ do- v <- param "fooparam"+ -- Looking for a parameter in the path. Since the path pattern does not+ -- contain the parameter name 'p', the server responds with 500 Server Error.+ get "/foo_fail" $ do+ v <- pathParam "p" html $ mconcat ["<h1>", v, "</h1>"] + -- Looking for a parameter 'p' in the path.+ get "/foo_path/:p" $ do+ v <- pathParam "p"+ html $ mconcat ["<h1>", v, "</h1>"]++ -- Looking for a parameter 'p' in the query string.+ get "/foo_query" $ do+ v <- queryParam "p"+ html $ mconcat ["<h1>", v, "</h1>"]+ -- An uncaught error becomes a 500 page.- get "/raise" $ raise "some error here"+ get "/raise" $ throw Boom -- You can set status and headers directly. get "/redirect-custom" $ do@@ -43,26 +62,27 @@ -- redirects preempt execution get "/redirect" $ do- redirect "http://www.google.com"- raise "this error is never reached"+ void $ redirect "http://www.google.com"+ throw NeverReached -- Of course you can catch your own errors. get "/rescue" $ do- (do 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")+ `catch` (\(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 <- pathParam "bar" html $ mconcat ["<h1>", v, "</h1>"] -- Files are streamed directly to the client. get "/404" $ file "404.html" + -- 'next' stops execution of the current action and keeps pattern matching routes. get "/random" $ do- next+ void next redirect "http://www.we-never-go-here.com" -- You can do IO with liftIO, and you can return JSON content.@@ -71,7 +91,7 @@ json $ take 20 $ randomRs (1::Int,100) g get "/ints/:is" $ do- is <- param "is"+ is <- pathParam "is" json $ [(1::Int)..10] ++ is get "/setbody" $ do@@ -81,13 +101,24 @@ ,"</form>" ] + -- Read and decode the request body as UTF-8 post "/readbody" $ do b <- body text $ decodeUtf8 b - get "/reqHeader" $ do- agent <- reqHeader "User-Agent"- maybe (raise "User-Agent header not found!") text agent+ -- Look up a request header+ get "/header" $ do+ agent <- header "User-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 {- If you don't want to use Warp as your webserver, you can use any WAI handler.
+ examples/bodyecho.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Web.Scotty++-- import Control.Monad.IO.Class (liftIO)+import qualified Blaze.ByteString.Builder as B+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text.Lazy as T++main :: IO ()+main = scotty 3000 $ do+ post "/echo" $ do+ rd <- bodyReader+ stream $ ioCopy rd $ return ()++ post "/count" $ do+ wb <- body -- this must happen before first 'rd'+ rd <- bodyReader+ let step acc = do + chunk <- rd+ putStrLn "got a chunk"+ let len = BS.length chunk+ if len > 0 + then step $ acc + len+ else return acc+ len <- liftIO $ step 0+ text $ T.pack $ "uploaded " ++ show len ++ " bytes, wb len is " ++ show (BSL.length wb)+++ioCopy :: IO BS.ByteString -> IO () -> (B.Builder -> IO ()) -> IO () -> IO ()+ioCopy reader close write flush = step >> flush where+ step = do chunk <- reader+ if (BS.length chunk > 0) + then (write $ B.insertByteString chunk) >> step+ else close
examples/cookies.hs view
@@ -1,35 +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 as T-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)) $- reqHeader "Cookie"- where- lazyToStrict = BS.concat . BSL.toChunks+import Text.Blaze.Html5.Attributes+import Text.Blaze.Html.Renderer.Text (renderHtml)+import Web.Scotty -- Web.Scotty exports setSimpleCookie,getCookies+import Web.Scotty.Cookie (CookiesText) renderCookiesTable :: CookiesText -> H.Html renderCookiesTable cs =@@ -37,9 +16,9 @@ H.tr $ do H.th "name" H.th "value"- forM_ cs $ \(name, val) -> do+ forM_ cs $ \(name', val) -> do H.tr $ do- H.td (H.toMarkup name)+ H.td (H.toMarkup name') H.td (H.toMarkup val) main :: IO ()@@ -47,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' <- pathParam "name"+ value' <- pathParam "value"+ setSimpleCookie name' value' redirect "/"
examples/exceptions.hs view
@@ -1,42 +1,46 @@ {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}-module Main where+{-# language DeriveAnyClass #-}+{-# language LambdaCase #-}+module Main (main) where -import Control.Applicative-import Control.Monad.Error+import Control.Exception (Exception(..))+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift (MonadUnliftIO(..)) -import Data.Monoid import Data.String (fromString)+import Data.Typeable import Network.HTTP.Types import Network.Wai.Middleware.RequestLogger-import Network.Wai import System.Random import Web.Scotty.Trans --- Define a custom exception type.+-- | A custom exception type. data Except = Forbidden | NotFound Int | StringEx String- deriving (Show, Eq)---- The type must be an instance of 'ScottyError'.--- 'ScottyError' is essentially a combination of 'Error' and 'Show'.-instance ScottyError Except where- stringError = StringEx- showError = fromString . show+ deriving (Show, Eq, Typeable, Exception) --- Handler for uncaught exceptions.-handleEx :: Monad m => Except -> ActionT Except m ()-handleEx Forbidden = do+-- | User-defined exceptions should have an associated Handler:+handleEx :: MonadIO m => ErrorHandler m+handleEx = Handler $ \case+ Forbidden -> do status status403 html "<h1>Scotty Says No</h1>"-handleEx (NotFound i) = do+ NotFound i -> do status status404 html $ fromString $ "<h1>Can't find " ++ show i ++ ".</h1>"+ StringEx s -> do+ status status500+ html $ fromString $ "<h1>" ++ s ++ "</h1>" main :: IO ()-main = scottyT 3000 id id $ do -- note, we aren't using any additional transformer layers- -- so we can just use 'id' for the runners.+main = do+ scottyT 3000 id server -- note: we use 'id' since we don't have to run any effects at each action++-- Any custom monad stack will need to implement 'MonadUnliftIO'+server :: MonadUnliftIO m => ScottyT m ()+server = do middleware logStdoutDev defaultHandler handleEx -- define what to do with uncaught exceptions@@ -50,13 +54,13 @@ ] get "/switch/:val" $ do- v <- param "val"- if even v then raise Forbidden else raise (NotFound v)+ v <- pathParam "val"+ _ <- if even v then throw Forbidden else throw (NotFound v) text "this will never be reached" get "/random" $ do rBool <- liftIO randomIO i <- liftIO randomIO let catchOne Forbidden = html "<h1>Forbidden was randomly thrown, but we caught it."- catchOne other = raise other- raise (if rBool then Forbidden else NotFound i) `rescue` catchOne+ catchOne other = throw other+ throw (if rBool then Forbidden else NotFound i) `catch` catchOne
examples/globalstate.hs view
@@ -7,14 +7,13 @@ -- is IO itself. The types of 'scottyT' and 'scottyAppT' are -- general enough to allow a Scotty application to be -- embedded into any MonadIO monad.-module Main where+module Main (main) where import Control.Concurrent.STM-import Control.Monad.Reader +import Control.Monad.IO.Unlift (MonadUnliftIO(..))+import Control.Monad.Reader -import Data.Default import Data.String-import Data.Text.Lazy (Text) import Network.Wai.Middleware.RequestLogger @@ -22,21 +21,21 @@ 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 -- to provide the state to _every action_, and save the resulting -- state, using an MVar. This means actions would be blocking, -- effectively meaning only one request could be serviced at a time.--- The 'ReaderT' solution means only actions that actually modify +-- The 'ReaderT' solution means only actions that actually modify -- the state need to block/retry.--- +-- -- 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 (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@@ -53,19 +52,17 @@ main :: IO () main = do- sync <- newTVarIO def- -- Note that 'runM' is only called once, at startup.- let runM m = runReaderT (runWebM m) sync+ sync <- newTVarIO defaultAppState -- 'runActionToIO' is called once per action.- runActionToIO = runM+ let runActionToIO m = runReaderT (runWebM m) sync - scottyT 3000 runM runActionToIO app+ scottyT 3000 runActionToIO app -- This app doesn't use raise/rescue, so the exception -- type is ambiguous. We can fix it by putting a type -- annotation just about anywhere. In this case, we'll -- just do it on the entire app.-app :: ScottyT Text WebM ()+app :: ScottyT WebM () app = do middleware logStdoutDev get "/" $ do
examples/gzip.hs view
@@ -1,13 +1,15 @@ {-# LANGUAGE OverloadedStrings #-}+module Main (main) where+ import Network.Wai.Middleware.RequestLogger-import Network.Wai.Middleware.Gzip+import Network.Wai.Middleware.Gzip (defaultGzipSettings, GzipSettings(..), GzipFiles(..), gzip) import Web.Scotty main :: IO () main = scotty 3000 $ do -- Note that files are not gzip'd by the default settings.- middleware $ gzip $ def { gzipFiles = GzipCompress }+ middleware $ gzip $ defaultGzipSettings { gzipFiles = GzipCompress } middleware logStdoutDev -- gzip a normal response
+ examples/json_mode.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Example demonstrating JSON mode in Scotty+--+-- By default, Scotty returns HTML error responses. Setting jsonMode = True+-- in Options causes all error responses to be returned as JSON instead.+--+-- To test:+-- cabal run scotty-json-mode+-- curl http://localhost:3000/ # HTML welcome page+-- curl http://localhost:3000/missing # 404 error as HTML+-- curl http://localhost:3000/error # 500 error as HTML (missing path param)+--+-- To enable JSON mode, change `useJsonMode = False` to `useJsonMode = True` below+module Main (main) where++import Web.Scotty+import Data.Aeson (object, (.=))+import qualified Data.Text.Lazy as TL++-- | Toggle this to test JSON mode+useJsonMode :: Bool+useJsonMode = False++main :: IO ()+main = do+ if useJsonMode+ then do+ putStrLn "\n=== Running server with JSON mode ENABLED ==="+ putStrLn "All error responses will be returned as JSON"+ else do+ putStrLn "\n=== Running server with HTML mode (default) ==="+ putStrLn "Error responses will be returned as HTML"+ + putStrLn "\nEndpoints to test:"+ putStrLn " http://localhost:3000/ - Welcome page"+ putStrLn " http://localhost:3000/missing - 404 Not Found"+ putStrLn " http://localhost:3000/error - 500 Internal Server Error"+ putStrLn "\nPress Ctrl+C to stop\n"+ + scottyOpts (defaultOptions { jsonMode = useJsonMode }) $ do+ get "/" $ do+ if useJsonMode+ then json $ object + [ "message" .= ("Welcome! JSON mode is ON" :: TL.Text)+ , "endpoints" .= object + [ "notFound" .= ("/missing" :: String)+ , "error" .= ("/error" :: String)+ ]+ ]+ else html "<h1>Welcome! JSON mode is OFF (default)</h1><ul><li><a href='/missing'>404 Example</a></li><li><a href='/error'>500 Example</a></li></ul>"+ + get "/error" $ do+ -- This will trigger a 500 error because we're trying to access a non-existent path parameter+ _ <- pathParam "nonexistent" :: ActionM TL.Text+ text "This will never be reached"
+ examples/middleware.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Web.Scotty+import Network.Wai.Middleware.RequestLogger+import Network.Wai.Middleware.ValidateHeaders (validateHeadersMiddleware, defaultValidateHeadersSettings)+import Data.Aeson (object, (.=))+import qualified Data.Text.Lazy as TL+import qualified Data.ByteString.Lazy as BL++main :: IO ()+main = do+ putStrLn "\n=== Scotty Middleware Example ==="+ putStrLn "\nThis example demonstrates two WAI middlewares:"+ putStrLn "1. Request Logging - logs all HTTP requests to stdout"+ putStrLn "2. Header Validation - validates incoming request headers\n"+ putStrLn "The validateHeadersMiddleware checks REQUEST headers from clients."+ putStrLn "It rejects requests with invalid headers (containing illegal characters)"+ putStrLn "such as CR/LF, control characters, or invalid header names.\n"+ putStrLn "Try these requests:"+ putStrLn " curl http://localhost:3000/"+ putStrLn " curl -H 'X-Custom: value' http://localhost:3000/headers"+ putStrLn " curl -H 'X-Token!#$: valid' http://localhost:3000/headers"+ putStrLn "\nTo test invalid headers (these will return 500):"+ putStrLn " curl -H 'Invalid Header: value' http://localhost:3000/ # header name cannot contain spaces"+ putStrLn " Note: Headers with CR/LF in values will also be rejected"+ putStrLn "\nPress Ctrl+C to stop\n"+ + scotty 3000 $ do+ -- Request logging middleware - logs all requests to stdout in development format+ middleware logStdoutDev+ + -- Header validation middleware - validates REQUEST headers to prevent header injection+ -- This middleware checks headers sent by the CLIENT and rejects malformed ones+ -- It validates both header names and values according to HTTP specifications+ middleware $ validateHeadersMiddleware defaultValidateHeadersSettings+ + -- Endpoint group 1: Basic endpoints that demonstrate logging+ get "/" $ do+ text "Welcome! This request was logged by the logging middleware."+ + get "/hello/:name" $ do+ name <- pathParam "name"+ text $ "Hello, " <> name <> "! Check the server logs to see the request details."+ + -- Endpoint group 2: Shows all request headers that passed validation+ get "/headers" $ do+ allHeaders <- headers+ let formatHeader (name, value) = + name <> ": " <> value <> "\n"+ headerList = map formatHeader allHeaders+ text $ mconcat + [ "Your request headers (all validated by middleware):\n\n"+ , mconcat headerList+ , "\nThese headers passed validation. Invalid headers would have been rejected with 500.\n"+ , "Try sending a request with invalid headers to see the middleware in action."+ ]+ + -- Endpoint group 3: Demonstrates specific header inspection+ get "/user-agent" $ do+ agent <- header "User-Agent"+ case agent of+ Just ua -> text $ "Your User-Agent: " <> ua+ Nothing -> text "No User-Agent header provided"+ + -- Endpoint group 4: POST request to demonstrate logging of different methods+ post "/echo" $ do+ requestBody <- body+ text $ "Request body received (" <> TL.pack (show (BL.length requestBody)) <> " bytes). Check server logs for details."+ + -- Endpoint group 5: JSON response with logging+ get "/json" $ do+ json $ object + [ "message" .= ("All request headers were validated" :: String)+ , "middleware" .= object+ [ "logging" .= ("logStdoutDev" :: String)+ , "validation" .= ("validateHeadersMiddleware" :: String)+ ]+ ]
+ examples/nested.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Web.Scotty+import Network.Wai+import qualified Data.Text.Lazy as TL+import Network.HTTP.Types.Status+import Data.Monoid (mconcat)++simpleApp :: Application+simpleApp _ respond = do+ putStrLn "I've done some IO here"+ respond $ responseLBS+ status200+ [("Content-Type", "text/plain")]+ "Hello, Web!"++scottApp :: IO Application+scottApp = scottyApp $ do++ get "/" $ do+ html $ mconcat ["<h1>Scotty, beam me up!</h1>"]++ get "/other/test/:word" $ do+ beam <- param "word"+ html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"]++ get "/test/:word" $ do+ beam <- param "word"+ html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"]++ get "/nested" $ nested simpleApp+ get "/other/nested" $ nested simpleApp++ notFound $ do+ r <- request+ html (TL.pack (show (pathInfo r)))++ -- For example, returns path info: ["other","qwer","adxf","jkashdfljhaslkfh","qwer"]+ -- for request http://localhost:3000/other/qwer/adxf/jkashdfljhaslkfh/qwer++main :: IO ()+main = do++ otherApp <- scottApp++ scotty 3000 $ do++ get "/" $ do+ html $ mconcat ["<h1>Scotty, beam me up!</h1>"]++ get "/test/:word" $ do+ beam <- param "word"+ html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"]++ get "/simple" $ nested simpleApp++ get "/other" $ nested otherApp++ get (regex "/other/.*") $ nested otherApp++
examples/options.hs view
@@ -1,16 +1,17 @@ {-# LANGUAGE OverloadedStrings #-}+module Main (main) where+ import Web.Scotty import Network.Wai.Middleware.RequestLogger -- install wai-extra if you don't have this -import Data.Default (def)-import Network.Wai.Handler.Warp (settingsPort)+import Network.Wai.Handler.Warp (setPort) -- Set some Scotty settings opts :: Options-opts = def { verbose = 0- , settings = (settings def) { settingsPort = 4000 }- }+opts = defaultOptions { verbose = 0+ , settings = setPort 4000 $ settings defaultOptions+ } -- This won't display anything at startup, and will listen on localhost:4000 main :: IO ()
+ examples/reader.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++{-+ An example of embedding a custom monad into Scotty's transformer+ stack, using ReaderT to provide access to a global state.+-}+module Main where++import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, asks, lift, runReaderT)+import Control.Monad.IO.Unlift (MonadUnliftIO(..))+import Data.Text.Lazy (pack)+import Web.Scotty.Trans (ScottyT, defaultOptions, get, scottyOptsT, text)++data Config = Config+ { environment :: String+ } deriving (Eq, Read, Show)++newtype ConfigM a = ConfigM+ { runConfigM :: ReaderT Config IO a+ } deriving (Applicative, Functor, Monad, MonadIO, MonadReader Config, MonadUnliftIO)++application :: ScottyT ConfigM ()+application = do+ get "/" $ do+ e <- lift $ asks environment+ text $ pack $ show e++main :: IO ()+main = scottyOptsT defaultOptions runIO application where+ runIO :: ConfigM a -> IO a+ runIO m = runReaderT (runConfigM m) config++ config :: Config+ config = Config+ { environment = "Development"+ }
+ examples/session.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Web.Scotty+import qualified Data.Text.Lazy as LT+import qualified Data.Text as T++main :: IO ()+main = do+ sessionJar <- liftIO createSessionJar :: IO (SessionJar T.Text)+ scotty 3000 $ do+ -- Login route+ get "/login" $ do+ username <- queryParam "username" :: ActionM String+ password <- queryParam "password" :: ActionM String+ if username == "foo" && password == "bar"+ then do+ _ <- createUserSession sessionJar Nothing "foo"+ text "Login successful!"+ else+ text "Invalid username or password."+ -- Dashboard route+ get "/dashboard" $ do+ mUser <- readUserSession sessionJar+ case mUser of+ Nothing -> text "Hello, user."+ Just userName -> text $ "Hello, " <> LT.fromStrict userName <> "."+ -- Logout route+ get "/logout" $ do+ deleteCookie "sess_id"+ text "Logged out successfully."
examples/upload.hs view
@@ -1,12 +1,16 @@ {-# LANGUAGE OverloadedStrings #-}+{-# language ScopedTypeVariables #-}+module Main (main) where+ import Web.Scotty -import Control.Monad.IO.Class-import Data.Monoid+import Control.Exception (SomeException)+import Data.Foldable (for_)+import qualified Data.Text.Lazy as TL import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.Static-import Network.Wai.Parse+import Network.Wai.Parse (fileName, fileContent, defaultParseRequestBodyOptions) import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes@@ -16,30 +20,43 @@ import qualified Data.ByteString.Char8 as BS import System.FilePath ((</>)) +{-| NB : the file paths where files are saved and looked up are relative, so make sure+to run this program from the root directory of the 'scotty' repo, or adjust the paths+accordingly.+-}+ main :: IO () main = scotty 3000 $ do middleware logStdoutDev- middleware $ staticPolicy (noDots >-> addBase "uploads")+ middleware $ staticPolicy (noDots >-> addBase "examples/uploads") get "/" $ do html $ renderHtml $ H.html $ do H.body $ do H.form H.! method "post" H.! enctype "multipart/form-data" H.! action "/upload" $ do- H.input H.! type_ "file" H.! name "foofile"+ H.input H.! type_ "file" H.! name "file_1" H.br- H.input H.! type_ "file" H.! name "barfile"+ H.input H.! type_ "file" H.! name "file_2" H.br H.input H.! type_ "submit" post "/upload" $ do- fs <- files- let fs' = [ (fieldName, BS.unpack (fileName fi), fileContent fi) | (fieldName,fi) <- fs ]- -- write the files to disk, so they will be served by the static middleware- liftIO $ sequence_ [ B.writeFile ("uploads" </> fn) fc | (_,fn,fc) <- fs' ]- -- generate list of links to the files just uploaded- html $ mconcat [ mconcat [ fName- , ": "- , renderHtml $ H.a (H.toHtml fn) H.! (href $ H.toValue fn) >> H.br- ]- | (fName,fn,_) <- fs' ]+ filesOpts defaultParseRequestBodyOptions $ \_ fs -> do+ let+ fs' = [(fieldName, BS.unpack (fileName fi), fileContent fi) | (fieldName, fi) <- fs]+ -- write the files to disk, so they can be served by the static middleware+ for_ fs' $ \(_, fnam, fpath) -> do+ -- copy temp file to local dir+ liftIO (do+ fc <- B.readFile fpath+ B.writeFile ("examples" </> "uploads" </> fnam) fc+ ) `catch` (\(e :: SomeException) -> do+ liftIO $ putStrLn $ unwords ["upload: something went wrong while saving temp files :", show e]+ )+ -- generate list of links to the files just uploaded+ html $ mconcat [ mconcat [ TL.fromStrict fName+ , ": "+ , renderHtml $ H.a (H.toHtml fn) H.! (href $ H.toValue fn) >> H.br+ ]+ | (fName,fn,_) <- fs' ]
+ examples/uploads/.keep view
examples/urlshortener.hs view
@@ -1,11 +1,16 @@ {-# LANGUAGE OverloadedStrings #-}+{-# language DeriveAnyClass #-}+{-# language LambdaCase #-}+-- {-# language ScopedTypeVariables #-}+module Main (main) where+ import Web.Scotty import Control.Concurrent.MVar-import Control.Monad.IO.Class+import Control.Exception (Exception(..)) import qualified Data.Map as M-import Data.Monoid (mconcat) import qualified Data.Text.Lazy as T+import Data.Typeable (Typeable) import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.Static@@ -19,16 +24,21 @@ 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 = scotty 3000 $ do+main = do+ m <- newMVar (0::Int, M.empty :: M.Map Int T.Text)+ scotty 3000 $ do middleware logStdoutDev middleware static - m <- liftIO $ newMVar (0::Int,M.empty :: M.Map Int T.Text)- get "/" $ do html $ renderHtml $ H.html $ do@@ -38,20 +48,20 @@ H.input H.! type_ "submit" post "/shorten" $ do- url <- param "url"+ url <- formParam "url" liftIO $ modifyMVar_ m $ \(i,db) -> return (i+1, M.insert i (T.pack url) db) redirect "/list" -- We have to be careful here, because this route can match pretty much anything. -- Thankfully, the type system knows that 'hash' must be an Int, so this route- -- only matches if 'read' can successfully parse the hash capture as an Int.+ -- only matches if 'parseParam' can successfully parse the hash capture as an Int. -- Otherwise, the pattern match will fail and Scotty will continue matching -- subsequent routes. get "/:hash" $ do- hash <- param "hash"+ hash <- captureParam "hash" (_,db) <- liftIO $ readMVar m case M.lookup hash db of- Nothing -> raise $ mconcat ["URL hash #", T.pack $ show $ hash, " not found in database!"]+ Nothing -> throw $ UrlHashNotFound hash Just url -> redirect url -- We put /list down here to show that it will not match the '/:hash' route above.
scotty.cabal view
@@ -1,13 +1,13 @@ Name: scotty-Version: 0.6.2+Version: 0.30 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 <afarmer@ittc.ku.edu>-Maintainer: Andrew Farmer <afarmer@ittc.ku.edu>-Copyright: (c) 2012-2013 Andrew Farmer+Author: Andrew Farmer <xichekolas@gmail.com>+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 $ do+ main = scotty 3000 $   get "/:word" $ do-     beam <- param "word"+     beam <- pathParam "word"     html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"] @ .@@ -44,47 +42,125 @@ [WAI] <http://hackage.haskell.org/package/wai> . [Warp] <http://hackage.haskell.org/package/warp>-+tested-with: GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.6+ , GHC == 9.6.4+ , GHC == 9.8.2 Extra-source-files: README.md- ReleaseNotes.md+ changelog.md examples/404.html- examples/basic.hs- examples/cookies.hs- examples/exceptions.hs- examples/globalstate.hs- examples/gzip.hs- examples/options.hs- examples/upload.hs- examples/urlshortener.hs+ examples/LICENSE+ examples/*.hs examples/static/jquery.js examples/static/jquery-json.js+ examples/uploads/.keep Library Exposed-modules: Web.Scotty Web.Scotty.Trans+ Web.Scotty.Trans.Strict+ Web.Scotty.Internal.Types+ Web.Scotty.Cookie+ Web.Scotty.Session other-modules: Web.Scotty.Action+ Web.Scotty.Body Web.Scotty.Route- Web.Scotty.Types+ Web.Scotty.Trans.Lazy Web.Scotty.Util default-language: Haskell2010- build-depends: aeson >= 0.6.2.1 && < 0.7,- base >= 4.3.1 && < 5,- blaze-builder >= 0.3.3.0 && < 0.4,- bytestring >= 0.10.0.2 && < 0.11,- case-insensitive >= 1.0.0.1 && < 1.2,- conduit >= 1.0.9.3 && < 1.1,- data-default >= 0.5.3 && < 0.6,- http-types >= 0.8.2 && < 0.9,- mtl >= 2.1.2 && < 2.2,- regex-compat >= 0.95.1 && < 0.96,- text >= 0.11.3.1 && < 1.1,- transformers >= 0.3.0.0 && < 0.4,- wai >= 2.0.0 && < 2.1,- wai-extra >= 2.0.1 && < 2.1,- warp >= 2.0.0.1 && < 2.1+ build-depends: aeson >= 0.6.2.1 && < 2.3,+ base >= 4.14 && < 5,+ blaze-builder >= 0.3.3.0 && < 0.5,+ bytestring >= 0.10.0.2 ,+ case-insensitive >= 1.0.0.1 && < 1.3,+ containers >= 0.5 && < 0.8,+ cookie >= 0.4,+ exceptions >= 0.7 && < 0.11,+ http-api-data < 0.7,+ 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.3,+ regex-compat >= 0.95.1 && < 0.96,+ resourcet,+ stm,+ text >= 0.11.3.1 ,+ time >= 1.8,+ transformers >= 0.3.0.0 && < 0.7,+ transformers-base >= 0.4.1 && < 0.5,+ unliftio >= 0.2,+ unordered-containers >= 0.2.10.0 && < 0.3,+ wai >= 3.0.0 && < 3.3,+ wai-extra >= 3.1.14,+ warp >= 3.0.13,+ random >= 1.0.0.0 - GHC-options: -Wall -fno-warn-orphans+ if impl(ghc < 8.0)+ build-depends: fail++ if impl(ghc < 7.10)+ build-depends: nats >= 0.1 && < 2++ GHC-options: -Wall -fno-warn-orphans -Wno-unused-imports++test-suite spec+ main-is: Spec.hs+ other-modules: Web.ScottySpec+ Test.Hspec.Wai.Extra+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: test+ build-depends: async,+ base,+ bytestring,+ directory,+ hspec == 2.*,+ hspec-wai >= 0.6.3,+ http-api-data,+ http-types,+ lifted-base,+ network,+ scotty,+ text,+ time,+ wai,+ wai-extra+ build-tool-depends: hspec-discover:hspec-discover == 2.*+ GHC-options: -Wall -threaded -fno-warn-orphans++test-suite doctest+ main-is: Main.hs+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ GHC-options: -Wall -threaded -fno-warn-orphans+ hs-source-dirs: doctest+ build-depends: base+ , bytestring+ , doctest >= 0.20.1+ , http-client+ , http-types+ , scotty+ , text+ , wai++benchmark weigh+ main-is: Main.hs+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: bench+ build-depends: base,+ scotty,+ lucid,+ bytestring,+ mtl,+ resourcet,+ text,+ transformers,+ weigh >= 0.0.16 && <0.1+ GHC-options: -Wall -O2 -threaded source-repository head type: git
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Test/Hspec/Wai/Extra.hs view
@@ -0,0 +1,65 @@+-- | This should be in 'hspec-wai', PR pending as of Feb 2024 : https://github.com/hspec/hspec-wai/pull/77+--+-- NB the code below has been changed wrt PR 77 and works in the scotty test suite as well.++{-# language OverloadedStrings #-}+module Test.Hspec.Wai.Extra (postMultipartForm, FileMeta(..)) where++import qualified Data.Char as Char+import Data.List (intersperse)++import Data.ByteString (ByteString)+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Lazy as LB++import Data.Word (Word8)++import Network.HTTP.Types (methodPost, hContentType)+import Network.Wai.Test (SResponse)++import Test.Hspec.Wai (request)+import Test.Hspec.Wai.Internal (WaiSession)++-- | @POST@ a @multipart/form-data@ form which might include files.+--+-- The @Content-Type@ is set to @multipart/form-data; boundary=<bd>@ where @bd@ is the part separator without the @--@ prefix.+postMultipartForm :: ByteString -- ^ path+ -> ByteString -- ^ part separator without any dashes+ -> [(FileMeta, ByteString, ByteString, ByteString)] -- ^ (file metadata, field MIME type, field name, field contents)+ -> WaiSession st SResponse+postMultipartForm path sbs =+ request methodPost path [(hContentType, "multipart/form-data; boundary=" <> sbs)] . formMultipartQuery sbs++-- | Encode the body of a multipart form post+--+-- schema from : https://swagger.io/docs/specification/describing-request-body/multipart-requests/+formMultipartQuery :: ByteString -- ^ part separator without any dashes+ -> [(FileMeta, ByteString, ByteString, ByteString)] -- ^ (file metadata, field MIME type, field name, field contents)+ -> LB.ByteString+formMultipartQuery sbs = Builder.toLazyByteString . mconcat . intersperse newline . encodeAll+ where+ encodeAll fs = map encodeFile fs <> [sepEnd]+ encodeFile (fieldMeta, ty, n, payload) = mconcat $ [+ sep+ , newline+ , kv "Content-Disposition" ("form-data;" <> " name=" <> quoted n <> encodeMPField fieldMeta)+ , newline+ , kv "Content-Type" (Builder.byteString ty)+ , newline, newline+ , Builder.byteString payload+ ]+ sep = Builder.byteString ("--" <> sbs)+ sepEnd = Builder.byteString ("--" <> sbs <> "--")+ encodeMPField FMFormField = mempty+ encodeMPField (FMFile fname) = "; filename=" <> quoted fname+ quoted x = Builder.byteString ("\"" <> x <> "\"")+ kv k v = k <> ": " <> v+ newline = Builder.word8 (ord '\n')+++data FileMeta = FMFormField -- ^ any form field except a file+ | FMFile ByteString -- ^ file name+++ord :: Char -> Word8+ord = fromIntegral . Char.ord
+ test/Web/ScottySpec.hs view
@@ -0,0 +1,770 @@+{-# LANGUAGE OverloadedStrings, CPP, ScopedTypeVariables, DeriveGeneric #-}+module Web.ScottySpec (main, spec) where++import Test.Hspec+import Test.Hspec.Wai (WaiSession, with, request, get, post, put, patch, delete, options, (<:>), shouldRespondWith, matchHeaders, matchBody, matchStatus)+import Test.Hspec.Wai.Extra (postMultipartForm, FileMeta(..))++import Control.Applicative+import Control.Monad+import Data.Char+import Data.String+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL+import qualified Data.Text as T+import qualified Data.Text.Lazy.Encoding as TLE+import Data.Time (UTCTime(..))+import Data.Time.Calendar (fromGregorian)+import Data.Time.Clock (secondsToDiffTime)++import GHC.Generics (Generic)++import Network.HTTP.Types+import Network.Wai (Application, Request(queryString), responseLBS)+import Network.Wai.Middleware.ValidateHeaders (validateHeadersMiddleware, defaultValidateHeadersSettings)+import Network.Wai.Parse (defaultParseRequestBodyOptions)+import Network.Wai.Test (SResponse)+import qualified Control.Exception.Lifted as EL+import qualified Control.Exception as E++import Web.FormUrlEncoded (FromForm)+import Web.Scotty as Scotty hiding (get, post, put, patch, delete, request, options)+import qualified Web.Scotty as Scotty+import Web.Scotty.Trans (scottyAppT) -- for testing JSON mode with custom Options+import Web.Scotty (ScottyException(..))+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 qualified Data.ByteString.Lazy as LBS+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)+#endif++main :: IO ()+main = hspec spec++availableMethods :: [StdMethod]+availableMethods = [GET, POST, HEAD, PUT, PATCH, DELETE, OPTIONS]++data SearchForm = SearchForm+ { sfQuery :: Text+ , sfYear :: Int+ } deriving (Generic)++instance FromForm SearchForm where++postForm :: ByteString -> LBS.ByteString -> WaiSession st SResponse+postForm p = request "POST" p [("Content-Type","application/x-www-form-urlencoded")]++spec :: Spec+spec = do+ let withApp = with . scottyApp+ describe "ScottyM" $ do+ forM_ [+ ("GET", Scotty.get, get)+ , ("POST", Scotty.post, (`post` ""))+ , ("PUT", Scotty.put, (`put` ""))+ , ("PATCH", Scotty.patch, (`patch` ""))+ , ("DELETE", Scotty.delete, delete)+ , ("OPTIONS", Scotty.options, options)+ ] $ \(method, route, makeRequest) -> do+ describe (map toLower method) $ do+ withApp (route "/scotty" $ html "") $ do+ it ("adds route for " ++ method ++ " requests") $ do+ makeRequest "/scotty" `shouldRespondWith` 200++ withApp (route "/scotty" $ html "") $ do+ it ("properly handles extra slash routes for " ++ method ++ " requests") $ do+ makeRequest "//scotty" `shouldRespondWith` 200++ withApp (route "/:paramName" $ captureParam "paramName" >>= text) $ do+ it ("captures route parameters for " ++ method ++ " requests when parameter matches its name") $ do+ makeRequest "/:paramName" `shouldRespondWith` ":paramName"+ it ("captures route parameters for " ++ method ++ " requests with url encoded '/' in path") $ do+ makeRequest "/a%2Fb" `shouldRespondWith` "a/b"++ describe "addroute" $ do+ forM_ availableMethods $ \method -> do+ withApp (addroute method "/scotty" $ html "") $ do+ it ("can be used to add route for " ++ show method ++ " requests") $ do+ request (renderStdMethod method) "/scotty" [] "" `shouldRespondWith` 200++ describe "matchAny" $ do+ withApp (matchAny "/scotty" $ html "") $ do+ forM_ ("NONSTANDARD" : fmap renderStdMethod availableMethods) $ \method -> do+ it ("adds route that matches " ++ show method ++ " requests") $ do+ request method "/scotty" [] "" `shouldRespondWith` 200++ describe "notFound" $ do+ withApp (notFound $ html "my custom not found page") $ do+ it "adds handler for requests that do not match any route" $ do+ get "/somewhere" `shouldRespondWith` "my custom not found page" {matchStatus = 404}++ withApp (notFound $ status status400 >> html "my custom not found page") $ do+ it "allows to customize the HTTP status code" $ do+ get "/somewhere" `shouldRespondWith` "my custom not found page" {matchStatus = 400}++ context "when not specified" $ do+ withApp (return ()) $ do+ it "returns 404 when no route matches" $ do+ get "/" `shouldRespondWith` "<h1>404: File Not Found!</h1>" {matchStatus = 404}++ describe "defaultHandler" $ 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 (do+ let h = Handler (\(_ :: E.ArithException) -> status status503)+ defaultHandler h+ Scotty.get "/" (liftIO $ E.throwIO E.DivideByZero)) $ do+ it "allows to customize the HTTP status code" $ do+ get "/" `shouldRespondWith` "" {matchStatus = 503}+ withApp (do+ let h = Handler (\(_ :: E.SomeException) -> setHeader "Location" "/c" >> status status500)+ defaultHandler h+ Scotty.get "/a" (redirect "/b")) $ do+ it "should give priority to actionErrorHandlers" $ do+ get "/a" `shouldRespondWith` 302 { matchHeaders = ["Location" <:> "/b"] }++ context "when not specified" $ do+ withApp (Scotty.get "/" $ throw E.DivideByZero) $ do+ it "returns 500 on exceptions" $ do+ get "/" `shouldRespondWith` 500+ context "only applies to endpoints defined after it (#237)" $ do+ withApp (do+ let h = Handler (\(_ :: E.SomeException) -> status status503 >> text "ok")+ Scotty.get "/a" (throw E.DivideByZero)+ defaultHandler h+ Scotty.get "/b" (throw E.DivideByZero)+ ) $ do+ it "doesn't catch an exception before the handler is set" $ do+ get "/a" `shouldRespondWith` 500+ it "catches an exception after the handler is set" $ do+ get "/b" `shouldRespondWith` "ok" {matchStatus = 503}++ context "custom handlers and HTTP status codes (issue noted by user)" $ do+ withApp (do+ let h = Handler (\(_ :: ScottyException) -> text "Custom error message")+ defaultHandler h+ Scotty.post "/missing-body" $ do+ _ <- jsonData :: ActionM Int+ text "ok"+ ) $ do+ it "custom handler catches exception before status is set (returns 200)" $ do+ -- Note: This demonstrates the issue where custom handlers lose the original status+ -- The scottyExceptionHandler would set 400, but custom handler runs first+ post "/missing-body" "" `shouldRespondWith` "Custom error message" {matchStatus = 200}++ withApp (do+ let h = Handler (\(e :: ScottyException) -> do+ case e of+ MalformedJSON _ _ -> status status400+ QueryParameterNotFound _ -> status status400+ PathParameterNotFound _ -> status status500+ _ -> status status500+ text "Custom error with status")+ defaultHandler h+ Scotty.post "/missing-body" $ do+ _ <- jsonData :: ActionM Int+ text "ok"+ ) $ do+ it "custom handler can manually set appropriate status" $ do+ -- This shows the workaround: custom handlers must explicitly set status+ post "/missing-body" "" `shouldRespondWith` "Custom error with status" {matchStatus = 400}++ withApp (do+ let h = Handler (\(_ :: ScottyException) -> text "Query error")+ defaultHandler h+ Scotty.get "/needs-param" $ do+ _ <- queryParam "missing" :: ActionM Int+ text "ok"+ ) $ do+ it "query parameter exception also returns 200 without explicit status" $ do+ get "/needs-param" `shouldRespondWith` "Query error" {matchStatus = 200}++ withApp (do+ let h = Handler (\(_ :: ScottyException) -> text "Path error")+ defaultHandler h+ Scotty.get "/path/:id" $ do+ _ <- pathParam "nonexistent" :: ActionM Int+ text "ok"+ ) $ do+ it "path parameter exception also returns 200 without explicit status" $ do+ get "/path/123" `shouldRespondWith` "Path error" {matchStatus = 200}+++ 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 (do+ Scotty.setMaxRequestBodySize 1+ Scotty.post "/upload" $ do+ _ <- files+ status status200+ ) $ do+ context "application/x-www-form-urlencoded" $ do+ it "should return 200 OK if the request body size is below 1 KB" $ do+ request "POST" "/upload" [("Content-Type","application/x-www-form-urlencoded")]+ 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","application/x-www-form-urlencoded")]+ large `shouldRespondWith` 413++ withApp (Scotty.post "/" $ status status200) $ do+ context "(counterexample)" $ do+ it "doesn't throw an uncaught exception if the body is large" $ do+ request "POST" "/" [("Content-Type","application/x-www-form-urlencoded")]+ large `shouldRespondWith` 200+ withApp (Scotty.setMaxRequestBodySize 1 >> Scotty.post "/upload" (do status status200)) $ do+ context "multipart/form-data; boundary=--33" $ do+ it "should return 200 OK if the request body size is above 1 KB (since multipart form bodies are only traversed or parsed on demand)" $ do+ request "POST" "/upload" [("Content-Type","multipart/form-data; boundary=--33")]+ large `shouldRespondWith` 200++ describe "middleware" $ do+ context "can rewrite the query string (#348)" $ do+ withApp (do+ Scotty.middleware $ \app req sendResponse ->+ app req{queryString = [("query", Just "haskell")]} sendResponse+ Scotty.matchAny "/search" $ queryParam "query" >>= text+ ) $ do+ it "returns query parameter with given name" $ do+ get "/search" `shouldRespondWith` "haskell"++ context "ValidateHeaders middleware" $ do+ context "rejects invalid header values" $ do+ withApp (do+ Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings+ Scotty.get "/test" $ do+ setHeader "X-Custom" "value\r\nwith\r\nnewlines"+ text "should not reach here"+ ) $ do+ it "returns 500 when header value contains CR/LF" $ do+ get "/test" `shouldRespondWith` 500++ withApp (do+ Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings+ Scotty.get "/test" $ do+ setHeader "X-Custom" "value\nwith\nnewlines"+ text "should not reach here"+ ) $ do+ it "returns 500 when header value contains LF" $ do+ get "/test" `shouldRespondWith` 500++ withApp (do+ Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings+ Scotty.get "/test" $ do+ setHeader "X-Custom" "value\0with\0null"+ text "should not reach here"+ ) $ do+ it "returns 500 when header value contains NUL" $ do+ get "/test" `shouldRespondWith` 500++ withApp (do+ Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings+ Scotty.get "/test" $ do+ setHeader "X-Custom" "trailing space "+ text "should not reach here"+ ) $ do+ it "returns 500 when header value has trailing whitespace" $ do+ get "/test" `shouldRespondWith` 500++ withApp (do+ Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings+ Scotty.get "/test" $ do+ setHeader "X-Custom" " leading space"+ text "should not reach here"+ ) $ do+ it "returns 500 when header value has leading whitespace" $ do+ get "/test" `shouldRespondWith` 500++ context "allows valid header values" $ do+ withApp (do+ Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings+ Scotty.get "/test" $ do+ setHeader "X-Custom" "valid-value"+ text "success"+ ) $ do+ it "returns 200 when header value is valid" $ do+ get "/test" `shouldRespondWith` "success" {matchStatus = 200}++ withApp (do+ Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings+ Scotty.get "/test" $ do+ setHeader "X-Custom" "value with spaces"+ text "success"+ ) $ do+ it "returns 200 when header value contains internal spaces" $ do+ get "/test" `shouldRespondWith` "success" {matchStatus = 200}++ withApp (do+ Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings+ Scotty.get "/test" $ do+ setHeader "Content-Type" "text/plain; charset=utf-8"+ text "success"+ ) $ do+ it "returns 200 for standard Content-Type header" $ do+ get "/test" `shouldRespondWith` 200++ context "can be disabled by not adding the middleware" $ do+ withApp (do+ Scotty.get "/test" $ do+ setHeader "X-Custom" "value\r\nwith\r\nnewlines"+ text "no validation"+ ) $ do+ it "allows invalid headers when middleware is not enabled" $ do+ get "/test" `shouldRespondWith` "no validation" {matchStatus = 200}++ describe "ActionM" $ do+ 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` 500++ 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"++ context "MonadFail instance" $ do+ withApp (Scotty.get "/" $ fail "boom!") $ do+ it "returns 500 if not caught" $+ get "/" `shouldRespondWith` 500+ withApp (Scotty.get "/" $ fail "boom!" `catch` (\(_ :: E.SomeException) -> do + status status200+ text "ok")) $+ it "can catch the Exception thrown by fail" $ do+ get "/" `shouldRespondWith` 200 { matchBody = "ok"}++ 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 "redirect300" $ do+ withApp (+ do+ Scotty.get "/a" $ redirect300 "/b"+ ) $ do+ it "Responds with a 300 Redirect" $ do+ get "/a" `shouldRespondWith` 300 { matchHeaders = ["Location" <:> "/b"] }+++ describe "redirect301" $ do+ withApp (+ do+ Scotty.get "/a" $ redirect301 "/b"+ ) $ do+ it "Responds with a 301 Redirect" $ do+ get "/a" `shouldRespondWith` 301 { matchHeaders = ["Location" <:> "/b"] }++ describe "redirect302" $ do+ withApp (+ do+ Scotty.get "/a" $ redirect302 "/b"+ ) $ do+ it "Responds with a 302 Redirect" $ do+ get "/a" `shouldRespondWith` 302 { matchHeaders = ["Location" <:> "/b"] }+++ describe "redirect303" $ do+ withApp (+ do+ Scotty.delete "/a" $ redirect303 "/b"+ ) $ do+ it "Responds with a 303 as passed in" $ do+ delete "/a" `shouldRespondWith` 303 { matchHeaders = ["Location" <:> "/b"]}++ describe "redirect304" $ do+ withApp (+ do+ Scotty.get "/a" $ redirect304 "/b"+ ) $ do+ it "Responds with a 304 Redirect" $ do+ get "/a" `shouldRespondWith` 304 { matchHeaders = ["Location" <:> "/b"] }++ describe "redirect307" $ do+ withApp (+ do+ Scotty.get "/a" $ redirect307 "/b"+ ) $ do+ it "Responds with a 307 Redirect" $ do+ get "/a" `shouldRespondWith` 307 { matchHeaders = ["Location" <:> "/b"] }++ describe "redirect308" $ do+ withApp (+ do+ Scotty.get "/a" $ redirect308 "/b"+ ) $ do+ it "Responds with a 308 Redirect" $ do+ get "/a" `shouldRespondWith` 308 { matchHeaders = ["Location" <:> "/b"] }++ describe "Parsable" $ do+ it "parses a UTCTime string" $ do+ parseParam "2023-12-18T00:38:00Z" `shouldBe` Right (UTCTime (fromGregorian 2023 12 18) (secondsToDiffTime (60 * 38)) )++ describe "captureParam" $ do+ withApp (+ do+ Scotty.get "/search/:q" $ do+ _ :: Int <- captureParam "q"+ text "int"+ Scotty.get "/search/:q" $ do+ _ :: String <- captureParam "q"+ text "string"+ Scotty.get "/search-time/:q" $ do+ t :: UTCTime <- captureParam "q"+ text $ TL.pack (show t)+ ) $ 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" }+ get "/search-time/2023-12-18T00:38:00Z" `shouldRespondWith` 200 {matchBody = "2023-12-18 00:38:00 UTC"}+ withApp (+ do+ Scotty.get "/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) `catch` (\(_::ScottyException) -> text "z")+ ) $ do+ it "catches a StatusError" $ do+ get "/search/xxx" `shouldRespondWith` 200 { matchBody = "z"}++ describe "queryParam" $ do+ withApp (Scotty.get "/search" $ queryParam "query" >>= text) $ do+ it "returns query parameter with given name" $ do+ get "/search?query=haskell" `shouldRespondWith` "haskell"+ it "decodes URL-encoding" $ do+ get "/search?query=Kurf%C3%BCrstendamm" `shouldRespondWith` "Kurfürstendamm"+ 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))) `catch` (\(_::ScottyException) -> text "z")+ ) $ do+ it "catches a ScottyException" $ do+ get "/search?query=potato" `shouldRespondWith` 200 { matchBody = "z"}+ + describe "formData" $ do+ withApp (Scotty.post "/search" $ formData >>= (text . sfQuery)) $ do+ it "decodes the form" $ do+ postForm "/search" "sfQuery=Haskell&sfYear=2024" `shouldRespondWith` "Haskell"++ it "decodes URL-encoding" $ do+ postForm "/search" "sfQuery=Kurf%C3%BCrstendamm&sfYear=2024" `shouldRespondWith` "Kurfürstendamm"++ it "returns 400 when the form is malformed" $ do+ postForm "/search" "sfQuery=Haskell" `shouldRespondWith` 400++ describe "formParam" $ do+ 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+ postForm "/search" "query=\xe9" `shouldRespondWith` "\xfffd"++ it "decodes URL-encoding" $ do+ postForm "/search" "query=Kurf%C3%BCrstendamm" `shouldRespondWith` "Kurfürstendamm"+ 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 (Scotty.post "/checkbox" (do+ e <- formParam "enabled"+ json (e :: Bool))) $ do+ it "responds with 200 OK if the checkbox parameter can be parsed at the right type" $ do+ postForm "/checkbox" "enabled=true" `shouldRespondWith` 200+ postForm "/checkbox" "enabled=on" `shouldRespondWith` 200+ postForm "/checkbox" "enabled=false" `shouldRespondWith` 200+ it "responds with 400 Bad Request if the checkbox parameter cannot be parsed at the right type" $ do+ postForm "/checkbox" "enabled=undefined" `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))) `catch` (\(_::ScottyException) -> text "z")+ ) $ do+ it "catches a StatusError" $ do+ postForm "/search" "z=potato" `shouldRespondWith` 200 { matchBody = "z"}++ describe "captureParamMaybe" $ do+ withApp (+ do+ Scotty.get "/a/:q" $ do+ mx <- captureParamMaybe "q"+ case mx of+ Just (_ :: Int) -> status status200+ Nothing -> status status500+ Scotty.get "/b/:q" $ do+ mx <- captureParamMaybe "z"+ case mx of+ Just (_ :: TL.Text) -> text "impossible" >> status status500+ Nothing -> status status200+ ) $ do+ it "responds with 200 OK if the parameter can be parsed at the right type, 500 otherwise" $ do+ get "/a/potato" `shouldRespondWith` 500+ get "/a/42" `shouldRespondWith` 200+ it "responds with 200 OK if the parameter is not found" $ do+ get "/b/potato" `shouldRespondWith` 200++ describe "files" $ do+ withApp (Scotty.post "/files" $ do+ fs <- files+ text $ TL.pack $ show $ length fs) $ do+ context "small number of files" $ do+ it "loads uploaded files in memory" $ do+ postMultipartForm "/files" "ABC123" [+ (FMFile "file1.txt", "text/plain;charset=UTF-8", "first_file", "xxx")+ ] `shouldRespondWith` 200 { matchBody = "1"}+ context "file name too long (> 32 bytes)" $ do+ it "responds with 413 - Request Too Large" $ do+ postMultipartForm "/files" "ABC123" [+ (FMFile "file.txt", "text/plain;charset=UTF-8", "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzx", "xxx")+ ] `shouldRespondWith` 413+ context "large number of files (> 10)" $ do+ it "responds with 413 - Request Too Large" $ do+ postMultipartForm "/files" "ABC123" [+ (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"),+ (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"),+ (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"),+ (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"),+ (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"),+ (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"),+ (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"),+ (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"),+ (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"),+ (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"),+ (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx")+ ] `shouldRespondWith` 413+++ describe "filesOpts" $ do+ let+ postMpForm = postMultipartForm "/files" "ABC123" [+ (FMFile "file1.txt", "text/plain;charset=UTF-8", "first_file", "xxx"),+ (FMFile "file2.txt", "text/plain;charset=UTF-8", "second_file", "yyy")+ ]+ processForm = do+ filesOpts defaultParseRequestBodyOptions $ \_ fs -> do+ text $ TL.pack $ show $ length fs+ withApp (Scotty.post "/files" processForm+ ) $ do+ it "loads uploaded files in memory" $ do+ postMpForm `shouldRespondWith` 200 { matchBody = "2"}+ context "preserves the body of a POST request even after 'next' (#147)" $ do+ withApp (do+ Scotty.post "/files" next+ Scotty.post "/files" processForm) $ do+ it "loads uploaded files in memory" $ do+ postMpForm `shouldRespondWith` 200 { matchBody = "2"}+++ describe "text" $ do+ let modernGreekText :: IsString a => a+ modernGreekText = "νέα ελληνικά"++ withApp (Scotty.get "/scotty" $ text modernGreekText) $ do+ it "sets body to given text" $ do+ get "/scotty" `shouldRespondWith` modernGreekText++ it "sets Content-Type header to \"text/plain; charset=utf-8\"" $ do+ get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]}++ withApp (Scotty.get "/scotty" $ setHeader "Content-Type" "text/somethingweird" >> text modernGreekText) $ do+ it "doesn't override a previously set Content-Type header" $ do+ get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/somethingweird"]}++ describe "html" $ do+ let russianLanguageTextInHtml :: IsString a => a+ russianLanguageTextInHtml = "<p>ру́сский язы́к</p>"++ withApp (Scotty.get "/scotty" $ html russianLanguageTextInHtml) $ do+ it "sets body to given text" $ do+ get "/scotty" `shouldRespondWith` russianLanguageTextInHtml++ it "sets Content-Type header to \"text/html; charset=utf-8\"" $ do+ get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/html; charset=utf-8"]}++ withApp (Scotty.get "/scotty" $ setHeader "Content-Type" "text/somethingweird" >> html russianLanguageTextInHtml) $ do+ it "doesn't override a previously set Content-Type header" $ do+ get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/somethingweird"]}++ describe "json" $ do+ withApp (Scotty.get "/scotty" $ setHeader "Content-Type" "text/somethingweird" >> json (Just (5::Int))) $ do+ it "doesn't override a previously set Content-Type header" $ do+ get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/somethingweird"]}++ describe "finish" $ do+ withApp (Scotty.get "/scotty" $ finish) $ do+ it "responds with 200 by default" $ do+ get "/scotty" `shouldRespondWith` 200++ withApp (Scotty.get "/scotty" $ status status400 >> finish >> status status200) $ do+ 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!"}+ + describe "Session Management" $ do+ withApp (Scotty.get "/scotty" $ do+ sessionJar <- liftIO createSessionJar + sess <- createUserSession sessionJar Nothing ("foo" :: T.Text)+ mRes <- readSession sessionJar (sessId sess)+ case mRes of+ Left _ -> Scotty.status status400+ Right res -> do + if res /= "foo" then Scotty.status status400+ else text "all good"+ ) $ do+ it "Roundtrip of session by adding and fetching a value" $ do+ get "/scotty" `shouldRespondWith` 200++ describe "JSON Mode" $ do+ let scottyAppJson = scottyAppT (defaultOptions { jsonMode = True }) id+ let withJsonApp = with . scottyAppJson+ + describe "notFound" $ do+ context "when JSON mode is enabled" $ do+ withJsonApp (return ()) $ do+ it "returns 404 with JSON response" $ do+ get "/" `shouldRespondWith` 404 {matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]}++ describe "exception handlers" $ do+ context "when JSON mode is enabled" $ do+ withJsonApp (Scotty.get "/" $ throw E.DivideByZero) $ do+ it "returns 500 with JSON response for unhandled exceptions" $ do+ get "/" `shouldRespondWith` 500 {matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]}++ withJsonApp (Scotty.get "/param/:id" $ do+ (_ :: Int) <- pathParam "nonexistent"+ text "ok") $ do+ it "returns 500 with JSON response for missing path parameter" $ do+ get "/param/test" `shouldRespondWith` 500 {matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]}++ withJsonApp (Scotty.get "/query" $ do+ (_ :: Int) <- queryParam "missing"+ text "ok") $ do+ it "returns 400 with JSON response for missing query parameter" $ do+ get "/query" `shouldRespondWith` 400 {matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]}++-- Unix sockets not available on Windows+#if !defined(mingw32_HOST_OS)+ describe "scottySocket" .+ it "works with a unix socket" .+ withServer (Scotty.get "/scotty" $ html "") .+ E.bracket (socket AF_UNIX Stream 0) close $ \sock -> do+ connect sock $ SockAddrUnix socketPath+ _ <- send sock "GET /scotty HTTP/1.1\r\n\n"+ r1 <- recv sock 1024+ _ <- send sock "GET /four-oh-four HTTP/1.1\r\n\n"+ r2 <- recv sock 1024+ (BS.take (BS.length ok) r1, BS.take (BS.length no) r2) `shouldBe` (ok, no)+ where ok, no :: ByteString+ ok = "HTTP/1.1 200 OK"+ no = "HTTP/1.1 404 Not Found"++socketPath :: FilePath+socketPath = "/tmp/scotty-test.socket"++withServer :: ScottyM () -> IO a -> IO a+withServer actions inner = E.bracket+ (listenOn socketPath)+ (\sock -> close sock >> removeFile socketPath)+ (\sock -> withAsync (Scotty.scottySocket defaultOptions sock actions) $ const inner)++-- See https://github.com/haskell/network/issues/318+listenOn :: String -> IO Socket+listenOn path =+ bracketOnError+ (socket AF_UNIX Stream 0)+ close+ (\sock -> do+ setSocketOption sock ReuseAddr 1+ bind sock (SockAddrUnix path)+ listen sock maxListenQueue+ return sock+ )+#endif+