packages feed

scotty 0.11.6 → 0.30

raw patch · 32 files changed

Files

README.md view
@@ -1,4 +1,4 @@-# Scotty [![Build Status](https://travis-ci.org/scotty-web/scotty.svg)](https://travis-ci.org/scotty-web/scotty)+# Scotty [![Hackage](http://img.shields.io/hackage/v/scotty.svg)](https://hackage.haskell.org/package/scotty) [![Stackage Lts](http://stackage.org/package/scotty/badge/lts)](http://stackage.org/lts/package/scotty) [![Stackage Nightly](http://stackage.org/package/scotty/badge/nightly)](http://stackage.org/nightly/package/scotty) [![CI](https://github.com/scotty-web/scotty/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/scotty-web/scotty/actions/workflows/haskell-ci.yml)  A Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp. @@ -6,11 +6,9 @@ {-# LANGUAGE OverloadedStrings #-} import Web.Scotty -import Data.Monoid (mconcat)- main = scotty 3000 $     get "/:word" $ do-        beam <- param "word"+        beam <- pathParam "word"         html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"] ``` @@ -21,22 +19,85 @@ * 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/): -### More Information+```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). -### Development & Support+## Contributing -Open an issue on GitHub.+Feel free to ask questions or report bugs on the [Github issue tracker](https://github.com/scotty-web/scotty/issues/). -Copyright (c) 2012-2019 Andrew Farmer+Github issues are now (September 2023) labeled, so newcomers to the Haskell language can start with `easy fix` ones and gradually progress to `new feature`s, `bug`s and `R&D` :)++## 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
Web/Scotty.hs view
@@ -1,56 +1,120 @@-{-# 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, scottySocket, 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, options, 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, header, headers, body, bodyReader, 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, stream, raw+      -- ** Accessing the fields of the Response+    , getResponseHeaders, getResponseStatus, getResponseContent       -- ** Exceptions-    , raise, raiseStatus, rescue, next, finish, defaultHandler, liftAndCatchIO+    , 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 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.Text.Lazy (Text)+import Data.Text.Lazy (Text, toStrict)+import qualified Data.Text as T -import Network.HTTP.Types (Status, StdMethod)+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.Internal.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@@ -69,18 +133,10 @@ -- | Turn a scotty application into a WAI 'Application', which can be -- run with any WAI handler. scottyApp :: ScottyM () -> IO Application-scottyApp = Trans.scottyAppT id+scottyApp = Trans.scottyAppT defaultOptions id --- | Global handler for uncaught exceptions.------ Uncaught exceptions normally become 500 responses.--- You can use this to selectively override that behavior.------ Note: IO exceptions are lifted into Scotty exceptions by default.--- This has security implications, so you probably want to provide your--- own defaultHandler in production which does not send out the error--- strings as 500 responses.-defaultHandler :: (Text -> ActionM ()) -> ScottyM ()+-- | Global handler for user-defined exceptions.+defaultHandler :: ErrorHandler IO -> ScottyM () defaultHandler = Trans.defaultHandler  -- | Use given middleware. Middleware is nested such that the first declared@@ -89,30 +145,48 @@ 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 --- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions turn into HTTP responses corresponding to the given status.-raiseStatus :: Status -> Text -> ActionM a-raiseStatus = Trans.raiseStatus+-- | 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  -- | Abort execution of this action. Like an exception, any code after 'finish'@@ -122,7 +196,7 @@ -- content the text message. -- -- > get "/foo/:bar" $ do--- >   w :: Text <- param "bar"+-- >   w :: Text <- pathParam "bar" -- >   unless (w == "special") finish -- >   text "You made a request to /foo/special" --@@ -130,18 +204,8 @@ finish :: ActionM a finish = Trans.finish --- | Catch an exception thrown by 'raise'.------ > raise "just kidding" `rescue` (\msg -> text msg)-rescue :: ActionM a -> (Text -> ActionM a) -> ActionM a-rescue = Trans.rescue---- | Like 'liftIO', but catch any IO exceptions and turn them into Scotty exceptions.-liftAndCatchIO :: IO a -> ActionM a-liftAndCatchIO = Trans.liftAndCatchIO---- | 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" --@@ -151,14 +215,66 @@ 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. header :: Text -> ActionM (Maybe Text) header = Trans.header@@ -168,6 +284,8 @@ headers = Trans.headers  -- | Get the request body.+--+-- NB: loads the entire request body in memory body :: ActionM ByteString body = Trans.body @@ -178,23 +296,99 @@ 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@@ -239,6 +433,24 @@ 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@@ -272,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 @@ -319,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,35 +1,63 @@ {-# 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-    , liftAndCatchIO+    , htmlLazy     , json     , jsonData+    , formData     , next-    , param-    , params-    , raise-    , raiseStatus+    , pathParam+    , captureParam+    , formParam+    , queryParam+    , pathParamMaybe+    , captureParamMaybe+    , formParamMaybe+    , queryParamMaybe+    , pathParams+    , captureParams+    , formParams+    , queryParams+    , throw     , raw+    , nested     , readEither     , redirect+    , redirect300+    , redirect301+    , redirect302+    , redirect303+    , redirect304+    , redirect307+    , redirect308     , request-    , rescue     , setHeader     , status     , stream     , text+    , textLazy+    , getResponseStatus+    , getResponseHeaders+    , getResponseContent     , Param     , Parsable(..)+    , ActionT       -- private to Scotty     , runAction     ) where@@ -37,21 +65,32 @@ import           Blaze.ByteString.Builder   (fromLazyByteString)  import qualified Control.Exception          as E-import           Control.Monad.Error.Class-import           Control.Monad.Reader       hiding (mapM)-import qualified Control.Monad.State.Strict as MS-import           Control.Monad.Trans.Except+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           Control.Concurrent.MVar+ import qualified Data.Aeson                 as A+import Data.Bool (bool) import qualified Data.ByteString.Char8      as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive       as CI-import           Data.Default.Class         (def)+import           Data.Traversable (for)+import qualified Data.Map.Strict            as Map+import qualified Data.HashMap.Strict        as HM import           Data.Int-import qualified Data.Text                  as ST-import qualified Data.Text.Encoding         as STE-import qualified Data.Text.Lazy             as T-import           Data.Text.Lazy.Encoding    (encodeUtf8)+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@@ -59,130 +98,326 @@ #if !MIN_VERSION_http_types(0,11,0) import           Network.HTTP.Types.Status #endif-import           Network.Wai+import           Network.Wai (Request, Response, StreamingBody, Application, requestHeaders)+import Network.Wai.Handler.Warp (InvalidRequest(..))+import qualified Network.Wai.Parse as W (FileInfo(..), ParseRequestBodyOptions, defaultParseRequestBodyOptions)  import           Numeric.Natural -import           Prelude ()-import           Prelude.Compat-+import           Web.FormUrlEncoded (Form(..), FromForm(..)) import           Web.Scotty.Internal.Types-import           Web.Scotty.Util+import           Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, decodeUtf8Lenient)+import           UnliftIO.Exception (Handler(..), catches, throwIO)+import           System.IO (hPutStrLn, stderr) --- Nothing indicates route failed (due to Next) and pattern matching should continue.--- Just indicates a successful response.-runAction :: (ScottyError e, Monad m) => ErrorHandler e m -> ActionEnv -> ActionT e m () -> m (Maybe Response)-runAction h env action = do-    (e,r) <- flip MS.runStateT def-           $ flip runReaderT env-           $ runExceptT-           $ runAM-           $ action `catchError` (defH h)-    return $ either (const Nothing) (const $ Just $ mkResponse r) e+import Network.Wai.Internal (ResponseReceived(..)) --- | Default error handler for all actions.-defH :: (ScottyError e, Monad m) => ErrorHandler e m -> ActionError e -> ActionT e m ()-defH _          (Redirect url)    = do-    status status302-    setHeader "Location" url-defH Nothing    (ActionError s e)   = do++-- | Evaluate a route, catch all exceptions (user-defined ones, internal and all remaining, in this order)+--   and construct the 'Response'+--+-- 'Nothing' indicates route failed (due to Next) and pattern matching should try the next available route.+-- 'Just' indicates a successful response.+runAction :: MonadUnliftIO m =>+             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-    let code = T.pack $ show $ statusCode s-    let msg = T.fromStrict $ STE.decodeUtf8 $ statusMessage s-    html $ mconcat ["<h1>", code, " ", msg, "</h1>", showError e]-defH h@(Just f) (ActionError _ e)   = f e `catchError` (defH h) -- so handlers can throw exceptions themselves-defH _          Next              = next-defH _          Finish            = return ()+    setHeader "Location" url+  AENext -> next+  AEFinish -> return () --- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions--- turn into HTTP 500 responses.-raise :: (ScottyError e, Monad m) => e -> ActionT e m a-raise = raiseStatus status500+-- | 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+    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 responses corresponding to the given status.-raiseStatus :: (ScottyError e, Monad m) => Status -> e -> ActionT e m a-raiseStatus s = throwError . ActionError s+-- | Uncaught exceptions turn into HTTP 500 Server Error codes+someExceptionHandler :: MonadIO m => 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---- | Like 'liftIO', but catch any IO exceptions and turn them into 'ScottyError's.-liftAndCatchIO :: (ScottyError e, MonadIO m) => IO a -> ActionT e m a-liftAndCatchIO io = ActionT $ do-    r <- liftIO $ liftM Right io `E.catch` (\ e -> return $ Left $ stringError $ show (e :: E.SomeException))-    either throwError return r+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 :: (ScottyError e, Monad m) => ActionT e m a-finish = throwError Finish+finish :: (Monad m) => ActionT m a+finish = E.throw AEFinish  -- | Get the 'Request' object.-request :: Monad m => ActionT e m Request-request = ActionT $ liftM getReq ask+request :: Monad m => ActionT m Request+request = ActionT $ envReq <$> ask  -- | Get list of uploaded files.-files :: Monad m => ActionT e m [File]-files = ActionT $ liftM getFiles ask+--+-- 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.-header :: (ScottyError e, Monad m) => T.Text -> ActionT e m (Maybe T.Text)+header :: (Monad m) => T.Text -> ActionT m (Maybe T.Text) header k = do-    hs <- liftM requestHeaders request-    return $ fmap strictByteStringToLazyText $ lookup (CI.mk (lazyTextToStrictByteString k)) hs+    hs <- requestHeaders <$> request+    return $ fmap decodeUtf8Lenient $ lookup (CI.mk (encodeUtf8 k)) hs  -- | Get all the request headers. Header names are case-insensitive.-headers :: (ScottyError e, Monad m) => ActionT e m [(T.Text, T.Text)]+headers :: (Monad m) => ActionT m [(T.Text, T.Text)] headers = do-    hs <- liftM requestHeaders request-    return [ ( strictByteStringToLazyText (CI.original k)-             , strictByteStringToLazyText v)+    hs <- requestHeaders <$> request+    return [ ( decodeUtf8Lenient (CI.original k)+             , decodeUtf8Lenient v)            | (k,v) <- hs ]  -- | Get the request body.-body :: (ScottyError e,  MonadIO m) => ActionT e m BL.ByteString-body = ActionT ask >>= (liftIO . getBody)+--+-- NB This loads the whole request body in memory at once.+body :: (MonadIO m) => ActionT m BL.ByteString+body = ActionT ask >>= (liftIO . envBody)  -- | Get an IO action that reads body chunks -- -- * This is incompatible with 'body' since 'body' consumes all chunks.-bodyReader :: Monad m => ActionT e m (IO B.ByteString)-bodyReader = ActionT $ getBodyChunk `liftM` ask+bodyReader :: Monad m => ActionT m (IO B.ByteString)+bodyReader = ActionT $ envBodyChunk <$> ask  -- | Parse the request body as a JSON object and return it. --@@ -193,81 +428,237 @@ --   422 Unprocessable Entity. -- --   These status codes are as per https://www.restapitutorial.com/httpstatuscodes.html.-jsonData :: (A.FromJSON a, ScottyError e, MonadIO m) => ActionT e m a+--+-- NB : Internally this uses 'body'.+jsonData :: (A.FromJSON a, MonadIO m) => ActionT m a jsonData = do     b <- body-    when (b == "") $ do-      let htmlError = "jsonData - No data was provided."-      raiseStatus status400 $ stringError htmlError+    when (b == "") $ throwIO $ MalformedJSON b "no data"     case A.eitherDecode b of-      Left err -> do-        let htmlError = "jsonData - malformed."-              `mappend` " Data was: " `mappend` BL.unpack b-              `mappend` " Error was: " `mappend` err-        raiseStatus status400 $ stringError htmlError+      Left err -> throwIO $ MalformedJSON b $ T.pack err       Right value -> case A.fromJSON value of-        A.Error err -> do-          let htmlError = "jsonData - failed parse."-                `mappend` " Data was: " `mappend` BL.unpack b `mappend` "."-                `mappend` " Error was: " `mappend` err-          raiseStatus status422 $ stringError htmlError-        A.Success a -> do-          return a+        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 :: 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 . encodeUtf8+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 t = if t' == T.toCaseFold "true"+    parseParam t = if t' == TL.toCaseFold "true" || t' == TL.toCaseFold "on"                    then Right True-                   else if t' == T.toCaseFold "false"+                   else if t' == TL.toCaseFold "false"                         then Right False                         else Left "parseParam Bool: no parse"-        where t' = T.toCaseFold t+        where t' = TL.toCaseFold t  instance Parsable Double where parseParam = readEither instance Parsable Float where parseParam = readEither@@ -286,60 +677,87 @@ 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 :: Monad m => Status -> ActionT e m ()-status = ActionT . MS.modify . setStatus+-- | Set the HTTP response status.+status :: MonadIO m => Status -> ActionT m ()+status = modifyResponse . setStatus  -- Not exported, but useful in the functions below.-changeHeader :: Monad m+changeHeader :: MonadIO m              => (CI.CI B.ByteString -> B.ByteString -> [(HeaderName, B.ByteString)] -> [(HeaderName, B.ByteString)])-             -> T.Text -> T.Text -> ActionT e m ()-changeHeader f k = ActionT-                 . MS.modify-                 . setHeaderWith-                 . f (CI.mk $ lazyTextToStrictByteString k)-                 . lazyTextToStrictByteString+             -> T.Text -> T.Text -> ActionT m ()+changeHeader f k =+  modifyResponse . setHeaderWith . f (CI.mk $ encodeUtf8 k) . encodeUtf8  -- | Add to the response headers. Header names are case-insensitive.-addHeader :: Monad m => T.Text -> T.Text -> ActionT e m ()+addHeader :: MonadIO m => T.Text -> T.Text -> ActionT m () addHeader = changeHeader add  -- | Set one of the response headers. Will override any previously set value for that header. -- Header names are case-insensitive.-setHeader :: Monad m => T.Text -> T.Text -> ActionT e m ()+setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m () setHeader = changeHeader replace  -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" -- header to \"text/plain; charset=utf-8\" if it has not already been set.-text :: (ScottyError e, Monad m) => T.Text -> ActionT e m ()+text :: (MonadIO m) => T.Text -> ActionT m () text t = do     changeHeader addIfNotPresent "Content-Type" "text/plain; charset=utf-8"-    raw $ encodeUtf8 t+    raw $ BL.fromStrict $ encodeUtf8 t  -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\"+-- header to \"text/plain; charset=utf-8\" if it has not already been set.+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 :: (ScottyError e, Monad m) => T.Text -> ActionT e m ()+html :: (MonadIO m) => T.Text -> ActionT m () html t = do     changeHeader addIfNotPresent "Content-Type" "text/html; charset=utf-8"-    raw $ encodeUtf8 t+    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 :: 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; charset=utf-8\" if it has not already been set.-json :: (A.ToJSON a, ScottyError e, Monad m) => a -> ActionT e m ()+json :: (A.ToJSON a, MonadIO m) => a -> ActionT m () json v = do     changeHeader addIfNotPresent "Content-Type" "application/json; charset=utf-8"     raw $ A.encode v@@ -347,11 +765,22 @@ -- | Set the body of the response to a Source. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'setHeader'.-stream :: Monad m => StreamingBody -> ActionT e m ()-stream = ActionT . MS.modify . setContent . ContentStream+stream :: MonadIO m => StreamingBody -> ActionT m ()+stream = modifyResponse . setContent . ContentStream  -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'setHeader'.-raw :: Monad m => BL.ByteString -> ActionT e m ()-raw = ActionT . MS.modify . setContent . ContentBuilder . fromLazyByteString+raw :: MonadIO m => BL.ByteString -> ActionT m ()+raw = modifyResponse . setContent . ContentBuilder . fromLazyByteString++-- | Nest a whole WAI application inside a Scotty handler.+-- See Web.Scotty for further documentation+nested :: (MonadIO m) => Network.Wai.Application -> ActionT m ()+nested app = do+  -- Is MVar really the best choice here? Not sure.+  r <- request+  ref <- liftIO $ newEmptyMVar+  _ <- 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
@@ -1,259 +1,288 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# 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.Base (MonadBase, liftBase, liftBaseDefault)-import           Control.Monad.Catch (MonadCatch, catch, MonadThrow, throwM)-import           Control.Monad.Error.Class-import qualified Control.Monad.Fail as Fail-import           Control.Monad.Reader-import           Control.Monad.State.Strict-import           Control.Monad.Trans.Control (MonadBaseControl, StM, liftBaseWith, restoreM, ComposeSt, defaultLiftBaseWith, defaultRestoreM, MonadTransControl, StT, liftWith, restoreT)-import           Control.Monad.Trans.Except+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           Data.ByteString.Lazy.Char8 (ByteString)-import           Data.Default.Class (Default, def)+import qualified Data.ByteString.Lazy.Char8 as LBS8 (ByteString) import           Data.String (IsString(..))-import           Data.Text.Lazy (Text, pack)-import           Data.Typeable (Typeable)-+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           Network.Wai.Handler.Warp (Settings, defaultSettings)+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           Prelude ()-import           Prelude.Compat+import UnliftIO.Exception (Handler(..), catch, catches, StringException(..)) +++ --------------------- Options ----------------------- data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner-                       , settings :: Settings -- ^ Warp 'Settings'+                       , 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                        } -instance Default Options where-    def = Options 1 defaultSettings+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 e m =++data ScottyState m =     ScottyState { middlewares :: [Wai.Middleware]-                , routes :: [Middleware m]-                , handler :: ErrorHandler e m+                , routes :: [BodyInfo -> Middleware m]+                , handler :: Maybe (ErrorHandler m)+                , routeOptions :: RouteOptions                 } -instance Default (ScottyState e m) where-    def = ScottyState [] [] Nothing+defaultScottyState :: ScottyState m+defaultScottyState = ScottyState [] [] Nothing defaultRouteOptions -addMiddleware :: Wai.Middleware -> ScottyState e m -> ScottyState e m+addMiddleware :: Wai.Middleware -> ScottyState m -> ScottyState m addMiddleware m s@(ScottyState {middlewares = ms}) = s { middlewares = m:ms } -addRoute :: Middleware m -> ScottyState e m -> ScottyState e m+addRoute :: (BodyInfo -> Middleware m) -> ScottyState m -> ScottyState m addRoute r s@(ScottyState {routes = rs}) = s { routes = r:rs } -addHandler :: ErrorHandler e m -> ScottyState e m -> ScottyState e m-addHandler h s = s { handler = h }+setHandler :: Maybe (ErrorHandler m) -> ScottyState m -> ScottyState m+setHandler h s = s { handler = h } -newtype ScottyT e m a = ScottyT { runS :: State (ScottyState e m) a }+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 ---------------------data ActionError e-  = Redirect Text-  | Next-  | Finish-  | ActionError Status e --- | In order to use a custom exception type (aside from 'Text'), you must--- define an instance of 'ScottyError' for that type.-class ScottyError e where-    stringError :: String -> e-    showError :: e -> Text+-- | Internal exception mechanism used to modify the request processing flow.+--+-- The exception constructor is not exposed to the user and all exceptions of this type are caught+-- and processed within the 'runAction' function.+data ActionError+  = AERedirect 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 -instance ScottyError Text where-    stringError = pack-    showError = id+tryNext :: MonadUnliftIO m => m a -> m Bool+tryNext io = catch (io >> pure True) $+  \case+    AENext -> pure False+    _ -> pure True -instance ScottyError e => ScottyError (ActionError e) where-    stringError = ActionError status500 . stringError-    showError (Redirect url)  = url-    showError Next            = pack "Next"-    showError Finish          = pack "Finish"-    showError (ActionError _ e) = showError e+-- | Specializes a 'Handler' to the 'ActionT' monad+type ErrorHandler m = Handler (ActionT m) () -type ErrorHandler e m = Maybe (e -> ActionT e 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 = (Text, Text)+type Param = (T.Text, T.Text) -type File = (Text, FileInfo ByteString)+-- | 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 { getReq       :: Request-                     , getParams    :: [Param]-                     , getBody      :: IO ByteString-                     , getBodyChunk :: IO BS.ByteString-                     , getFiles     :: [File]+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                      } -data RequestBodyState = BodyUntouched-                      | BodyCached ByteString [BS.ByteString] -- whole body, chunks left to stream-                      | BodyCorrupted -data BodyPartiallyStreamed = BodyPartiallyStreamed deriving (Show, Typeable) -instance E.Exception BodyPartiallyStreamed -data Content = ContentBuilder Builder-             | ContentFile    FilePath-             | ContentStream  StreamingBody+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 -data ScottyResponse = SR { srStatus  :: Status-                         , srHeaders :: ResponseHeaders-                         , srContent :: Content-                         }+getResponse :: MonadIO m => ActionEnv -> m ScottyResponse+getResponse ae = liftIO $ readTVarIO (envResponse ae) -instance Default ScottyResponse where-    def = SR status200 [] (ContentBuilder mempty)+getResponseAction :: (MonadIO m) => ActionT m ScottyResponse+getResponseAction = do+  ae <- ActionT ask+  getResponse ae -newtype ActionT e m a = ActionT { runAM :: ExceptT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) a }-    deriving ( Functor, Applicative, MonadIO )+modifyResponse :: (MonadIO m) => (ScottyResponse -> ScottyResponse) -> ActionT m ()+modifyResponse f = do+  tv <- ActionT $ asks envResponse+  liftIO $ atomically $ modifyTVar' tv f -instance (Monad m, ScottyError e) => Monad (ActionT e m) where-    return = ActionT . return-    ActionT m >>= k = ActionT (m >>= runAM . k)-#if !(MIN_VERSION_base(4,13,0))-    fail = Fail.fail-#endif+data BodyPartiallyStreamed = BodyPartiallyStreamed deriving (Show) -instance (Monad m, ScottyError e) => Fail.MonadFail (ActionT e m) where-    fail = ActionT . throwError . stringError+instance E.Exception BodyPartiallyStreamed -instance ( Monad m, ScottyError e-#if !(MIN_VERSION_base(4,8,0))-         , Functor m-#endif-         ) => Alternative (ActionT e m) where-    empty = mzero-    (<|>) = mplus+data Content = ContentBuilder  Builder+             | ContentFile     FilePath+             | ContentStream   StreamingBody+             | ContentResponse Response -instance (Monad m, ScottyError e) => MonadPlus (ActionT e m) where-    mzero = ActionT . ExceptT . return $ Left Next-    ActionT m `mplus` ActionT n = ActionT . ExceptT $ do-        a <- runExceptT m-        case a of-            Left  _ -> runExceptT n-            Right r -> return $ Right r+data ScottyResponse = SR { srStatus  :: Status+                         , srHeaders :: ResponseHeaders+                         , srContent :: Content+                         } -instance MonadTrans (ActionT e) where-    lift = ActionT . lift . lift . lift+setContent :: Content -> ScottyResponse -> ScottyResponse+setContent c sr = sr { srContent = c } -instance (ScottyError e, Monad m) => MonadError (ActionError e) (ActionT e m) where-    throwError = ActionT . throwError+setHeaderWith :: ([(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)]) -> ScottyResponse -> ScottyResponse+setHeaderWith f sr = sr { srHeaders = f (srHeaders sr) } -    catchError (ActionT m) f = ActionT (catchError m (runAM . f))+setStatus :: Status -> ScottyResponse -> ScottyResponse+setStatus s sr = sr { srStatus = s }  -instance (MonadBase b m, ScottyError e) => MonadBase b (ActionT e m) where-    liftBase = liftBaseDefault+-- | The default response has code 200 OK and empty body+defaultScottyResponse :: ScottyResponse+defaultScottyResponse = SR status200 [] (ContentBuilder mempty)  -instance (MonadThrow m, ScottyError e) => MonadThrow (ActionT e m) where-    throwM = ActionT . throwM+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) -instance (MonadCatch m, ScottyError e) => MonadCatch (ActionT e m) where-    catch (ActionT m) f = ActionT (m `catch` (runAM . f))+withActionEnv :: Monad m =>+                 (ActionEnv -> ActionEnv) -> ActionT m a -> ActionT m a+withActionEnv f (ActionT r) = ActionT $ local f r -instance MonadTransControl (ActionT e) where-     type StT (ActionT e) a = StT (StateT ScottyResponse) (StT (ReaderT ActionEnv) (StT (ExceptT (ActionError e)) a))-     liftWith = \f ->-        ActionT $  liftWith $ \run  ->-                   liftWith $ \run' ->-                   liftWith $ \run'' ->-                   f $ run'' . run' . run . runAM-     restoreT = ActionT . restoreT . restoreT . restoreT+instance MonadReader r m => MonadReader r (ActionT m) where+  ask = ActionT $ lift ask+  local f = ActionT . mapReaderT (local f) . runAM -instance (ScottyError e, MonadBaseControl b m) => MonadBaseControl b (ActionT e m) where-    type StM (ActionT e m) a = ComposeSt (ActionT e) m a-    liftBaseWith = defaultLiftBaseWith-    restoreM     = defaultRestoreM+-- | 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 -instance (MonadReader r m, ScottyError e) => MonadReader r (ActionT e m) where-    {-# INLINE ask #-}-    ask = lift ask-    {-# INLINE local #-}-    local f = ActionT . mapExceptT (mapReaderT (mapStateT $ local f)) . runAM+-- | '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 = (<|>) -instance (MonadState s m, ScottyError e) => MonadState s (ActionT e m) where-    {-# INLINE get #-}-    get = lift get-    {-# INLINE put #-}-    put = lift . put+-- | catches either ActionError (thrown by 'next'),+-- '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 e m a) where+instance (Semigroup a) => Semigroup (ScottyT m a) where   x <> y = (<>) <$> x <*> y  instance   ( Monoid a-#if !(MIN_VERSION_base(4,11,0))-  , Semigroup a-#endif-#if !(MIN_VERSION_base(4,8,0))-  , Functor m-#endif-  ) => Monoid (ScottyT e m a) where+  ) => Monoid (ScottyT m a) where   mempty = return mempty-#if !(MIN_VERSION_base(4,11,0))-  mappend = (<>)-#endif  instance   ( Monad m-#if !(MIN_VERSION_base(4,8,0))-  , Functor m-#endif   , Semigroup a-  ) => Semigroup (ActionT e m a) where+  ) => Semigroup (ActionT m a) where   x <> y = (<>) <$> x <*> y  instance-  ( Monad m, ScottyError e, Monoid a-#if !(MIN_VERSION_base(4,11,0))-  , Semigroup a-#endif-#if !(MIN_VERSION_base(4,8,0))-  , Functor m-#endif-  ) => Monoid (ActionT e m a) where+  ( Monad m, Monoid a+  ) => Monoid (ActionT m a) where   mempty = return mempty-#if !(MIN_VERSION_base(4,11,0))-  mappend = (<>)-#endif  ------------------ Scotty Routes ---------------------data RoutePattern = Capture   Text-                  | Literal   Text+data RoutePattern = Capture   T.Text+                  | Literal   T.Text                   | Function  (Request -> Maybe [Param])  instance IsString RoutePattern where-    fromString = Capture . pack+    fromString = Capture . T.pack++
Web/Scotty/Route.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances,+{-# LANGUAGE FlexibleContexts, FlexibleInstances,              OverloadedStrings, RankNTypes, ScopedTypeVariables #-} module Web.Scotty.Route     ( get, post, put, delete, patch, options, addroute, matchAny, notFound,@@ -6,216 +6,208 @@     ) where  import           Control.Arrow ((***))-import           Control.Concurrent.MVar-import           Control.Exception (throw)-import           Control.Monad.IO.Class+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.Maybe (fromMaybe, isJust) import           Data.String (fromString)-import qualified Data.Text.Lazy as T-import qualified Data.Text as TS+import qualified Data.Text as T  import           Network.HTTP.Types import           Network.Wai (Request(..))-#if MIN_VERSION_wai(3,2,2)-import           Network.Wai.Internal (getRequestBodyChunk)-#endif-import qualified Network.Wai.Parse as Parse hiding (parseRequestBody) -import           Prelude ()-import           Prelude.Compat- import qualified Text.Regex as Regex  import           Web.Scotty.Action-import           Web.Scotty.Internal.Types-import           Web.Scotty.Util +import           Web.Scotty.Internal.Types (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 :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()+options :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () options = addroute OPTIONS  -- | Add a route that matches regardless of the HTTP verb.-matchAny :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()-matchAny pattern action = ScottyT $ MS.modify $ \s -> addRoute (route (handler s) Nothing pattern action) s+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) (Just 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 -> Maybe StdMethod -> RoutePattern -> ActionT e m () -> Middleware m-route h method pat action 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-        -}-        methodMatches :: Bool-        methodMatches =-            case method of-                Nothing -> True-                Just m -> Right m == parseMethod (requestMethod req)-    in if methodMatches-       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) (compress $ 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's Network.Wai.Parse, modified to accept body as list of Bytestrings.--- Reason: WAI's getRequestBodyChunk is an IO action that returns the body as chunks.--- Once read, they can't be read again. We read them into a lazy Bytestring, so Scotty--- user can get the raw body, even if they also want to call wai-extra's parsing routines.-parseRequestBody :: MonadIO m-                 => [B.ByteString]-                 -> Parse.BackEnd y-                 -> Request-                 -> m ([Parse.Param], [Parse.File y])-parseRequestBody bl s r =-    case Parse.getRequestBodyType r of-        Nothing -> return ([], [])-        Just rbt -> do-            mvar <- liftIO $ newMVar bl -- MVar is a bit of a hack so we don't have to inline-                                        -- large portions of Network.Wai.Parse-            let provider = modifyMVar mvar $ \bsold -> case bsold of-                                                []     -> return ([], B.empty)-                                                (b:bs) -> return (bs, b)-            liftIO $ Parse.sinkRequestBody s rbt provider+-- | Parse the request and construct the initial 'ActionEnv' with a default 200 OK response+mkEnv :: MonadIO m =>+         BodyInfo+      -> Request+      -> [Param]+      -> RouteOptions+      -> m ActionEnv+mkEnv bodyInfo req 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 :: forall m. MonadIO m => Request -> [Param] -> m ActionEnv-mkEnv req captures = do-    bodyState <- liftIO $ newMVar BodyUntouched -    let rbody = getRequestBodyChunk req-        takeAll :: ([B.ByteString] -> IO [B.ByteString]) -> IO [B.ByteString]-        takeAll prefix = rbody >>= \b -> if B.null b then prefix [] else takeAll (prefix . (b:)) -        safeBodyReader :: IO B.ByteString-        safeBodyReader =  do-          state <- takeMVar bodyState-          let direct = putMVar bodyState BodyCorrupted >> rbody-          case state of-            s@(BodyCached _ []) ->-              do putMVar bodyState s-                 return B.empty-            BodyCached b (chunk:rest) ->-              do putMVar bodyState $ BodyCached b rest-                 return chunk-            BodyUntouched -> direct-            BodyCorrupted -> direct--        bs :: IO BL.ByteString-        bs = do-          state <- takeMVar bodyState-          case state of-            s@(BodyCached b _) ->-              do putMVar bodyState s-                 return b-            BodyCorrupted -> throw BodyPartiallyStreamed-            BodyUntouched ->-              do chunks <- takeAll return-                 let b = BL.fromChunks chunks-                 putMVar bodyState $ BodyCached b chunks-                 return b--        shouldParseBody = isJust $ Parse.getRequestBodyType req--    (formparams, fs) <- if shouldParseBody-      then liftIO $ do wholeBody <- BL.toChunks `fmap` bs-                       parseRequestBody wholeBody Parse.lbsBackEnd req-      else return ([], [])--    let-        convert (k, v) = (strictByteStringToLazyText k, strictByteStringToLazyText v)-        parameters =  captures ++ map convert formparams ++ queryparams-        queryparams = parseEncodedParams $ rawQueryString req--    return $ Env req parameters bs safeBodyReader [ (strictByteStringToLazyText k, fi) | (k,fi) <- fs ]+parseEncodedParams :: 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.@@ -233,26 +225,22 @@ capture :: String -> RoutePattern 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  -- | Build a route that requires the requested path match exactly, without captures. literal :: String -> RoutePattern literal = Literal . T.pack--#if !(MIN_VERSION_wai(3,2,2))-getRequestBodyChunk :: Request -> IO B.ByteString-getRequestBodyChunk = requestBody-#endif
+ Web/Scotty/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,83 +1,125 @@ {-# 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, scottySocketT, 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, options, 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, header, headers, body, bodyReader, 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, stream, raw+    , Lazy.text, Lazy.html, file, json, stream, raw, nested+      -- ** Accessing the fields of the Response+    , getResponseHeaders, getResponseStatus, getResponseContent       -- ** Exceptions-    , raise, raiseStatus, rescue, next, finish, defaultHandler, ScottyError(..), liftAndCatchIO+    , 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.Reader (runReaderT) import Control.Monad.State.Strict (execState, modify) import Control.Monad.IO.Class -import Data.Default.Class (def)+import qualified Data.Aeson as A+import qualified Data.Text as T -import Network.HTTP.Types (status404, status500)+import Network.HTTP.Types (status404, status413, status500) import Network.Socket (Socket)-import Network.Wai+import qualified Network.Wai as W (Application, Middleware, Response, responseBuilder) import Network.Wai.Handler.Warp (Port, runSettings, runSettingsSocket, setPort, getPort)  import Web.Scotty.Action import Web.Scotty.Route-import Web.Scotty.Internal.Types hiding (Application, Middleware)+import Web.Scotty.Internal.Types (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 qualified Web.Scotty.Internal.Types as Scotty+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 scottyT :: (Monad m, MonadIO n)         => Port-        -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action.-        -> ScottyT e m ()+        -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action.+        -> ScottyT m ()         -> n ()-scottyT p = scottyOptsT $ def { settings = setPort p (settings def) }+scottyT p = scottyOptsT $ defaultOptions { settings = setPort p (settings defaultOptions) }  -- | Run a scotty application using the warp server, passing extra options. -- NB: scottyOpts opts === scottyOptsT opts id scottyOptsT :: (Monad m, MonadIO n)             => Options-            -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action.-            -> ScottyT e m ()+            -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action.+            -> ScottyT m ()             -> n () scottyOptsT opts runActionToIO s = do     when (verbose opts > 0) $         liftIO $ putStrLn $ "Setting phasers to stun... (port " ++ show (getPort (settings opts)) ++ ") (ctrl-c to quit)"-    liftIO . runSettings (settings opts) =<< scottyAppT runActionToIO s+    liftIO . runSettings (settings opts) =<< scottyAppT opts runActionToIO s  -- | Run a scotty application using the warp server, passing extra options, and -- listening on the provided socket.@@ -85,45 +127,83 @@ scottySocketT :: (Monad m, MonadIO n)               => Options               -> Socket-              -> (m Response -> IO Response)-              -> ScottyT e m ()+              -> (m W.Response -> IO W.Response)+              -> ScottyT m ()               -> n () scottySocketT opts sock runActionToIO s = do     when (verbose opts > 0) $ do         d <- liftIO $ socketDescription sock         liftIO $ putStrLn $ "Setting phasers to stun... (" ++ d ++ ") (ctrl-c to quit)"-    liftIO . runSettingsSocket (settings opts) sock =<< scottyAppT runActionToIO s+    liftIO . runSettingsSocket (settings opts) sock =<< scottyAppT opts runActionToIO s  -- | Turn a scotty application into a WAI 'Application', which can be -- run with any WAI handler. -- NB: scottyApp === scottyAppT id scottyAppT :: (Monad m, Monad n)-           => (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action.-           -> ScottyT e m ()-           -> n Application-scottyAppT runActionToIO defs = do-    let s = execState (runS defs) def-    let rapp req callback = runActionToIO (foldl (flip ($)) notFoundApp (routes s) req) >>= callback-    return $ foldl (flip ($)) rapp (middlewares s)+           => 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.------ Note: IO exceptions are lifted into 'ScottyError's by 'stringError'.--- This has security implications, so you probably want to provide your--- own defaultHandler in production which does not send out the error--- strings as 500 responses.-defaultHandler :: (ScottyError e, Monad m) => (e -> ActionT e m ()) -> ScottyT e m ()-defaultHandler f = ScottyT $ modify $ addHandler $ Just (\e -> status status500 >> f e)+-- | Global handler for user-defined exceptions.+defaultHandler :: (Monad m) => ErrorHandler m -> ScottyT m ()+defaultHandler f = ScottyT $ modify $ setHandler $ Just f  -- | Use given middleware. Middleware is nested such that the first declared -- is the outermost middleware (it has first dibs on the request and last action -- on the response). Every middleware is run on each request.-middleware :: Middleware -> ScottyT e m ()+middleware :: W.Middleware -> ScottyT m () middleware = ScottyT . modify . addMiddleware++-- | Set global size limit for the request body. Requests with body size exceeding the limit will not be+-- processed and an HTTP response 413 will be returned to the client. Size limit needs to be greater than 0,+-- otherwise the application will terminate on start.+setMaxRequestBodySize :: Kilobytes -- ^ 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/Util.hs view
@@ -1,51 +1,51 @@+{-# 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 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  import Web.Scotty.Internal.Types -lazyTextToStrictByteString :: T.Text -> B.ByteString-lazyTextToStrictByteString = ES.encodeUtf8 . T.toStrict--strictByteStringToLazyText :: B.ByteString -> T.Text-strictByteStringToLazyText = T.fromStrict . ES.decodeUtf8With ES.lenientDecode--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-                    ContentStream str -> responseStream s h str+                    ContentBuilder  b   -> responseBuilder s h b+                    ContentFile     f   -> responseFile s h f Nothing+                    ContentStream   str -> responseStream s h str+                    ContentResponse res -> res     where s = srStatus sr           h = srHeaders sr @@ -70,3 +70,31 @@   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
@@ -6,13 +6,12 @@ module Main (main) where  import Control.Monad-import Data.Default.Class (def) import Data.Functor.Identity-import Data.Text (Text) import Lucid.Base import Lucid.Html5 import Web.Scotty 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@@ -25,12 +24,15 @@     setColumns [Case,Allocated,GCs,Live,Check,Max,MaxOS]     setFormat Markdown     io "ScottyM Strict" BL.putStr-      (SS.evalState (runS $ renderBST htmlScotty) def)+      (SS.evalState+        (R.runReaderT (runS $ renderBST htmlScotty) defaultOptions)+        defaultScottyState)     io "ScottyM Lazy" BL.putStr-      (SL.evalState (runScottyLazy $ renderBST htmlScottyLazy) def)+      (SL.evalState (runScottyLazy $ renderBST htmlScottyLazy) defaultScottyState)     io "Identity" BL.putStr       (runIdentity $ renderBST htmlIdentity) + htmlTest :: Monad m => HtmlT m () htmlTest = replicateM_ 2 $ div_ $ do   replicateM_ 1000 $ div_ $ do@@ -49,6 +51,6 @@ {-# noinline htmlScottyLazy #-}  newtype ScottyLazy a = ScottyLazy-  { runScottyLazy:: SL.State (ScottyState Text IO) a }+  { runScottyLazy:: SL.State (ScottyState IO) a }   deriving (Functor,Applicative,Monad)
changelog.md view
@@ -1,3 +1,99 @@+## 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
+ 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/basic.hs view
@@ -1,21 +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.Exception (Exception(..)) import Control.Monad-import Control.Monad.Trans+-- import Control.Monad.Trans import System.Random (newStdGen, randomRs)  import Network.HTTP.Types (status302) +import Data.Text.Lazy (pack) import Data.Text.Lazy.Encoding (decodeUtf8) import Data.String (fromString)-import Prelude ()-import Prelude.Compat+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.@@ -29,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@@ -47,24 +63,24 @@     -- redirects preempt execution     get "/redirect" $ do         void $ redirect "http://www.google.com"-        raise "this error is never reached"+        throw NeverReached      -- Of course you can catch your own errors.     get "/rescue" $ do-        (do void $ raise "a rescued error"; redirect "http://www.we-never-go-here.com")-        `rescue` (\m -> text $ "we recovered from " `mappend` m)+        (do void $ throw Boom; redirect "http://www.we-never-go-here.com")+        `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" -    -- You can stop execution of this action and keep pattern matching routes.+    -- 'next' stops execution of the current action and keeps pattern matching routes.     get "/random" $ do         void next         redirect "http://www.we-never-go-here.com"@@ -75,7 +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@@ -85,17 +101,21 @@                        ,"</form>"                        ] +    -- Read and decode the request body as UTF-8     post "/readbody" $ do         b <- body         text $ decodeUtf8 b +    -- Look up a request header     get "/header" $ do         agent <- header "User-Agent"-        maybe (raise "User-Agent header not found!") text agent+        maybe (throw UserAgentNotFound) text agent      -- Make a request to this URI, then type a line in the terminal, which     -- will be the response. Using ctrl-c will cause getLine to fail.     -- This demonstrates that IO exceptions are lifted into ActionM exceptions.+    --+    -- (#310) we don't catch async exceptions, so ctrl-c just exits the program     get "/iofail" $ do         msg <- liftIO $ liftM fromString getLine         text msg
examples/bodyecho.hs view
@@ -3,7 +3,7 @@  import Web.Scotty -import Control.Monad.IO.Class (liftIO)+-- 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
examples/cookies.hs view
@@ -1,36 +1,14 @@ {-# LANGUAGE OverloadedStrings #-}--- This examples requires you to: cabal install cookie--- and: cabal install blaze-html+-- This examples requires you to: cabal install blaze-html module Main (main) where  import Control.Monad (forM_)-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy.Encoding as T-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import qualified Blaze.ByteString.Builder as B  import qualified Text.Blaze.Html5 as H-import Text.Blaze.Html5.Attributes-import Text.Blaze.Html.Renderer.Text (renderHtml)-import Web.Scotty-import Web.Cookie--makeCookie :: BS.ByteString -> BS.ByteString -> SetCookie-makeCookie n v = def { setCookieName = n, setCookieValue = v }--renderSetCookie' :: SetCookie -> Text-renderSetCookie' = T.decodeUtf8 . B.toLazyByteString . renderSetCookie--setCookie :: BS.ByteString -> BS.ByteString -> ActionM ()-setCookie n v = setHeader "Set-Cookie" (renderSetCookie' (makeCookie n v))--getCookies :: ActionM (Maybe CookiesText)-getCookies =-    fmap (fmap (parseCookiesText . lazyToStrict . T.encodeUtf8)) $-        header "Cookie"-    where-        lazyToStrict = BS.concat . BSL.toChunks+import           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 =@@ -48,16 +26,14 @@     get "/" $ do         cookies <- getCookies         html $ renderHtml $ do-            case cookies of-                Just cs -> renderCookiesTable cs-                Nothing -> return ()+            renderCookiesTable cookies             H.form H.! method "post" H.! action "/set-a-cookie" $ do                 H.input H.! type_ "text" H.! name "name"                 H.input H.! type_ "text" H.! name "value"                 H.input H.! type_ "submit" H.! value "set a cookie"      post "/set-a-cookie" $ do-        name'  <- param "name"-        value' <- param "value"-        setCookie name' value'+        name'  <- pathParam "name"+        value' <- pathParam "value"+        setSimpleCookie name' value'         redirect "/"
examples/exceptions.hs view
@@ -1,45 +1,46 @@ {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}+{-# language DeriveAnyClass #-}+{-# language LambdaCase #-} module Main (main) where +import Control.Exception (Exception(..)) import Control.Monad.IO.Class+import Control.Monad.IO.Unlift (MonadUnliftIO(..))  import Data.String (fromString)+import Data.Typeable  import Network.HTTP.Types import Network.Wai.Middleware.RequestLogger -import Prelude ()-import Prelude.Compat- 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>"-handleEx (StringEx s) = do+  StringEx s -> do     status status500     html $ fromString $ "<h1>" ++ s ++ "</h1>"  main :: IO ()-main = scottyT 3000 id $ do -- note, we aren't using any additional transformer layers-                            -- so we can just use 'id' for the runner.+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@@ -53,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
@@ -10,23 +10,19 @@ module Main (main) where  import Control.Concurrent.STM+import Control.Monad.IO.Unlift (MonadUnliftIO(..)) import Control.Monad.Reader -import Data.Default.Class import Data.String-import Data.Text.Lazy (Text)  import Network.Wai.Middleware.RequestLogger -import Prelude ()-import Prelude.Compat- import Web.Scotty.Trans  newtype AppState = AppState { tickCount :: Int } -instance Default AppState where-    def = AppState 0+defaultAppState :: AppState+defaultAppState = AppState 0  -- Why 'ReaderT (TVar AppState)' rather than 'StateT AppState'? -- With a state transformer, 'runActionToIO' (below) would have@@ -39,7 +35,7 @@ -- Also note: your monad must be an instance of 'MonadIO' for -- Scotty to use it. newtype WebM a = WebM { runWebM :: ReaderT (TVar AppState) IO a }-    deriving (Applicative, Functor, Monad, MonadIO, MonadReader (TVar AppState))+    deriving (Applicative, Functor, Monad, MonadIO, MonadReader (TVar AppState), MonadUnliftIO)  -- Scotty's monads are layered on top of our custom monad. -- We define this synonym for lift in order to be explicit@@ -56,7 +52,7 @@  main :: IO () main = do-    sync <- newTVarIO def+    sync <- newTVarIO defaultAppState         -- 'runActionToIO' is called once per action.     let runActionToIO m = runReaderT (runWebM m) sync @@ -66,7 +62,7 @@ -- type is ambiguous. We can fix it by putting a type -- annotation just about anywhere. In this case, we'll -- just do it on the entire app.-app :: ScottyT Text WebM ()+app :: ScottyT WebM () app = do     middleware logStdoutDev     get "/" $ do
examples/gzip.hs view
@@ -2,14 +2,14 @@ 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
@@ -5,14 +5,13 @@  import Network.Wai.Middleware.RequestLogger -- install wai-extra if you don't have this -import Data.Default.Class (def) import Network.Wai.Handler.Warp (setPort)  -- Set some Scotty settings opts :: Options-opts = def { verbose = 0-           , settings = setPort 4000 $ settings def-           }+opts = defaultOptions { verbose = 0+                      , settings = setPort 4000 $ settings defaultOptions+                      }  -- This won't display anything at startup, and will listen on localhost:4000 main :: IO ()
examples/reader.hs view
@@ -8,11 +8,9 @@ module Main where  import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, asks, lift, runReaderT)-import Data.Default.Class (def)-import Data.Text.Lazy (Text, pack)-import Prelude ()-import Prelude.Compat-import Web.Scotty.Trans (ScottyT, get, scottyOptsT, text)+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@@ -20,16 +18,16 @@  newtype ConfigM a = ConfigM   { runConfigM :: ReaderT Config IO a-  } deriving (Applicative, Functor, Monad, MonadIO, MonadReader Config)+  } deriving (Applicative, Functor, Monad, MonadIO, MonadReader Config, MonadUnliftIO) -application :: ScottyT Text ConfigM ()+application :: ScottyT ConfigM () application = do   get "/" $ do     e <- lift $ asks environment     text $ pack $ show e  main :: IO ()-main = scottyOptsT def runIO application where+main = scottyOptsT defaultOptions runIO application where   runIO :: ConfigM a -> IO a   runIO m = runReaderT (runConfigM m) config
+ examples/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,13 +1,16 @@ {-# LANGUAGE OverloadedStrings #-}+{-# language ScopedTypeVariables #-} module Main (main) where  import Web.Scotty -import Control.Monad.IO.Class+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,33 +19,44 @@ import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Char8 as BS import System.FilePath ((</>))-import Prelude ()-import Prelude.Compat +{-| 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/urlshortener.hs view
@@ -1,19 +1,20 @@ {-# 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 qualified Data.Text.Lazy as T+import Data.Typeable (Typeable)  import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.Static -import Prelude ()-import Prelude.Compat- import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes -- Note:@@ -23,12 +24,17 @@ import Text.Blaze.Html.Renderer.Text (renderHtml)  -- TODO:--- Implement some kind of session and/or cookies+-- Implement some kind of session (#317) and/or cookies -- Add links +data SessionError = UrlHashNotFound Int deriving (Typeable, Exception)+instance Show SessionError where+  show = \case+    UrlHashNotFound hash -> unwords ["URL hash #", show hash, " not found in database!"]+ main :: IO () main = do-  m <- newMVar (0::Int,M.empty :: M.Map Int T.Text)+  m <- newMVar (0::Int, M.empty :: M.Map Int T.Text)   scotty 3000 $ do     middleware logStdoutDev     middleware static@@ -42,20 +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.11.6+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 <xichekolas@gmail.com>-Maintainer:          Andrew Farmer <xichekolas@gmail.com>-Copyright:           (c) 2012-Present Andrew Farmer+Maintainer:          The Scotty maintainers+Copyright:           (c) 2012-Present, Andrew Farmer and the Scotty contributors Category:            Web Stability:           experimental Build-type:          Simple@@ -20,11 +20,9 @@     .     import Web.Scotty     .-    import Data.Monoid (mconcat)-    .     main = scotty 3000 $     &#32;&#32;get &#34;/:word&#34; $ do-    &#32;&#32;&#32;&#32;beam <- param &#34;word&#34;+    &#32;&#32;&#32;&#32;beam <- pathParam &#34;word&#34;     &#32;&#32;&#32;&#32;html $ mconcat [&#34;&#60;h1&#62;Scotty, &#34;, beam, &#34; me up!&#60;/h1&#62;&#34;]   @   .@@ -44,15 +42,12 @@   [WAI] <http://hackage.haskell.org/package/wai>   .   [Warp] <http://hackage.haskell.org/package/warp>-tested-with:         GHC == 7.6.3-                   , GHC == 7.8.4-                   , GHC == 7.10.3-                   , GHC == 8.0.2-                   , GHC == 8.2.2-                   , GHC == 8.4.4-                   , GHC == 8.6.5-                   , GHC == 8.8.3-                   , GHC == 8.10.1+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     changelog.md@@ -66,58 +61,91 @@ 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.Trans.Lazy                        Web.Scotty.Util   default-language:    Haskell2010-  build-depends:       aeson                 >= 0.6.2.1  && < 1.5,-                       base                  >= 4.6      && < 5,-                       base-compat-batteries >= 0.10     && < 0.12,+  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 && < 0.11,+                       bytestring            >= 0.10.0.2 ,                        case-insensitive      >= 1.0.0.1  && < 1.3,-                       data-default-class    >= 0.0.1    && < 0.2,+                       containers            >= 0.5      && < 0.8,+                       cookie                >= 0.4,                        exceptions            >= 0.7      && < 0.11,-                       fail,+                       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.3,-                       nats                  >= 0.1      && < 2,-                       network               >= 2.6.0.2  && < 3.2,+                       mtl                   >= 2.1.2    && < 2.4,+                       network               >= 2.6.0.2  && < 3.3,                        regex-compat          >= 0.95.1   && < 0.96,-                       text                  >= 0.11.3.1 && < 1.3,-                       transformers          >= 0.3.0.0  && < 0.6,+                       resourcet,+                       stm,+                       text                  >= 0.11.3.1 ,+                       time                  >= 1.8,+                       transformers          >= 0.3.0.0  && < 0.7,                        transformers-base     >= 0.4.1    && < 0.5,-                       transformers-compat   >= 0.4      && < 0.7,+                       unliftio >= 0.2,+                       unordered-containers  >= 0.2.10.0 && < 0.3,                        wai                   >= 3.0.0    && < 3.3,-                       wai-extra             >= 3.0.0    && < 3.1,-                       warp                  >= 3.0.13   && < 3.4+                       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,-                       data-default-class,                        directory,                        hspec == 2.*,                        hspec-wai >= 0.6.3,+                       http-api-data,                        http-types,                        lifted-base,                        network,                        scotty,                        text,-                       wai+                       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@@ -128,10 +156,10 @@                        lucid,                        bytestring,                        mtl,+                       resourcet,                        text,                        transformers,-                       data-default-class,-                       weigh == 0.0.16+                       weigh >= 0.0.16 && <0.1   GHC-options:         -Wall -O2 -threaded  source-repository head
+ 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
@@ -1,26 +1,45 @@-{-# LANGUAGE OverloadedStrings, CPP #-}+{-# LANGUAGE OverloadedStrings, CPP, ScopedTypeVariables, DeriveGeneric #-} module Web.ScottySpec (main, spec) where  import           Test.Hspec-import           Test.Hspec.Wai+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           Data.Default.Class (def)+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)@@ -32,8 +51,19 @@ 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)@@ -52,6 +82,12 @@           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@@ -79,42 +115,501 @@             get "/" `shouldRespondWith` "<h1>404: File Not Found!</h1>" {matchStatus = 404}      describe "defaultHandler" $ do-      withApp (defaultHandler text >> Scotty.get "/" (liftAndCatchIO $ E.throwIO E.DivideByZero)) $ do+      withApp (do+                  let h = Handler (\(e :: E.ArithException) -> status status500 >> text (TL.pack $ show e))+                  defaultHandler h+                  Scotty.get "/" (throw E.DivideByZero)) $ do         it "sets custom exception handler" $ do           get "/" `shouldRespondWith` "divide by zero" {matchStatus = 500}--      withApp (defaultHandler (\_ -> status status503) >> Scotty.get "/" (liftAndCatchIO $ E.throwIO E.DivideByZero)) $ do+      withApp (do+                  let h = Handler (\(_ :: E.ArithException) -> status status503)+                  defaultHandler h+                  Scotty.get "/" (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 "/" $ liftAndCatchIO $ E.throwIO E.DivideByZero) $ do+        withApp (Scotty.get "/" $ throw E.DivideByZero) $ do           it "returns 500 on exceptions" $ do-            get "/" `shouldRespondWith` "<h1>500 Internal Server Error</h1>divide by zero" {matchStatus = 500}+            get "/" `shouldRespondWith` 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-    withApp (Scotty.get "/" $ (undefined `EL.catch` ((\_ -> html "") :: E.SomeException -> ActionM ()))) $ do-      it "has a MonadBaseControl instance" $ do-        get "/" `shouldRespondWith` 200+    context "MonadBaseControl instance" $ do+        withApp (Scotty.get "/" $ (undefined `EL.catch` ((\_ -> html "") :: E.SomeException -> ActionM ()))) $ do+          it "catches SomeException and returns 200" $ do+            get "/" `shouldRespondWith` 200+        withApp (Scotty.get "/" $ EL.throwIO E.DivideByZero) $ do+          it "returns 500 on uncaught exceptions" $ do+            get "/" `shouldRespondWith` 500 -    withApp (Scotty.get "/dictionary" $ empty <|> param "word1" <|> empty <|> param "word2" >>= text) $-      it "has an Alternative instance" $ do-        get "/dictionary?word1=haskell"   `shouldRespondWith` "haskell"-        get "/dictionary?word2=scotty"    `shouldRespondWith` "scotty"-        get "/dictionary?word1=a&word2=b" `shouldRespondWith` "a"+    context "Alternative instance" $ do+      withApp (Scotty.get "/" $ empty >>= text) $+        it "empty without any route following returns a 404" $+          get "/" `shouldRespondWith` 404+      withApp (Scotty.get "/dictionary" $ empty <|> queryParam "word1" >>= text) $+        it "empty throws Next" $ do+          get "/dictionary?word1=x" `shouldRespondWith` "x"+      withApp (Scotty.get "/dictionary" $ queryParam "word1" <|> empty <|> queryParam "word2" >>= text) $+        it "<|> skips the left route if that fails" $ do+          get "/dictionary?word2=y" `shouldRespondWith` "y"+          get "/dictionary?word1=a&word2=b" `shouldRespondWith` "a" -    describe "param" $ do-      withApp (Scotty.matchAny "/search" $ param "query" >>= text) $ do+    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" -        context "when used with application/x-www-form-urlencoded data" $ do-          it "returns POST parameter with given name" $ do-            request "POST" "/search" [("Content-Type","application/x-www-form-urlencoded")] "query=haskell" `shouldRespondWith` "haskell"+        it "decodes URL-encoding" $ do+          postForm "/search" "sfQuery=Kurf%C3%BCrstendamm&sfYear=2024" `shouldRespondWith` "Kurfürstendamm" -          it "replaces non UTF-8 bytes with Unicode replacement character" $ do-            request "POST" "/search" [("Content-Type","application/x-www-form-urlencoded")] "query=\xe9" `shouldRespondWith` "\xfffd"+        it "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 = "νέα ελληνικά"@@ -159,6 +654,81 @@         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" .@@ -175,8 +745,6 @@         ok = "HTTP/1.1 200 OK"         no = "HTTP/1.1 404 Not Found" -        withApp = with . scottyApp- socketPath :: FilePath socketPath = "/tmp/scotty-test.socket" @@ -184,7 +752,7 @@ withServer actions inner = E.bracket   (listenOn socketPath)   (\sock -> close sock >> removeFile socketPath)-  (\sock -> withAsync (Scotty.scottySocket def sock actions) $ const inner)+  (\sock -> withAsync (Scotty.scottySocket defaultOptions sock actions) $ const inner)  -- See https://github.com/haskell/network/issues/318 listenOn :: String -> IO Socket@@ -199,3 +767,4 @@       return sock     ) #endif+