diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -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
diff --git a/README b/README
deleted file mode 100644
--- a/README
+++ /dev/null
@@ -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 ["Scotty, ", beam, " me up!
"]
-
-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
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,103 @@
+# Scotty [](https://hackage.haskell.org/package/scotty) [](http://stackage.org/lts/package/scotty) [](http://stackage.org/nightly/package/scotty) [](https://github.com/scotty-web/scotty/actions/workflows/haskell-ci.yml)
+
+A Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp.
+
+```haskell
+{-# LANGUAGE OverloadedStrings #-}
+import Web.Scotty
+
+main = scotty 3000 $
+ get "/:word" $ do
+ beam <- pathParam "word"
+ html $ mconcat ["Scotty, ", beam, " me up!
"]
+```
+
+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
+```
+`42
`
+
+
+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
+
+
+ 
+
+
+
+# Copyright
+(c) 2012-Present, Andrew Farmer and Scotty contributors
diff --git a/Web/Scotty.hs b/Web/Scotty.hs
--- a/Web/Scotty.hs
+++ b/Web/Scotty.hs
@@ -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 "404: File Not Found!
"
+-- | 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
diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs
--- a/Web/Scotty/Action.hs
+++ b/Web/Scotty/Action.hs
@@ -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 ["500 Internal Server Error
", 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
diff --git a/Web/Scotty/Body.hs b/Web/Scotty/Body.hs
new file mode 100644
--- /dev/null
+++ b/Web/Scotty/Body.hs
@@ -0,0 +1,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))
+
diff --git a/Web/Scotty/Cookie.hs b/Web/Scotty/Cookie.hs
new file mode 100644
--- /dev/null
+++ b/Web/Scotty/Cookie.hs
@@ -0,0 +1,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 [ \"\\\"
+ , 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
+ }
+
diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs
new file mode 100644
--- /dev/null
+++ b/Web/Scotty/Internal/Types.hs
@@ -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
+
+
diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs
--- a/Web/Scotty/Route.hs
+++ b/Web/Scotty/Route.hs
@@ -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
diff --git a/Web/Scotty/Session.hs b/Web/Scotty/Session.hs
new file mode 100644
--- /dev/null
+++ b/Web/Scotty/Session.hs
@@ -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
diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs
new file mode 100644
--- /dev/null
+++ b/Web/Scotty/Trans.hs
@@ -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 "404: File Not Found!
"
+
+-- | 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 }
+
diff --git a/Web/Scotty/Trans/Lazy.hs b/Web/Scotty/Trans/Lazy.hs
new file mode 100644
--- /dev/null
+++ b/Web/Scotty/Trans/Lazy.hs
@@ -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
diff --git a/Web/Scotty/Trans/Strict.hs b/Web/Scotty/Trans/Strict.hs
new file mode 100644
--- /dev/null
+++ b/Web/Scotty/Trans/Strict.hs
@@ -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
diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs
deleted file mode 100644
--- a/Web/Scotty/Types.hs
+++ /dev/null
@@ -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
diff --git a/Web/Scotty/Util.hs b/Web/Scotty/Util.hs
--- a/Web/Scotty/Util.hs
+++ b/Web/Scotty/Util.hs
@@ -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
+
+
diff --git a/bench/Main.hs b/bench/Main.hs
new file mode 100644
--- /dev/null
+++ b/bench/Main.hs
@@ -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)
+
diff --git a/changelog.md b/changelog.md
new file mode 100644
--- /dev/null
+++ b/changelog.md
@@ -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": , "description": ""}`. 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).
diff --git a/doctest/Main.hs b/doctest/Main.hs
new file mode 100644
--- /dev/null
+++ b/doctest/Main.hs
@@ -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
diff --git a/examples/404.html b/examples/404.html
new file mode 100644
--- /dev/null
+++ b/examples/404.html
@@ -0,0 +1,1 @@
+This is a 404 page!
diff --git a/examples/LICENSE b/examples/LICENSE
new file mode 100644
--- /dev/null
+++ b/examples/LICENSE
@@ -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.
diff --git a/examples/basic.hs b/examples/basic.hs
--- a/examples/basic.hs
+++ b/examples/basic.hs
@@ -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 ["", v, "
"]
+ -- Looking for a parameter 'p' in the path.
+ get "/foo_path/:p" $ do
+ v <- pathParam "p"
+ html $ mconcat ["", v, "
"]
+
+ -- Looking for a parameter 'p' in the query string.
+ get "/foo_query" $ do
+ v <- queryParam "p"
+ html $ mconcat ["", v, "
"]
+
-- An uncaught error becomes a 500 page.
- get "/raise" $ raise "some error here"
+ get "/raise" $ throw Boom
-- You can set status and headers directly.
get "/redirect-custom" $ do
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 ["", v, "
"]
-- 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 @@
,""
]
+ -- 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.
diff --git a/examples/bodyecho.hs b/examples/bodyecho.hs
new file mode 100644
--- /dev/null
+++ b/examples/bodyecho.hs
@@ -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
diff --git a/examples/cookies.hs b/examples/cookies.hs
new file mode 100644
--- /dev/null
+++ b/examples/cookies.hs
@@ -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 "/"
diff --git a/examples/exceptions.hs b/examples/exceptions.hs
new file mode 100644
--- /dev/null
+++ b/examples/exceptions.hs
@@ -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 "Scotty Says No
"
+ NotFound i -> do
+ status status404
+ html $ fromString $ "Can't find " ++ show i ++ ".
"
+ StringEx s -> do
+ status status500
+ html $ fromString $ "" ++ s ++ "
"
+
+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 ["Option 1 (Not Found)"
+ ,"
"
+ ,"Option 2 (Forbidden)"
+ ,"
"
+ ,"Option 3 (Random)"
+ ]
+
+ 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 "Forbidden was randomly thrown, but we caught it."
+ catchOne other = throw other
+ throw (if rBool then Forbidden else NotFound i) `catch` catchOne
diff --git a/examples/globalstate.hs b/examples/globalstate.hs
new file mode 100644
--- /dev/null
+++ b/examples/globalstate.hs
@@ -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 "/"
diff --git a/examples/gzip.hs b/examples/gzip.hs
new file mode 100644
--- /dev/null
+++ b/examples/gzip.hs
@@ -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"
diff --git a/examples/json.hs b/examples/json.hs
deleted file mode 100644
--- a/examples/json.hs
+++ /dev/null
@@ -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'
diff --git a/examples/json_mode.hs b/examples/json_mode.hs
new file mode 100644
--- /dev/null
+++ b/examples/json_mode.hs
@@ -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 "Welcome! JSON mode is OFF (default)
"
+
+ 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"
diff --git a/examples/middleware.hs b/examples/middleware.hs
new file mode 100644
--- /dev/null
+++ b/examples/middleware.hs
@@ -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)
+ ]
+ ]
diff --git a/examples/nested.hs b/examples/nested.hs
new file mode 100644
--- /dev/null
+++ b/examples/nested.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import Web.Scotty
+import Network.Wai
+import qualified Data.Text.Lazy as TL
+import Network.HTTP.Types.Status
+import Data.Monoid (mconcat)
+
+simpleApp :: Application
+simpleApp _ respond = do
+ putStrLn "I've done some IO here"
+ respond $ responseLBS
+ status200
+ [("Content-Type", "text/plain")]
+ "Hello, Web!"
+
+scottApp :: IO Application
+scottApp = scottyApp $ do
+
+ get "/" $ do
+ html $ mconcat ["Scotty, beam me up!
"]
+
+ get "/other/test/:word" $ do
+ beam <- param "word"
+ html $ mconcat ["Scotty, ", beam, " me up!
"]
+
+ get "/test/:word" $ do
+ beam <- param "word"
+ html $ mconcat ["Scotty, ", beam, " me up!
"]
+
+ get "/nested" $ nested simpleApp
+ get "/other/nested" $ nested simpleApp
+
+ notFound $ do
+ r <- request
+ html (TL.pack (show (pathInfo r)))
+
+ -- For example, returns path info: ["other","qwer","adxf","jkashdfljhaslkfh","qwer"]
+ -- for request http://localhost:3000/other/qwer/adxf/jkashdfljhaslkfh/qwer
+
+main :: IO ()
+main = do
+
+ otherApp <- scottApp
+
+ scotty 3000 $ do
+
+ get "/" $ do
+ html $ mconcat ["Scotty, beam me up!
"]
+
+ get "/test/:word" $ do
+ beam <- param "word"
+ html $ mconcat ["Scotty, ", beam, " me up!
"]
+
+ get "/simple" $ nested simpleApp
+
+ get "/other" $ nested otherApp
+
+ get (regex "/other/.*") $ nested otherApp
+
+
diff --git a/examples/options.hs b/examples/options.hs
--- a/examples/options.hs
+++ b/examples/options.hs
@@ -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 ()
diff --git a/examples/reader.hs b/examples/reader.hs
new file mode 100644
--- /dev/null
+++ b/examples/reader.hs
@@ -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"
+ }
diff --git a/examples/session.hs b/examples/session.hs
new file mode 100644
--- /dev/null
+++ b/examples/session.hs
@@ -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."
diff --git a/examples/static/json.js b/examples/static/json.js
deleted file mode 100644
--- a/examples/static/json.js
+++ /dev/null
@@ -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) + "");
- },
- 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);
-}
diff --git a/examples/upload.hs b/examples/upload.hs
new file mode 100644
--- /dev/null
+++ b/examples/upload.hs
@@ -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' ]
diff --git a/examples/uploads/.keep b/examples/uploads/.keep
new file mode 100644
--- /dev/null
+++ b/examples/uploads/.keep
diff --git a/examples/urlshortener.hs b/examples/urlshortener.hs
--- a/examples/urlshortener.hs
+++ b/examples/urlshortener.hs
@@ -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.
diff --git a/scotty.cabal b/scotty.cabal
--- a/scotty.cabal
+++ b/scotty.cabal
@@ -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
-Maintainer: Andrew Farmer
-Copyright: (c) 2012 Andrew Farmer
+Author: Andrew Farmer
+Maintainer: The Scotty maintainers
+Copyright: (c) 2012-Present, Andrew Farmer and the Scotty contributors
Category: Web
Stability: experimental
Build-type: Simple
@@ -20,11 +20,9 @@
.
import Web.Scotty
.
- import Data.Monoid (mconcat)
- .
- main = scotty 3000 $ do
+ main = scotty 3000 $
get "/:word" $ do
- beam <- param "word"
+ beam <- pathParam "word"
html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"]
@
.
@@ -44,42 +42,126 @@
[WAI]
.
[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
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
diff --git a/test/Test/Hspec/Wai/Extra.hs b/test/Test/Hspec/Wai/Extra.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Hspec/Wai/Extra.hs
@@ -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=@ 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
diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Web/ScottySpec.hs
@@ -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` "404: File Not Found!
" {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 = "ру́сский язы́к
"
+
+ 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
+