diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# Scotty [![Build Status](https://travis-ci.org/scotty-web/scotty.svg)](https://travis-ci.org/scotty-web/scotty) +# Scotty [![Hackage](http://img.shields.io/hackage/v/scotty.svg)](https://hackage.haskell.org/package/scotty) [![Stackage Lts](http://stackage.org/package/scotty/badge/lts)](http://stackage.org/lts/package/scotty) [![Stackage Nightly](http://stackage.org/package/scotty/badge/nightly)](http://stackage.org/nightly/package/scotty) [![CI](https://github.com/scotty-web/scotty/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/scotty-web/scotty/actions/workflows/haskell-ci.yml) A Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp. @@ -6,11 +6,9 @@ {-# LANGUAGE OverloadedStrings #-} import Web.Scotty -import Data.Monoid (mconcat) - main = scotty 3000 $ get "/:word" $ do - beam <- param "word" + beam <- pathParam "word" html $ mconcat ["

Scotty, ", beam, " me up!

"] ``` @@ -21,28 +19,64 @@ * Conforms to the [web application interface (WAI)](https://github.com/yesodweb/wai/). * Uses the very fast Warp webserver by default. -See examples/basic.hs to see Scotty in action. (basic.hs needs the wai-extra package) +As for the name: Sinatra + Warp = Scotty. +## Examples + +Run /basic.hs to see Scotty in action: + ```bash -> runghc examples/basic.hs -Setting phasers to stun... (port 3000) (ctrl-c to quit) -(visit localhost:3000/somepath) +runghc examples/basic.hs ``` +`Setting phasers to stun... (port 3000) (ctrl-c to quit)` -As for the name: Sinatra + Warp = Scotty. +Or equivalently with [`stack`](https://docs.haskellstack.org/en/stable/): -### More Information +```bash +stack exec -- scotty-basic +``` +Once the server is running you can interact with it with curl or a browser: + +```bash +curl localhost:3000 +``` +`foobar` + +```bash +curl localhost:3000/foo_query?p=42 +``` +`

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). -### Development & Support +## Contributing -Open an issue on GitHub. +Feel free to ask questions or report bugs on the [Github issue tracker](https://github.com/scotty-web/scotty/issues/). -Copyright (c) 2012-2019 Andrew Farmer +Github issues are now (September 2023) labeled, so newcomers to the Haskell language can start with `easy fix` ones and gradually progress to `new feature`s, `bug`s and `R&D` :) -### FAQ +## Package versions +Scotty adheres to the [Package Versioning Policy](https://pvp.haskell.org/). + + +## FAQ + * Fails to compile regex-posix on Windows * If you are using stack, add the following parameters to `stack.yaml`: * ```yaml @@ -57,3 +91,13 @@ constraints: regex-posix +_regex-posix-clib ``` + +### Contributors + + + + + + +# Copyright +(c) 2012-Present, Andrew Farmer and Scotty contributors diff --git a/Web/Scotty.hs b/Web/Scotty.hs --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -1,56 +1,120 @@ -{-# LANGUAGE OverloadedStrings, RankNTypes #-} +{-# LANGUAGE RankNTypes #-} -- | It should be noted that most of the code snippets below depend on the -- OverloadedStrings language pragma. -- -- Scotty is set up by default for development mode. For production servers, -- you will likely want to modify 'Trans.settings' and the 'defaultHandler'. See -- the comments on each of these functions for more information. +-- +-- Please refer to the @examples@ directory and the @spec@ test suite for concrete use cases, e.g. constructing responses, exception handling and useful implementation details. module Web.Scotty - ( -- * scotty-to-WAI - scotty, scottyApp, scottyOpts, scottySocket, Options(..) + ( -- * Running 'scotty' servers + scotty + , scottyOpts + , scottySocket + , Options(..), defaultOptions + -- ** scotty-to-WAI + , scottyApp -- * Defining Middleware and Routes -- -- | 'Middleware' and routes are run in the order in which they -- are defined. All middleware is run first, followed by the first -- route that matches. If no route matches, a 404 response is given. - , middleware, get, post, put, delete, patch, options, addroute, matchAny, notFound, setMaxRequestBodySize + , middleware, get, post, put, delete, patch, options, addroute, matchAny, notFound, nested, setMaxRequestBodySize -- ** Route Patterns , capture, regex, function, literal - -- ** Accessing the Request, Captures, and Query Parameters - , request, header, headers, body, bodyReader, param, params, jsonData, files - -- ** Modifying the Response and Redirecting - , status, addHeader, setHeader, redirect + -- ** Accessing the Request and its fields + , request, header, headers, body, bodyReader + , jsonData, formData + -- ** Accessing Path, Form and Query Parameters + , pathParam, captureParam, formParam, queryParam + , pathParamMaybe, captureParamMaybe, formParamMaybe, queryParamMaybe + , pathParams, captureParams, formParams, queryParams + -- *** Files + , files, filesOpts + -- ** Modifying the Response + , status, addHeader, setHeader + -- ** Redirecting + , redirect, redirect300, redirect301, redirect302, redirect303, redirect304, redirect307, redirect308 -- ** Setting Response Body -- -- | Note: only one of these should be present in any given route -- definition, as they completely replace the current 'Response' body. , text, html, file, json, stream, raw + -- ** Accessing the fields of the Response + , getResponseHeaders, getResponseStatus, getResponseContent -- ** Exceptions - , raise, raiseStatus, rescue, next, finish, defaultHandler, liftAndCatchIO + , throw, next, finish, defaultHandler + , liftIO, catch + , ScottyException(..) -- * Parsing Parameters , Param, Trans.Parsable(..), Trans.readEither -- * Types - , ScottyM, ActionM, RoutePattern, File, Kilobytes + , ScottyM, ActionM, RoutePattern, File, Content(..), Kilobytes, ErrorHandler, Handler(..) + , ScottyState, defaultScottyState + -- ** Cookie functions + , setCookie, setSimpleCookie, getCookie, getCookies, deleteCookie, Cookie.makeSimpleCookie + -- ** Session Management + , Session (..), SessionId, SessionJar, SessionStatus + , createSessionJar, createUserSession, createSession, addSession + , readSession, getUserSession, getSession, readUserSession + , deleteSession, maintainSessions ) where --- With the exception of this, everything else better just import types. import qualified Web.Scotty.Trans as Trans +import qualified Control.Exception as E +import Control.Monad.IO.Class import Data.Aeson (FromJSON, ToJSON) import qualified Data.ByteString as BS import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Text.Lazy (Text) +import Data.Text.Lazy (Text, toStrict) +import qualified Data.Text as T -import Network.HTTP.Types (Status, StdMethod) +import Network.HTTP.Types (Status, StdMethod, ResponseHeaders) import Network.Socket (Socket) import Network.Wai (Application, Middleware, Request, StreamingBody) import Network.Wai.Handler.Warp (Port) +import qualified Network.Wai.Parse as W -import Web.Scotty.Internal.Types (ScottyT, ActionT, Param, RoutePattern, Options, File, Kilobytes) +import Web.FormUrlEncoded (FromForm) +import Web.Scotty.Internal.Types (ScottyT, ActionT, ErrorHandler, Param, RoutePattern, Options, defaultOptions, File, Kilobytes, ScottyState, defaultScottyState, ScottyException, Content(..)) +import UnliftIO.Exception (Handler(..), catch) +import qualified Web.Scotty.Cookie as Cookie +import Web.Scotty.Session (Session (..), SessionId, SessionJar, SessionStatus , createSessionJar, + createSession, addSession, maintainSessions) -type ScottyM = ScottyT Text IO -type ActionM = ActionT Text IO +{- $setup +>>> :{ +import Control.Monad.IO.Class (MonadIO(..)) +import qualified Network.HTTP.Client as H +import qualified Network.HTTP.Types as H +import qualified Network.Wai as W (httpVersion) +import qualified Data.ByteString.Lazy.Char8 as LBS (unpack) +import qualified Data.Text as T (pack) +import Control.Concurrent (ThreadId, forkIO, killThread) +import Control.Exception (bracket) +import qualified Web.Scotty as S (ScottyM, scottyOpts, get, text, regex, pathParam, Options(..), defaultOptions) +-- | GET an HTTP path +curl :: MonadIO m => + String -- ^ path + -> m String -- ^ response body +curl path = liftIO $ do + req0 <- H.parseRequest path + let req = req0 { H.method = "GET"} + mgr <- H.newManager H.defaultManagerSettings + (LBS.unpack . H.responseBody) <$> H.httpLbs req mgr +-- | Fork a process, run a Scotty server in it and run an action while the server is running. Kills the scotty thread once the inner action is done. +withScotty :: S.ScottyM () + -> IO a -- ^ inner action, e.g. 'curl "localhost:3000/"' + -> IO a +withScotty serv act = bracket (forkIO $ S.scottyOpts (S.defaultOptions{ S.verbose = 0 }) serv) killThread (\_ -> act) +:} +-} +type ScottyM = ScottyT IO +type ActionM = ActionT IO + -- | Run a scotty application using the warp server. scotty :: Port -> ScottyM () -> IO () scotty p = Trans.scottyT p id @@ -69,18 +133,10 @@ -- | Turn a scotty application into a WAI 'Application', which can be -- run with any WAI handler. scottyApp :: ScottyM () -> IO Application -scottyApp = Trans.scottyAppT id +scottyApp = Trans.scottyAppT defaultOptions id --- | Global handler for uncaught exceptions. --- --- Uncaught exceptions normally become 500 responses. --- You can use this to selectively override that behavior. --- --- Note: IO exceptions are lifted into Scotty exceptions by default. --- This has security implications, so you probably want to provide your --- own defaultHandler in production which does not send out the error --- strings as 500 responses. -defaultHandler :: (Text -> ActionM ()) -> ScottyM () +-- | Global handler for user-defined exceptions. +defaultHandler :: ErrorHandler IO -> ScottyM () defaultHandler = Trans.defaultHandler -- | Use given middleware. Middleware is nested such that the first declared @@ -89,36 +145,48 @@ middleware :: Middleware -> ScottyM () middleware = Trans.middleware +-- | Nest a whole WAI application inside a Scotty handler. +-- Note: You will want to ensure that this route fully handles the response, +-- as there is no easy delegation as per normal Scotty actions. +-- Also, you will have to carefully ensure that you are expecting the correct routes, +-- this could require stripping the current prefix, or adding the prefix to your +-- application's handlers if it depends on them. One potential use-case for this +-- is hosting a web-socket handler under a specific route. +nested :: Application -> ActionM () +nested = Trans.nested + -- | Set global size limit for the request body. Requests with body size exceeding the limit will not be --- processed and an HTTP response 413 will be returned to the client. Size limit needs to be greater than 0, --- otherwise the application will terminate on start. +-- processed and an HTTP response 413 will be returned to the client. Size limit needs to be greater than 0, +-- otherwise the application will terminate on start. setMaxRequestBodySize :: Kilobytes -> ScottyM () setMaxRequestBodySize = Trans.setMaxRequestBodySize --- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions --- turn into HTTP 500 responses. -raise :: Text -> ActionM a -raise = Trans.raise - --- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions turn into HTTP responses corresponding to the given status. -raiseStatus :: Status -> Text -> ActionM a -raiseStatus = Trans.raiseStatus +-- | Throw an exception which can be caught within the scope of the current Action with 'catch'. +-- +-- If the exception is not caught locally, another option is to implement a global 'Handler' (with 'defaultHandler') that defines its interpretation and a translation to HTTP error codes. +-- +-- Uncaught exceptions turn into HTTP 500 responses. +throw :: (E.Exception e) => e -> ActionM a +throw = Trans.throw -- | Abort execution of this action and continue pattern matching routes. -- Like an exception, any code after 'next' is not executed. -- +-- NB : Internally, this is implemented with an exception that can only be +-- caught by the library, but not by the user. +-- -- As an example, these two routes overlap. The only way the second one will -- ever run is if the first one calls 'next'. -- -- > get "/foo/:bar" $ do --- > w :: Text <- param "bar" +-- > w :: Text <- pathParam "bar" -- > unless (w == "special") next -- > text "You made a request to /foo/special" -- > -- > get "/foo/:baz" $ do --- > w <- param "baz" +-- > w <- pathParam "baz" -- > text $ "You made a request to: " <> w -next :: ActionM a +next :: ActionM () next = Trans.next -- | Abort execution of this action. Like an exception, any code after 'finish' @@ -128,7 +196,7 @@ -- content the text message. -- -- > get "/foo/:bar" $ do --- > w :: Text <- param "bar" +-- > w :: Text <- pathParam "bar" -- > unless (w == "special") finish -- > text "You made a request to /foo/special" -- @@ -136,18 +204,8 @@ finish :: ActionM a finish = Trans.finish --- | Catch an exception thrown by 'raise'. --- --- > raise "just kidding" `rescue` (\msg -> text msg) -rescue :: ActionM a -> (Text -> ActionM a) -> ActionM a -rescue = Trans.rescue - --- | Like 'liftIO', but catch any IO exceptions and turn them into Scotty exceptions. -liftAndCatchIO :: IO a -> ActionM a -liftAndCatchIO = Trans.liftAndCatchIO - --- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect --- will not be run. +-- | Synonym for 'redirect302'. +-- If you are unsure which redirect to use, you probably want this one. -- -- > redirect "http://www.google.com" -- @@ -157,14 +215,66 @@ redirect :: Text -> ActionM a redirect = Trans.redirect +-- | Redirect to given URL with status 300 (Multiple Choices). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect300 :: Text -> ActionM a +redirect300 = Trans.redirect300 + +-- | Redirect to given URL with status 301 (Moved Permanently). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect301 :: Text -> ActionM a +redirect301 = Trans.redirect301 + +-- | Redirect to given URL with status 302 (Found). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect302 :: Text -> ActionM a +redirect302 = Trans.redirect302 + +-- | Redirect to given URL with status 303 (See Other). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect303 :: Text -> ActionM a +redirect303 = Trans.redirect303 + +-- | Redirect to given URL with status 304 (Not Modified). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect304 :: Text -> ActionM a +redirect304 = Trans.redirect304 + +-- | Redirect to given URL with status 307 (Temporary Redirect). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect307 :: Text -> ActionM a +redirect307 = Trans.redirect307 + +-- | Redirect to given URL with status 308 (Permanent Redirect). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect308 :: Text -> ActionM a +redirect308 = Trans.redirect308 + -- | Get the 'Request' object. request :: ActionM Request request = Trans.request -- | Get list of uploaded files. -files :: ActionM [File] +-- +-- NB: Loads all file contents in memory with options 'W.defaultParseRequestBodyOptions' +files :: ActionM [File ByteString] files = Trans.files +-- | Get list of temp files and form parameters decoded from multipart payloads. +-- +-- NB the temp files are deleted when the continuation exits +filesOpts :: W.ParseRequestBodyOptions + -> ([Param] -> [File FilePath] -> ActionM a) -- ^ temp files validation, storage etc + -> ActionM a +filesOpts = Trans.filesOpts + -- | Get a request header. Header name is case-insensitive. header :: Text -> ActionM (Maybe Text) header = Trans.header @@ -174,6 +284,8 @@ headers = Trans.headers -- | Get the request body. +-- +-- NB: loads the entire request body in memory body :: ActionM ByteString body = Trans.body @@ -184,23 +296,99 @@ bodyReader = Trans.bodyReader -- | Parse the request body as a JSON object and return it. Raises an exception if parse is unsuccessful. +-- +-- NB: uses 'body' internally jsonData :: FromJSON a => ActionM a jsonData = Trans.jsonData --- | Get a parameter. First looks in captures, then form data, then query parameters. +-- | Parse the request body as @x-www-form-urlencoded@ form data and return it. Raises an exception if parse is unsuccessful. -- --- * Raises an exception which can be caught by 'rescue' if parameter is not found. +-- NB: uses 'body' internally +formData :: FromForm a => ActionM a +formData = Trans.formData + +-- | Synonym for 'pathParam' -- --- * If parameter is found, but 'read' fails to parse to the correct type, 'next' is called. --- This means captures are somewhat typed, in that a route won't match if a correctly typed --- capture cannot be parsed. -param :: Trans.Parsable a => Text -> ActionM a -param = Trans.param +-- /Since: 0.20/ +captureParam :: Trans.Parsable a => Text -> ActionM a +captureParam = Trans.captureParam . toStrict --- | Get all parameters from capture, form and query (in that order). -params :: ActionM [Param] -params = Trans.params +-- | Get a path parameter. +-- +-- * Raises an exception which can be caught by 'catch' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 500 ("Internal Server Error") to the client. +-- +-- * If the parameter is found, but 'parseParam' fails to parse to the correct type, 'next' is called. +-- +-- /Since: 0.21/ +pathParam :: Trans.Parsable a => Text -> ActionM a +pathParam = Trans.pathParam . toStrict +-- | Get a form parameter. +-- +-- * Raises an exception which can be caught by 'catch' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client. +-- +-- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type. +-- +-- /Since: 0.20/ +formParam :: Trans.Parsable a => Text -> ActionM a +formParam = Trans.formParam . toStrict + +-- | Get a query parameter. +-- +-- * Raises an exception which can be caught by 'catch' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client. +-- +-- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type. +-- +-- /Since: 0.20/ +queryParam :: Trans.Parsable a => Text -> ActionM a +queryParam = Trans.queryParam . toStrict + + +-- | Look up a path parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. +-- +-- NB : Doesn't throw exceptions. In particular, route pattern matching will not continue, so developers +-- must 'raiseStatus' or 'throw' to signal something went wrong. +-- +-- /Since: 0.21/ +pathParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a) +pathParamMaybe = Trans.pathParamMaybe . toStrict + +-- | Synonym for 'pathParamMaybe' +-- +-- /Since: 0.21/ +captureParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a) +captureParamMaybe = Trans.pathParamMaybe . toStrict + +-- | Look up a form parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. +-- +-- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong. +-- +-- /Since: 0.21/ +formParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a) +formParamMaybe = Trans.formParamMaybe . toStrict + +-- | Look up a query parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. +-- +-- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong. +-- +-- /Since: 0.21/ +queryParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a) +queryParamMaybe = Trans.queryParamMaybe . toStrict + +-- | Synonym for 'pathParams' +captureParams :: ActionM [Param] +captureParams = Trans.captureParams +-- | Get path parameters +pathParams :: ActionM [Param] +pathParams = Trans.pathParams +-- | Get form parameters +formParams :: ActionM [Param] +formParams = Trans.formParams +-- | Get query parameters +queryParams :: ActionM [Param] +queryParams = Trans.queryParams + + -- | Set the HTTP response status. Default is 200. status :: Status -> ActionM () status = Trans.status @@ -245,6 +433,24 @@ raw :: ByteString -> ActionM () raw = Trans.raw + +-- | Access the HTTP 'Status' of the Response +-- +-- /Since: 0.21/ +getResponseStatus :: ActionM Status +getResponseStatus = Trans.getResponseStatus +-- | Access the HTTP headers of the Response +-- +-- /Since: 0.21/ +getResponseHeaders :: ActionM ResponseHeaders +getResponseHeaders = Trans.getResponseHeaders +-- | Access the content of the Response +-- +-- /Since: 0.21/ +getResponseContent :: ActionM Content +getResponseContent = Trans.getResponseContent + + -- | get = 'addroute' 'GET' get :: RoutePattern -> ActionM () -> ScottyM () get = Trans.get @@ -278,35 +484,37 @@ notFound :: ActionM () -> ScottyM () notFound = Trans.notFound --- | Define a route with a 'StdMethod', 'Text' value representing the path spec, --- and a body ('Action') which modifies the response. --- --- > addroute GET "/" $ text "beam me up!" --- --- The path spec can include values starting with a colon, which are interpreted --- as /captures/. These are named wildcards that can be looked up with 'param'. --- --- > addroute GET "/foo/:bar" $ do --- > v <- param "bar" --- > text v --- --- >>> curl http://localhost:3000/foo/something --- something +{- | Define a route with a 'StdMethod', a route pattern representing the path spec, +and an 'Action' which may modify the response. + +> get "/" $ text "beam me up!" + +The path spec can include values starting with a colon, which are interpreted +as /captures/. These are parameters that can be looked up with 'pathParam'. + +>>> :{ +let server = S.get "/foo/:bar" (S.pathParam "bar" >>= S.text) + in do + withScotty server $ curl "http://localhost:3000/foo/something" +:} +"something" +-} addroute :: StdMethod -> RoutePattern -> ActionM () -> ScottyM () addroute = Trans.addroute --- | Match requests using a regular expression. --- Named captures are not yet supported. --- --- > get (regex "^/f(.*)r$") $ do --- > path <- param "0" --- > cap <- param "1" --- > text $ mconcat ["Path: ", path, "\nCapture: ", cap] --- --- >>> curl http://localhost:3000/foo/bar --- Path: /foo/bar --- Capture: oo/ba --- + +{- | Match requests using a regular expression. +Named captures are not yet supported. + +>>> :{ +let server = S.get (S.regex "^/f(.*)r$") $ do + cap <- S.pathParam "1" + S.text cap + in do + withScotty server $ curl "http://localhost:3000/foo/bar" +:} +"oo/ba" +-} regex :: String -> RoutePattern regex = Trans.regex @@ -325,21 +533,82 @@ capture :: String -> RoutePattern capture = Trans.capture --- | Build a route based on a function which can match using the entire 'Request' object. --- 'Nothing' indicates the route does not match. A 'Just' value indicates --- a successful match, optionally returning a list of key-value pairs accessible --- by 'param'. --- --- > get (function $ \req -> Just [("version", pack $ show $ httpVersion req)]) $ do --- > v <- param "version" --- > text v --- --- >>> curl http://localhost:3000/ --- HTTP/1.1 --- + +{- | Build a route based on a function which can match using the entire 'Request' object. +'Nothing' indicates the route does not match. A 'Just' value indicates +a successful match, optionally returning a list of key-value pairs accessible by 'param'. + +>>> :{ +let server = S.get (function $ \req -> Just [("version", T.pack $ show $ W.httpVersion req)]) $ do + v <- S.pathParam "version" + S.text v + in do + withScotty server $ curl "http://localhost:3000/" +:} +"HTTP/1.1" +-} function :: (Request -> Maybe [Param]) -> RoutePattern function = Trans.function -- | Build a route that requires the requested path match exactly, without captures. literal :: String -> RoutePattern literal = Trans.literal + + +-- | Retrieves a session by its ID from the session jar. +getSession :: SessionJar a -> SessionId -> ActionM (Either SessionStatus (Session a)) +getSession = Trans.getSession + +-- | Deletes a session by its ID from the session jar. +deleteSession :: SessionJar a -> SessionId -> ActionM () +deleteSession = Trans.deleteSession + +{- | Retrieves the current user's session based on the "sess_id" cookie. +| Returns `Left SessionStatus` if the session is expired or does not exist. +-} +getUserSession :: SessionJar a -> ActionM (Either SessionStatus (Session a)) +getUserSession = Trans.getUserSession + +-- | Reads the content of a session by its ID. +readSession :: SessionJar a -> SessionId -> ActionM (Either SessionStatus a) +readSession = Trans.readSession + +-- | Reads the content of the current user's session. +readUserSession ::SessionJar a -> ActionM (Either SessionStatus a) +readUserSession = Trans.readUserSession + +-- | Creates a new session for a user, storing the content and setting a cookie. +createUserSession :: + SessionJar a -- ^ SessionJar, which can be created by createSessionJar + -> Maybe Int -- ^ Optional expiration time (in seconds) + -> a -- ^ Content + -> ActionM (Session a) +createUserSession = Trans.createUserSession + +-- Cookie functions + +-- | Set a cookie, with full access to its options (see 'SetCookie') +setCookie :: Cookie.SetCookie -> ActionM () +setCookie = Cookie.setCookie + +-- | 'makeSimpleCookie' and 'setCookie' combined. +setSimpleCookie :: T.Text -- ^ name + -> T.Text -- ^ value + -> ActionM () +setSimpleCookie = Cookie.setSimpleCookie + +-- | Lookup one cookie name +getCookie :: T.Text -- ^ name + -> ActionM (Maybe T.Text) +getCookie = Cookie.getCookie + +-- | Returns all cookies +getCookies :: ActionM Cookie.CookiesText +getCookies = Cookie.getCookies + +-- | Browsers don't directly delete a cookie, but setting its expiry to a past date (e.g. the UNIX epoch) +-- ensures that the cookie will be invalidated +-- (whether and when it will be actually deleted by the browser seems to be browser-dependent). +deleteCookie :: T.Text -- ^ name + -> ActionM () +deleteCookie = Cookie.deleteCookie diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -1,35 +1,63 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# language ScopedTypeVariables #-} module Web.Scotty.Action ( addHeader , body , bodyReader , file + , rawResponse , files + , filesOpts + , W.ParseRequestBodyOptions, W.defaultParseRequestBodyOptions , finish , header , headers , html - , liftAndCatchIO + , htmlLazy , json , jsonData + , formData , next - , param - , params - , raise - , raiseStatus + , pathParam + , captureParam + , formParam + , queryParam + , pathParamMaybe + , captureParamMaybe + , formParamMaybe + , queryParamMaybe + , pathParams + , captureParams + , formParams + , queryParams + , throw , raw + , nested , readEither , redirect + , redirect300 + , redirect301 + , redirect302 + , redirect303 + , redirect304 + , redirect307 + , redirect308 , request - , rescue , setHeader , status , stream , text + , textLazy + , getResponseStatus + , getResponseHeaders + , getResponseContent , Param , Parsable(..) + , ActionT -- private to Scotty , runAction ) where @@ -37,23 +65,32 @@ import Blaze.ByteString.Builder (fromLazyByteString) import qualified Control.Exception as E -import Control.Monad (liftM, when) -import Control.Monad.Error.Class +import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Reader (MonadReader(..), ReaderT(..)) -import qualified Control.Monad.State.Strict as MS -import Control.Monad.Trans.Except +import UnliftIO (MonadUnliftIO(..)) +import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks) +import Control.Monad.Trans.Resource (withInternalState, runResourceT) +import Control.Concurrent.MVar + import qualified Data.Aeson as A +import Data.Bool (bool) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI -import Data.Default.Class (def) +import Data.Traversable (for) +import qualified Data.Map.Strict as Map +import qualified Data.HashMap.Strict as HM import Data.Int -import qualified Data.Text as ST -import qualified Data.Text.Encoding as STE -import qualified Data.Text.Lazy as T -import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.List (foldl') +import Data.Maybe (maybeToList) +import qualified Data.Text as T +import Data.Text.Encoding as STE +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import Data.Time (UTCTime) +import Data.Time.Format (parseTimeM, defaultTimeLocale) +import Data.Typeable (typeOf) import Data.Word import Network.HTTP.Types @@ -61,130 +98,326 @@ #if !MIN_VERSION_http_types(0,11,0) import Network.HTTP.Types.Status #endif -import Network.Wai +import Network.Wai (Request, Response, StreamingBody, Application, requestHeaders) +import Network.Wai.Handler.Warp (InvalidRequest(..)) +import qualified Network.Wai.Parse as W (FileInfo(..), ParseRequestBodyOptions, defaultParseRequestBodyOptions) import Numeric.Natural -import Prelude () -import Prelude.Compat - +import Web.FormUrlEncoded (Form(..), FromForm(..)) import Web.Scotty.Internal.Types -import Web.Scotty.Util +import Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, decodeUtf8Lenient) +import UnliftIO.Exception (Handler(..), catches, throwIO) +import System.IO (hPutStrLn, stderr) --- Nothing indicates route failed (due to Next) and pattern matching should continue. --- Just indicates a successful response. -runAction :: (ScottyError e, Monad m) => ErrorHandler e m -> ActionEnv -> ActionT e m () -> m (Maybe Response) -runAction h env action = do - (e,r) <- flip MS.runStateT def - $ flip runReaderT env - $ runExceptT - $ runAM - $ action `catchError` (defH h) - return $ either (const Nothing) (const $ Just $ mkResponse r) e +import Network.Wai.Internal (ResponseReceived(..)) --- | Default error handler for all actions. -defH :: (ScottyError e, Monad m) => ErrorHandler e m -> ActionError e -> ActionT e m () -defH _ (Redirect url) = do - status status302 - setHeader "Location" url -defH Nothing (ActionError s e) = do + +-- | Evaluate a route, catch all exceptions (user-defined ones, internal and all remaining, in this order) +-- and construct the 'Response' +-- +-- 'Nothing' indicates route failed (due to Next) and pattern matching should try the next available route. +-- 'Just' indicates a successful response. +runAction :: MonadUnliftIO m => + Options + -> Maybe (ErrorHandler m) -- ^ this handler (if present) is in charge of user-defined exceptions + -> ActionEnv + -> ActionT m () -- ^ Route action to be evaluated + -> m (Maybe Response) +runAction options mh env action = do + ok <- flip runReaderT env $ runAM $ tryNext $ action `catches` concat + [ [actionErrorHandler] + , maybeToList mh + , [scottyExceptionHandler options, someExceptionHandler options] + ] + res <- getResponse env + return $ bool Nothing (Just $ mkResponse res) ok + +-- | Exception handler in charge of 'ActionError'. Rethrowing 'Next' here is caught by 'tryNext'. +-- All other cases of 'ActionError' are converted to HTTP responses. +actionErrorHandler :: MonadIO m => ErrorHandler m +actionErrorHandler = Handler $ \case + AERedirect s url -> do status s - let code = T.pack $ show $ statusCode s - let msg = T.fromStrict $ STE.decodeUtf8 $ statusMessage s - html $ mconcat ["

", code, " ", msg, "

", showError e] -defH h@(Just f) (ActionError _ e) = f e `catchError` (defH h) -- so handlers can throw exceptions themselves -defH _ Next = next -defH _ Finish = return () + setHeader "Location" url + AENext -> next + AEFinish -> return () --- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions --- turn into HTTP 500 responses. -raise :: (ScottyError e, Monad m) => e -> ActionT e m a -raise = raiseStatus status500 +-- | Default handler for exceptions from scotty +scottyExceptionHandler :: MonadIO m => Options -> ErrorHandler m +scottyExceptionHandler Options{jsonMode} = Handler $ \case + RequestTooLarge -> do + status status413 + if jsonMode + then json $ A.object ["status" A..= (413 :: Int), "description" A..= ("Request body is too large" :: T.Text)] + else text "Request body is too large" + MalformedJSON bs err -> do + status status400 + if jsonMode + then json $ A.object + [ "status" A..= (400 :: Int) + , "description" A..= ("jsonData: malformed" :: T.Text) + , "body" A..= decodeUtf8Lenient (BL.toStrict bs) + , "error" A..= err + ] + else raw $ BL.unlines + [ "jsonData: malformed" + , "Body: " <> bs + , "Error: " <> BL.fromStrict (encodeUtf8 err) + ] + FailedToParseJSON bs err -> do + status status422 + if jsonMode + then json $ A.object + [ "status" A..= (422 :: Int) + , "description" A..= ("jsonData: failed to parse" :: T.Text) + , "body" A..= decodeUtf8Lenient (BL.toStrict bs) + , "error" A..= err + ] + else raw $ BL.unlines + [ "jsonData: failed to parse" + , "Body: " <> bs + , "Error: " <> BL.fromStrict (encodeUtf8 err) + ] + MalformedForm err -> do + status status400 + if jsonMode + then json $ A.object + [ "status" A..= (400 :: Int) + , "description" A..= ("formData: malformed" :: T.Text) + , "error" A..= err + ] + else raw $ BL.unlines + [ "formData: malformed" + , "Error: " <> BL.fromStrict (encodeUtf8 err) + ] + PathParameterNotFound k -> do + status status500 + if jsonMode + then json $ A.object + [ "status" A..= (500 :: Int) + , "description" A..= T.unwords [ "Path parameter", k, "not found"] + ] + else text $ T.unwords [ "Path parameter", k, "not found"] + QueryParameterNotFound k -> do + status status400 + if jsonMode + then json $ A.object + [ "status" A..= (400 :: Int) + , "description" A..= T.unwords [ "Query parameter", k, "not found"] + ] + else text $ T.unwords [ "Query parameter", k, "not found"] + FormFieldNotFound k -> do + status status400 + if jsonMode + then json $ A.object + [ "status" A..= (400 :: Int) + , "description" A..= T.unwords [ "Form field", k, "not found"] + ] + else text $ T.unwords [ "Form field", k, "not found"] + FailedToParseParameter k v e -> do + status status400 + if jsonMode + then json $ A.object + [ "status" A..= (400 :: Int) + , "description" A..= T.unwords [ "Failed to parse parameter", k, v, ":", e] + ] + else text $ T.unwords [ "Failed to parse parameter", k, v, ":", e] + WarpRequestException we -> case we of + RequestHeaderFieldsTooLarge -> do + status status413 + if jsonMode + then json $ A.object + [ "status" A..= (413 :: Int) + , "description" A..= ("Request header fields too large" :: T.Text) + ] + else text "Request header fields too large" + weo -> do -- FIXME fall-through case on InvalidRequest, it would be nice to return more specific error messages and codes here + status status400 + if jsonMode + then json $ A.object + [ "status" A..= (400 :: Int) + , "description" A..= T.unwords ["Request Exception:", T.pack (show weo)] + ] + else text $ T.unwords ["Request Exception:", T.pack (show weo)] + WaiRequestParseException we -> do + status status413 -- 413 Content Too Large https://developer.mozilla.org/en-US/docs/Web/HTTP/Status/413 + if jsonMode + then json $ A.object + [ "status" A..= (413 :: Int) + , "description" A..= T.unwords ["wai-extra Exception:", T.pack (show we)] + ] + else text $ T.unwords ["wai-extra Exception:", T.pack (show we)] + ResourceTException rte -> do + status status500 + if jsonMode + then json $ A.object + [ "status" A..= (500 :: Int) + , "description" A..= T.unwords ["resourcet Exception:", T.pack (show rte)] + ] + else text $ T.unwords ["resourcet Exception:", T.pack (show rte)] --- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions turn into HTTP responses corresponding to the given status. -raiseStatus :: (ScottyError e, Monad m) => Status -> e -> ActionT e m a -raiseStatus s = throwError . ActionError s +-- | Uncaught exceptions turn into HTTP 500 Server Error codes +someExceptionHandler :: MonadIO m => Options -> ErrorHandler m +someExceptionHandler Options{verbose, jsonMode} = + Handler $ \(E.SomeException e) -> do + when (verbose > 0) $ + liftIO $ + hPutStrLn stderr $ + "Unhandled exception of " <> show (typeOf e) <> ": " <> show e + status status500 + if jsonMode + then json $ A.object + [ "status" A..= (500 :: Int) + , "description" A..= ("Internal Server Error" :: T.Text) + ] + else text "Internal Server Error" +-- | Throw an exception which can be caught within the scope of the current Action with 'catch'. +-- +-- If the exception is not caught locally, another option is to implement a global 'Handler' (with 'defaultHandler') that defines its interpretation and a translation to HTTP error codes. +-- +-- Uncaught exceptions turn into HTTP 500 responses. +throw :: (MonadIO m, E.Exception e) => e -> ActionT m a +throw = E.throw + -- | Abort execution of this action and continue pattern matching routes. -- Like an exception, any code after 'next' is not executed. -- +-- NB : Internally, this is implemented with an exception that can only be +-- caught by the library, but not by the user. +-- -- As an example, these two routes overlap. The only way the second one will -- ever run is if the first one calls 'next'. -- -- > get "/foo/:bar" $ do --- > w :: Text <- param "bar" +-- > w :: Text <- pathParam "bar" -- > unless (w == "special") next -- > text "You made a request to /foo/special" -- > -- > get "/foo/:baz" $ do --- > w <- param "baz" +-- > w <- pathParam "baz" -- > text $ "You made a request to: " <> w -next :: (ScottyError e, Monad m) => ActionT e m a -next = throwError Next - --- | Catch an exception thrown by 'raise'. --- --- > raise "just kidding" `rescue` (\msg -> text msg) -rescue :: (ScottyError e, Monad m) => ActionT e m a -> (e -> ActionT e m a) -> ActionT e m a -rescue action h = catchError action $ \e -> case e of - ActionError _ err -> h err -- handle errors - other -> throwError other -- rethrow internal error types - --- | Like 'liftIO', but catch any IO exceptions and turn them into 'ScottyError's. -liftAndCatchIO :: (ScottyError e, MonadIO m) => IO a -> ActionT e m a -liftAndCatchIO io = ActionT $ do - r <- liftIO $ liftM Right io `E.catch` (\ e -> return $ Left $ stringError $ show (e :: E.SomeException)) - either throwError return r +next :: Monad m => ActionT m a +next = E.throw AENext --- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect --- will not be run. +-- | Synonym for 'redirect302'. +-- If you are unsure which redirect to use, you probably want this one. -- -- > redirect "http://www.google.com" -- -- OR -- -- > redirect "/foo/bar" -redirect :: (ScottyError e, Monad m) => T.Text -> ActionT e m a -redirect = throwError . Redirect +redirect :: (Monad m) => T.Text -> ActionT m a +redirect = redirect302 +-- | Redirect to given URL with status 300 (Multiple Choices). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect300 :: (Monad m) => T.Text -> ActionT m a +redirect300 = redirectStatus status300 + +-- | Redirect to given URL with status 301 (Moved Permanently). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect301 :: (Monad m) => T.Text -> ActionT m a +redirect301 = redirectStatus status301 + +-- | Redirect to given URL with status 302 (Found). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect302 :: (Monad m) => T.Text -> ActionT m a +redirect302 = redirectStatus status302 + +-- | Redirect to given URL with status 303 (See Other). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect303 :: (Monad m) => T.Text -> ActionT m a +redirect303 = redirectStatus status303 + +-- | Redirect to given URL with status 304 (Not Modified). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect304 :: (Monad m) => T.Text -> ActionT m a +redirect304 = redirectStatus status304 + +-- | Redirect to given URL with status 307 (Temporary Redirect). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect307 :: (Monad m) => T.Text -> ActionT m a +redirect307 = redirectStatus status307 + +-- | Redirect to given URL with status 308 (Permanent Redirect). Like throwing +-- an uncatchable exception. Any code after the call to +-- redirect will not be run. +redirect308 :: (Monad m) => T.Text -> ActionT m a +redirect308 = redirectStatus status308 + +redirectStatus :: (Monad m) => Status -> T.Text -> ActionT m a +redirectStatus s = E.throw . AERedirect s + -- | Finish the execution of the current action. Like throwing an uncatchable -- exception. Any code after the call to finish will not be run. -- -- /Since: 0.10.3/ -finish :: (ScottyError e, Monad m) => ActionT e m a -finish = throwError Finish +finish :: (Monad m) => ActionT m a +finish = E.throw AEFinish -- | Get the 'Request' object. -request :: Monad m => ActionT e m Request -request = ActionT $ liftM getReq ask +request :: Monad m => ActionT m Request +request = ActionT $ envReq <$> ask -- | Get list of uploaded files. -files :: Monad m => ActionT e m [File] -files = ActionT $ liftM getFiles ask +-- +-- NB: Loads all file contents in memory with options 'W.defaultParseRequestBodyOptions' +files :: MonadUnliftIO m => ActionT m [File BL.ByteString] +files = runResourceT $ withInternalState $ \istate -> do + (_, fs) <- formParamsAndFilesWith istate W.defaultParseRequestBodyOptions + for fs (\(fname, f) -> do + bs <- liftIO $ BL.readFile (W.fileContent f) + pure (fname, f{ W.fileContent = bs}) + ) + +-- | Get list of uploaded temp files and form parameters decoded from multipart payloads. +-- +-- NB the temp files are deleted when the continuation exits. +filesOpts :: MonadUnliftIO m => + W.ParseRequestBodyOptions + -> ([Param] -> [File FilePath] -> ActionT m a) -- ^ temp files validation, storage etc + -> ActionT m a +filesOpts prbo io = runResourceT $ withInternalState $ \istate -> do + (ps, fs) <- formParamsAndFilesWith istate prbo + io ps fs + + + -- | Get a request header. Header name is case-insensitive. -header :: (ScottyError e, Monad m) => T.Text -> ActionT e m (Maybe T.Text) +header :: (Monad m) => T.Text -> ActionT m (Maybe T.Text) header k = do - hs <- liftM requestHeaders request - return $ fmap strictByteStringToLazyText $ lookup (CI.mk (lazyTextToStrictByteString k)) hs + hs <- requestHeaders <$> request + return $ fmap decodeUtf8Lenient $ lookup (CI.mk (encodeUtf8 k)) hs -- | Get all the request headers. Header names are case-insensitive. -headers :: (ScottyError e, Monad m) => ActionT e m [(T.Text, T.Text)] +headers :: (Monad m) => ActionT m [(T.Text, T.Text)] headers = do - hs <- liftM requestHeaders request - return [ ( strictByteStringToLazyText (CI.original k) - , strictByteStringToLazyText v) + hs <- requestHeaders <$> request + return [ ( decodeUtf8Lenient (CI.original k) + , decodeUtf8Lenient v) | (k,v) <- hs ] -- | Get the request body. -body :: (ScottyError e, MonadIO m) => ActionT e m BL.ByteString -body = ActionT ask >>= (liftIO . getBody) +-- +-- NB This loads the whole request body in memory at once. +body :: (MonadIO m) => ActionT m BL.ByteString +body = ActionT ask >>= (liftIO . envBody) -- | Get an IO action that reads body chunks -- -- * This is incompatible with 'body' since 'body' consumes all chunks. -bodyReader :: Monad m => ActionT e m (IO B.ByteString) -bodyReader = ActionT $ getBodyChunk `liftM` ask +bodyReader :: Monad m => ActionT m (IO B.ByteString) +bodyReader = ActionT $ envBodyChunk <$> ask -- | Parse the request body as a JSON object and return it. -- @@ -195,81 +428,237 @@ -- 422 Unprocessable Entity. -- -- These status codes are as per https://www.restapitutorial.com/httpstatuscodes.html. -jsonData :: (A.FromJSON a, ScottyError e, MonadIO m) => ActionT e m a +-- +-- NB : Internally this uses 'body'. +jsonData :: (A.FromJSON a, MonadIO m) => ActionT m a jsonData = do b <- body - when (b == "") $ do - let htmlError = "jsonData - No data was provided." - raiseStatus status400 $ stringError htmlError + when (b == "") $ throwIO $ MalformedJSON b "no data" case A.eitherDecode b of - Left err -> do - let htmlError = "jsonData - malformed." - `mappend` " Data was: " `mappend` BL.unpack b - `mappend` " Error was: " `mappend` err - raiseStatus status400 $ stringError htmlError + Left err -> throwIO $ MalformedJSON b $ T.pack err Right value -> case A.fromJSON value of - A.Error err -> do - let htmlError = "jsonData - failed parse." - `mappend` " Data was: " `mappend` BL.unpack b `mappend` "." - `mappend` " Error was: " `mappend` err - raiseStatus status422 $ stringError htmlError - A.Success a -> do - return a + A.Error err -> throwIO $ FailedToParseJSON b $ T.pack err + A.Success a -> return a --- | Get a parameter. First looks in captures, then form data, then query parameters. +-- | Parse the request body as @x-www-form-urlencoded@ form data and return it. -- --- * Raises an exception which can be caught by 'rescue' if parameter is not found. +-- The form is parsed using 'urlDecodeAsForm'. If that returns 'Left', the +-- status is set to 400 and an exception is thrown. +formData :: (FromForm a, MonadUnliftIO m) => ActionT m a +formData = do + form <- paramListToForm <$> formParams + case fromForm form of + Left err -> throwIO $ MalformedForm err + Right value -> return value + where + -- This rather contrived implementation uses cons and reverse to avoid + -- quadratic complexity when constructing a Form from a list of Param. + -- It's equivalent to using HashMap.insertWith (++) which does have + -- quadratic complexity due to appending at the end of list. + paramListToForm :: [Param] -> Form + paramListToForm = Form . fmap reverse . foldl' (\f (k, v) -> HM.alter (prependValue v) k f) HM.empty + + prependValue :: a -> Maybe [a] -> Maybe [a] + prependValue v = Just . maybe [v] (v :) + +-- | Synonym for 'pathParam' +captureParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a +captureParam = pathParam + +-- | Look up a path parameter. -- --- * If parameter is found, but 'read' fails to parse to the correct type, 'next' is called. --- This means captures are somewhat typed, in that a route won't match if a correctly typed --- capture cannot be parsed. -param :: (Parsable a, ScottyError e, Monad m) => T.Text -> ActionT e m a -param k = do - val <- ActionT $ liftM (lookup k . getParams) ask +-- * Raises an exception which can be caught by 'catch' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 500 ("Internal Server Error") to the client. +-- +-- * If the parameter is found, but 'parseParam' fails to parse to the correct type, 'next' is called. +-- +-- /Since: 0.20/ +pathParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a +pathParam k = do + val <- ActionT $ lookup k . envPathParams <$> ask + case val of + Nothing -> throwIO $ PathParameterNotFound k + Just v -> case parseParam $ TL.fromStrict v of + Left _ -> next + Right a -> pure a + +-- | Look up a form parameter. +-- +-- * Raises an exception which can be caught by 'catch' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client. +-- +-- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type. +-- +-- /Since: 0.20/ +formParam :: (MonadUnliftIO m, Parsable b) => T.Text -> ActionT m b +formParam k = runResourceT $ withInternalState $ \istate -> do + (ps, _) <- formParamsAndFilesWith istate W.defaultParseRequestBodyOptions + case lookup k ps of + Nothing -> throwIO $ FormFieldNotFound k + Just v -> case parseParam $ TL.fromStrict v of + Left e -> throwIO $ FailedToParseParameter k v (TL.toStrict e) + Right a -> pure a + +-- | Look up a query parameter. +-- +-- * Raises an exception which can be caught by 'catch' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client. +-- +-- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type. +-- +-- /Since: 0.20/ +queryParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a +queryParam = paramWith QueryParameterNotFound envQueryParams + +-- | Look up a path parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. +-- +-- NB : Doesn't throw exceptions. In particular, route pattern matching will not continue, so developers +-- must 'raiseStatus' or 'throw' to signal something went wrong. +-- +-- /Since: 0.21/ +pathParamMaybe :: (Parsable a, Monad m) => T.Text -> ActionT m (Maybe a) +pathParamMaybe = paramWithMaybe envPathParams + +-- | Look up a capture parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. +-- +-- NB : Doesn't throw exceptions. In particular, route pattern matching will not continue, so developers +-- must 'raiseStatus' or 'throw' to signal something went wrong. +-- +-- /Since: 0.21/ +captureParamMaybe :: (Parsable a, Monad m) => T.Text -> ActionT m (Maybe a) +captureParamMaybe = paramWithMaybe envPathParams + +-- | Look up a form parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. +-- +-- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong. +-- +-- /Since: 0.21/ +formParamMaybe :: (MonadUnliftIO m, Parsable a) => + T.Text -> ActionT m (Maybe a) +formParamMaybe k = runResourceT $ withInternalState $ \istate -> do + (ps, _) <- formParamsAndFilesWith istate W.defaultParseRequestBodyOptions + case lookup k ps of + Nothing -> pure Nothing + Just v -> either (const $ pure Nothing) (pure . Just) $ parseParam $ TL.fromStrict v + + +-- | Look up a query parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. +-- +-- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong. +-- +-- /Since: 0.21/ +queryParamMaybe :: (Parsable a, Monad m) => T.Text -> ActionT m (Maybe a) +queryParamMaybe = paramWithMaybe envQueryParams + +data ParamType = PathParam + | FormParam + | QueryParam +instance Show ParamType where + show = \case + PathParam -> "path" + FormParam -> "form" + QueryParam -> "query" + +paramWith :: (MonadIO m, Parsable b) => + (T.Text -> ScottyException) + -> (ActionEnv -> [Param]) + -> T.Text -- ^ parameter name + -> ActionT m b +paramWith toError f k = do + val <- ActionT $ (lookup k . f) <$> ask case val of - Nothing -> raise $ stringError $ "Param: " ++ T.unpack k ++ " not found!" - Just v -> either (const next) return $ parseParam v + Nothing -> throwIO $ toError k + Just v -> case parseParam $ TL.fromStrict v of + Left e -> throwIO $ FailedToParseParameter k v (TL.toStrict e) + Right a -> pure a --- | Get all parameters from capture, form and query (in that order). -params :: Monad m => ActionT e m [Param] -params = ActionT $ liftM getParams ask +-- | Look up a parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. +-- +-- NB : Doesn't throw exceptions. +-- +-- /Since: 0.21/ +paramWithMaybe :: (Monad m, Parsable b) => + (ActionEnv -> [Param]) + -> T.Text -- ^ parameter name + -> ActionT m (Maybe b) +paramWithMaybe f k = do + val <- ActionT $ asks (lookup k . f) + case val of + Nothing -> pure Nothing + Just v -> either (const $ pure Nothing) (pure . Just) $ parseParam $ TL.fromStrict v +-- | Get path parameters +pathParams :: Monad m => ActionT m [Param] +pathParams = paramsWith envPathParams + +-- | Get path parameters +captureParams :: Monad m => ActionT m [Param] +captureParams = paramsWith envPathParams + +-- | Get form parameters +formParams :: MonadUnliftIO m => ActionT m [Param] +formParams = runResourceT $ withInternalState $ \istate -> do + fst <$> formParamsAndFilesWith istate W.defaultParseRequestBodyOptions + +-- | Get query parameters +queryParams :: Monad m => ActionT m [Param] +queryParams = paramsWith envQueryParams + +paramsWith :: Monad m => (ActionEnv -> a) -> ActionT m a +paramsWith f = ActionT (asks f) + +-- === access the fields of the Response being constructed + +-- | Access the HTTP 'Status' of the Response +-- +-- /SINCE 0.21/ +getResponseStatus :: (MonadIO m) => ActionT m Status +getResponseStatus = srStatus <$> getResponseAction +-- | Access the HTTP headers of the Response +-- +-- /SINCE 0.21/ +getResponseHeaders :: (MonadIO m) => ActionT m ResponseHeaders +getResponseHeaders = srHeaders <$> getResponseAction +-- | Access the content of the Response +-- +-- /SINCE 0.21/ +getResponseContent :: (MonadIO m) => ActionT m Content +getResponseContent = srContent <$> getResponseAction + + -- | Minimum implemention: 'parseParam' class Parsable a where -- | Take a 'T.Text' value and parse it as 'a', or fail with a message. - parseParam :: T.Text -> Either T.Text a + parseParam :: TL.Text -> Either TL.Text a -- | Default implementation parses comma-delimited lists. -- -- > parseParamList t = mapM parseParam (T.split (== ',') t) - parseParamList :: T.Text -> Either T.Text [a] - parseParamList t = mapM parseParam (T.split (== ',') t) + parseParamList :: TL.Text -> Either TL.Text [a] + parseParamList t = mapM parseParam (TL.split (== ',') t) -- No point using 'read' for Text, ByteString, Char, and String. -instance Parsable T.Text where parseParam = Right -instance Parsable ST.Text where parseParam = Right . T.toStrict +instance Parsable T.Text where parseParam = Right . TL.toStrict +instance Parsable TL.Text where parseParam = Right instance Parsable B.ByteString where parseParam = Right . lazyTextToStrictByteString -instance Parsable BL.ByteString where parseParam = Right . encodeUtf8 +instance Parsable BL.ByteString where parseParam = Right . TLE.encodeUtf8 -- | Overrides default 'parseParamList' to parse String. instance Parsable Char where - parseParam t = case T.unpack t of + parseParam t = case TL.unpack t of [c] -> Right c _ -> Left "parseParam Char: no parse" - parseParamList = Right . T.unpack -- String + parseParamList = Right . TL.unpack -- String -- | Checks if parameter is present and is null-valued, not a literal '()'. -- If the URI requested is: '/foo?bar=()&baz' then 'baz' will parse as (), where 'bar' will not. instance Parsable () where - parseParam t = if T.null t then Right () else Left "parseParam Unit: no parse" + parseParam t = if TL.null t then Right () else Left "parseParam Unit: no parse" instance (Parsable a) => Parsable [a] where parseParam = parseParamList instance Parsable Bool where - parseParam t = if t' == T.toCaseFold "true" + parseParam t = if t' == TL.toCaseFold "true" || t' == TL.toCaseFold "on" then Right True - else if t' == T.toCaseFold "false" + else if t' == TL.toCaseFold "false" then Right False else Left "parseParam Bool: no parse" - where t' = T.toCaseFold t + where t' = TL.toCaseFold t instance Parsable Double where parseParam = readEither instance Parsable Float where parseParam = readEither @@ -288,61 +677,87 @@ instance Parsable Word64 where parseParam = readEither instance Parsable Natural where parseParam = readEither +-- | parse a UTCTime timestamp formatted as a ISO 8601 timestamp: +-- +-- @yyyy-mm-ddThh:mm:ssZ@ , where the seconds can have a decimal part with up to 12 digits and no trailing zeros. +instance Parsable UTCTime where + parseParam t = + let + fmt = "%FT%T%QZ" + in + case parseTimeM True defaultTimeLocale fmt (TL.unpack t) of + Just d -> Right d + _ -> Left $ "parseParam UTCTime: no parse of \"" <> t <> "\"" + -- | Useful for creating 'Parsable' instances for things that already implement 'Read'. Ex: -- -- > instance Parsable Int where parseParam = readEither -readEither :: Read a => T.Text -> Either T.Text a -readEither t = case [ x | (x,"") <- reads (T.unpack t) ] of +readEither :: Read a => TL.Text -> Either TL.Text a +readEither t = case [ x | (x,"") <- reads (TL.unpack t) ] of [x] -> Right x [] -> Left "readEither: no parse" _ -> Left "readEither: ambiguous parse" --- | Set the HTTP response status. Default is 200. -status :: Monad m => Status -> ActionT e m () -status = ActionT . MS.modify . setStatus +-- | Set the HTTP response status. +status :: MonadIO m => Status -> ActionT m () +status = modifyResponse . setStatus -- Not exported, but useful in the functions below. -changeHeader :: Monad m +changeHeader :: MonadIO m => (CI.CI B.ByteString -> B.ByteString -> [(HeaderName, B.ByteString)] -> [(HeaderName, B.ByteString)]) - -> T.Text -> T.Text -> ActionT e m () -changeHeader f k = ActionT - . MS.modify - . setHeaderWith - . f (CI.mk $ lazyTextToStrictByteString k) - . lazyTextToStrictByteString + -> T.Text -> T.Text -> ActionT m () +changeHeader f k = + modifyResponse . setHeaderWith . f (CI.mk $ encodeUtf8 k) . encodeUtf8 -- | Add to the response headers. Header names are case-insensitive. -addHeader :: Monad m => T.Text -> T.Text -> ActionT e m () +addHeader :: MonadIO m => T.Text -> T.Text -> ActionT m () addHeader = changeHeader add -- | Set one of the response headers. Will override any previously set value for that header. -- Header names are case-insensitive. -setHeader :: Monad m => T.Text -> T.Text -> ActionT e m () +setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m () setHeader = changeHeader replace -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" -- header to \"text/plain; charset=utf-8\" if it has not already been set. -text :: (ScottyError e, Monad m) => T.Text -> ActionT e m () +text :: (MonadIO m) => T.Text -> ActionT m () text t = do changeHeader addIfNotPresent "Content-Type" "text/plain; charset=utf-8" - raw $ encodeUtf8 t + raw $ BL.fromStrict $ encodeUtf8 t -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" +-- header to \"text/plain; charset=utf-8\" if it has not already been set. +textLazy :: (MonadIO m) => TL.Text -> ActionT m () +textLazy t = do + changeHeader addIfNotPresent "Content-Type" "text/plain; charset=utf-8" + raw $ TLE.encodeUtf8 t + +-- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" -- header to \"text/html; charset=utf-8\" if it has not already been set. -html :: (ScottyError e, Monad m) => T.Text -> ActionT e m () +html :: (MonadIO m) => T.Text -> ActionT m () html t = do changeHeader addIfNotPresent "Content-Type" "text/html; charset=utf-8" - raw $ encodeUtf8 t + raw $ BL.fromStrict $ encodeUtf8 t +-- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" +-- header to \"text/html; charset=utf-8\" if it has not already been set. +htmlLazy :: (MonadIO m) => TL.Text -> ActionT m () +htmlLazy t = do + changeHeader addIfNotPresent "Content-Type" "text/html; charset=utf-8" + raw $ TLE.encodeUtf8 t + -- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably -- want to do that on your own with 'setHeader'. Setting a status code will have no effect -- because Warp will overwrite that to 200 (see 'Network.Wai.Handler.Warp.Internal.sendResponse'). -file :: Monad m => FilePath -> ActionT e m () -file = ActionT . MS.modify . setContent . ContentFile +file :: MonadIO m => FilePath -> ActionT m () +file = modifyResponse . setContent . ContentFile +rawResponse :: MonadIO m => Response -> ActionT m () +rawResponse = modifyResponse . setContent . ContentResponse + -- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\" -- header to \"application/json; charset=utf-8\" if it has not already been set. -json :: (A.ToJSON a, ScottyError e, Monad m) => a -> ActionT e m () +json :: (A.ToJSON a, MonadIO m) => a -> ActionT m () json v = do changeHeader addIfNotPresent "Content-Type" "application/json; charset=utf-8" raw $ A.encode v @@ -350,11 +765,22 @@ -- | Set the body of the response to a Source. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'setHeader'. -stream :: Monad m => StreamingBody -> ActionT e m () -stream = ActionT . MS.modify . setContent . ContentStream +stream :: MonadIO m => StreamingBody -> ActionT m () +stream = modifyResponse . setContent . ContentStream -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'setHeader'. -raw :: Monad m => BL.ByteString -> ActionT e m () -raw = ActionT . MS.modify . setContent . ContentBuilder . fromLazyByteString +raw :: MonadIO m => BL.ByteString -> ActionT m () +raw = modifyResponse . setContent . ContentBuilder . fromLazyByteString + +-- | Nest a whole WAI application inside a Scotty handler. +-- See Web.Scotty for further documentation +nested :: (MonadIO m) => Network.Wai.Application -> ActionT m () +nested app = do + -- Is MVar really the best choice here? Not sure. + r <- request + ref <- liftIO $ newEmptyMVar + _ <- liftIO $ app r (\res -> putMVar ref res >> return ResponseReceived) + res <- liftIO $ readMVar ref + rawResponse res 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 --- a/Web/Scotty/Internal/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -1,283 +1,288 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# language ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE RecordWildCards #-} - +{-# LANGUAGE LambdaCase #-} module Web.Scotty.Internal.Types where import Blaze.ByteString.Builder (Builder) import Control.Applicative -import Control.Exception (Exception) +import Control.Concurrent.MVar +import Control.Concurrent.STM (TVar, atomically, readTVarIO, modifyTVar') import qualified Control.Exception as E -import qualified Control.Monad as Monad import Control.Monad (MonadPlus(..)) -import Control.Monad.Base (MonadBase, liftBase, liftBaseDefault) -import Control.Monad.Catch (MonadCatch, catch, MonadThrow, throwM) -import Control.Monad.Error.Class -import qualified Control.Monad.Fail as Fail -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Reader (MonadReader(..), ReaderT, mapReaderT) -import Control.Monad.State.Strict (MonadState(..), State, StateT, mapStateT) +import Control.Monad.Base (MonadBase) +import Control.Monad.Catch (MonadCatch, MonadThrow) +import Control.Monad.IO.Class (MonadIO(..)) +import UnliftIO (MonadUnliftIO(..)) +import Control.Monad.Reader (MonadReader(..), ReaderT, asks, mapReaderT) +import Control.Monad.State.Strict (State) import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.Control (MonadBaseControl, StM, liftBaseWith, restoreM, ComposeSt, defaultLiftBaseWith, defaultRestoreM, MonadTransControl, StT, liftWith, restoreT) -import Control.Monad.Trans.Except +import Control.Monad.Trans.Control (MonadBaseControl, MonadTransControl) +import qualified Control.Monad.Trans.Resource as RT (InternalState, InvalidAccess) import qualified Data.ByteString as BS -import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Default.Class (Default, def) +import qualified Data.ByteString.Lazy.Char8 as LBS8 (ByteString) import Data.String (IsString(..)) -import Data.Text.Lazy (Text, pack) -import Data.Typeable (Typeable) - +import qualified Data.Text as T (Text, pack) +import GHC.Stack (callStack) import Network.HTTP.Types import Network.Wai hiding (Middleware, Application) import qualified Network.Wai as Wai -import Network.Wai.Handler.Warp (Settings, defaultSettings) +import qualified Network.Wai.Handler.Warp as W (Settings, defaultSettings, InvalidRequest(..)) import Network.Wai.Parse (FileInfo) +import qualified Network.Wai.Parse as WPS (ParseRequestBodyOptions, RequestParseException(..)) -import Prelude () -import Prelude.Compat +import UnliftIO.Exception (Handler(..), catch, catches, StringException(..)) + + + --------------------- Options ----------------------- data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner - , settings :: Settings -- ^ Warp 'Settings' + , settings :: W.Settings -- ^ Warp 'Settings' -- Note: to work around an issue in warp, -- the default FD cache duration is set to 0 -- so changes to static files are always picked -- up. This likely has performance implications, -- so you may want to modify this for production -- servers using `setFdCacheDuration`. + , jsonMode :: Bool -- ^ If True, return JSON error responses instead of HTML } -instance Default Options where - def = Options 1 defaultSettings +defaultOptions :: Options +defaultOptions = Options 1 W.defaultSettings False newtype RouteOptions = RouteOptions { maxRequestBodySize :: Maybe Kilobytes -- max allowed request size in KB } -instance Default RouteOptions where - def = RouteOptions Nothing +defaultRouteOptions :: RouteOptions +defaultRouteOptions = RouteOptions Nothing type Kilobytes = Int ----- Transformer Aware Applications/Middleware ----- type Middleware m = Application m -> Application m type Application m = Request -> m Response +------------------ Scotty Request Body -------------------- + +data BodyChunkBuffer = BodyChunkBuffer { hasFinishedReadingChunks :: Bool -- ^ whether we've reached the end of the stream yet + , chunksReadSoFar :: [BS.ByteString] + } +-- | The key part of having two MVars is that we can "clone" the BodyInfo to create a copy where the index is reset to 0, but the chunk cache is the same. Passing a cloned BodyInfo into each matched route allows them each to start from the first chunk if they call bodyReader. +-- +-- Introduced in (#308) +data BodyInfo = BodyInfo { bodyInfoReadProgress :: MVar Int -- ^ index into the stream read so far + , bodyInfoChunkBuffer :: MVar BodyChunkBuffer + , bodyInfoDirectChunkRead :: IO BS.ByteString -- ^ can be called to get more chunks + } + --------------- Scotty Applications ----------------- -data ScottyState e m = + +data ScottyState m = ScottyState { middlewares :: [Wai.Middleware] - , routes :: [Middleware m] - , handler :: ErrorHandler e m + , routes :: [BodyInfo -> Middleware m] + , handler :: Maybe (ErrorHandler m) , routeOptions :: RouteOptions } -instance Default (ScottyState e m) where - def = ScottyState [] [] Nothing def +defaultScottyState :: ScottyState m +defaultScottyState = ScottyState [] [] Nothing defaultRouteOptions -addMiddleware :: Wai.Middleware -> ScottyState e m -> ScottyState e m +addMiddleware :: Wai.Middleware -> ScottyState m -> ScottyState m addMiddleware m s@(ScottyState {middlewares = ms}) = s { middlewares = m:ms } -addRoute :: Middleware m -> ScottyState e m -> ScottyState e m +addRoute :: (BodyInfo -> Middleware m) -> ScottyState m -> ScottyState m addRoute r s@(ScottyState {routes = rs}) = s { routes = r:rs } -addHandler :: ErrorHandler e m -> ScottyState e m -> ScottyState e m -addHandler h s = s { handler = h } +setHandler :: Maybe (ErrorHandler m) -> ScottyState m -> ScottyState m +setHandler h s = s { handler = h } -updateMaxRequestBodySize :: RouteOptions -> ScottyState e m -> ScottyState e m +updateMaxRequestBodySize :: RouteOptions -> ScottyState m -> ScottyState m updateMaxRequestBodySize RouteOptions { .. } s@ScottyState { routeOptions = ro } = let ro' = ro { maxRequestBodySize = maxRequestBodySize } in s { routeOptions = ro' } -newtype ScottyT e m a = ScottyT { runS :: State (ScottyState e m) a } +newtype ScottyT m a = + ScottyT { runS :: ReaderT Options (State (ScottyState m)) a } deriving ( Functor, Applicative, Monad ) ------------------ Scotty Errors -------------------- -data ActionError e - = Redirect Text - | Next - | Finish - | ActionError Status e --- | In order to use a custom exception type (aside from 'Text'), you must --- define an instance of 'ScottyError' for that type. -class ScottyError e where - stringError :: String -> e - showError :: e -> Text - -instance ScottyError Text where - stringError = pack - showError = id - -instance ScottyError e => ScottyError (ActionError e) where - stringError = ActionError status500 . stringError - showError (Redirect url) = url - showError Next = pack "Next" - showError Finish = pack "Finish" - showError (ActionError _ e) = showError e +-- | 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 -type ErrorHandler e m = Maybe (e -> ActionT e m ()) +tryNext :: MonadUnliftIO m => m a -> m Bool +tryNext io = catch (io >> pure True) $ + \case + AENext -> pure False + _ -> pure True -data ScottyException = RequestException BS.ByteString Status deriving (Show, Typeable) +-- | Specializes a 'Handler' to the 'ActionT' monad +type ErrorHandler m = Handler (ActionT m) () -instance Exception ScottyException +-- | Thrown e.g. when a request is too large +data ScottyException + = RequestTooLarge + | MalformedJSON LBS8.ByteString T.Text + | FailedToParseJSON LBS8.ByteString T.Text + | MalformedForm T.Text + | PathParameterNotFound T.Text + | QueryParameterNotFound T.Text + | FormFieldNotFound T.Text + | FailedToParseParameter T.Text T.Text T.Text + | WarpRequestException W.InvalidRequest + | WaiRequestParseException WPS.RequestParseException -- request parsing + | ResourceTException RT.InvalidAccess -- use after free + deriving (Show) +instance E.Exception ScottyException ------------------ Scotty Actions ------------------- -type Param = (Text, Text) +type Param = (T.Text, T.Text) -type File = (Text, FileInfo ByteString) +-- | Type parameter @t@ is the file content. Could be @()@ when not needed or a @FilePath@ for temp files instead. +type File t = (T.Text, FileInfo t) -data ActionEnv = Env { getReq :: Request - , getParams :: [Param] - , getBody :: IO ByteString - , getBodyChunk :: IO BS.ByteString - , getFiles :: [File] +data ActionEnv = Env { envReq :: Request + , envPathParams :: [Param] + , envQueryParams :: [Param] + , envFormDataAction :: RT.InternalState -> WPS.ParseRequestBodyOptions -> IO ([Param], [File FilePath]) + , envBody :: IO LBS8.ByteString + , envBodyChunk :: IO BS.ByteString + , envResponse :: TVar ScottyResponse } -data RequestBodyState = BodyUntouched - | BodyCached ByteString [BS.ByteString] -- whole body, chunks left to stream - | BodyCorrupted -data BodyPartiallyStreamed = BodyPartiallyStreamed deriving (Show, Typeable) -instance E.Exception BodyPartiallyStreamed -data Content = ContentBuilder Builder - | ContentFile FilePath - | ContentStream StreamingBody +formParamsAndFilesWith :: MonadUnliftIO m => + RT.InternalState + -> WPS.ParseRequestBodyOptions + -> ActionT m ([Param], [File FilePath]) +formParamsAndFilesWith istate prbo = action `catch` (\(e :: RT.InvalidAccess) -> E.throw $ ResourceTException e) + where + action = do + act <- ActionT $ asks envFormDataAction + liftIO $ act istate prbo -data ScottyResponse = SR { srStatus :: Status - , srHeaders :: ResponseHeaders - , srContent :: Content - } +getResponse :: MonadIO m => ActionEnv -> m ScottyResponse +getResponse ae = liftIO $ readTVarIO (envResponse ae) -instance Default ScottyResponse where - def = SR status200 [] (ContentBuilder mempty) +getResponseAction :: (MonadIO m) => ActionT m ScottyResponse +getResponseAction = do + ae <- ActionT ask + getResponse ae -newtype ActionT e m a = ActionT { runAM :: ExceptT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) a } - deriving ( Functor, Applicative, MonadIO ) +modifyResponse :: (MonadIO m) => (ScottyResponse -> ScottyResponse) -> ActionT m () +modifyResponse f = do + tv <- ActionT $ asks envResponse + liftIO $ atomically $ modifyTVar' tv f -instance (Monad m, ScottyError e) => Monad.Monad (ActionT e m) where - return = ActionT . return - ActionT m >>= k = ActionT (m >>= runAM . k) -#if !(MIN_VERSION_base(4,13,0)) - fail = Fail.fail -#endif +data BodyPartiallyStreamed = BodyPartiallyStreamed deriving (Show) -instance (Monad m, ScottyError e) => Fail.MonadFail (ActionT e m) where - fail = ActionT . throwError . stringError +instance E.Exception BodyPartiallyStreamed -instance ( Monad m, ScottyError e -#if !(MIN_VERSION_base(4,8,0)) - , Functor m -#endif - ) => Alternative (ActionT e m) where - empty = mzero - (<|>) = mplus +data Content = ContentBuilder Builder + | ContentFile FilePath + | ContentStream StreamingBody + | ContentResponse Response -instance (Monad m, ScottyError e) => MonadPlus (ActionT e m) where - mzero = ActionT . ExceptT . return $ Left Next - ActionT m `mplus` ActionT n = ActionT . ExceptT $ do - a <- runExceptT m - case a of - Left _ -> runExceptT n - Right r -> return $ Right r +data ScottyResponse = SR { srStatus :: Status + , srHeaders :: ResponseHeaders + , srContent :: Content + } -instance ScottyError e => MonadTrans (ActionT e) where - lift = ActionT . lift . lift . lift +setContent :: Content -> ScottyResponse -> ScottyResponse +setContent c sr = sr { srContent = c } -instance (ScottyError e, Monad m) => MonadError (ActionError e) (ActionT e m) where - throwError = ActionT . throwError +setHeaderWith :: ([(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)]) -> ScottyResponse -> ScottyResponse +setHeaderWith f sr = sr { srHeaders = f (srHeaders sr) } - catchError (ActionT m) f = ActionT (catchError m (runAM . f)) +setStatus :: Status -> ScottyResponse -> ScottyResponse +setStatus s sr = sr { srStatus = s } -instance (MonadBase b m, ScottyError e) => MonadBase b (ActionT e m) where - liftBase = liftBaseDefault +-- | The default response has code 200 OK and empty body +defaultScottyResponse :: ScottyResponse +defaultScottyResponse = SR status200 [] (ContentBuilder mempty) -instance (MonadThrow m, ScottyError e) => MonadThrow (ActionT e m) where - throwM = ActionT . throwM +newtype ActionT m a = ActionT { runAM :: ReaderT ActionEnv m a } + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadThrow, MonadCatch, MonadBase b, MonadBaseControl b, MonadTransControl, MonadUnliftIO) -instance (MonadCatch m, ScottyError e) => MonadCatch (ActionT e m) where - catch (ActionT m) f = ActionT (m `catch` (runAM . f)) +withActionEnv :: Monad m => + (ActionEnv -> ActionEnv) -> ActionT m a -> ActionT m a +withActionEnv f (ActionT r) = ActionT $ local f r -instance ScottyError e => MonadTransControl (ActionT e) where - type StT (ActionT e) a = StT (StateT ScottyResponse) (StT (ReaderT ActionEnv) (StT (ExceptT (ActionError e)) a)) - liftWith = \f -> - ActionT $ liftWith $ \run -> - liftWith $ \run' -> - liftWith $ \run'' -> - f $ run'' . run' . run . runAM - restoreT = ActionT . restoreT . restoreT . restoreT +instance MonadReader r m => MonadReader r (ActionT m) where + ask = ActionT $ lift ask + local f = ActionT . mapReaderT (local f) . runAM -instance (ScottyError e, MonadBaseControl b m) => MonadBaseControl b (ActionT e m) where - type StM (ActionT e m) a = ComposeSt (ActionT e) m a - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM +-- | MonadFail instance for ActionT that converts 'fail' calls into Scotty exceptions +-- which allows these failures to be caught by Scotty's error handling system +-- and properly returned as HTTP 500 responses. The instance throws a 'StringException' +-- containing both the failure message and a call stack for debugging purposes. +instance (MonadIO m) => MonadFail (ActionT m) where + fail msg = E.throw $ StringException msg callStack -instance (MonadReader r m, ScottyError e) => MonadReader r (ActionT e m) where - {-# INLINE ask #-} - ask = lift ask - {-# INLINE local #-} - local f = ActionT . mapExceptT (mapReaderT (mapStateT $ local f)) . runAM +-- | 'empty' throws 'ActionError' 'AENext', whereas '(<|>)' catches any 'ActionError's or 'StatusError's in the first action and proceeds to the second one. +instance (MonadUnliftIO m) => Alternative (ActionT m) where + empty = E.throw AENext + a <|> b = do + ok <- tryAnyStatus a + if ok then a else b +instance (MonadUnliftIO m) => MonadPlus (ActionT m) where + mzero = empty + mplus = (<|>) -instance (MonadState s m, ScottyError e) => MonadState s (ActionT e m) where - {-# INLINE get #-} - get = lift get - {-# INLINE put #-} - put = lift . put +-- | catches either ActionError (thrown by 'next'), +-- 'ScottyException' (thrown if e.g. a query parameter is not found) +tryAnyStatus :: MonadUnliftIO m => m a -> m Bool +tryAnyStatus io = (io >> pure True) `catches` [h1, h2] + where + h1 = Handler $ \(_ :: ActionError) -> pure False + h2 = Handler $ \(_ :: ScottyException) -> pure False -instance (Semigroup a) => Semigroup (ScottyT e m a) where +instance (Semigroup a) => Semigroup (ScottyT m a) where x <> y = (<>) <$> x <*> y instance ( Monoid a -#if !(MIN_VERSION_base(4,11,0)) - , Semigroup a -#endif -#if !(MIN_VERSION_base(4,8,0)) - , Functor m -#endif - ) => Monoid (ScottyT e m a) where + ) => Monoid (ScottyT m a) where mempty = return mempty -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<>) -#endif instance ( Monad m -#if !(MIN_VERSION_base(4,8,0)) - , Functor m -#endif , Semigroup a - ) => Semigroup (ActionT e m a) where + ) => Semigroup (ActionT m a) where x <> y = (<>) <$> x <*> y instance - ( Monad m, ScottyError e, Monoid a -#if !(MIN_VERSION_base(4,11,0)) - , Semigroup a -#endif -#if !(MIN_VERSION_base(4,8,0)) - , Functor m -#endif - ) => Monoid (ActionT e m a) where + ( Monad m, Monoid a + ) => Monoid (ActionT m a) where mempty = return mempty -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<>) -#endif ------------------ Scotty Routes -------------------- -data RoutePattern = Capture Text - | Literal Text +data RoutePattern = Capture T.Text + | Literal T.Text | Function (Request -> Maybe [Param]) instance IsString RoutePattern where - fromString = Capture . pack + fromString = Capture . T.pack + + diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -1,225 +1,213 @@ -{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, +{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, RankNTypes, ScopedTypeVariables #-} module Web.Scotty.Route ( get, post, put, delete, patch, options, addroute, matchAny, notFound, capture, regex, function, literal ) where - -import Blaze.ByteString.Builder (fromByteString) + import Control.Arrow ((***)) -import Control.Concurrent.MVar -import Control.Exception (throw, catch) -import Control.Monad.IO.Class +import Control.Concurrent.STM (newTVarIO) +import Control.Monad.IO.Class (MonadIO(..)) +import UnliftIO (MonadUnliftIO(..)) +import qualified Control.Monad.Reader as MR import qualified Control.Monad.State as MS - -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as BL +import Control.Monad.Trans.Resource (InternalState) -import Data.Maybe (fromMaybe, isJust) import Data.String (fromString) -import qualified Data.Text.Lazy as T -import qualified Data.Text as TS +import qualified Data.Text as T import Network.HTTP.Types -import Network.Wai (Request(..), Response, responseBuilder) -#if MIN_VERSION_wai(3,2,2) -import Network.Wai.Internal (getRequestBodyChunk) -#endif -import qualified Network.Wai.Parse as Parse hiding (parseRequestBody) - -import Prelude () -import Prelude.Compat +import Network.Wai (Request(..)) import qualified Text.Regex as Regex import Web.Scotty.Action -import Web.Scotty.Internal.Types -import Web.Scotty.Util +import Web.Scotty.Internal.Types (Options, RoutePattern(..), RouteOptions, ActionEnv(..), ScottyState(..), ScottyT(..), ErrorHandler, Middleware, BodyInfo, File, handler, addRoute, defaultScottyResponse) + +import Web.Scotty.Util (decodeUtf8Lenient) +import Web.Scotty.Body (cloneBodyInfo, getBodyAction, getBodyChunkAction, getFormParamsAndFilesAction) + + +{- $setup +>>> :{ +import Control.Monad.IO.Class (MonadIO(..)) +import qualified Network.HTTP.Client as H +import qualified Network.HTTP.Types as H +import qualified Network.Wai as W (httpVersion) +import qualified Data.ByteString.Lazy.Char8 as LBS (unpack) +import qualified Data.Text as T (pack) +import Control.Concurrent (ThreadId, forkIO, killThread) +import Control.Exception (bracket) +import qualified Web.Scotty as S (ScottyM, scottyOpts, get, text, regex, pathParam, Options(..), defaultOptions) +-- | GET an HTTP path +curl :: MonadIO m => + String -- ^ path + -> m String -- ^ response body +curl path = liftIO $ do + req0 <- H.parseRequest path + let req = req0 { H.method = "GET"} + mgr <- H.newManager H.defaultManagerSettings + (LBS.unpack . H.responseBody) <$> H.httpLbs req mgr +-- | Fork a process, run a Scotty server in it and run an action while the server is running. Kills the scotty thread once the inner action is done. +withScotty :: S.ScottyM () + -> IO a -- ^ inner action, e.g. 'curl "localhost:3000/"' + -> IO a +withScotty serv act = bracket (forkIO $ S.scottyOpts (S.defaultOptions{ S.verbose = 0 }) serv) killThread (\_ -> act) +:} +-} + -- | get = 'addroute' 'GET' -get :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () +get :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () get = addroute GET -- | post = 'addroute' 'POST' -post :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () +post :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () post = addroute POST -- | put = 'addroute' 'PUT' -put :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () +put :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () put = addroute PUT -- | delete = 'addroute' 'DELETE' -delete :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () +delete :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () delete = addroute DELETE -- | patch = 'addroute' 'PATCH' -patch :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () +patch :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () patch = addroute PATCH -- | options = 'addroute' 'OPTIONS' -options :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () +options :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () options = addroute OPTIONS -- | Add a route that matches regardless of the HTTP verb. -matchAny :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () -matchAny pattern action = ScottyT $ MS.modify $ \s -> addRoute (route (routeOptions s) (handler s) Nothing pattern action) s +matchAny :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () +matchAny pat action = + ScottyT $ do + serverOptions <- MR.ask + MS.modify $ \s -> + addRoute + (route serverOptions (routeOptions s) (handler s) Nothing pat action) + s -- | Specify an action to take if nothing else is found. Note: this _always_ matches, -- so should generally be the last route specified. -notFound :: (ScottyError e, MonadIO m) => ActionT e m () -> ScottyT e m () +notFound :: (MonadUnliftIO m) => ActionT m () -> ScottyT m () notFound action = matchAny (Function (\req -> Just [("path", path req)])) (status status404 >> action) --- | Define a route with a 'StdMethod', 'T.Text' value representing the path spec, --- and a body ('Action') which modifies the response. --- --- > addroute GET "/" $ text "beam me up!" --- --- The path spec can include values starting with a colon, which are interpreted --- as /captures/. These are named wildcards that can be looked up with 'param'. --- --- > addroute GET "/foo/:bar" $ do --- > v <- param "bar" --- > text v --- --- >>> curl http://localhost:3000/foo/something --- something -addroute :: (ScottyError e, MonadIO m) => StdMethod -> RoutePattern -> ActionT e m () -> ScottyT e m () -addroute method pat action = ScottyT $ MS.modify $ \s -> addRoute (route (routeOptions s) (handler s) (Just method) pat action) s +{- | Define a route with a 'StdMethod', a route pattern representing the path spec, +and an 'Action' which may modify the response. -route :: (ScottyError e, MonadIO m) => RouteOptions -> ErrorHandler e m -> Maybe StdMethod -> RoutePattern -> ActionT e m () -> Middleware m -route opts h method pat action app req = - let tryNext = app req - {- | - We match all methods in the case where 'method' is 'Nothing'. - See https://github.com/scotty-web/scotty/issues/196 - -} - methodMatches :: Bool - methodMatches = - case method of - Nothing -> True - Just m -> Right m == parseMethod (requestMethod req) - in if methodMatches - then case matchRoute pat req of +> get "/" $ text "beam me up!" + +The path spec can include values starting with a colon, which are interpreted +as /captures/. These are parameters that can be looked up with 'pathParam'. + +>>> :{ +let server = S.get "/foo/:bar" (S.pathParam "bar" >>= S.text) + in do + withScotty server $ curl "http://localhost:3000/foo/something" +:} +"something" +-} +addroute :: (MonadUnliftIO m) => StdMethod -> RoutePattern -> ActionT m () -> ScottyT m () +addroute method pat action = + ScottyT $ do + serverOptions <- MR.ask + MS.modify $ \s -> + addRoute + (route serverOptions (routeOptions s) (handler s) (Just method) pat action) + s + + +route :: (MonadUnliftIO m) => + Options + -> RouteOptions + -> Maybe (ErrorHandler m) -> Maybe StdMethod -> RoutePattern -> ActionT m () -> BodyInfo -> Middleware m +route serverOpts opts h method pat action bodyInfo app req = + let tryNext = app req + -- We match all methods in the case where 'method' is 'Nothing'. + -- See https://github.com/scotty-web/scotty/issues/196 and 'matchAny' + methodMatches :: Bool + methodMatches = maybe True (\x -> (Right x == parseMethod (requestMethod req))) method + + in if methodMatches + then case matchRoute pat req of Just captures -> do - env <- liftIO $ catch (Right <$> mkEnv req captures opts) (\ex -> return . Left $ ex) - res <- evalAction h env action - maybe tryNext return res + -- The user-facing API for "body" and "bodyReader" involve an IO action that + -- reads the body/chunks thereof only once, so we shouldn't pass in our BodyInfo + -- directly; otherwise, the body might get consumed and then it would be unavailable + -- if `next` is called and we try to match further routes. + -- Instead, make a "cloned" copy of the BodyInfo that allows the IO actions to be called + -- without messing up the state of the original BodyInfo. + cbi <- cloneBodyInfo bodyInfo + + env <- mkEnv cbi req captures opts + res <- runAction serverOpts h env action + + maybe tryNext return res Nothing -> tryNext - else tryNext + else tryNext -evalAction :: (ScottyError e, Monad m) => ErrorHandler e m -> (Either ScottyException ActionEnv) -> ActionT e m () -> m (Maybe Response) -evalAction _ (Left (RequestException msg s)) _ = return . Just $ responseBuilder s [("Content-Type","text/html")] $ fromByteString msg -evalAction h (Right env) action = runAction h env action - matchRoute :: RoutePattern -> Request -> Maybe [Param] matchRoute (Literal pat) req | pat == path req = Just [] | otherwise = Nothing matchRoute (Function fun) req = fun req -matchRoute (Capture pat) req = go (T.split (=='/') pat) (compress $ T.split (=='/') $ path req) [] +matchRoute (Capture pat) req = go (T.split (=='/') pat) (compress $ "":pathInfo req) [] -- add empty segment to simulate being at the root where go [] [] prs = Just prs -- request string and pattern match! go [] r prs | T.null (mconcat r) = Just prs -- in case request has trailing slashes | otherwise = Nothing -- request string is longer than pattern go p [] prs | T.null (mconcat p) = Just prs -- in case pattern has trailing slashes | otherwise = Nothing -- request string is not long enough - go (p:ps) (r:rs) prs | p == r = go ps rs prs -- equal literals, keeping checking - | T.null p = Nothing -- p is null, but r is not, fail - | T.head p == ':' = go ps rs $ (T.tail p, r) : prs -- p is a capture, add to params - | otherwise = Nothing -- both literals, but unequal, fail + go (p:ps) (r:rs) prs = case T.uncons p of + Just (':', name) -> go ps rs $ (name, r) : prs -- p is a capture, add to params + _ | p == r -> go ps rs prs -- equal literals, keeping checking + | otherwise -> Nothing -- both literals, but unequal, fail compress ("":rest@("":_)) = compress rest compress (x:xs) = x : compress xs compress [] = [] -- Pretend we are at the top level. path :: Request -> T.Text -path = T.fromStrict . TS.cons '/' . TS.intercalate "/" . pathInfo +path = T.cons '/' . T.intercalate "/" . pathInfo --- Stolen from wai-extra's Network.Wai.Parse, modified to accept body as list of Bytestrings. --- Reason: WAI's getRequestBodyChunk is an IO action that returns the body as chunks. --- Once read, they can't be read again. We read them into a lazy Bytestring, so Scotty --- user can get the raw body, even if they also want to call wai-extra's parsing routines. -parseRequestBody :: MonadIO m - => [B.ByteString] - -> Parse.BackEnd y - -> Request - -> m ([Parse.Param], [Parse.File y]) -parseRequestBody bl s r = - case Parse.getRequestBodyType r of - Nothing -> return ([], []) - Just rbt -> do - mvar <- liftIO $ newMVar bl -- MVar is a bit of a hack so we don't have to inline - -- large portions of Network.Wai.Parse - let provider = modifyMVar mvar $ \bsold -> case bsold of - [] -> return ([], B.empty) - (b:bs) -> return (bs, b) - liftIO $ Parse.sinkRequestBody s rbt provider +-- | Parse the request and construct the initial 'ActionEnv' with a default 200 OK response +mkEnv :: MonadIO m => + BodyInfo + -> Request + -> [Param] + -> RouteOptions + -> m ActionEnv +mkEnv bodyInfo req pathps opts = do + let + getFormData :: InternalState -> ParseRequestBodyOptions -> IO ([Param], [File FilePath]) + getFormData istate prbo = getFormParamsAndFilesAction istate prbo req bodyInfo opts + queryps = parseEncodedParams $ queryString req + responseInit <- liftIO $ newTVarIO defaultScottyResponse + return $ Env req pathps queryps getFormData (getBodyAction bodyInfo opts) (getBodyChunkAction bodyInfo) responseInit -mkEnv :: forall m. MonadIO m => Request -> [Param] -> RouteOptions ->m ActionEnv -mkEnv req captures opts = do - bodyState <- liftIO $ newMVar BodyUntouched - let rbody = getRequestBodyChunk req - safeBodyReader :: IO B.ByteString - safeBodyReader = do - state <- takeMVar bodyState - let direct = putMVar bodyState BodyCorrupted >> rbody - case state of - s@(BodyCached _ []) -> - do putMVar bodyState s - return B.empty - BodyCached b (chunk:rest) -> - do putMVar bodyState $ BodyCached b rest - return chunk - BodyUntouched -> direct - BodyCorrupted -> direct - - bs :: IO BL.ByteString - bs = do - state <- takeMVar bodyState - case state of - s@(BodyCached b _) -> - do putMVar bodyState s - return b - BodyCorrupted -> throw BodyPartiallyStreamed - BodyUntouched -> - do chunks <- readRequestBody rbody return (maxRequestBodySize opts) - let b = BL.fromChunks chunks - putMVar bodyState $ BodyCached b chunks - return b - - shouldParseBody = isJust $ Parse.getRequestBodyType req - - (formparams, fs) <- if shouldParseBody - then liftIO $ do wholeBody <- BL.toChunks `fmap` bs - parseRequestBody wholeBody Parse.lbsBackEnd req - else return ([], []) - - let - convert (k, v) = (strictByteStringToLazyText k, strictByteStringToLazyText v) - parameters = captures ++ map convert formparams ++ queryparams - queryparams = parseEncodedParams $ rawQueryString req - - return $ Env req parameters bs safeBodyReader [ (strictByteStringToLazyText k, fi) | (k,fi) <- fs ] +parseEncodedParams :: 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. @@ -237,26 +225,22 @@ capture :: String -> RoutePattern capture = fromString --- | Build a route based on a function which can match using the entire 'Request' object. --- 'Nothing' indicates the route does not match. A 'Just' value indicates --- a successful match, optionally returning a list of key-value pairs accessible --- by 'param'. --- --- > get (function $ \req -> Just [("version", T.pack $ show $ httpVersion req)]) $ do --- > v <- param "version" --- > text v --- --- >>> curl http://localhost:3000/ --- HTTP/1.1 --- +{- | Build a route based on a function which can match using the entire 'Request' object. +'Nothing' indicates the route does not match. A 'Just' value indicates +a successful match, optionally returning a list of key-value pairs accessible by 'param'. + +>>> :{ +let server = S.get (function $ \req -> Just [("version", T.pack $ show $ W.httpVersion req)]) $ do + v <- S.pathParam "version" + S.text v + in do + withScotty server $ curl "http://localhost:3000/" +:} +"HTTP/1.1" +-} function :: (Request -> Maybe [Param]) -> RoutePattern function = Function -- | Build a route that requires the requested path match exactly, without captures. literal :: String -> RoutePattern literal = Literal . T.pack - -#if !(MIN_VERSION_wai(3,2,2)) -getRequestBodyChunk :: Request -> IO B.ByteString -getRequestBodyChunk = requestBody -#endif 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 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -1,17 +1,25 @@ {-# LANGUAGE OverloadedStrings, RankNTypes #-} +{-# language LambdaCase #-} -- | It should be noted that most of the code snippets below depend on the -- OverloadedStrings language pragma. -- -- The functions in this module allow an arbitrary monad to be embedded --- in Scotty's monad transformer stack in order that Scotty be combined --- with other DSLs. +-- in Scotty's monad transformer stack, e.g. for complex endpoint configuration, +-- interacting with databases etc. -- -- Scotty is set up by default for development mode. For production servers, -- you will likely want to modify 'settings' and the 'defaultHandler'. See -- the comments on each of these functions for more information. +-- +-- Please refer to the @examples@ directory and the @spec@ test suite for concrete use cases, e.g. constructing responses, exception handling and useful implementation details. module Web.Scotty.Trans - ( -- * scotty-to-WAI - scottyT, scottyAppT, scottyOptsT, scottySocketT, Options(..) + ( -- * Running 'scotty' servers + scottyT + , scottyOptsT + , scottySocketT + , Options(..), defaultOptions + -- ** scotty-to-WAI + , scottyAppT -- * Defining Middleware and Routes -- -- | 'Middleware' and routes are run in the order in which they @@ -20,65 +28,98 @@ , middleware, get, post, put, delete, patch, options, addroute, matchAny, notFound, setMaxRequestBodySize -- ** Route Patterns , capture, regex, function, literal - -- ** Accessing the Request, Captures, and Query Parameters - , request, header, headers, body, bodyReader, param, params, jsonData, files - -- ** Modifying the Response and Redirecting - , status, addHeader, setHeader, redirect + -- ** Accessing the Request and its fields + , request, Lazy.header, Lazy.headers, body, bodyReader + , jsonData, formData + + -- ** Accessing Path, Form and Query Parameters + , pathParam, captureParam, formParam, queryParam + , pathParamMaybe, captureParamMaybe, formParamMaybe, queryParamMaybe + , pathParams, captureParams, formParams, queryParams + -- *** Files + , files, filesOpts + -- ** Modifying the Response + , status, Lazy.addHeader, Lazy.setHeader + -- ** Redirecting + , Lazy.redirect, Lazy.redirect300, Lazy.redirect301, Lazy.redirect302, Lazy.redirect303 + , Lazy.redirect304, Lazy.redirect307, Lazy.redirect308 -- ** Setting Response Body -- -- | Note: only one of these should be present in any given route -- definition, as they completely replace the current 'Response' body. - , text, html, file, json, stream, raw + , Lazy.text, Lazy.html, file, json, stream, raw, nested + -- ** Accessing the fields of the Response + , getResponseHeaders, getResponseStatus, getResponseContent -- ** Exceptions - , raise, raiseStatus, rescue, next, finish, defaultHandler, ScottyError(..), liftAndCatchIO + , throw, next, finish, defaultHandler + , liftIO, catch + , ScottyException(..) -- * Parsing Parameters , Param, Parsable(..), readEither -- * Types - , RoutePattern, File, Kilobytes + , RoutePattern, File, Content(..), Kilobytes, ErrorHandler, Handler(..) -- * Monad Transformers , ScottyT, ActionT + , ScottyState, defaultScottyState + -- ** Functions from Cookie module + , setSimpleCookie, getCookie, getCookies, deleteCookie, makeSimpleCookie + -- ** Session Management + , Session (..), SessionId, SessionJar, createSessionJar, + createUserSession, createSession, readUserSession, + readSession, getUserSession, getSession, addSession, deleteSession, maintainSessions ) where -import Blaze.ByteString.Builder (fromByteString) +import Blaze.ByteString.Builder (fromByteString, fromLazyByteString) +import Blaze.ByteString.Builder.Char8 (fromString) import Control.Exception (assert) import Control.Monad (when) +import Control.Monad.Reader (runReaderT) import Control.Monad.State.Strict (execState, modify) import Control.Monad.IO.Class -import Data.Default.Class (def) +import qualified Data.Aeson as A +import qualified Data.Text as T -import Network.HTTP.Types (status404, status500) +import Network.HTTP.Types (status404, status413, status500) import Network.Socket (Socket) -import Network.Wai +import qualified Network.Wai as W (Application, Middleware, Response, responseBuilder) import Network.Wai.Handler.Warp (Port, runSettings, runSettingsSocket, setPort, getPort) import Web.Scotty.Action import Web.Scotty.Route -import Web.Scotty.Internal.Types hiding (Application, Middleware) +import Web.Scotty.Internal.Types (ScottyT(..), defaultScottyState, Application, RoutePattern, Options(..), defaultOptions, RouteOptions(..), defaultRouteOptions, ErrorHandler, Kilobytes, File, addMiddleware, setHandler, updateMaxRequestBodySize, routes, middlewares, ScottyException(..), ScottyState, defaultScottyState, Content(..)) +import Web.Scotty.Trans.Lazy as Lazy import Web.Scotty.Util (socketDescription) -import qualified Web.Scotty.Internal.Types as Scotty +import Web.Scotty.Body (newBodyInfo) +import UnliftIO.Exception (Handler(..), catch) +import Web.Scotty.Cookie (setSimpleCookie,getCookie,getCookies,deleteCookie,makeSimpleCookie) +import Web.Scotty.Session (Session (..), SessionId, SessionJar, createSessionJar, + createUserSession, createSession, readUserSession, + readSession, getUserSession, getSession, addSession, deleteSession, maintainSessions) + + -- | Run a scotty application using the warp server. -- NB: scotty p === scottyT p id scottyT :: (Monad m, MonadIO n) => Port - -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. - -> ScottyT e m () + -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action. + -> ScottyT m () -> n () -scottyT p = scottyOptsT $ def { settings = setPort p (settings def) } +scottyT p = scottyOptsT $ defaultOptions { settings = setPort p (settings defaultOptions) } -- | Run a scotty application using the warp server, passing extra options. -- NB: scottyOpts opts === scottyOptsT opts id scottyOptsT :: (Monad m, MonadIO n) => Options - -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. - -> ScottyT e m () + -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action. + -> ScottyT m () -> n () scottyOptsT opts runActionToIO s = do when (verbose opts > 0) $ liftIO $ putStrLn $ "Setting phasers to stun... (port " ++ show (getPort (settings opts)) ++ ") (ctrl-c to quit)" - liftIO . runSettings (settings opts) =<< scottyAppT runActionToIO s + liftIO . runSettings (settings opts) =<< scottyAppT opts runActionToIO s -- | Run a scotty application using the warp server, passing extra options, and -- listening on the provided socket. @@ -86,51 +127,83 @@ scottySocketT :: (Monad m, MonadIO n) => Options -> Socket - -> (m Response -> IO Response) - -> ScottyT e m () + -> (m W.Response -> IO W.Response) + -> ScottyT m () -> n () scottySocketT opts sock runActionToIO s = do when (verbose opts > 0) $ do d <- liftIO $ socketDescription sock liftIO $ putStrLn $ "Setting phasers to stun... (" ++ d ++ ") (ctrl-c to quit)" - liftIO . runSettingsSocket (settings opts) sock =<< scottyAppT runActionToIO s + liftIO . runSettingsSocket (settings opts) sock =<< scottyAppT opts runActionToIO s -- | Turn a scotty application into a WAI 'Application', which can be -- run with any WAI handler. -- NB: scottyApp === scottyAppT id scottyAppT :: (Monad m, Monad n) - => (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. - -> ScottyT e m () - -> n Application -scottyAppT runActionToIO defs = do - let s = execState (runS defs) def - let rapp req callback = runActionToIO (foldl (flip ($)) notFoundApp (routes s) req) >>= callback - return $ foldl (flip ($)) rapp (middlewares s) + => Options + -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action. + -> ScottyT m () + -> n W.Application +scottyAppT opts runActionToIO defs = do + let s = execState (runReaderT (runS defs) opts) defaultScottyState + let rapp req callback = do + bodyInfo <- newBodyInfo req + resp <- runActionToIO (applyAll (notFoundApp opts) ([midd bodyInfo | midd <- routes s]) req) + `catch` unhandledExceptionHandler opts + callback resp + return $ applyAll rapp (middlewares s) -notFoundApp :: Monad m => Scotty.Application m -notFoundApp _ = return $ responseBuilder status404 [("Content-Type","text/html")] +-- | Exception handler in charge of 'ScottyException' that's not caught by 'scottyExceptionHandler' +unhandledExceptionHandler :: MonadIO m => Options -> ScottyException -> m W.Response +unhandledExceptionHandler opts = \case + RequestTooLarge -> + if jsonMode opts + then return $ W.responseBuilder status413 ctJson $ + fromLazyByteString $ A.encode $ A.object + [ "status" A..= (413 :: Int) + , "description" A..= ("Request is too big Jim!" :: T.Text) + ] + else return $ W.responseBuilder status413 ctText "Request is too big Jim!" + e -> + if jsonMode opts + then return $ W.responseBuilder status500 ctJson $ + fromLazyByteString $ A.encode $ A.object + [ "status" A..= (500 :: Int) + , "description" A..= ("Internal Server Error: " <> T.pack (show e)) + ] + else return $ W.responseBuilder status500 ctText $ "Internal Server Error: " <> fromString (show e) + where + ctText = [("Content-Type", "text/plain")] + ctJson = [("Content-Type", "application/json; charset=utf-8")] + +applyAll :: Foldable t => a -> t (a -> a) -> a +applyAll = foldl (flip ($)) + +notFoundApp :: Monad m => Options -> Application m +notFoundApp opts _ = + if jsonMode opts + then return $ W.responseBuilder status404 [("Content-Type","application/json; charset=utf-8")] + $ fromLazyByteString $ A.encode $ A.object + [ "status" A..= (404 :: Int) + , "description" A..= ("File Not Found!" :: T.Text) + ] + else return $ W.responseBuilder status404 [("Content-Type","text/html")] $ fromByteString "

404: File Not Found!

" --- | Global handler for uncaught exceptions. --- --- Uncaught exceptions normally become 500 responses. --- You can use this to selectively override that behavior. --- --- Note: IO exceptions are lifted into 'ScottyError's by 'stringError'. --- This has security implications, so you probably want to provide your --- own defaultHandler in production which does not send out the error --- strings as 500 responses. -defaultHandler :: (ScottyError e, Monad m) => (e -> ActionT e m ()) -> ScottyT e m () -defaultHandler f = ScottyT $ modify $ addHandler $ Just (\e -> status status500 >> f e) +-- | Global handler for user-defined exceptions. +defaultHandler :: (Monad m) => ErrorHandler m -> ScottyT m () +defaultHandler f = ScottyT $ modify $ setHandler $ Just f -- | Use given middleware. Middleware is nested such that the first declared -- is the outermost middleware (it has first dibs on the request and last action -- on the response). Every middleware is run on each request. -middleware :: Middleware -> ScottyT e m () +middleware :: W.Middleware -> ScottyT m () middleware = ScottyT . modify . addMiddleware -- | Set global size limit for the request body. Requests with body size exceeding the limit will not be --- processed and an HTTP response 413 will be returned to the client. Size limit needs to be greater than 0, --- otherwise the application will terminate on start. -setMaxRequestBodySize :: Kilobytes -> ScottyT e m () -setMaxRequestBodySize i = assert (i > 0) $ ScottyT . modify . updateMaxRequestBodySize $ def { maxRequestBodySize = Just i } +-- 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/Util.hs b/Web/Scotty/Util.hs --- a/Web/Scotty/Util.hs +++ b/Web/Scotty/Util.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# options_ghc -Wno-unused-imports #-} module Web.Scotty.Util ( lazyTextToStrictByteString , strictByteStringToLazyText - , setContent - , setHeaderWith - , setStatus + , decodeUtf8Lenient , mkResponse , replace , add @@ -15,42 +16,36 @@ import Network.Socket (SockAddr(..), Socket, getSocketName, socketPort) import Network.Wai +import Control.Exception import Control.Monad (when) -import Control.Exception (throw) - -import Network.HTTP.Types - import qualified Data.ByteString as B -import qualified Data.Text as TP (pack) -import qualified Data.Text.Lazy as T -import qualified Data.Text.Encoding as ES +import qualified Data.Text as TP (Text, pack) +import qualified Data.Text.Lazy as TL +import Data.Text.Encoding as ES import qualified Data.Text.Encoding.Error as ES import Web.Scotty.Internal.Types -lazyTextToStrictByteString :: T.Text -> B.ByteString -lazyTextToStrictByteString = ES.encodeUtf8 . T.toStrict - -strictByteStringToLazyText :: B.ByteString -> T.Text -strictByteStringToLazyText = T.fromStrict . ES.decodeUtf8With ES.lenientDecode - -setContent :: Content -> ScottyResponse -> ScottyResponse -setContent c sr = sr { srContent = c } +lazyTextToStrictByteString :: TL.Text -> B.ByteString +lazyTextToStrictByteString = ES.encodeUtf8 . TL.toStrict -setHeaderWith :: ([(HeaderName, B.ByteString)] -> [(HeaderName, B.ByteString)]) -> ScottyResponse -> ScottyResponse -setHeaderWith f sr = sr { srHeaders = f (srHeaders sr) } +strictByteStringToLazyText :: B.ByteString -> TL.Text +strictByteStringToLazyText = TL.fromStrict . ES.decodeUtf8With ES.lenientDecode -setStatus :: Status -> ScottyResponse -> ScottyResponse -setStatus s sr = sr { srStatus = s } +#if !MIN_VERSION_text(2,0,0) +decodeUtf8Lenient :: B.ByteString -> TP.Text +decodeUtf8Lenient = ES.decodeUtf8With ES.lenientDecode +#endif -- Note: we currently don't support responseRaw, which may be useful -- for websockets. However, we always read the request body, which -- is incompatible with responseRaw responses. mkResponse :: ScottyResponse -> Response mkResponse sr = case srContent sr of - ContentBuilder b -> responseBuilder s h b - ContentFile f -> responseFile s h f Nothing - ContentStream str -> responseStream s h str + ContentBuilder b -> responseBuilder s h b + ContentFile f -> responseFile s h f Nothing + ContentStream str -> responseStream s h str + ContentResponse res -> res where s = srStatus sr h = srHeaders sr @@ -76,18 +71,30 @@ SockAddrUnix u -> return $ "unix socket " ++ u _ -> fmap (\port -> "port " ++ show port) $ socketPort sock --- return request body or throw an exception if request body too big -readRequestBody :: IO B.ByteString -> ([B.ByteString] -> IO [B.ByteString]) -> Maybe Kilobytes ->IO [B.ByteString] +-- | return request body or throw a '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 + checkBodyLength maxSize readRequestBody rbody (prefix . (b:)) maxSize where checkBodyLength :: Maybe Kilobytes -> IO () - checkBodyLength (Just maxSize') = prefix [] >>= \bodySoFar -> when (isBigger bodySoFar maxSize') readUntilEmpty - checkBodyLength Nothing = return () - isBigger bodySoFar maxSize' = (B.length . B.concat $ bodySoFar) > maxSize' * 1024 - readUntilEmpty = rbody >>= \b -> if B.null b then throw (RequestException (ES.encodeUtf8 . TP.pack $ "Request is too big Jim!") status413) else readUntilEmpty + checkBodyLength = \case + Just maxSize' -> do + bodySoFar <- prefix [] + when (bodySoFar `isBigger` maxSize') readUntilEmpty + Nothing -> return () + isBigger bodySoFar maxSize' = (B.length . B.concat $ bodySoFar) > maxSize' * 1024 -- XXX this looks both inefficient and wrong + readUntilEmpty = do + b <- rbody + if B.null b + then throwIO RequestTooLarge + else readUntilEmpty + + diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -6,13 +6,12 @@ module Main (main) where import Control.Monad -import Data.Default.Class (def) import Data.Functor.Identity -import Data.Text (Text) import Lucid.Base import Lucid.Html5 import Web.Scotty import Web.Scotty.Internal.Types +import qualified Control.Monad.Reader as R import qualified Control.Monad.State.Lazy as SL import qualified Control.Monad.State.Strict as SS import qualified Data.ByteString.Lazy as BL @@ -25,12 +24,15 @@ setColumns [Case,Allocated,GCs,Live,Check,Max,MaxOS] setFormat Markdown io "ScottyM Strict" BL.putStr - (SS.evalState (runS $ renderBST htmlScotty) def) + (SS.evalState + (R.runReaderT (runS $ renderBST htmlScotty) defaultOptions) + defaultScottyState) io "ScottyM Lazy" BL.putStr - (SL.evalState (runScottyLazy $ renderBST htmlScottyLazy) def) + (SL.evalState (runScottyLazy $ renderBST htmlScottyLazy) defaultScottyState) io "Identity" BL.putStr (runIdentity $ renderBST htmlIdentity) + htmlTest :: Monad m => HtmlT m () htmlTest = replicateM_ 2 $ div_ $ do replicateM_ 1000 $ div_ $ do @@ -49,6 +51,6 @@ {-# noinline htmlScottyLazy #-} newtype ScottyLazy a = ScottyLazy - { runScottyLazy:: SL.State (ScottyState Text IO) a } + { runScottyLazy:: SL.State (ScottyState IO) a } deriving (Functor,Applicative,Monad) diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,4 +1,90 @@ -## next [????.??.??] +## 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. 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/basic.hs b/examples/basic.hs --- a/examples/basic.hs +++ b/examples/basic.hs @@ -1,21 +1,27 @@ {-# LANGUAGE OverloadedStrings #-} +{-# language DeriveAnyClass #-} +{-# language ScopedTypeVariables #-} module Main (main) where import Web.Scotty import Network.Wai.Middleware.RequestLogger -- install wai-extra if you don't have this +import Control.Exception (Exception(..)) import Control.Monad -import Control.Monad.Trans +-- import Control.Monad.Trans import System.Random (newStdGen, randomRs) import Network.HTTP.Types (status302) +import Data.Text.Lazy (pack) import Data.Text.Lazy.Encoding (decodeUtf8) import Data.String (fromString) -import Prelude () -import Prelude.Compat +import Data.Typeable (Typeable) +data Err = Boom | UserAgentNotFound | NeverReached deriving (Show, Typeable, Exception) + + main :: IO () main = scotty 3000 $ do -- Add any WAI middleware, they are run top-down. @@ -29,14 +35,24 @@ get "/" $ text "foobar" get "/" $ text "barfoo" - -- Using a parameter in the query string. If it has - -- not been given, a 500 page is generated. - get "/foo" $ do - v <- param "fooparam" + -- Looking for a parameter in the path. Since the path pattern does not + -- contain the parameter name 'p', the server responds with 500 Server Error. + get "/foo_fail" $ do + v <- pathParam "p" html $ mconcat ["

", 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 @@ -47,24 +63,24 @@ -- redirects preempt execution get "/redirect" $ do void $ redirect "http://www.google.com" - raise "this error is never reached" + throw NeverReached -- Of course you can catch your own errors. get "/rescue" $ do - (do void $ raise "a rescued error"; redirect "http://www.we-never-go-here.com") - `rescue` (\m -> text $ "we recovered from " `mappend` m) + (do void $ throw Boom; redirect "http://www.we-never-go-here.com") + `catch` (\(e :: Err) -> text $ "we recovered from " `mappend` pack (show e)) -- Parts of the URL that start with a colon match -- any string, and capture that value as a parameter. -- URL captures take precedence over query string parameters. get "/foo/:bar/required" $ do - v <- param "bar" + v <- pathParam "bar" html $ mconcat ["

", v, "

"] -- Files are streamed directly to the client. get "/404" $ file "404.html" - -- You can stop execution of this action and keep pattern matching routes. + -- 'next' stops execution of the current action and keeps pattern matching routes. get "/random" $ do void next redirect "http://www.we-never-go-here.com" @@ -75,7 +91,7 @@ json $ take 20 $ randomRs (1::Int,100) g get "/ints/:is" $ do - is <- param "is" + is <- pathParam "is" json $ [(1::Int)..10] ++ is get "/setbody" $ do @@ -85,17 +101,21 @@ ,"" ] + -- Read and decode the request body as UTF-8 post "/readbody" $ do b <- body text $ decodeUtf8 b + -- Look up a request header get "/header" $ do agent <- header "User-Agent" - maybe (raise "User-Agent header not found!") text agent + maybe (throw UserAgentNotFound) text agent -- Make a request to this URI, then type a line in the terminal, which -- will be the response. Using ctrl-c will cause getLine to fail. -- This demonstrates that IO exceptions are lifted into ActionM exceptions. + -- + -- (#310) we don't catch async exceptions, so ctrl-c just exits the program get "/iofail" $ do msg <- liftIO $ liftM fromString getLine text msg diff --git a/examples/bodyecho.hs b/examples/bodyecho.hs --- a/examples/bodyecho.hs +++ b/examples/bodyecho.hs @@ -3,7 +3,7 @@ import Web.Scotty -import Control.Monad.IO.Class (liftIO) +-- import Control.Monad.IO.Class (liftIO) import qualified Blaze.ByteString.Builder as B import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL diff --git a/examples/cookies.hs b/examples/cookies.hs --- a/examples/cookies.hs +++ b/examples/cookies.hs @@ -1,36 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} --- This examples requires you to: cabal install cookie --- and: cabal install blaze-html +-- This examples requires you to: cabal install blaze-html module Main (main) where import Control.Monad (forM_) -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy.Encoding as T -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import qualified Blaze.ByteString.Builder as B import qualified Text.Blaze.Html5 as H -import Text.Blaze.Html5.Attributes -import Text.Blaze.Html.Renderer.Text (renderHtml) -import Web.Scotty -import Web.Cookie - -makeCookie :: BS.ByteString -> BS.ByteString -> SetCookie -makeCookie n v = def { setCookieName = n, setCookieValue = v } - -renderSetCookie' :: SetCookie -> Text -renderSetCookie' = T.decodeUtf8 . B.toLazyByteString . renderSetCookie - -setCookie :: BS.ByteString -> BS.ByteString -> ActionM () -setCookie n v = setHeader "Set-Cookie" (renderSetCookie' (makeCookie n v)) - -getCookies :: ActionM (Maybe CookiesText) -getCookies = - fmap (fmap (parseCookiesText . lazyToStrict . T.encodeUtf8)) $ - header "Cookie" - where - lazyToStrict = BS.concat . BSL.toChunks +import Text.Blaze.Html5.Attributes +import Text.Blaze.Html.Renderer.Text (renderHtml) +import Web.Scotty -- Web.Scotty exports setSimpleCookie,getCookies +import Web.Scotty.Cookie (CookiesText) renderCookiesTable :: CookiesText -> H.Html renderCookiesTable cs = @@ -48,16 +26,14 @@ get "/" $ do cookies <- getCookies html $ renderHtml $ do - case cookies of - Just cs -> renderCookiesTable cs - Nothing -> return () + renderCookiesTable cookies H.form H.! method "post" H.! action "/set-a-cookie" $ do H.input H.! type_ "text" H.! name "name" H.input H.! type_ "text" H.! name "value" H.input H.! type_ "submit" H.! value "set a cookie" post "/set-a-cookie" $ do - name' <- param "name" - value' <- param "value" - setCookie name' value' + name' <- pathParam "name" + value' <- pathParam "value" + setSimpleCookie name' value' redirect "/" diff --git a/examples/exceptions.hs b/examples/exceptions.hs --- a/examples/exceptions.hs +++ b/examples/exceptions.hs @@ -1,45 +1,46 @@ {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} +{-# language DeriveAnyClass #-} +{-# language LambdaCase #-} module Main (main) where +import Control.Exception (Exception(..)) import Control.Monad.IO.Class +import Control.Monad.IO.Unlift (MonadUnliftIO(..)) import Data.String (fromString) +import Data.Typeable import Network.HTTP.Types import Network.Wai.Middleware.RequestLogger -import Prelude () -import Prelude.Compat - import System.Random import Web.Scotty.Trans --- Define a custom exception type. +-- | A custom exception type. data Except = Forbidden | NotFound Int | StringEx String - deriving (Show, Eq) - --- The type must be an instance of 'ScottyError'. --- 'ScottyError' is essentially a combination of 'Error' and 'Show'. -instance ScottyError Except where - stringError = StringEx - showError = fromString . show + deriving (Show, Eq, Typeable, Exception) --- Handler for uncaught exceptions. -handleEx :: Monad m => Except -> ActionT Except m () -handleEx Forbidden = do +-- | User-defined exceptions should have an associated Handler: +handleEx :: MonadIO m => ErrorHandler m +handleEx = Handler $ \case + Forbidden -> do status status403 html "

Scotty Says No

" -handleEx (NotFound i) = do + NotFound i -> do status status404 html $ fromString $ "

Can't find " ++ show i ++ ".

" -handleEx (StringEx s) = do + StringEx s -> do status status500 html $ fromString $ "

" ++ s ++ "

" main :: IO () -main = scottyT 3000 id $ do -- note, we aren't using any additional transformer layers - -- so we can just use 'id' for the runner. +main = do + scottyT 3000 id server -- note: we use 'id' since we don't have to run any effects at each action + +-- Any custom monad stack will need to implement 'MonadUnliftIO' +server :: MonadUnliftIO m => ScottyT m () +server = do middleware logStdoutDev defaultHandler handleEx -- define what to do with uncaught exceptions @@ -53,13 +54,13 @@ ] get "/switch/:val" $ do - v <- param "val" - _ <- if even v then raise Forbidden else raise (NotFound v) + v <- pathParam "val" + _ <- if even v then throw Forbidden else throw (NotFound v) text "this will never be reached" get "/random" $ do rBool <- liftIO randomIO i <- liftIO randomIO let catchOne Forbidden = html "

Forbidden was randomly thrown, but we caught it." - catchOne other = raise other - raise (if rBool then Forbidden else NotFound i) `rescue` catchOne + catchOne other = throw other + throw (if rBool then Forbidden else NotFound i) `catch` catchOne diff --git a/examples/globalstate.hs b/examples/globalstate.hs --- a/examples/globalstate.hs +++ b/examples/globalstate.hs @@ -10,23 +10,19 @@ module Main (main) where import Control.Concurrent.STM +import Control.Monad.IO.Unlift (MonadUnliftIO(..)) import Control.Monad.Reader -import Data.Default.Class import Data.String -import Data.Text.Lazy (Text) import Network.Wai.Middleware.RequestLogger -import Prelude () -import Prelude.Compat - import Web.Scotty.Trans newtype AppState = AppState { tickCount :: Int } -instance Default AppState where - def = AppState 0 +defaultAppState :: AppState +defaultAppState = AppState 0 -- Why 'ReaderT (TVar AppState)' rather than 'StateT AppState'? -- With a state transformer, 'runActionToIO' (below) would have @@ -39,7 +35,7 @@ -- Also note: your monad must be an instance of 'MonadIO' for -- Scotty to use it. newtype WebM a = WebM { runWebM :: ReaderT (TVar AppState) IO a } - deriving (Applicative, Functor, Monad, MonadIO, MonadReader (TVar AppState)) + deriving (Applicative, Functor, Monad, MonadIO, MonadReader (TVar AppState), MonadUnliftIO) -- Scotty's monads are layered on top of our custom monad. -- We define this synonym for lift in order to be explicit @@ -56,7 +52,7 @@ main :: IO () main = do - sync <- newTVarIO def + sync <- newTVarIO defaultAppState -- 'runActionToIO' is called once per action. let runActionToIO m = runReaderT (runWebM m) sync @@ -66,7 +62,7 @@ -- type is ambiguous. We can fix it by putting a type -- annotation just about anywhere. In this case, we'll -- just do it on the entire app. -app :: ScottyT Text WebM () +app :: ScottyT WebM () app = do middleware logStdoutDev get "/" $ do diff --git a/examples/gzip.hs b/examples/gzip.hs --- a/examples/gzip.hs +++ b/examples/gzip.hs @@ -2,14 +2,14 @@ module Main (main) where import Network.Wai.Middleware.RequestLogger -import Network.Wai.Middleware.Gzip +import Network.Wai.Middleware.Gzip (defaultGzipSettings, GzipSettings(..), GzipFiles(..), gzip) import Web.Scotty main :: IO () main = scotty 3000 $ do -- Note that files are not gzip'd by the default settings. - middleware $ gzip $ def { gzipFiles = GzipCompress } + middleware $ gzip $ defaultGzipSettings { gzipFiles = GzipCompress } middleware logStdoutDev -- gzip a normal response 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 @@ -5,14 +5,13 @@ import Network.Wai.Middleware.RequestLogger -- install wai-extra if you don't have this -import Data.Default.Class (def) import Network.Wai.Handler.Warp (setPort) -- Set some Scotty settings opts :: Options -opts = def { verbose = 0 - , settings = setPort 4000 $ settings def - } +opts = defaultOptions { verbose = 0 + , settings = setPort 4000 $ settings defaultOptions + } -- This won't display anything at startup, and will listen on localhost:4000 main :: IO () diff --git a/examples/reader.hs b/examples/reader.hs --- a/examples/reader.hs +++ b/examples/reader.hs @@ -8,11 +8,9 @@ module Main where import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, asks, lift, runReaderT) -import Data.Default.Class (def) -import Data.Text.Lazy (Text, pack) -import Prelude () -import Prelude.Compat -import Web.Scotty.Trans (ScottyT, get, scottyOptsT, text) +import Control.Monad.IO.Unlift (MonadUnliftIO(..)) +import Data.Text.Lazy (pack) +import Web.Scotty.Trans (ScottyT, defaultOptions, get, scottyOptsT, text) data Config = Config { environment :: String @@ -20,16 +18,16 @@ newtype ConfigM a = ConfigM { runConfigM :: ReaderT Config IO a - } deriving (Applicative, Functor, Monad, MonadIO, MonadReader Config) + } deriving (Applicative, Functor, Monad, MonadIO, MonadReader Config, MonadUnliftIO) -application :: ScottyT Text ConfigM () +application :: ScottyT ConfigM () application = do get "/" $ do e <- lift $ asks environment text $ pack $ show e main :: IO () -main = scottyOptsT def runIO application where +main = scottyOptsT defaultOptions runIO application where runIO :: ConfigM a -> IO a runIO m = runReaderT (runConfigM m) config 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/upload.hs b/examples/upload.hs --- a/examples/upload.hs +++ b/examples/upload.hs @@ -1,13 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} +{-# language ScopedTypeVariables #-} module Main (main) where import Web.Scotty -import Control.Monad.IO.Class +import Control.Exception (SomeException) +import Data.Foldable (for_) +import qualified Data.Text.Lazy as TL import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.Static -import Network.Wai.Parse +import Network.Wai.Parse (fileName, fileContent, defaultParseRequestBodyOptions) import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes @@ -16,33 +19,44 @@ import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Char8 as BS import System.FilePath (()) -import Prelude () -import Prelude.Compat +{-| NB : the file paths where files are saved and looked up are relative, so make sure +to run this program from the root directory of the 'scotty' repo, or adjust the paths +accordingly. +-} + main :: IO () main = scotty 3000 $ do middleware logStdoutDev - middleware $ staticPolicy (noDots >-> addBase "uploads") + middleware $ staticPolicy (noDots >-> addBase "examples/uploads") get "/" $ do html $ renderHtml $ H.html $ do H.body $ do H.form H.! method "post" H.! enctype "multipart/form-data" H.! action "/upload" $ do - H.input H.! type_ "file" H.! name "foofile" + H.input H.! type_ "file" H.! name "file_1" H.br - H.input H.! type_ "file" H.! name "barfile" + H.input H.! type_ "file" H.! name "file_2" H.br H.input H.! type_ "submit" post "/upload" $ do - fs <- files - let fs' = [ (fieldName, BS.unpack (fileName fi), fileContent fi) | (fieldName,fi) <- fs ] - -- write the files to disk, so they will be served by the static middleware - liftIO $ sequence_ [ B.writeFile ("uploads" fn) fc | (_,fn,fc) <- fs' ] - -- generate list of links to the files just uploaded - html $ mconcat [ mconcat [ fName - , ": " - , renderHtml $ H.a (H.toHtml fn) H.! (href $ H.toValue fn) >> H.br - ] - | (fName,fn,_) <- fs' ] + filesOpts defaultParseRequestBodyOptions $ \_ fs -> do + let + fs' = [(fieldName, BS.unpack (fileName fi), fileContent fi) | (fieldName, fi) <- fs] + -- write the files to disk, so they can be served by the static middleware + for_ fs' $ \(_, fnam, fpath) -> do + -- copy temp file to local dir + liftIO (do + fc <- B.readFile fpath + B.writeFile ("examples" "uploads" fnam) fc + ) `catch` (\(e :: SomeException) -> do + liftIO $ putStrLn $ unwords ["upload: something went wrong while saving temp files :", show e] + ) + -- generate list of links to the files just uploaded + html $ mconcat [ mconcat [ TL.fromStrict fName + , ": " + , renderHtml $ H.a (H.toHtml fn) H.! (href $ H.toValue fn) >> H.br + ] + | (fName,fn,_) <- fs' ] diff --git a/examples/urlshortener.hs b/examples/urlshortener.hs --- a/examples/urlshortener.hs +++ b/examples/urlshortener.hs @@ -1,19 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} +{-# language DeriveAnyClass #-} +{-# language LambdaCase #-} +-- {-# language ScopedTypeVariables #-} module Main (main) where import Web.Scotty import Control.Concurrent.MVar -import Control.Monad.IO.Class +import Control.Exception (Exception(..)) import qualified Data.Map as M import qualified Data.Text.Lazy as T +import Data.Typeable (Typeable) import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.Static -import Prelude () -import Prelude.Compat - import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes -- Note: @@ -23,12 +24,17 @@ import Text.Blaze.Html.Renderer.Text (renderHtml) -- TODO: --- Implement some kind of session and/or cookies +-- Implement some kind of session (#317) and/or cookies -- Add links +data SessionError = UrlHashNotFound Int deriving (Typeable, Exception) +instance Show SessionError where + show = \case + UrlHashNotFound hash -> unwords ["URL hash #", show hash, " not found in database!"] + main :: IO () main = do - m <- newMVar (0::Int,M.empty :: M.Map Int T.Text) + m <- newMVar (0::Int, M.empty :: M.Map Int T.Text) scotty 3000 $ do middleware logStdoutDev middleware static @@ -42,20 +48,20 @@ H.input H.! type_ "submit" post "/shorten" $ do - url <- param "url" + url <- formParam "url" liftIO $ modifyMVar_ m $ \(i,db) -> return (i+1, M.insert i (T.pack url) db) redirect "/list" -- We have to be careful here, because this route can match pretty much anything. -- Thankfully, the type system knows that 'hash' must be an Int, so this route - -- only matches if 'read' can successfully parse the hash capture as an Int. + -- only matches if 'parseParam' can successfully parse the hash capture as an Int. -- Otherwise, the pattern match will fail and Scotty will continue matching -- subsequent routes. get "/:hash" $ do - hash <- param "hash" + hash <- captureParam "hash" (_,db) <- liftIO $ readMVar m case M.lookup hash db of - Nothing -> raise $ mconcat ["URL hash #", T.pack $ show $ hash, " not found in database!"] + Nothing -> throw $ UrlHashNotFound hash Just url -> redirect url -- We put /list down here to show that it will not match the '/:hash' route above. diff --git a/scotty.cabal b/scotty.cabal --- a/scotty.cabal +++ b/scotty.cabal @@ -1,13 +1,13 @@ Name: scotty -Version: 0.12.1 +Version: 0.30 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues License: BSD3 License-file: LICENSE Author: Andrew Farmer -Maintainer: Andrew Farmer -Copyright: (c) 2012-Present Andrew Farmer +Maintainer: The Scotty maintainers +Copyright: (c) 2012-Present, Andrew Farmer and the Scotty contributors Category: Web Stability: experimental Build-type: Simple @@ -20,11 +20,9 @@ . import Web.Scotty . - import Data.Monoid (mconcat) - . main = scotty 3000 $ get "/:word" $ do - beam <- param "word" + beam <- pathParam "word" html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"] @ . @@ -44,16 +42,12 @@ [WAI] . [Warp] -tested-with: GHC == 7.6.3 - , GHC == 7.8.4 - , GHC == 7.10.3 - , GHC == 8.0.2 - , GHC == 8.2.2 - , GHC == 8.4.4 - , GHC == 8.6.5 - , GHC == 8.8.4 - , GHC == 8.10.4 - , GHC == 9.0.1 +tested-with: GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.8 + , GHC == 9.4.6 + , GHC == 9.6.4 + , GHC == 9.8.2 Extra-source-files: README.md changelog.md @@ -67,31 +61,42 @@ Library Exposed-modules: Web.Scotty Web.Scotty.Trans + Web.Scotty.Trans.Strict Web.Scotty.Internal.Types + Web.Scotty.Cookie + Web.Scotty.Session other-modules: Web.Scotty.Action + Web.Scotty.Body Web.Scotty.Route + Web.Scotty.Trans.Lazy Web.Scotty.Util default-language: Haskell2010 - build-depends: aeson >= 0.6.2.1 && < 2.2, - base >= 4.6 && < 5, - base-compat-batteries >= 0.10 && < 0.13, + build-depends: aeson >= 0.6.2.1 && < 2.3, + base >= 4.14 && < 5, blaze-builder >= 0.3.3.0 && < 0.5, - bytestring >= 0.10.0.2 && < 0.12, + bytestring >= 0.10.0.2 , case-insensitive >= 1.0.0.1 && < 1.3, - data-default-class >= 0.0.1 && < 0.2, + containers >= 0.5 && < 0.8, + cookie >= 0.4, exceptions >= 0.7 && < 0.11, + 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.2, + network >= 2.6.0.2 && < 3.3, regex-compat >= 0.95.1 && < 0.96, - text >= 0.11.3.1 && < 2.1, + resourcet, + stm, + text >= 0.11.3.1 , + time >= 1.8, transformers >= 0.3.0.0 && < 0.7, transformers-base >= 0.4.1 && < 0.5, - transformers-compat >= 0.4 && < 0.8, + unliftio >= 0.2, + unordered-containers >= 0.2.10.0 && < 0.3, wai >= 3.0.0 && < 3.3, - wai-extra >= 3.0.0 && < 3.2, - warp >= 3.0.13 && < 3.4 + wai-extra >= 3.1.14, + warp >= 3.0.13, + random >= 1.0.0.0 if impl(ghc < 8.0) build-depends: fail @@ -99,30 +104,48 @@ if impl(ghc < 7.10) build-depends: nats >= 0.1 && < 2 - GHC-options: -Wall -fno-warn-orphans + GHC-options: -Wall -fno-warn-orphans -Wno-unused-imports test-suite spec main-is: Spec.hs other-modules: Web.ScottySpec + Test.Hspec.Wai.Extra type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test build-depends: async, base, bytestring, - data-default-class, directory, hspec == 2.*, hspec-wai >= 0.6.3, + http-api-data, http-types, lifted-base, network, scotty, text, - wai + time, + wai, + wai-extra build-tool-depends: hspec-discover:hspec-discover == 2.* GHC-options: -Wall -threaded -fno-warn-orphans +test-suite doctest + main-is: Main.hs + type: exitcode-stdio-1.0 + default-language: Haskell2010 + GHC-options: -Wall -threaded -fno-warn-orphans + hs-source-dirs: doctest + build-depends: base + , bytestring + , doctest >= 0.20.1 + , http-client + , http-types + , scotty + , text + , wai + benchmark weigh main-is: Main.hs type: exitcode-stdio-1.0 @@ -133,10 +156,10 @@ lucid, bytestring, mtl, + resourcet, text, transformers, - data-default-class, - weigh == 0.0.16 + weigh >= 0.0.16 && <0.1 GHC-options: -Wall -O2 -threaded source-repository head 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 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -1,28 +1,45 @@ -{-# LANGUAGE OverloadedStrings, CPP #-} +{-# LANGUAGE OverloadedStrings, CPP, ScopedTypeVariables, DeriveGeneric #-} module Web.ScottySpec (main, spec) where import Test.Hspec -import Test.Hspec.Wai +import Test.Hspec.Wai (WaiSession, with, request, get, post, put, patch, delete, options, (<:>), shouldRespondWith, matchHeaders, matchBody, matchStatus) +import Test.Hspec.Wai.Extra (postMultipartForm, FileMeta(..)) import Control.Applicative import Control.Monad import Data.Char import Data.String +import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +import qualified Data.Text as T import qualified Data.Text.Lazy.Encoding as TLE +import Data.Time (UTCTime(..)) +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (secondsToDiffTime) + +import GHC.Generics (Generic) + import Network.HTTP.Types +import Network.Wai (Application, Request(queryString), responseLBS) +import Network.Wai.Middleware.ValidateHeaders (validateHeadersMiddleware, defaultValidateHeadersSettings) +import Network.Wai.Parse (defaultParseRequestBodyOptions) +import Network.Wai.Test (SResponse) import qualified Control.Exception.Lifted as EL import qualified Control.Exception as E +import Web.FormUrlEncoded (FromForm) import Web.Scotty as Scotty hiding (get, post, put, patch, delete, request, options) import qualified Web.Scotty as Scotty +import Web.Scotty.Trans (scottyAppT) -- for testing JSON mode with custom Options +import Web.Scotty (ScottyException(..)) +import qualified Web.Scotty.Cookie as SC (getCookie, setSimpleCookie, deleteCookie) #if !defined(mingw32_HOST_OS) import Control.Concurrent.Async (withAsync) import Control.Exception (bracketOnError) import qualified Data.ByteString as BS import Data.ByteString (ByteString) -import Data.Default.Class (def) +import qualified Data.ByteString.Lazy as LBS import Network.Socket (Family(..), SockAddr(..), Socket, SocketOption(..), SocketType(..), bind, close, connect, listen, maxListenQueue, setSocketOption, socket) import Network.Socket.ByteString (send, recv) import System.Directory (removeFile) @@ -34,6 +51,16 @@ 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 @@ -55,6 +82,12 @@ it ("properly handles extra slash routes for " ++ method ++ " requests") $ do makeRequest "//scotty" `shouldRespondWith` 200 + withApp (route "/:paramName" $ captureParam "paramName" >>= text) $ do + it ("captures route parameters for " ++ method ++ " requests when parameter matches its name") $ do + makeRequest "/:paramName" `shouldRespondWith` ":paramName" + it ("captures route parameters for " ++ method ++ " requests with url encoded '/' in path") $ do + makeRequest "/a%2Fb" `shouldRespondWith` "a/b" + describe "addroute" $ do forM_ availableMethods $ \method -> do withApp (addroute method "/scotty" $ html "") $ do @@ -82,51 +115,501 @@ get "/" `shouldRespondWith` "

404: File Not Found!

" {matchStatus = 404} describe "defaultHandler" $ do - withApp (defaultHandler text >> Scotty.get "/" (liftAndCatchIO $ E.throwIO E.DivideByZero)) $ do + withApp (do + let h = Handler (\(e :: E.ArithException) -> status status500 >> text (TL.pack $ show e)) + defaultHandler h + Scotty.get "/" (throw E.DivideByZero)) $ do it "sets custom exception handler" $ do get "/" `shouldRespondWith` "divide by zero" {matchStatus = 500} - - withApp (defaultHandler (\_ -> status status503) >> Scotty.get "/" (liftAndCatchIO $ E.throwIO E.DivideByZero)) $ do + withApp (do + let h = Handler (\(_ :: E.ArithException) -> status status503) + defaultHandler h + Scotty.get "/" (liftIO $ E.throwIO E.DivideByZero)) $ do it "allows to customize the HTTP status code" $ do get "/" `shouldRespondWith` "" {matchStatus = 503} + withApp (do + let h = Handler (\(_ :: E.SomeException) -> setHeader "Location" "/c" >> status status500) + defaultHandler h + Scotty.get "/a" (redirect "/b")) $ do + it "should give priority to actionErrorHandlers" $ do + get "/a" `shouldRespondWith` 302 { matchHeaders = ["Location" <:> "/b"] } context "when not specified" $ do - withApp (Scotty.get "/" $ liftAndCatchIO $ E.throwIO E.DivideByZero) $ do + withApp (Scotty.get "/" $ throw E.DivideByZero) $ do it "returns 500 on exceptions" $ do - get "/" `shouldRespondWith` "

500 Internal Server Error

divide by zero" {matchStatus = 500} + get "/" `shouldRespondWith` 500 + context "only applies to endpoints defined after it (#237)" $ do + withApp (do + let h = Handler (\(_ :: E.SomeException) -> status status503 >> text "ok") + Scotty.get "/a" (throw E.DivideByZero) + defaultHandler h + Scotty.get "/b" (throw E.DivideByZero) + ) $ do + it "doesn't catch an exception before the handler is set" $ do + get "/a" `shouldRespondWith` 500 + it "catches an exception after the handler is set" $ do + get "/b" `shouldRespondWith` "ok" {matchStatus = 503} + context "custom handlers and HTTP status codes (issue noted by user)" $ do + withApp (do + let h = Handler (\(_ :: ScottyException) -> text "Custom error message") + defaultHandler h + Scotty.post "/missing-body" $ do + _ <- jsonData :: ActionM Int + text "ok" + ) $ do + it "custom handler catches exception before status is set (returns 200)" $ do + -- Note: This demonstrates the issue where custom handlers lose the original status + -- The scottyExceptionHandler would set 400, but custom handler runs first + post "/missing-body" "" `shouldRespondWith` "Custom error message" {matchStatus = 200} + + withApp (do + let h = Handler (\(e :: ScottyException) -> do + case e of + MalformedJSON _ _ -> status status400 + QueryParameterNotFound _ -> status status400 + PathParameterNotFound _ -> status status500 + _ -> status status500 + text "Custom error with status") + defaultHandler h + Scotty.post "/missing-body" $ do + _ <- jsonData :: ActionM Int + text "ok" + ) $ do + it "custom handler can manually set appropriate status" $ do + -- This shows the workaround: custom handlers must explicitly set status + post "/missing-body" "" `shouldRespondWith` "Custom error with status" {matchStatus = 400} + + withApp (do + let h = Handler (\(_ :: ScottyException) -> text "Query error") + defaultHandler h + Scotty.get "/needs-param" $ do + _ <- queryParam "missing" :: ActionM Int + text "ok" + ) $ do + it "query parameter exception also returns 200 without explicit status" $ do + get "/needs-param" `shouldRespondWith` "Query error" {matchStatus = 200} + + withApp (do + let h = Handler (\(_ :: ScottyException) -> text "Path error") + defaultHandler h + Scotty.get "/path/:id" $ do + _ <- pathParam "nonexistent" :: ActionM Int + text "ok" + ) $ do + it "path parameter exception also returns 200 without explicit status" $ do + get "/path/123" `shouldRespondWith` "Path error" {matchStatus = 200} + + + describe "setMaxRequestBodySize" $ do + let + large = TLE.encodeUtf8 . TL.pack . concat $ [show c | c <- ([1..4500]::[Integer])] + smol = TLE.encodeUtf8 . TL.pack . concat $ [show c | c <- ([1..50]::[Integer])] + withApp (do + Scotty.setMaxRequestBodySize 1 + Scotty.post "/upload" $ do + _ <- files + status status200 + ) $ do + context "application/x-www-form-urlencoded" $ do + it "should return 200 OK if the request body size is below 1 KB" $ do + request "POST" "/upload" [("Content-Type","application/x-www-form-urlencoded")] + smol `shouldRespondWith` 200 + it "should return 413 (Content Too Large) if the request body size is above 1 KB" $ do + request "POST" "/upload" [("Content-Type","application/x-www-form-urlencoded")] + large `shouldRespondWith` 413 + + withApp (Scotty.post "/" $ status status200) $ do + context "(counterexample)" $ do + it "doesn't throw an uncaught exception if the body is large" $ do + request "POST" "/" [("Content-Type","application/x-www-form-urlencoded")] + large `shouldRespondWith` 200 + withApp (Scotty.setMaxRequestBodySize 1 >> Scotty.post "/upload" (do status status200)) $ do + context "multipart/form-data; boundary=--33" $ do + it "should return 200 OK if the request body size is above 1 KB (since multipart form bodies are only traversed or parsed on demand)" $ do + request "POST" "/upload" [("Content-Type","multipart/form-data; boundary=--33")] + large `shouldRespondWith` 200 + + describe "middleware" $ do + context "can rewrite the query string (#348)" $ do + withApp (do + Scotty.middleware $ \app req sendResponse -> + app req{queryString = [("query", Just "haskell")]} sendResponse + Scotty.matchAny "/search" $ queryParam "query" >>= text + ) $ do + it "returns query parameter with given name" $ do + get "/search" `shouldRespondWith` "haskell" + + context "ValidateHeaders middleware" $ do + context "rejects invalid header values" $ do + withApp (do + Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings + Scotty.get "/test" $ do + setHeader "X-Custom" "value\r\nwith\r\nnewlines" + text "should not reach here" + ) $ do + it "returns 500 when header value contains CR/LF" $ do + get "/test" `shouldRespondWith` 500 + + withApp (do + Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings + Scotty.get "/test" $ do + setHeader "X-Custom" "value\nwith\nnewlines" + text "should not reach here" + ) $ do + it "returns 500 when header value contains LF" $ do + get "/test" `shouldRespondWith` 500 + + withApp (do + Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings + Scotty.get "/test" $ do + setHeader "X-Custom" "value\0with\0null" + text "should not reach here" + ) $ do + it "returns 500 when header value contains NUL" $ do + get "/test" `shouldRespondWith` 500 + + withApp (do + Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings + Scotty.get "/test" $ do + setHeader "X-Custom" "trailing space " + text "should not reach here" + ) $ do + it "returns 500 when header value has trailing whitespace" $ do + get "/test" `shouldRespondWith` 500 + + withApp (do + Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings + Scotty.get "/test" $ do + setHeader "X-Custom" " leading space" + text "should not reach here" + ) $ do + it "returns 500 when header value has leading whitespace" $ do + get "/test" `shouldRespondWith` 500 + + context "allows valid header values" $ do + withApp (do + Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings + Scotty.get "/test" $ do + setHeader "X-Custom" "valid-value" + text "success" + ) $ do + it "returns 200 when header value is valid" $ do + get "/test" `shouldRespondWith` "success" {matchStatus = 200} + + withApp (do + Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings + Scotty.get "/test" $ do + setHeader "X-Custom" "value with spaces" + text "success" + ) $ do + it "returns 200 when header value contains internal spaces" $ do + get "/test" `shouldRespondWith` "success" {matchStatus = 200} + + withApp (do + Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings + Scotty.get "/test" $ do + setHeader "Content-Type" "text/plain; charset=utf-8" + text "success" + ) $ do + it "returns 200 for standard Content-Type header" $ do + get "/test" `shouldRespondWith` 200 + + context "can be disabled by not adding the middleware" $ do + withApp (do + Scotty.get "/test" $ do + setHeader "X-Custom" "value\r\nwith\r\nnewlines" + text "no validation" + ) $ do + it "allows invalid headers when middleware is not enabled" $ do + get "/test" `shouldRespondWith` "no validation" {matchStatus = 200} + describe "ActionM" $ do - withApp (Scotty.get "/" $ (undefined `EL.catch` ((\_ -> html "") :: E.SomeException -> ActionM ()))) $ do - it "has a MonadBaseControl instance" $ do - get "/" `shouldRespondWith` 200 + context "MonadBaseControl instance" $ do + withApp (Scotty.get "/" $ (undefined `EL.catch` ((\_ -> html "") :: E.SomeException -> ActionM ()))) $ do + it "catches SomeException and returns 200" $ do + get "/" `shouldRespondWith` 200 + withApp (Scotty.get "/" $ EL.throwIO E.DivideByZero) $ do + it "returns 500 on uncaught exceptions" $ do + get "/" `shouldRespondWith` 500 - withApp (Scotty.get "/dictionary" $ empty <|> param "word1" <|> empty <|> param "word2" >>= text) $ - it "has an Alternative instance" $ do - get "/dictionary?word1=haskell" `shouldRespondWith` "haskell" - get "/dictionary?word2=scotty" `shouldRespondWith` "scotty" - get "/dictionary?word1=a&word2=b" `shouldRespondWith` "a" + context "Alternative instance" $ do + withApp (Scotty.get "/" $ empty >>= text) $ + it "empty without any route following returns a 404" $ + get "/" `shouldRespondWith` 404 + withApp (Scotty.get "/dictionary" $ empty <|> queryParam "word1" >>= text) $ + it "empty throws Next" $ do + get "/dictionary?word1=x" `shouldRespondWith` "x" + withApp (Scotty.get "/dictionary" $ queryParam "word1" <|> empty <|> queryParam "word2" >>= text) $ + it "<|> skips the left route if that fails" $ do + get "/dictionary?word2=y" `shouldRespondWith` "y" + get "/dictionary?word1=a&word2=b" `shouldRespondWith` "a" - describe "param" $ do - withApp (Scotty.matchAny "/search" $ param "query" >>= text) $ do + context "MonadFail instance" $ do + withApp (Scotty.get "/" $ fail "boom!") $ do + it "returns 500 if not caught" $ + get "/" `shouldRespondWith` 500 + withApp (Scotty.get "/" $ fail "boom!" `catch` (\(_ :: E.SomeException) -> do + status status200 + text "ok")) $ + it "can catch the Exception thrown by fail" $ do + get "/" `shouldRespondWith` 200 { matchBody = "ok"} + + describe "redirect" $ do + withApp ( + do + Scotty.get "/a" $ redirect "/b" + ) $ do + it "Responds with a 302 Redirect" $ do + get "/a" `shouldRespondWith` 302 { matchHeaders = ["Location" <:> "/b"] } + + describe "redirect300" $ do + withApp ( + do + Scotty.get "/a" $ redirect300 "/b" + ) $ do + it "Responds with a 300 Redirect" $ do + get "/a" `shouldRespondWith` 300 { matchHeaders = ["Location" <:> "/b"] } + + + describe "redirect301" $ do + withApp ( + do + Scotty.get "/a" $ redirect301 "/b" + ) $ do + it "Responds with a 301 Redirect" $ do + get "/a" `shouldRespondWith` 301 { matchHeaders = ["Location" <:> "/b"] } + + describe "redirect302" $ do + withApp ( + do + Scotty.get "/a" $ redirect302 "/b" + ) $ do + it "Responds with a 302 Redirect" $ do + get "/a" `shouldRespondWith` 302 { matchHeaders = ["Location" <:> "/b"] } + + + describe "redirect303" $ do + withApp ( + do + Scotty.delete "/a" $ redirect303 "/b" + ) $ do + it "Responds with a 303 as passed in" $ do + delete "/a" `shouldRespondWith` 303 { matchHeaders = ["Location" <:> "/b"]} + + describe "redirect304" $ do + withApp ( + do + Scotty.get "/a" $ redirect304 "/b" + ) $ do + it "Responds with a 304 Redirect" $ do + get "/a" `shouldRespondWith` 304 { matchHeaders = ["Location" <:> "/b"] } + + describe "redirect307" $ do + withApp ( + do + Scotty.get "/a" $ redirect307 "/b" + ) $ do + it "Responds with a 307 Redirect" $ do + get "/a" `shouldRespondWith` 307 { matchHeaders = ["Location" <:> "/b"] } + + describe "redirect308" $ do + withApp ( + do + Scotty.get "/a" $ redirect308 "/b" + ) $ do + it "Responds with a 308 Redirect" $ do + get "/a" `shouldRespondWith` 308 { matchHeaders = ["Location" <:> "/b"] } + + describe "Parsable" $ do + it "parses a UTCTime string" $ do + parseParam "2023-12-18T00:38:00Z" `shouldBe` Right (UTCTime (fromGregorian 2023 12 18) (secondsToDiffTime (60 * 38)) ) + + describe "captureParam" $ do + withApp ( + do + Scotty.get "/search/:q" $ do + _ :: Int <- captureParam "q" + text "int" + Scotty.get "/search/:q" $ do + _ :: String <- captureParam "q" + text "string" + Scotty.get "/search-time/:q" $ do + t :: UTCTime <- captureParam "q" + text $ TL.pack (show t) + ) $ do + it "responds with 200 OK iff at least one route matches at the right type" $ do + get "/search/42" `shouldRespondWith` 200 { matchBody = "int" } + get "/search/potato" `shouldRespondWith` 200 { matchBody = "string" } + get "/search-time/2023-12-18T00:38:00Z" `shouldRespondWith` 200 {matchBody = "2023-12-18 00:38:00 UTC"} + withApp ( + do + Scotty.get "/search/:q" $ do + v <- captureParam "q" + json (v :: Int) + ) $ do + it "responds with 404 Not Found if no route matches at the right type" $ do + get "/search/potato" `shouldRespondWith` 404 + withApp ( + do + Scotty.matchAny "/search/:q" $ do + v <- captureParam "zzz" + json (v :: Int) + ) $ do + it "responds with 500 Server Error if the parameter cannot be found in the capture" $ do + get "/search/potato" `shouldRespondWith` 500 + context "recover from missing parameter exception" $ do + withApp (Scotty.get "/search/:q" $ + (captureParam "z" >>= text) `catch` (\(_::ScottyException) -> text "z") + ) $ do + it "catches a StatusError" $ do + get "/search/xxx" `shouldRespondWith` 200 { matchBody = "z"} + + describe "queryParam" $ do + withApp (Scotty.get "/search" $ queryParam "query" >>= text) $ do it "returns query parameter with given name" $ do get "/search?query=haskell" `shouldRespondWith` "haskell" + it "decodes URL-encoding" $ do + get "/search?query=Kurf%C3%BCrstendamm" `shouldRespondWith` "Kurfürstendamm" + withApp (Scotty.matchAny "/search" (do + v <- queryParam "query" + json (v :: Int) )) $ do + it "responds with 200 OK if the query parameter can be parsed at the right type" $ do + get "/search?query=42" `shouldRespondWith` 200 + it "responds with 400 Bad Request if the query parameter cannot be parsed at the right type" $ do + get "/search?query=potato" `shouldRespondWith` 400 + context "recover from type mismatch parameter exception" $ do + withApp (Scotty.get "/search" $ + (queryParam "z" >>= (\v -> json (v :: Int))) `catch` (\(_::ScottyException) -> text "z") + ) $ do + it "catches a ScottyException" $ do + get "/search?query=potato" `shouldRespondWith` 200 { matchBody = "z"} + + describe "formData" $ do + withApp (Scotty.post "/search" $ formData >>= (text . sfQuery)) $ do + it "decodes the form" $ do + postForm "/search" "sfQuery=Haskell&sfYear=2024" `shouldRespondWith` "Haskell" - context "when used with application/x-www-form-urlencoded data" $ do - it "returns POST parameter with given name" $ do - request "POST" "/search" [("Content-Type","application/x-www-form-urlencoded")] "query=haskell" `shouldRespondWith` "haskell" + it "decodes URL-encoding" $ do + postForm "/search" "sfQuery=Kurf%C3%BCrstendamm&sfYear=2024" `shouldRespondWith` "Kurfürstendamm" - it "replaces non UTF-8 bytes with Unicode replacement character" $ do - request "POST" "/search" [("Content-Type","application/x-www-form-urlencoded")] "query=\xe9" `shouldRespondWith` "\xfffd" + it "returns 400 when the form is malformed" $ do + postForm "/search" "sfQuery=Haskell" `shouldRespondWith` 400 + describe "formParam" $ do + withApp (Scotty.post "/search" $ formParam "query" >>= text) $ do + it "returns form parameter with given name" $ do + postForm "/search" "query=haskell" `shouldRespondWith` "haskell" - describe "requestLimit" $ do - withApp (Scotty.setMaxRequestBodySize 1 >> Scotty.matchAny "/upload" (do status status200)) $ do - it "upload endpoint for max-size requests, status 413 if request is too big, 200 otherwise" $ do - request "POST" "/upload" [("Content-Type","multipart/form-data; boundary=--33")] - (TLE.encodeUtf8 . TL.pack . concat $ [show c | c <- ([1..4500]::[Integer])]) `shouldRespondWith` 413 - request "POST" "/upload" [("Content-Type","multipart/form-data; boundary=--33")] - (TLE.encodeUtf8 . TL.pack . concat $ [show c | c <- ([1..50]::[Integer])]) `shouldRespondWith` 200 + 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 = "νέα ελληνικά" @@ -171,6 +654,81 @@ it "stops the execution of an action" $ do get "/scotty" `shouldRespondWith` 400 + describe "setSimpleCookie" $ do + withApp (Scotty.get "/scotty" $ SC.setSimpleCookie "foo" "bar") $ do + it "responds with a Set-Cookie header" $ do + get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Set-Cookie" <:> "foo=bar"]} + + describe "getCookie" $ do + withApp (Scotty.get "/scotty" $ do + mt <- SC.getCookie "foo" + case mt of + Just "bar" -> Scotty.status status200 + _ -> Scotty.status status400 ) $ do + it "finds the right cookie in the request headers" $ do + request "GET" "/scotty" [("Cookie", "foo=bar")] "" `shouldRespondWith` 200 + + describe "deleteCookie" $ do + withApp (Scotty.get "/scotty" $ SC.deleteCookie "foo") $ do + it "responds with a Set-Cookie header with expiry date Jan 1, 1970" $ do + get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Set-Cookie" <:> "foo=; Expires=Thu, 01-Jan-1970 00:00:00 GMT"]} + + describe "nested" $ do + let + simpleApp :: Application + simpleApp _ respond = do + putStrLn "I've done some IO here" + respond $ responseLBS + status200 + [("Content-Type", "text/plain")] + "Hello, Web!" + + withApp (Scotty.get "/nested" (nested simpleApp)) $ do + it "responds with the expected simpleApp response" $ do + get "/nested" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/plain"], matchBody = "Hello, Web!"} + + describe "Session Management" $ do + withApp (Scotty.get "/scotty" $ do + sessionJar <- liftIO createSessionJar + sess <- createUserSession sessionJar Nothing ("foo" :: T.Text) + mRes <- readSession sessionJar (sessId sess) + case mRes of + Left _ -> Scotty.status status400 + Right res -> do + if res /= "foo" then Scotty.status status400 + else text "all good" + ) $ do + it "Roundtrip of session by adding and fetching a value" $ do + get "/scotty" `shouldRespondWith` 200 + + describe "JSON Mode" $ do + let scottyAppJson = scottyAppT (defaultOptions { jsonMode = True }) id + let withJsonApp = with . scottyAppJson + + describe "notFound" $ do + context "when JSON mode is enabled" $ do + withJsonApp (return ()) $ do + it "returns 404 with JSON response" $ do + get "/" `shouldRespondWith` 404 {matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]} + + describe "exception handlers" $ do + context "when JSON mode is enabled" $ do + withJsonApp (Scotty.get "/" $ throw E.DivideByZero) $ do + it "returns 500 with JSON response for unhandled exceptions" $ do + get "/" `shouldRespondWith` 500 {matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]} + + withJsonApp (Scotty.get "/param/:id" $ do + (_ :: Int) <- pathParam "nonexistent" + text "ok") $ do + it "returns 500 with JSON response for missing path parameter" $ do + get "/param/test" `shouldRespondWith` 500 {matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]} + + withJsonApp (Scotty.get "/query" $ do + (_ :: Int) <- queryParam "missing" + text "ok") $ do + it "returns 400 with JSON response for missing query parameter" $ do + get "/query" `shouldRespondWith` 400 {matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]} + -- Unix sockets not available on Windows #if !defined(mingw32_HOST_OS) describe "scottySocket" . @@ -194,7 +752,7 @@ withServer actions inner = E.bracket (listenOn socketPath) (\sock -> close sock >> removeFile socketPath) - (\sock -> withAsync (Scotty.scottySocket def sock actions) $ const inner) + (\sock -> withAsync (Scotty.scottySocket defaultOptions sock actions) $ const inner) -- See https://github.com/haskell/network/issues/318 listenOn :: String -> IO Socket @@ -209,3 +767,4 @@ return sock ) #endif +