packages feed

scotty 0.4.6 → 0.30

raw patch · 41 files changed

Files

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