├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── Web ├── Scotty.hs └── Scotty │ ├── Action.hs │ ├── Body.hs │ ├── Cookie.hs │ ├── Internal │ └── Types.hs │ ├── Route.hs │ ├── Session.hs │ ├── Trans.hs │ ├── Trans │ ├── Lazy.hs │ └── Strict.hs │ └── Util.hs ├── bench └── Main.hs ├── cabal.haskell-ci ├── cabal.project ├── changelog.md ├── doctest └── Main.hs ├── examples ├── 404.html ├── LICENSE ├── basic.hs ├── bodyecho.hs ├── cookies.hs ├── exceptions.hs ├── globalstate.hs ├── gzip.hs ├── nested.hs ├── options.hs ├── reader.hs ├── scotty-examples.cabal ├── session.hs ├── static │ ├── jquery-json.js │ └── jquery.js ├── upload.hs ├── uploads │ └── .keep └── urlshortener.hs ├── scotty.cabal └── test ├── Spec.hs ├── Test └── Hspec │ └── Wai │ └── Extra.hs └── Web └── ScottySpec.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | pull_request: 5 | push: 6 | branches: [master] 7 | 8 | defaults: 9 | run: 10 | shell: bash 11 | 12 | jobs: 13 | cabal: 14 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 15 | runs-on: ${{ matrix.os }} 16 | strategy: 17 | matrix: 18 | include: 19 | - { cabal: "3.10", os: ubuntu-latest, ghc: "8.10.7" } 20 | - { cabal: "3.10", os: ubuntu-latest, ghc: "9.0.2" } 21 | - { cabal: "3.10", os: ubuntu-latest, ghc: "9.2.8" } 22 | - { cabal: "3.10", os: ubuntu-latest, ghc: "9.4.6" } 23 | - { cabal: "3.10", os: ubuntu-latest, ghc: "9.6.4" } 24 | - { cabal: "3.10", os: ubuntu-latest, ghc: "9.8.2" } 25 | - { cabal: "3.10", os: ubuntu-latest, ghc: "9.10.1" } 26 | fail-fast: false 27 | 28 | steps: 29 | - uses: actions/checkout@v3 30 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 31 | - uses: haskell-actions/setup@v2 32 | id: setup-haskell-cabal 33 | name: Setup Haskell 34 | with: 35 | ghc-version: ${{ matrix.ghc }} 36 | cabal-version: ${{ matrix.cabal }} 37 | - uses: actions/cache@v4 38 | name: Cache ~/.cabal/store 39 | with: 40 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 41 | key: ${{ runner.os }}-${{ matrix.ghc }}--${{ matrix.cabal }}-cache 42 | - name: Versions 43 | run: | 44 | cabal -V 45 | ghc -V 46 | - name: Build 47 | run: | 48 | cabal configure --haddock-all --enable-tests --enable-benchmarks --benchmark-option=-l 49 | cabal build all --write-ghc-environment-files=always 50 | - name: Test 51 | run: | 52 | cabal test all 53 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | stack.yaml 24 | stack.yaml.lock 25 | 26 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012-2017 Andrew Farmer 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above 11 | copyright notice, this list of conditions and the following 12 | disclaimer in the documentation and/or other materials provided 13 | with the distribution. 14 | 15 | * Neither the name of Andrew Farmer nor the names of other 16 | contributors may be used to endorse or promote products derived 17 | from this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | boot: 2 | cabal install --force-reinstalls 3 | 4 | ghci: 5 | cabal repl 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # 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) 2 | 3 | A Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp. 4 | 5 | ```haskell 6 | {-# LANGUAGE OverloadedStrings #-} 7 | import Web.Scotty 8 | 9 | main = scotty 3000 $ 10 | get "/:word" $ do 11 | beam <- pathParam "word" 12 | html $ mconcat ["

Scotty, ", beam, " me up!

"] 13 | ``` 14 | 15 | Scotty is the cheap and cheerful way to write RESTful, declarative web applications. 16 | 17 | * A page is as simple as defining the verb, URL pattern, and Text content. 18 | * It is template-language agnostic. Anything that returns a Text value will do. 19 | * Conforms to the [web application interface (WAI)](https://github.com/yesodweb/wai/). 20 | * Uses the very fast Warp webserver by default. 21 | 22 | As for the name: Sinatra + Warp = Scotty. 23 | 24 | ## Examples 25 | 26 | Run /basic.hs to see Scotty in action: 27 | 28 | ```bash 29 | runghc examples/basic.hs 30 | ``` 31 | `Setting phasers to stun... (port 3000) (ctrl-c to quit)` 32 | 33 | Or equivalently with [`stack`](https://docs.haskellstack.org/en/stable/): 34 | 35 | ```bash 36 | stack exec -- scotty-basic 37 | ``` 38 | 39 | Once the server is running you can interact with it with curl or a browser: 40 | 41 | ```bash 42 | curl localhost:3000 43 | ``` 44 | `foobar` 45 | 46 | ```bash 47 | curl localhost:3000/foo_query?p=42 48 | ``` 49 | `

42

` 50 | 51 | 52 | Additionally, the `examples` directory shows a number of concrete use cases, e.g. 53 | 54 | * [exception handling](./examples/exceptions.hs) 55 | * [global state](./examples/globalstate.hs) 56 | * [configuration](./examples/reader.hs) 57 | * [cookies](./examples/cookies.hs) 58 | * [file upload](./examples/upload.hs) 59 | * [session](./examples/session.hs) 60 | * and more 61 | 62 | ## More Information 63 | 64 | Tutorials and related projects can be found in the [Scotty wiki](https://github.com/scotty-web/scotty/wiki). 65 | 66 | ## Contributing 67 | 68 | Feel free to ask questions or report bugs on the [Github issue tracker](https://github.com/scotty-web/scotty/issues/). 69 | 70 | 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` :) 71 | 72 | ## Package versions 73 | 74 | Scotty adheres to the [Package Versioning Policy](https://pvp.haskell.org/). 75 | 76 | 77 | ## FAQ 78 | 79 | * Fails to compile regex-posix on Windows 80 | * If you are using stack, add the following parameters to `stack.yaml`: 81 | * ```yaml 82 | extra-deps: 83 | - regex-posix-clib-2.7 84 | flags: 85 | regex-posix: 86 | _regex-posix-clib: true 87 | ``` 88 | * If you are using cabal, update the `constraints` section of `cabal.project.local` as follows: 89 | * ``` 90 | constraints: 91 | regex-posix +_regex-posix-clib 92 | ``` 93 | 94 | ### Contributors 95 | 96 | 97 | 98 | 99 | 100 | 101 | # Copyright 102 | (c) 2012-Present, Andrew Farmer and Scotty contributors 103 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Web/Scotty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | -- | It should be noted that most of the code snippets below depend on the 3 | -- OverloadedStrings language pragma. 4 | -- 5 | -- Scotty is set up by default for development mode. For production servers, 6 | -- you will likely want to modify 'Trans.settings' and the 'defaultHandler'. See 7 | -- the comments on each of these functions for more information. 8 | -- 9 | -- 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. 10 | module Web.Scotty 11 | ( -- * Running 'scotty' servers 12 | scotty 13 | , scottyOpts 14 | , scottySocket 15 | , Options(..), defaultOptions 16 | -- ** scotty-to-WAI 17 | , scottyApp 18 | -- * Defining Middleware and Routes 19 | -- 20 | -- | 'Middleware' and routes are run in the order in which they 21 | -- are defined. All middleware is run first, followed by the first 22 | -- route that matches. If no route matches, a 404 response is given. 23 | , middleware, get, post, put, delete, patch, options, addroute, matchAny, notFound, nested, setMaxRequestBodySize 24 | -- ** Route Patterns 25 | , capture, regex, function, literal 26 | -- ** Accessing the Request and its fields 27 | , request, header, headers, body, bodyReader 28 | , jsonData, formData 29 | -- ** Accessing Path, Form and Query Parameters 30 | , pathParam, captureParam, formParam, queryParam 31 | , pathParamMaybe, captureParamMaybe, formParamMaybe, queryParamMaybe 32 | , pathParams, captureParams, formParams, queryParams 33 | -- *** Files 34 | , files, filesOpts 35 | -- ** Modifying the Response 36 | , status, addHeader, setHeader 37 | -- ** Redirecting 38 | , redirect, redirect300, redirect301, redirect302, redirect303, redirect304, redirect307, redirect308 39 | -- ** Setting Response Body 40 | -- 41 | -- | Note: only one of these should be present in any given route 42 | -- definition, as they completely replace the current 'Response' body. 43 | , text, html, file, json, stream, raw 44 | -- ** Accessing the fields of the Response 45 | , getResponseHeaders, getResponseStatus, getResponseContent 46 | -- ** Exceptions 47 | , throw, next, finish, defaultHandler 48 | , liftIO, catch 49 | , ScottyException(..) 50 | -- * Parsing Parameters 51 | , Param, Trans.Parsable(..), Trans.readEither 52 | -- * Types 53 | , ScottyM, ActionM, RoutePattern, File, Content(..), Kilobytes, ErrorHandler, Handler(..) 54 | , ScottyState, defaultScottyState 55 | -- ** Cookie functions 56 | , setCookie, setSimpleCookie, getCookie, getCookies, deleteCookie, Cookie.makeSimpleCookie 57 | -- ** Session Management 58 | , Session (..), SessionId, SessionJar, SessionStatus 59 | , createSessionJar, createUserSession, createSession, addSession 60 | , readSession, getUserSession, getSession, readUserSession 61 | , deleteSession, maintainSessions 62 | ) where 63 | 64 | import qualified Web.Scotty.Trans as Trans 65 | 66 | import qualified Control.Exception as E 67 | import Control.Monad.IO.Class 68 | import Data.Aeson (FromJSON, ToJSON) 69 | import qualified Data.ByteString as BS 70 | import Data.ByteString.Lazy.Char8 (ByteString) 71 | import Data.Text.Lazy (Text, toStrict) 72 | import qualified Data.Text as T 73 | 74 | import Network.HTTP.Types (Status, StdMethod, ResponseHeaders) 75 | import Network.Socket (Socket) 76 | import Network.Wai (Application, Middleware, Request, StreamingBody) 77 | import Network.Wai.Handler.Warp (Port) 78 | import qualified Network.Wai.Parse as W 79 | 80 | import Web.FormUrlEncoded (FromForm) 81 | import Web.Scotty.Internal.Types (ScottyT, ActionT, ErrorHandler, Param, RoutePattern, Options, defaultOptions, File, Kilobytes, ScottyState, defaultScottyState, ScottyException, Content(..)) 82 | import UnliftIO.Exception (Handler(..), catch) 83 | import qualified Web.Scotty.Cookie as Cookie 84 | import Web.Scotty.Session (Session (..), SessionId, SessionJar, SessionStatus , createSessionJar, 85 | createSession, addSession, maintainSessions) 86 | 87 | {- $setup 88 | >>> :{ 89 | import Control.Monad.IO.Class (MonadIO(..)) 90 | import qualified Network.HTTP.Client as H 91 | import qualified Network.HTTP.Types as H 92 | import qualified Network.Wai as W (httpVersion) 93 | import qualified Data.ByteString.Lazy.Char8 as LBS (unpack) 94 | import qualified Data.Text as T (pack) 95 | import Control.Concurrent (ThreadId, forkIO, killThread) 96 | import Control.Exception (bracket) 97 | import qualified Web.Scotty as S (ScottyM, scottyOpts, get, text, regex, pathParam, Options(..), defaultOptions) 98 | -- | GET an HTTP path 99 | curl :: MonadIO m => 100 | String -- ^ path 101 | -> m String -- ^ response body 102 | curl path = liftIO $ do 103 | req0 <- H.parseRequest path 104 | let req = req0 { H.method = "GET"} 105 | mgr <- H.newManager H.defaultManagerSettings 106 | (LBS.unpack . H.responseBody) <$> H.httpLbs req mgr 107 | -- | 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. 108 | withScotty :: S.ScottyM () 109 | -> IO a -- ^ inner action, e.g. 'curl "localhost:3000/"' 110 | -> IO a 111 | withScotty serv act = bracket (forkIO $ S.scottyOpts (S.defaultOptions{ S.verbose = 0 }) serv) killThread (\_ -> act) 112 | :} 113 | -} 114 | 115 | type ScottyM = ScottyT IO 116 | type ActionM = ActionT IO 117 | 118 | -- | Run a scotty application using the warp server. 119 | scotty :: Port -> ScottyM () -> IO () 120 | scotty p = Trans.scottyT p id 121 | 122 | -- | Run a scotty application using the warp server, passing extra options. 123 | scottyOpts :: Options -> ScottyM () -> IO () 124 | scottyOpts opts = Trans.scottyOptsT opts id 125 | 126 | -- | Run a scotty application using the warp server, passing extra options, 127 | -- and listening on the provided socket. This allows the user to provide, for 128 | -- example, a Unix named socket, which can be used when reverse HTTP proxying 129 | -- into your application. 130 | scottySocket :: Options -> Socket -> ScottyM () -> IO () 131 | scottySocket opts sock = Trans.scottySocketT opts sock id 132 | 133 | -- | Turn a scotty application into a WAI 'Application', which can be 134 | -- run with any WAI handler. 135 | scottyApp :: ScottyM () -> IO Application 136 | scottyApp = Trans.scottyAppT defaultOptions id 137 | 138 | -- | Global handler for user-defined exceptions. 139 | defaultHandler :: ErrorHandler IO -> ScottyM () 140 | defaultHandler = Trans.defaultHandler 141 | 142 | -- | Use given middleware. Middleware is nested such that the first declared 143 | -- is the outermost middleware (it has first dibs on the request and last action 144 | -- on the response). Every middleware is run on each request. 145 | middleware :: Middleware -> ScottyM () 146 | middleware = Trans.middleware 147 | 148 | -- | Nest a whole WAI application inside a Scotty handler. 149 | -- Note: You will want to ensure that this route fully handles the response, 150 | -- as there is no easy delegation as per normal Scotty actions. 151 | -- Also, you will have to carefully ensure that you are expecting the correct routes, 152 | -- this could require stripping the current prefix, or adding the prefix to your 153 | -- application's handlers if it depends on them. One potential use-case for this 154 | -- is hosting a web-socket handler under a specific route. 155 | nested :: Application -> ActionM () 156 | nested = Trans.nested 157 | 158 | -- | Set global size limit for the request body. Requests with body size exceeding the limit will not be 159 | -- processed and an HTTP response 413 will be returned to the client. Size limit needs to be greater than 0, 160 | -- otherwise the application will terminate on start. 161 | setMaxRequestBodySize :: Kilobytes -> ScottyM () 162 | setMaxRequestBodySize = Trans.setMaxRequestBodySize 163 | 164 | -- | Throw an exception which can be caught within the scope of the current Action with 'catch'. 165 | -- 166 | -- 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. 167 | -- 168 | -- Uncaught exceptions turn into HTTP 500 responses. 169 | throw :: (E.Exception e) => e -> ActionM a 170 | throw = Trans.throw 171 | 172 | -- | Abort execution of this action and continue pattern matching routes. 173 | -- Like an exception, any code after 'next' is not executed. 174 | -- 175 | -- NB : Internally, this is implemented with an exception that can only be 176 | -- caught by the library, but not by the user. 177 | -- 178 | -- As an example, these two routes overlap. The only way the second one will 179 | -- ever run is if the first one calls 'next'. 180 | -- 181 | -- > get "/foo/:bar" $ do 182 | -- > w :: Text <- pathParam "bar" 183 | -- > unless (w == "special") next 184 | -- > text "You made a request to /foo/special" 185 | -- > 186 | -- > get "/foo/:baz" $ do 187 | -- > w <- pathParam "baz" 188 | -- > text $ "You made a request to: " <> w 189 | next :: ActionM () 190 | next = Trans.next 191 | 192 | -- | Abort execution of this action. Like an exception, any code after 'finish' 193 | -- is not executed. 194 | -- 195 | -- As an example only requests to @\/foo\/special@ will include in the response 196 | -- content the text message. 197 | -- 198 | -- > get "/foo/:bar" $ do 199 | -- > w :: Text <- pathParam "bar" 200 | -- > unless (w == "special") finish 201 | -- > text "You made a request to /foo/special" 202 | -- 203 | -- /Since: 0.10.3/ 204 | finish :: ActionM a 205 | finish = Trans.finish 206 | 207 | -- | Synonym for 'redirect302'. 208 | -- If you are unsure which redirect to use, you probably want this one. 209 | -- 210 | -- > redirect "http://www.google.com" 211 | -- 212 | -- OR 213 | -- 214 | -- > redirect "/foo/bar" 215 | redirect :: Text -> ActionM a 216 | redirect = Trans.redirect 217 | 218 | -- | Redirect to given URL with status 300 (Multiple Choices). Like throwing 219 | -- an uncatchable exception. Any code after the call to 220 | -- redirect will not be run. 221 | redirect300 :: Text -> ActionM a 222 | redirect300 = Trans.redirect300 223 | 224 | -- | Redirect to given URL with status 301 (Moved Permanently). Like throwing 225 | -- an uncatchable exception. Any code after the call to 226 | -- redirect will not be run. 227 | redirect301 :: Text -> ActionM a 228 | redirect301 = Trans.redirect301 229 | 230 | -- | Redirect to given URL with status 302 (Found). Like throwing 231 | -- an uncatchable exception. Any code after the call to 232 | -- redirect will not be run. 233 | redirect302 :: Text -> ActionM a 234 | redirect302 = Trans.redirect302 235 | 236 | -- | Redirect to given URL with status 303 (See Other). Like throwing 237 | -- an uncatchable exception. Any code after the call to 238 | -- redirect will not be run. 239 | redirect303 :: Text -> ActionM a 240 | redirect303 = Trans.redirect303 241 | 242 | -- | Redirect to given URL with status 304 (Not Modified). Like throwing 243 | -- an uncatchable exception. Any code after the call to 244 | -- redirect will not be run. 245 | redirect304 :: Text -> ActionM a 246 | redirect304 = Trans.redirect304 247 | 248 | -- | Redirect to given URL with status 307 (Temporary Redirect). Like throwing 249 | -- an uncatchable exception. Any code after the call to 250 | -- redirect will not be run. 251 | redirect307 :: Text -> ActionM a 252 | redirect307 = Trans.redirect307 253 | 254 | -- | Redirect to given URL with status 308 (Permanent Redirect). Like throwing 255 | -- an uncatchable exception. Any code after the call to 256 | -- redirect will not be run. 257 | redirect308 :: Text -> ActionM a 258 | redirect308 = Trans.redirect308 259 | 260 | -- | Get the 'Request' object. 261 | request :: ActionM Request 262 | request = Trans.request 263 | 264 | -- | Get list of uploaded files. 265 | -- 266 | -- NB: Loads all file contents in memory with options 'W.defaultParseRequestBodyOptions' 267 | files :: ActionM [File ByteString] 268 | files = Trans.files 269 | 270 | -- | Get list of temp files and form parameters decoded from multipart payloads. 271 | -- 272 | -- NB the temp files are deleted when the continuation exits 273 | filesOpts :: W.ParseRequestBodyOptions 274 | -> ([Param] -> [File FilePath] -> ActionM a) -- ^ temp files validation, storage etc 275 | -> ActionM a 276 | filesOpts = Trans.filesOpts 277 | 278 | -- | Get a request header. Header name is case-insensitive. 279 | header :: Text -> ActionM (Maybe Text) 280 | header = Trans.header 281 | 282 | -- | Get all the request headers. Header names are case-insensitive. 283 | headers :: ActionM [(Text, Text)] 284 | headers = Trans.headers 285 | 286 | -- | Get the request body. 287 | -- 288 | -- NB: loads the entire request body in memory 289 | body :: ActionM ByteString 290 | body = Trans.body 291 | 292 | -- | Get an IO action that reads body chunks 293 | -- 294 | -- * This is incompatible with 'body' since 'body' consumes all chunks. 295 | bodyReader :: ActionM (IO BS.ByteString) 296 | bodyReader = Trans.bodyReader 297 | 298 | -- | Parse the request body as a JSON object and return it. Raises an exception if parse is unsuccessful. 299 | -- 300 | -- NB: uses 'body' internally 301 | jsonData :: FromJSON a => ActionM a 302 | jsonData = Trans.jsonData 303 | 304 | -- | Parse the request body as @x-www-form-urlencoded@ form data and return it. Raises an exception if parse is unsuccessful. 305 | -- 306 | -- NB: uses 'body' internally 307 | formData :: FromForm a => ActionM a 308 | formData = Trans.formData 309 | 310 | -- | Synonym for 'pathParam' 311 | -- 312 | -- /Since: 0.20/ 313 | captureParam :: Trans.Parsable a => Text -> ActionM a 314 | captureParam = Trans.captureParam . toStrict 315 | 316 | -- | Get a path parameter. 317 | -- 318 | -- * 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. 319 | -- 320 | -- * If the parameter is found, but 'parseParam' fails to parse to the correct type, 'next' is called. 321 | -- 322 | -- /Since: 0.21/ 323 | pathParam :: Trans.Parsable a => Text -> ActionM a 324 | pathParam = Trans.pathParam . toStrict 325 | 326 | -- | Get a form parameter. 327 | -- 328 | -- * 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. 329 | -- 330 | -- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type. 331 | -- 332 | -- /Since: 0.20/ 333 | formParam :: Trans.Parsable a => Text -> ActionM a 334 | formParam = Trans.formParam . toStrict 335 | 336 | -- | Get a query parameter. 337 | -- 338 | -- * 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. 339 | -- 340 | -- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type. 341 | -- 342 | -- /Since: 0.20/ 343 | queryParam :: Trans.Parsable a => Text -> ActionM a 344 | queryParam = Trans.queryParam . toStrict 345 | 346 | 347 | -- | Look up a path parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. 348 | -- 349 | -- NB : Doesn't throw exceptions. In particular, route pattern matching will not continue, so developers 350 | -- must 'raiseStatus' or 'throw' to signal something went wrong. 351 | -- 352 | -- /Since: 0.21/ 353 | pathParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a) 354 | pathParamMaybe = Trans.pathParamMaybe . toStrict 355 | 356 | -- | Synonym for 'pathParamMaybe' 357 | -- 358 | -- /Since: 0.21/ 359 | captureParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a) 360 | captureParamMaybe = Trans.pathParamMaybe . toStrict 361 | 362 | -- | Look up a form parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. 363 | -- 364 | -- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong. 365 | -- 366 | -- /Since: 0.21/ 367 | formParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a) 368 | formParamMaybe = Trans.formParamMaybe . toStrict 369 | 370 | -- | Look up a query parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. 371 | -- 372 | -- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong. 373 | -- 374 | -- /Since: 0.21/ 375 | queryParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a) 376 | queryParamMaybe = Trans.queryParamMaybe . toStrict 377 | 378 | -- | Synonym for 'pathParams' 379 | captureParams :: ActionM [Param] 380 | captureParams = Trans.captureParams 381 | -- | Get path parameters 382 | pathParams :: ActionM [Param] 383 | pathParams = Trans.pathParams 384 | -- | Get form parameters 385 | formParams :: ActionM [Param] 386 | formParams = Trans.formParams 387 | -- | Get query parameters 388 | queryParams :: ActionM [Param] 389 | queryParams = Trans.queryParams 390 | 391 | 392 | -- | Set the HTTP response status. Default is 200. 393 | status :: Status -> ActionM () 394 | status = Trans.status 395 | 396 | -- | Add to the response headers. Header names are case-insensitive. 397 | addHeader :: Text -> Text -> ActionM () 398 | addHeader = Trans.addHeader 399 | 400 | -- | Set one of the response headers. Will override any previously set value for that header. 401 | -- Header names are case-insensitive. 402 | setHeader :: Text -> Text -> ActionM () 403 | setHeader = Trans.setHeader 404 | 405 | -- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" 406 | -- header to \"text/plain; charset=utf-8\" if it has not already been set. 407 | text :: Text -> ActionM () 408 | text = Trans.text 409 | 410 | -- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" 411 | -- header to \"text/html; charset=utf-8\" if it has not already been set. 412 | html :: Text -> ActionM () 413 | html = Trans.html 414 | 415 | -- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably 416 | -- want to do that on your own with 'setHeader'. 417 | file :: FilePath -> ActionM () 418 | file = Trans.file 419 | 420 | -- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\" 421 | -- header to \"application/json; charset=utf-8\" if it has not already been set. 422 | json :: ToJSON a => a -> ActionM () 423 | json = Trans.json 424 | 425 | -- | Set the body of the response to a StreamingBody. Doesn't set the 426 | -- \"Content-Type\" header, so you probably want to do that on your 427 | -- own with 'setHeader'. 428 | stream :: StreamingBody -> ActionM () 429 | stream = Trans.stream 430 | 431 | -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the 432 | -- \"Content-Type\" header, so you probably want to do that on your own with 'setHeader'. 433 | raw :: ByteString -> ActionM () 434 | raw = Trans.raw 435 | 436 | 437 | -- | Access the HTTP 'Status' of the Response 438 | -- 439 | -- /Since: 0.21/ 440 | getResponseStatus :: ActionM Status 441 | getResponseStatus = Trans.getResponseStatus 442 | -- | Access the HTTP headers of the Response 443 | -- 444 | -- /Since: 0.21/ 445 | getResponseHeaders :: ActionM ResponseHeaders 446 | getResponseHeaders = Trans.getResponseHeaders 447 | -- | Access the content of the Response 448 | -- 449 | -- /Since: 0.21/ 450 | getResponseContent :: ActionM Content 451 | getResponseContent = Trans.getResponseContent 452 | 453 | 454 | -- | get = 'addroute' 'GET' 455 | get :: RoutePattern -> ActionM () -> ScottyM () 456 | get = Trans.get 457 | 458 | -- | post = 'addroute' 'POST' 459 | post :: RoutePattern -> ActionM () -> ScottyM () 460 | post = Trans.post 461 | 462 | -- | put = 'addroute' 'PUT' 463 | put :: RoutePattern -> ActionM () -> ScottyM () 464 | put = Trans.put 465 | 466 | -- | delete = 'addroute' 'DELETE' 467 | delete :: RoutePattern -> ActionM () -> ScottyM () 468 | delete = Trans.delete 469 | 470 | -- | patch = 'addroute' 'PATCH' 471 | patch :: RoutePattern -> ActionM () -> ScottyM () 472 | patch = Trans.patch 473 | 474 | -- | options = 'addroute' 'OPTIONS' 475 | options :: RoutePattern -> ActionM () -> ScottyM () 476 | options = Trans.options 477 | 478 | -- | Add a route that matches regardless of the HTTP verb. 479 | matchAny :: RoutePattern -> ActionM () -> ScottyM () 480 | matchAny = Trans.matchAny 481 | 482 | -- | Specify an action to take if nothing else is found. Note: this _always_ matches, 483 | -- so should generally be the last route specified. 484 | notFound :: ActionM () -> ScottyM () 485 | notFound = Trans.notFound 486 | 487 | {- | Define a route with a 'StdMethod', a route pattern representing the path spec, 488 | and an 'Action' which may modify the response. 489 | 490 | > get "/" $ text "beam me up!" 491 | 492 | The path spec can include values starting with a colon, which are interpreted 493 | as /captures/. These are parameters that can be looked up with 'pathParam'. 494 | 495 | >>> :{ 496 | let server = S.get "/foo/:bar" (S.pathParam "bar" >>= S.text) 497 | in do 498 | withScotty server $ curl "http://localhost:3000/foo/something" 499 | :} 500 | "something" 501 | -} 502 | addroute :: StdMethod -> RoutePattern -> ActionM () -> ScottyM () 503 | addroute = Trans.addroute 504 | 505 | 506 | {- | Match requests using a regular expression. 507 | Named captures are not yet supported. 508 | 509 | >>> :{ 510 | let server = S.get (S.regex "^/f(.*)r$") $ do 511 | cap <- S.pathParam "1" 512 | S.text cap 513 | in do 514 | withScotty server $ curl "http://localhost:3000/foo/bar" 515 | :} 516 | "oo/ba" 517 | -} 518 | regex :: String -> RoutePattern 519 | regex = Trans.regex 520 | 521 | -- | Standard Sinatra-style route. Named captures are prepended with colons. 522 | -- This is the default route type generated by OverloadedString routes. i.e. 523 | -- 524 | -- > get (capture "/foo/:bar") $ ... 525 | -- 526 | -- and 527 | -- 528 | -- > {-# LANGUAGE OverloadedStrings #-} 529 | -- > ... 530 | -- > get "/foo/:bar" $ ... 531 | -- 532 | -- are equivalent. 533 | capture :: String -> RoutePattern 534 | capture = Trans.capture 535 | 536 | 537 | {- | Build a route based on a function which can match using the entire 'Request' object. 538 | 'Nothing' indicates the route does not match. A 'Just' value indicates 539 | a successful match, optionally returning a list of key-value pairs accessible by 'param'. 540 | 541 | >>> :{ 542 | let server = S.get (function $ \req -> Just [("version", T.pack $ show $ W.httpVersion req)]) $ do 543 | v <- S.pathParam "version" 544 | S.text v 545 | in do 546 | withScotty server $ curl "http://localhost:3000/" 547 | :} 548 | "HTTP/1.1" 549 | -} 550 | function :: (Request -> Maybe [Param]) -> RoutePattern 551 | function = Trans.function 552 | 553 | -- | Build a route that requires the requested path match exactly, without captures. 554 | literal :: String -> RoutePattern 555 | literal = Trans.literal 556 | 557 | 558 | -- | Retrieves a session by its ID from the session jar. 559 | getSession :: SessionJar a -> SessionId -> ActionM (Either SessionStatus (Session a)) 560 | getSession = Trans.getSession 561 | 562 | -- | Deletes a session by its ID from the session jar. 563 | deleteSession :: SessionJar a -> SessionId -> ActionM () 564 | deleteSession = Trans.deleteSession 565 | 566 | {- | Retrieves the current user's session based on the "sess_id" cookie. 567 | | Returns `Left SessionStatus` if the session is expired or does not exist. 568 | -} 569 | getUserSession :: SessionJar a -> ActionM (Either SessionStatus (Session a)) 570 | getUserSession = Trans.getUserSession 571 | 572 | -- | Reads the content of a session by its ID. 573 | readSession :: SessionJar a -> SessionId -> ActionM (Either SessionStatus a) 574 | readSession = Trans.readSession 575 | 576 | -- | Reads the content of the current user's session. 577 | readUserSession ::SessionJar a -> ActionM (Either SessionStatus a) 578 | readUserSession = Trans.readUserSession 579 | 580 | -- | Creates a new session for a user, storing the content and setting a cookie. 581 | createUserSession :: 582 | SessionJar a -- ^ SessionJar, which can be created by createSessionJar 583 | -> Maybe Int -- ^ Optional expiration time (in seconds) 584 | -> a -- ^ Content 585 | -> ActionM (Session a) 586 | createUserSession = Trans.createUserSession 587 | 588 | -- Cookie functions 589 | 590 | -- | Set a cookie, with full access to its options (see 'SetCookie') 591 | setCookie :: Cookie.SetCookie -> ActionM () 592 | setCookie = Cookie.setCookie 593 | 594 | -- | 'makeSimpleCookie' and 'setCookie' combined. 595 | setSimpleCookie :: T.Text -- ^ name 596 | -> T.Text -- ^ value 597 | -> ActionM () 598 | setSimpleCookie = Cookie.setSimpleCookie 599 | 600 | -- | Lookup one cookie name 601 | getCookie :: T.Text -- ^ name 602 | -> ActionM (Maybe T.Text) 603 | getCookie = Cookie.getCookie 604 | 605 | -- | Returns all cookies 606 | getCookies :: ActionM Cookie.CookiesText 607 | getCookies = Cookie.getCookies 608 | 609 | -- | Browsers don't directly delete a cookie, but setting its expiry to a past date (e.g. the UNIX epoch) 610 | -- ensures that the cookie will be invalidated 611 | -- (whether and when it will be actually deleted by the browser seems to be browser-dependent). 612 | deleteCookie :: T.Text -- ^ name 613 | -> ActionM () 614 | deleteCookie = Cookie.deleteCookie 615 | -------------------------------------------------------------------------------- /Web/Scotty/Action.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# language ScopedTypeVariables #-} 7 | module Web.Scotty.Action 8 | ( addHeader 9 | , body 10 | , bodyReader 11 | , file 12 | , rawResponse 13 | , files 14 | , filesOpts 15 | , W.ParseRequestBodyOptions, W.defaultParseRequestBodyOptions 16 | , finish 17 | , header 18 | , headers 19 | , html 20 | , htmlLazy 21 | , json 22 | , jsonData 23 | , formData 24 | , next 25 | , pathParam 26 | , captureParam 27 | , formParam 28 | , queryParam 29 | , pathParamMaybe 30 | , captureParamMaybe 31 | , formParamMaybe 32 | , queryParamMaybe 33 | , pathParams 34 | , captureParams 35 | , formParams 36 | , queryParams 37 | , throw 38 | , raw 39 | , nested 40 | , readEither 41 | , redirect 42 | , redirect300 43 | , redirect301 44 | , redirect302 45 | , redirect303 46 | , redirect304 47 | , redirect307 48 | , redirect308 49 | , request 50 | , setHeader 51 | , status 52 | , stream 53 | , text 54 | , textLazy 55 | , getResponseStatus 56 | , getResponseHeaders 57 | , getResponseContent 58 | , Param 59 | , Parsable(..) 60 | , ActionT 61 | -- private to Scotty 62 | , runAction 63 | ) where 64 | 65 | import Blaze.ByteString.Builder (fromLazyByteString) 66 | 67 | import qualified Control.Exception as E 68 | import Control.Monad (when) 69 | import Control.Monad.IO.Class (MonadIO(..)) 70 | import UnliftIO (MonadUnliftIO(..)) 71 | import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks) 72 | import Control.Monad.Trans.Resource (withInternalState, runResourceT) 73 | 74 | import Control.Concurrent.MVar 75 | 76 | import qualified Data.Aeson as A 77 | import Data.Bool (bool) 78 | import qualified Data.ByteString.Char8 as B 79 | import qualified Data.ByteString.Lazy.Char8 as BL 80 | import qualified Data.CaseInsensitive as CI 81 | import Data.Traversable (for) 82 | import qualified Data.HashMap.Strict as HashMap 83 | import Data.Int 84 | import Data.List (foldl') 85 | import Data.Maybe (maybeToList) 86 | import qualified Data.Text as T 87 | import Data.Text.Encoding as STE 88 | import qualified Data.Text.Lazy as TL 89 | import qualified Data.Text.Lazy.Encoding as TLE 90 | import Data.Time (UTCTime) 91 | import Data.Time.Format (parseTimeM, defaultTimeLocale) 92 | import Data.Typeable (typeOf) 93 | import Data.Word 94 | 95 | import Network.HTTP.Types 96 | -- not re-exported until version 0.11 97 | #if !MIN_VERSION_http_types(0,11,0) 98 | import Network.HTTP.Types.Status 99 | #endif 100 | import Network.Wai (Request, Response, StreamingBody, Application, requestHeaders) 101 | import Network.Wai.Handler.Warp (InvalidRequest(..)) 102 | import qualified Network.Wai.Parse as W (FileInfo(..), ParseRequestBodyOptions, defaultParseRequestBodyOptions) 103 | 104 | import Numeric.Natural 105 | 106 | import Web.FormUrlEncoded (Form(..), FromForm(..)) 107 | import Web.Scotty.Internal.Types 108 | import Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, decodeUtf8Lenient) 109 | import UnliftIO.Exception (Handler(..), catches, throwIO) 110 | import System.IO (hPutStrLn, stderr) 111 | 112 | import Network.Wai.Internal (ResponseReceived(..)) 113 | 114 | 115 | -- | Evaluate a route, catch all exceptions (user-defined ones, internal and all remaining, in this order) 116 | -- and construct the 'Response' 117 | -- 118 | -- 'Nothing' indicates route failed (due to Next) and pattern matching should try the next available route. 119 | -- 'Just' indicates a successful response. 120 | runAction :: MonadUnliftIO m => 121 | Options 122 | -> Maybe (ErrorHandler m) -- ^ this handler (if present) is in charge of user-defined exceptions 123 | -> ActionEnv 124 | -> ActionT m () -- ^ Route action to be evaluated 125 | -> m (Maybe Response) 126 | runAction options mh env action = do 127 | ok <- flip runReaderT env $ runAM $ tryNext $ action `catches` concat 128 | [ [actionErrorHandler] 129 | , maybeToList mh 130 | , [scottyExceptionHandler, someExceptionHandler options] 131 | ] 132 | res <- getResponse env 133 | return $ bool Nothing (Just $ mkResponse res) ok 134 | 135 | -- | Exception handler in charge of 'ActionError'. Rethrowing 'Next' here is caught by 'tryNext'. 136 | -- All other cases of 'ActionError' are converted to HTTP responses. 137 | actionErrorHandler :: MonadIO m => ErrorHandler m 138 | actionErrorHandler = Handler $ \case 139 | AERedirect s url -> do 140 | status s 141 | setHeader "Location" url 142 | AENext -> next 143 | AEFinish -> return () 144 | 145 | -- | Default handler for exceptions from scotty 146 | scottyExceptionHandler :: MonadIO m => ErrorHandler m 147 | scottyExceptionHandler = Handler $ \case 148 | RequestTooLarge -> do 149 | status status413 150 | text "Request body is too large" 151 | MalformedJSON bs err -> do 152 | status status400 153 | raw $ BL.unlines 154 | [ "jsonData: malformed" 155 | , "Body: " <> bs 156 | , "Error: " <> BL.fromStrict (encodeUtf8 err) 157 | ] 158 | FailedToParseJSON bs err -> do 159 | status status422 160 | raw $ BL.unlines 161 | [ "jsonData: failed to parse" 162 | , "Body: " <> bs 163 | , "Error: " <> BL.fromStrict (encodeUtf8 err) 164 | ] 165 | MalformedForm err -> do 166 | status status400 167 | raw $ BL.unlines 168 | [ "formData: malformed" 169 | , "Error: " <> BL.fromStrict (encodeUtf8 err) 170 | ] 171 | PathParameterNotFound k -> do 172 | status status500 173 | text $ T.unwords [ "Path parameter", k, "not found"] 174 | QueryParameterNotFound k -> do 175 | status status400 176 | text $ T.unwords [ "Query parameter", k, "not found"] 177 | FormFieldNotFound k -> do 178 | status status400 179 | text $ T.unwords [ "Query parameter", k, "not found"] 180 | FailedToParseParameter k v e -> do 181 | status status400 182 | text $ T.unwords [ "Failed to parse parameter", k, v, ":", e] 183 | WarpRequestException we -> case we of 184 | RequestHeaderFieldsTooLarge -> do 185 | status status413 186 | weo -> do -- FIXME fall-through case on InvalidRequest, it would be nice to return more specific error messages and codes here 187 | status status400 188 | text $ T.unwords ["Request Exception:", T.pack (show weo)] 189 | WaiRequestParseException we -> do 190 | status status413 -- 413 Content Too Large https://developer.mozilla.org/en-US/docs/Web/HTTP/Status/413 191 | text $ T.unwords ["wai-extra Exception:", T.pack (show we)] 192 | ResourceTException rte -> do 193 | status status500 194 | text $ T.unwords ["resourcet Exception:", T.pack (show rte)] 195 | 196 | -- | Uncaught exceptions turn into HTTP 500 Server Error codes 197 | someExceptionHandler :: MonadIO m => Options -> ErrorHandler m 198 | someExceptionHandler Options{verbose} = 199 | Handler $ \(E.SomeException e) -> do 200 | when (verbose > 0) $ 201 | liftIO $ 202 | hPutStrLn stderr $ 203 | "Unhandled exception of " <> show (typeOf e) <> ": " <> show e 204 | status status500 205 | 206 | -- | Throw an exception which can be caught within the scope of the current Action with 'catch'. 207 | -- 208 | -- 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. 209 | -- 210 | -- Uncaught exceptions turn into HTTP 500 responses. 211 | throw :: (MonadIO m, E.Exception e) => e -> ActionT m a 212 | throw = E.throw 213 | 214 | -- | Abort execution of this action and continue pattern matching routes. 215 | -- Like an exception, any code after 'next' is not executed. 216 | -- 217 | -- NB : Internally, this is implemented with an exception that can only be 218 | -- caught by the library, but not by the user. 219 | -- 220 | -- As an example, these two routes overlap. The only way the second one will 221 | -- ever run is if the first one calls 'next'. 222 | -- 223 | -- > get "/foo/:bar" $ do 224 | -- > w :: Text <- pathParam "bar" 225 | -- > unless (w == "special") next 226 | -- > text "You made a request to /foo/special" 227 | -- > 228 | -- > get "/foo/:baz" $ do 229 | -- > w <- pathParam "baz" 230 | -- > text $ "You made a request to: " <> w 231 | next :: Monad m => ActionT m a 232 | next = E.throw AENext 233 | 234 | -- | Synonym for 'redirect302'. 235 | -- If you are unsure which redirect to use, you probably want this one. 236 | -- 237 | -- > redirect "http://www.google.com" 238 | -- 239 | -- OR 240 | -- 241 | -- > redirect "/foo/bar" 242 | redirect :: (Monad m) => T.Text -> ActionT m a 243 | redirect = redirect302 244 | 245 | -- | Redirect to given URL with status 300 (Multiple Choices). Like throwing 246 | -- an uncatchable exception. Any code after the call to 247 | -- redirect will not be run. 248 | redirect300 :: (Monad m) => T.Text -> ActionT m a 249 | redirect300 = redirectStatus status300 250 | 251 | -- | Redirect to given URL with status 301 (Moved Permanently). Like throwing 252 | -- an uncatchable exception. Any code after the call to 253 | -- redirect will not be run. 254 | redirect301 :: (Monad m) => T.Text -> ActionT m a 255 | redirect301 = redirectStatus status301 256 | 257 | -- | Redirect to given URL with status 302 (Found). Like throwing 258 | -- an uncatchable exception. Any code after the call to 259 | -- redirect will not be run. 260 | redirect302 :: (Monad m) => T.Text -> ActionT m a 261 | redirect302 = redirectStatus status302 262 | 263 | -- | Redirect to given URL with status 303 (See Other). Like throwing 264 | -- an uncatchable exception. Any code after the call to 265 | -- redirect will not be run. 266 | redirect303 :: (Monad m) => T.Text -> ActionT m a 267 | redirect303 = redirectStatus status303 268 | 269 | -- | Redirect to given URL with status 304 (Not Modified). Like throwing 270 | -- an uncatchable exception. Any code after the call to 271 | -- redirect will not be run. 272 | redirect304 :: (Monad m) => T.Text -> ActionT m a 273 | redirect304 = redirectStatus status304 274 | 275 | -- | Redirect to given URL with status 307 (Temporary Redirect). Like throwing 276 | -- an uncatchable exception. Any code after the call to 277 | -- redirect will not be run. 278 | redirect307 :: (Monad m) => T.Text -> ActionT m a 279 | redirect307 = redirectStatus status307 280 | 281 | -- | Redirect to given URL with status 308 (Permanent Redirect). Like throwing 282 | -- an uncatchable exception. Any code after the call to 283 | -- redirect will not be run. 284 | redirect308 :: (Monad m) => T.Text -> ActionT m a 285 | redirect308 = redirectStatus status308 286 | 287 | redirectStatus :: (Monad m) => Status -> T.Text -> ActionT m a 288 | redirectStatus s = E.throw . AERedirect s 289 | 290 | -- | Finish the execution of the current action. Like throwing an uncatchable 291 | -- exception. Any code after the call to finish will not be run. 292 | -- 293 | -- /Since: 0.10.3/ 294 | finish :: (Monad m) => ActionT m a 295 | finish = E.throw AEFinish 296 | 297 | -- | Get the 'Request' object. 298 | request :: Monad m => ActionT m Request 299 | request = ActionT $ envReq <$> ask 300 | 301 | -- | Get list of uploaded files. 302 | -- 303 | -- NB: Loads all file contents in memory with options 'W.defaultParseRequestBodyOptions' 304 | files :: MonadUnliftIO m => ActionT m [File BL.ByteString] 305 | files = runResourceT $ withInternalState $ \istate -> do 306 | (_, fs) <- formParamsAndFilesWith istate W.defaultParseRequestBodyOptions 307 | for fs (\(fname, f) -> do 308 | bs <- liftIO $ BL.readFile (W.fileContent f) 309 | pure (fname, f{ W.fileContent = bs}) 310 | ) 311 | 312 | 313 | -- | Get list of uploaded temp files and form parameters decoded from multipart payloads. 314 | -- 315 | -- NB the temp files are deleted when the continuation exits. 316 | filesOpts :: MonadUnliftIO m => 317 | W.ParseRequestBodyOptions 318 | -> ([Param] -> [File FilePath] -> ActionT m a) -- ^ temp files validation, storage etc 319 | -> ActionT m a 320 | filesOpts prbo io = runResourceT $ withInternalState $ \istate -> do 321 | (ps, fs) <- formParamsAndFilesWith istate prbo 322 | io ps fs 323 | 324 | 325 | 326 | -- | Get a request header. Header name is case-insensitive. 327 | header :: (Monad m) => T.Text -> ActionT m (Maybe T.Text) 328 | header k = do 329 | hs <- requestHeaders <$> request 330 | return $ fmap decodeUtf8Lenient $ lookup (CI.mk (encodeUtf8 k)) hs 331 | 332 | -- | Get all the request headers. Header names are case-insensitive. 333 | headers :: (Monad m) => ActionT m [(T.Text, T.Text)] 334 | headers = do 335 | hs <- requestHeaders <$> request 336 | return [ ( decodeUtf8Lenient (CI.original k) 337 | , decodeUtf8Lenient v) 338 | | (k,v) <- hs ] 339 | 340 | -- | Get the request body. 341 | -- 342 | -- NB This loads the whole request body in memory at once. 343 | body :: (MonadIO m) => ActionT m BL.ByteString 344 | body = ActionT ask >>= (liftIO . envBody) 345 | 346 | -- | Get an IO action that reads body chunks 347 | -- 348 | -- * This is incompatible with 'body' since 'body' consumes all chunks. 349 | bodyReader :: Monad m => ActionT m (IO B.ByteString) 350 | bodyReader = ActionT $ envBodyChunk <$> ask 351 | 352 | -- | Parse the request body as a JSON object and return it. 353 | -- 354 | -- If the JSON object is malformed, this sets the status to 355 | -- 400 Bad Request, and throws an exception. 356 | -- 357 | -- If the JSON fails to parse, this sets the status to 358 | -- 422 Unprocessable Entity. 359 | -- 360 | -- These status codes are as per https://www.restapitutorial.com/httpstatuscodes.html. 361 | -- 362 | -- NB : Internally this uses 'body'. 363 | jsonData :: (A.FromJSON a, MonadIO m) => ActionT m a 364 | jsonData = do 365 | b <- body 366 | when (b == "") $ throwIO $ MalformedJSON b "no data" 367 | case A.eitherDecode b of 368 | Left err -> throwIO $ MalformedJSON b $ T.pack err 369 | Right value -> case A.fromJSON value of 370 | A.Error err -> throwIO $ FailedToParseJSON b $ T.pack err 371 | A.Success a -> return a 372 | 373 | -- | Parse the request body as @x-www-form-urlencoded@ form data and return it. 374 | -- 375 | -- The form is parsed using 'urlDecodeAsForm'. If that returns 'Left', the 376 | -- status is set to 400 and an exception is thrown. 377 | formData :: (FromForm a, MonadUnliftIO m) => ActionT m a 378 | formData = do 379 | form <- paramListToForm <$> formParams 380 | case fromForm form of 381 | Left err -> throwIO $ MalformedForm err 382 | Right value -> return value 383 | where 384 | -- This rather contrived implementation uses cons and reverse to avoid 385 | -- quadratic complexity when constructing a Form from a list of Param. 386 | -- It's equivalent to using HashMap.insertWith (++) which does have 387 | -- quadratic complexity due to appending at the end of list. 388 | paramListToForm :: [Param] -> Form 389 | paramListToForm = Form . fmap reverse . foldl' (\f (k, v) -> HashMap.alter (prependValue v) k f) HashMap.empty 390 | 391 | prependValue :: a -> Maybe [a] -> Maybe [a] 392 | prependValue v = Just . maybe [v] (v :) 393 | 394 | -- | Synonym for 'pathParam' 395 | captureParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a 396 | captureParam = pathParam 397 | 398 | -- | Look up a path parameter. 399 | -- 400 | -- * 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. 401 | -- 402 | -- * If the parameter is found, but 'parseParam' fails to parse to the correct type, 'next' is called. 403 | -- 404 | -- /Since: 0.20/ 405 | pathParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a 406 | pathParam k = do 407 | val <- ActionT $ lookup k . envPathParams <$> ask 408 | case val of 409 | Nothing -> throwIO $ PathParameterNotFound k 410 | Just v -> case parseParam $ TL.fromStrict v of 411 | Left _ -> next 412 | Right a -> pure a 413 | 414 | -- | Look up a form parameter. 415 | -- 416 | -- * 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. 417 | -- 418 | -- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type. 419 | -- 420 | -- /Since: 0.20/ 421 | formParam :: (MonadUnliftIO m, Parsable b) => T.Text -> ActionT m b 422 | formParam k = runResourceT $ withInternalState $ \istate -> do 423 | (ps, _) <- formParamsAndFilesWith istate W.defaultParseRequestBodyOptions 424 | case lookup k ps of 425 | Nothing -> throwIO $ FormFieldNotFound k 426 | Just v -> case parseParam $ TL.fromStrict v of 427 | Left e -> throwIO $ FailedToParseParameter k v (TL.toStrict e) 428 | Right a -> pure a 429 | 430 | -- | Look up a query parameter. 431 | -- 432 | -- * 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. 433 | -- 434 | -- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type. 435 | -- 436 | -- /Since: 0.20/ 437 | queryParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a 438 | queryParam = paramWith QueryParameterNotFound envQueryParams 439 | 440 | -- | Look up a path parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. 441 | -- 442 | -- NB : Doesn't throw exceptions. In particular, route pattern matching will not continue, so developers 443 | -- must 'raiseStatus' or 'throw' to signal something went wrong. 444 | -- 445 | -- /Since: 0.21/ 446 | pathParamMaybe :: (Parsable a, Monad m) => T.Text -> ActionT m (Maybe a) 447 | pathParamMaybe = paramWithMaybe envPathParams 448 | 449 | -- | Look up a capture parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. 450 | -- 451 | -- NB : Doesn't throw exceptions. In particular, route pattern matching will not continue, so developers 452 | -- must 'raiseStatus' or 'throw' to signal something went wrong. 453 | -- 454 | -- /Since: 0.21/ 455 | captureParamMaybe :: (Parsable a, Monad m) => T.Text -> ActionT m (Maybe a) 456 | captureParamMaybe = paramWithMaybe envPathParams 457 | 458 | -- | Look up a form parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. 459 | -- 460 | -- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong. 461 | -- 462 | -- /Since: 0.21/ 463 | formParamMaybe :: (MonadUnliftIO m, Parsable a) => 464 | T.Text -> ActionT m (Maybe a) 465 | formParamMaybe k = runResourceT $ withInternalState $ \istate -> do 466 | (ps, _) <- formParamsAndFilesWith istate W.defaultParseRequestBodyOptions 467 | case lookup k ps of 468 | Nothing -> pure Nothing 469 | Just v -> either (const $ pure Nothing) (pure . Just) $ parseParam $ TL.fromStrict v 470 | 471 | 472 | -- | Look up a query parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. 473 | -- 474 | -- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong. 475 | -- 476 | -- /Since: 0.21/ 477 | queryParamMaybe :: (Parsable a, Monad m) => T.Text -> ActionT m (Maybe a) 478 | queryParamMaybe = paramWithMaybe envQueryParams 479 | 480 | data ParamType = PathParam 481 | | FormParam 482 | | QueryParam 483 | instance Show ParamType where 484 | show = \case 485 | PathParam -> "path" 486 | FormParam -> "form" 487 | QueryParam -> "query" 488 | 489 | paramWith :: (MonadIO m, Parsable b) => 490 | (T.Text -> ScottyException) 491 | -> (ActionEnv -> [Param]) 492 | -> T.Text -- ^ parameter name 493 | -> ActionT m b 494 | paramWith toError f k = do 495 | val <- ActionT $ (lookup k . f) <$> ask 496 | case val of 497 | Nothing -> throwIO $ toError k 498 | Just v -> case parseParam $ TL.fromStrict v of 499 | Left e -> throwIO $ FailedToParseParameter k v (TL.toStrict e) 500 | Right a -> pure a 501 | 502 | -- | Look up a parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. 503 | -- 504 | -- NB : Doesn't throw exceptions. 505 | -- 506 | -- /Since: 0.21/ 507 | paramWithMaybe :: (Monad m, Parsable b) => 508 | (ActionEnv -> [Param]) 509 | -> T.Text -- ^ parameter name 510 | -> ActionT m (Maybe b) 511 | paramWithMaybe f k = do 512 | val <- ActionT $ asks (lookup k . f) 513 | case val of 514 | Nothing -> pure Nothing 515 | Just v -> either (const $ pure Nothing) (pure . Just) $ parseParam $ TL.fromStrict v 516 | 517 | -- | Get path parameters 518 | pathParams :: Monad m => ActionT m [Param] 519 | pathParams = paramsWith envPathParams 520 | 521 | -- | Get path parameters 522 | captureParams :: Monad m => ActionT m [Param] 523 | captureParams = paramsWith envPathParams 524 | 525 | -- | Get form parameters 526 | formParams :: MonadUnliftIO m => ActionT m [Param] 527 | formParams = runResourceT $ withInternalState $ \istate -> do 528 | fst <$> formParamsAndFilesWith istate W.defaultParseRequestBodyOptions 529 | 530 | -- | Get query parameters 531 | queryParams :: Monad m => ActionT m [Param] 532 | queryParams = paramsWith envQueryParams 533 | 534 | paramsWith :: Monad m => (ActionEnv -> a) -> ActionT m a 535 | paramsWith f = ActionT (asks f) 536 | 537 | -- === access the fields of the Response being constructed 538 | 539 | -- | Access the HTTP 'Status' of the Response 540 | -- 541 | -- /SINCE 0.21/ 542 | getResponseStatus :: (MonadIO m) => ActionT m Status 543 | getResponseStatus = srStatus <$> getResponseAction 544 | -- | Access the HTTP headers of the Response 545 | -- 546 | -- /SINCE 0.21/ 547 | getResponseHeaders :: (MonadIO m) => ActionT m ResponseHeaders 548 | getResponseHeaders = srHeaders <$> getResponseAction 549 | -- | Access the content of the Response 550 | -- 551 | -- /SINCE 0.21/ 552 | getResponseContent :: (MonadIO m) => ActionT m Content 553 | getResponseContent = srContent <$> getResponseAction 554 | 555 | 556 | -- | Minimum implemention: 'parseParam' 557 | class Parsable a where 558 | -- | Take a 'T.Text' value and parse it as 'a', or fail with a message. 559 | parseParam :: TL.Text -> Either TL.Text a 560 | 561 | -- | Default implementation parses comma-delimited lists. 562 | -- 563 | -- > parseParamList t = mapM parseParam (T.split (== ',') t) 564 | parseParamList :: TL.Text -> Either TL.Text [a] 565 | parseParamList t = mapM parseParam (TL.split (== ',') t) 566 | 567 | -- No point using 'read' for Text, ByteString, Char, and String. 568 | instance Parsable T.Text where parseParam = Right . TL.toStrict 569 | instance Parsable TL.Text where parseParam = Right 570 | instance Parsable B.ByteString where parseParam = Right . lazyTextToStrictByteString 571 | instance Parsable BL.ByteString where parseParam = Right . TLE.encodeUtf8 572 | -- | Overrides default 'parseParamList' to parse String. 573 | instance Parsable Char where 574 | parseParam t = case TL.unpack t of 575 | [c] -> Right c 576 | _ -> Left "parseParam Char: no parse" 577 | parseParamList = Right . TL.unpack -- String 578 | -- | Checks if parameter is present and is null-valued, not a literal '()'. 579 | -- If the URI requested is: '/foo?bar=()&baz' then 'baz' will parse as (), where 'bar' will not. 580 | instance Parsable () where 581 | parseParam t = if TL.null t then Right () else Left "parseParam Unit: no parse" 582 | 583 | instance (Parsable a) => Parsable [a] where parseParam = parseParamList 584 | 585 | instance Parsable Bool where 586 | parseParam t = if t' == TL.toCaseFold "true" 587 | then Right True 588 | else if t' == TL.toCaseFold "false" 589 | then Right False 590 | else Left "parseParam Bool: no parse" 591 | where t' = TL.toCaseFold t 592 | 593 | instance Parsable Double where parseParam = readEither 594 | instance Parsable Float where parseParam = readEither 595 | 596 | instance Parsable Int where parseParam = readEither 597 | instance Parsable Int8 where parseParam = readEither 598 | instance Parsable Int16 where parseParam = readEither 599 | instance Parsable Int32 where parseParam = readEither 600 | instance Parsable Int64 where parseParam = readEither 601 | instance Parsable Integer where parseParam = readEither 602 | 603 | instance Parsable Word where parseParam = readEither 604 | instance Parsable Word8 where parseParam = readEither 605 | instance Parsable Word16 where parseParam = readEither 606 | instance Parsable Word32 where parseParam = readEither 607 | instance Parsable Word64 where parseParam = readEither 608 | instance Parsable Natural where parseParam = readEither 609 | 610 | -- | parse a UTCTime timestamp formatted as a ISO 8601 timestamp: 611 | -- 612 | -- @yyyy-mm-ddThh:mm:ssZ@ , where the seconds can have a decimal part with up to 12 digits and no trailing zeros. 613 | instance Parsable UTCTime where 614 | parseParam t = 615 | let 616 | fmt = "%FT%T%QZ" 617 | in 618 | case parseTimeM True defaultTimeLocale fmt (TL.unpack t) of 619 | Just d -> Right d 620 | _ -> Left $ "parseParam UTCTime: no parse of \"" <> t <> "\"" 621 | 622 | -- | Useful for creating 'Parsable' instances for things that already implement 'Read'. Ex: 623 | -- 624 | -- > instance Parsable Int where parseParam = readEither 625 | readEither :: Read a => TL.Text -> Either TL.Text a 626 | readEither t = case [ x | (x,"") <- reads (TL.unpack t) ] of 627 | [x] -> Right x 628 | [] -> Left "readEither: no parse" 629 | _ -> Left "readEither: ambiguous parse" 630 | 631 | -- | Set the HTTP response status. 632 | status :: MonadIO m => Status -> ActionT m () 633 | status = modifyResponse . setStatus 634 | 635 | -- Not exported, but useful in the functions below. 636 | changeHeader :: MonadIO m 637 | => (CI.CI B.ByteString -> B.ByteString -> [(HeaderName, B.ByteString)] -> [(HeaderName, B.ByteString)]) 638 | -> T.Text -> T.Text -> ActionT m () 639 | changeHeader f k = 640 | modifyResponse . setHeaderWith . f (CI.mk $ encodeUtf8 k) . encodeUtf8 641 | 642 | -- | Add to the response headers. Header names are case-insensitive. 643 | addHeader :: MonadIO m => T.Text -> T.Text -> ActionT m () 644 | addHeader = changeHeader add 645 | 646 | -- | Set one of the response headers. Will override any previously set value for that header. 647 | -- Header names are case-insensitive. 648 | setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m () 649 | setHeader = changeHeader replace 650 | 651 | -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" 652 | -- header to \"text/plain; charset=utf-8\" if it has not already been set. 653 | text :: (MonadIO m) => T.Text -> ActionT m () 654 | text t = do 655 | changeHeader addIfNotPresent "Content-Type" "text/plain; charset=utf-8" 656 | raw $ BL.fromStrict $ encodeUtf8 t 657 | 658 | -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" 659 | -- header to \"text/plain; charset=utf-8\" if it has not already been set. 660 | textLazy :: (MonadIO m) => TL.Text -> ActionT m () 661 | textLazy t = do 662 | changeHeader addIfNotPresent "Content-Type" "text/plain; charset=utf-8" 663 | raw $ TLE.encodeUtf8 t 664 | 665 | -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" 666 | -- header to \"text/html; charset=utf-8\" if it has not already been set. 667 | html :: (MonadIO m) => T.Text -> ActionT m () 668 | html t = do 669 | changeHeader addIfNotPresent "Content-Type" "text/html; charset=utf-8" 670 | raw $ BL.fromStrict $ encodeUtf8 t 671 | 672 | -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" 673 | -- header to \"text/html; charset=utf-8\" if it has not already been set. 674 | htmlLazy :: (MonadIO m) => TL.Text -> ActionT m () 675 | htmlLazy t = do 676 | changeHeader addIfNotPresent "Content-Type" "text/html; charset=utf-8" 677 | raw $ TLE.encodeUtf8 t 678 | 679 | -- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably 680 | -- want to do that on your own with 'setHeader'. Setting a status code will have no effect 681 | -- because Warp will overwrite that to 200 (see 'Network.Wai.Handler.Warp.Internal.sendResponse'). 682 | file :: MonadIO m => FilePath -> ActionT m () 683 | file = modifyResponse . setContent . ContentFile 684 | 685 | rawResponse :: MonadIO m => Response -> ActionT m () 686 | rawResponse = modifyResponse . setContent . ContentResponse 687 | 688 | -- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\" 689 | -- header to \"application/json; charset=utf-8\" if it has not already been set. 690 | json :: (A.ToJSON a, MonadIO m) => a -> ActionT m () 691 | json v = do 692 | changeHeader addIfNotPresent "Content-Type" "application/json; charset=utf-8" 693 | raw $ A.encode v 694 | 695 | -- | Set the body of the response to a Source. Doesn't set the 696 | -- \"Content-Type\" header, so you probably want to do that on your 697 | -- own with 'setHeader'. 698 | stream :: MonadIO m => StreamingBody -> ActionT m () 699 | stream = modifyResponse . setContent . ContentStream 700 | 701 | -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the 702 | -- \"Content-Type\" header, so you probably want to do that on your 703 | -- own with 'setHeader'. 704 | raw :: MonadIO m => BL.ByteString -> ActionT m () 705 | raw = modifyResponse . setContent . ContentBuilder . fromLazyByteString 706 | 707 | -- | Nest a whole WAI application inside a Scotty handler. 708 | -- See Web.Scotty for further documentation 709 | nested :: (MonadIO m) => Network.Wai.Application -> ActionT m () 710 | nested app = do 711 | -- Is MVar really the best choice here? Not sure. 712 | r <- request 713 | ref <- liftIO $ newEmptyMVar 714 | _ <- liftIO $ app r (\res -> putMVar ref res >> return ResponseReceived) 715 | res <- liftIO $ readMVar ref 716 | rawResponse res 717 | -------------------------------------------------------------------------------- /Web/Scotty/Body.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE MultiWayIf #-} 3 | {-# language OverloadedStrings #-} 4 | {-# language ScopedTypeVariables #-} 5 | module Web.Scotty.Body ( 6 | newBodyInfo, 7 | cloneBodyInfo 8 | 9 | , getFormParamsAndFilesAction 10 | , getBodyAction 11 | , getBodyChunkAction 12 | -- wai-extra 13 | , W.RequestParseException(..) 14 | ) where 15 | 16 | import Control.Concurrent.MVar 17 | import Control.Monad.IO.Class 18 | import Control.Monad.Trans.Resource (InternalState) 19 | import Data.Bifunctor (first, bimap) 20 | import qualified Data.ByteString as BS 21 | import qualified Data.ByteString.Char8 as B 22 | import qualified Data.ByteString.Lazy.Char8 as BL 23 | import qualified GHC.Exception as E (throw) 24 | import Network.Wai (Request(..), getRequestBodyChunk) 25 | import qualified Network.Wai.Handler.Warp as Warp (InvalidRequest(..)) 26 | import qualified Network.Wai.Parse as W (File, Param, getRequestBodyType, tempFileBackEnd, RequestBodyType(..), sinkRequestBodyEx, RequestParseException(..), ParseRequestBodyOptions) 27 | -- import UnliftIO (MonadUnliftIO(..)) 28 | import UnliftIO.Exception (Handler(..), catches, throwIO) 29 | 30 | import Web.Scotty.Internal.Types (BodyInfo(..), BodyChunkBuffer(..), BodyPartiallyStreamed(..), RouteOptions(..), File, ScottyException(..), Param) 31 | import Web.Scotty.Util (readRequestBody, decodeUtf8Lenient) 32 | 33 | 34 | -- | Make a new BodyInfo with readProgress at 0 and an empty BodyChunkBuffer. 35 | newBodyInfo :: (MonadIO m) => Request -> m BodyInfo 36 | newBodyInfo req = liftIO $ do 37 | readProgress <- newMVar 0 38 | chunkBuffer <- newMVar (BodyChunkBuffer False []) 39 | return $ BodyInfo readProgress chunkBuffer (getRequestBodyChunk req) 40 | 41 | -- | Make a copy of a BodyInfo, sharing the previous BodyChunkBuffer but with the 42 | -- readProgress MVar reset to 0. 43 | cloneBodyInfo :: (MonadIO m) => BodyInfo -> m BodyInfo 44 | cloneBodyInfo (BodyInfo _ chunkBufferVar getChunk) = liftIO $ do 45 | cleanReadProgressVar <- newMVar 0 46 | return $ BodyInfo cleanReadProgressVar chunkBufferVar getChunk 47 | 48 | -- | Get the form params and files from the request. 49 | -- 50 | -- NB : catches exceptions from 'warp' and 'wai-extra' and wraps them into 'ScottyException' 51 | getFormParamsAndFilesAction :: 52 | InternalState 53 | -> W.ParseRequestBodyOptions 54 | -> Request -- ^ only used for its body type 55 | -> BodyInfo -- ^ the request body contents are read from here 56 | -> RouteOptions 57 | -> IO ([Param], [File FilePath]) 58 | getFormParamsAndFilesAction istate prbo req bodyInfo opts = do 59 | let 60 | bs2t = decodeUtf8Lenient 61 | convertBoth = bimap bs2t bs2t 62 | convertKey = first bs2t 63 | bs <- getBodyAction bodyInfo opts 64 | let 65 | wholeBody = BL.toChunks bs 66 | (formparams, fs) <- parseRequestBodyExBS istate prbo wholeBody (W.getRequestBodyType req) `catches` handleWaiParseSafeExceptions 67 | return (convertBoth <$> formparams, convertKey <$> fs) 68 | 69 | -- | Wrap exceptions from upstream libraries into 'ScottyException' 70 | handleWaiParseSafeExceptions :: MonadIO m => [Handler m a] 71 | handleWaiParseSafeExceptions = [h1, h2] 72 | where 73 | h1 = Handler (\ (e :: W.RequestParseException ) -> throwIO $ WaiRequestParseException e) 74 | h2 = Handler (\(e :: Warp.InvalidRequest) -> throwIO $ WarpRequestException e) 75 | 76 | -- | Adapted from wai-extra's Network.Wai.Parse, modified to accept body as list of Bytestrings. 77 | -- Reason: WAI's requestBody is an IO action that returns the body as chunks. Once read, 78 | -- they can't be read again. We read them into a lazy Bytestring, so Scotty user can get 79 | -- the raw body, even if they also want to call wai-extra's parsing routines. 80 | parseRequestBodyExBS :: MonadIO m => 81 | InternalState 82 | -> W.ParseRequestBodyOptions 83 | -> [B.ByteString] 84 | -> Maybe W.RequestBodyType 85 | -> m ([W.Param], [W.File FilePath]) 86 | parseRequestBodyExBS istate o bl rty = 87 | case rty of 88 | Nothing -> return ([], []) 89 | Just rbt -> do 90 | mvar <- liftIO $ newMVar bl -- MVar is a bit of a hack so we don't have to inline 91 | -- large portions of Network.Wai.Parse 92 | let provider = modifyMVar mvar $ \bsold -> case bsold of 93 | [] -> return ([], B.empty) 94 | (b:bs) -> return (bs, b) 95 | liftIO $ W.sinkRequestBodyEx o (W.tempFileBackEnd istate) rbt provider 96 | 97 | 98 | -- | Retrieve the entire body, using the cached chunks in the BodyInfo and reading any other 99 | -- chunks if they still exist. 100 | -- Mimic the previous behavior by throwing 'BodyPartiallyStreamed' if the user has already 101 | -- started reading the body by chunks. 102 | -- 103 | -- throw 'ScottyException' if request body too big 104 | getBodyAction :: BodyInfo -> RouteOptions -> IO (BL.ByteString) 105 | getBodyAction (BodyInfo readProgress chunkBufferVar getChunk) opts = 106 | modifyMVar readProgress $ \index -> 107 | modifyMVar chunkBufferVar $ \bcb@(BodyChunkBuffer hasFinished chunks) -> do 108 | if | index > 0 -> E.throw BodyPartiallyStreamed 109 | | hasFinished -> return (bcb, (index, BL.fromChunks chunks)) 110 | | otherwise -> do 111 | newChunks <- readRequestBody getChunk return (maxRequestBodySize opts) 112 | return $ (BodyChunkBuffer True (chunks ++ newChunks), (index, BL.fromChunks (chunks ++ newChunks))) 113 | 114 | -- | Retrieve a chunk from the body at the index stored in the readProgress MVar. 115 | -- Serve the chunk from the cached array if it's already present; otherwise read another 116 | -- chunk from WAI and advance the index. 117 | getBodyChunkAction :: BodyInfo -> IO BS.ByteString 118 | getBodyChunkAction (BodyInfo readProgress chunkBufferVar getChunk) = 119 | modifyMVar readProgress $ \index -> 120 | modifyMVar chunkBufferVar $ \bcb@(BodyChunkBuffer hasFinished chunks) -> do 121 | if | index < length chunks -> return (bcb, (index + 1, chunks !! index)) 122 | | hasFinished -> return (bcb, (index, mempty)) 123 | | otherwise -> do 124 | newChunk <- getChunk 125 | return (BodyChunkBuffer (B.null newChunk) (chunks ++ [newChunk]), (index + 1, newChunk)) 126 | 127 | -------------------------------------------------------------------------------- /Web/Scotty/Cookie.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Web.Scotty.Cookie 3 | Copyright : (c) 2014, 2015 Mārtiņš Mačs, 4 | (c) 2023 Marco Zocca 5 | 6 | License : BSD-3-Clause 7 | Maintainer : 8 | Stability : experimental 9 | Portability : GHC 10 | 11 | This module provides utilities for adding cookie support inside @scotty@ applications. Most code has been adapted from 'scotty-cookie'. 12 | 13 | == Example 14 | 15 | A simple hit counter that stores the number of page visits in a cookie: 16 | 17 | @ 18 | \{\-\# LANGUAGE OverloadedStrings \#\-\} 19 | 20 | import Control.Monad 21 | import Data.Monoid 22 | import Data.Maybe 23 | import qualified Data.Text.Lazy as TL 24 | import qualified Data.Text.Lazy.Read as TL (decimal) 25 | import Web.Scotty (scotty, html, get) 26 | import Web.Scotty.Cookie (getCookie, setSimpleCookie) 27 | 28 | main :: IO () 29 | main = scotty 3000 $ 30 | get \"/\" $ do 31 | hits <- liftM (fromMaybe \"0\") $ 'getCookie' \"hits\" 32 | let hits' = 33 | case TL.decimal $ TL.fromStrict hits of 34 | Right n -> TL.pack . show . (+1) $ (fst n :: Integer) 35 | Left _ -> \"1\" 36 | 'setSimpleCookie' \"hits\" $ TL.toStrict hits' 37 | html $ mconcat [ \"\\\" 38 | , hits' 39 | , \"\<\/body\>\<\/html\>\" 40 | ] 41 | @ 42 | -} 43 | {-# LANGUAGE OverloadedStrings #-} 44 | module Web.Scotty.Cookie ( 45 | -- * Set cookie 46 | setCookie 47 | , setSimpleCookie 48 | -- * Get cookie(s) 49 | , getCookie 50 | , getCookies 51 | -- * Delete a cookie 52 | , deleteCookie 53 | -- * Helpers and advanced interface (re-exported from 'cookie') 54 | , CookiesText 55 | , makeSimpleCookie 56 | -- ** cookie configuration 57 | , SetCookie 58 | , defaultSetCookie 59 | , setCookieName 60 | , setCookieValue 61 | , setCookiePath 62 | , setCookieExpires 63 | , setCookieMaxAge 64 | , setCookieDomain 65 | , setCookieHttpOnly 66 | , setCookieSecure 67 | , setCookieSameSite 68 | , SameSiteOption 69 | , sameSiteNone 70 | , sameSiteLax 71 | , sameSiteStrict 72 | ) where 73 | 74 | import Control.Monad.IO.Class (MonadIO(..)) 75 | 76 | -- bytestring 77 | import Data.ByteString.Builder (toLazyByteString) 78 | import qualified Data.ByteString.Lazy as BSL (toStrict) 79 | -- cookie 80 | import Web.Cookie (SetCookie, setCookieName , setCookieValue, setCookiePath, setCookieExpires, setCookieMaxAge, setCookieDomain, setCookieHttpOnly, setCookieSecure, setCookieSameSite, renderSetCookie, defaultSetCookie, CookiesText, parseCookiesText, SameSiteOption, sameSiteStrict, sameSiteNone, sameSiteLax) 81 | -- scotty 82 | import Web.Scotty.Action (ActionT, addHeader, header) 83 | -- time 84 | import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) 85 | -- text 86 | import Data.Text (Text) 87 | import qualified Data.Text.Encoding as T (encodeUtf8) 88 | import Web.Scotty.Util (decodeUtf8Lenient) 89 | 90 | -- | Set a cookie, with full access to its options (see 'SetCookie') 91 | setCookie :: (MonadIO m) 92 | => SetCookie 93 | -> ActionT m () 94 | setCookie c = addHeader "Set-Cookie" 95 | $ decodeUtf8Lenient 96 | $ BSL.toStrict 97 | $ toLazyByteString 98 | $ renderSetCookie c 99 | 100 | 101 | -- | 'makeSimpleCookie' and 'setCookie' combined. 102 | setSimpleCookie :: (MonadIO m) 103 | => Text -- ^ name 104 | -> Text -- ^ value 105 | -> ActionT m () 106 | setSimpleCookie n v = setCookie $ makeSimpleCookie n v 107 | 108 | -- | Lookup one cookie name 109 | getCookie :: (Monad m) 110 | => Text -- ^ name 111 | -> ActionT m (Maybe Text) 112 | getCookie c = lookup c <$> getCookies 113 | 114 | 115 | -- | Returns all cookies 116 | getCookies :: (Monad m) 117 | => ActionT m CookiesText 118 | getCookies = (maybe [] parse) <$> header "Cookie" 119 | where parse = parseCookiesText . T.encodeUtf8 120 | 121 | -- | 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). 122 | deleteCookie :: (MonadIO m) 123 | => Text -- ^ name 124 | -> ActionT m () 125 | deleteCookie c = setCookie $ (makeSimpleCookie c "") { setCookieExpires = Just $ posixSecondsToUTCTime 0 } 126 | 127 | 128 | -- | Construct a simple cookie (an UTF-8 string pair with default cookie options) 129 | makeSimpleCookie :: Text -- ^ name 130 | -> Text -- ^ value 131 | -> SetCookie 132 | makeSimpleCookie n v = defaultSetCookie { setCookieName = T.encodeUtf8 n 133 | , setCookieValue = T.encodeUtf8 v 134 | } 135 | 136 | -------------------------------------------------------------------------------- /Web/Scotty/Internal/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# language ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | {-# LANGUAGE RecordWildCards #-} 10 | {-# LANGUAGE LambdaCase #-} 11 | module Web.Scotty.Internal.Types where 12 | 13 | import Blaze.ByteString.Builder (Builder) 14 | 15 | import Control.Applicative 16 | import Control.Concurrent.MVar 17 | import Control.Concurrent.STM (TVar, atomically, readTVarIO, modifyTVar') 18 | import qualified Control.Exception as E 19 | import Control.Monad (MonadPlus(..)) 20 | import Control.Monad.Base (MonadBase) 21 | import Control.Monad.Catch (MonadCatch, MonadThrow) 22 | import Control.Monad.IO.Class (MonadIO(..)) 23 | import UnliftIO (MonadUnliftIO(..)) 24 | import Control.Monad.Reader (MonadReader(..), ReaderT, asks, mapReaderT) 25 | import Control.Monad.State.Strict (State) 26 | import Control.Monad.Trans.Class (MonadTrans(..)) 27 | import Control.Monad.Trans.Control (MonadBaseControl, MonadTransControl) 28 | import qualified Control.Monad.Trans.Resource as RT (InternalState, InvalidAccess) 29 | 30 | import qualified Data.ByteString as BS 31 | import qualified Data.ByteString.Lazy.Char8 as LBS8 (ByteString) 32 | import Data.String (IsString(..)) 33 | import qualified Data.Text as T (Text, pack) 34 | import Data.Typeable (Typeable) 35 | import GHC.Stack (callStack) 36 | import Network.HTTP.Types 37 | 38 | import Network.Wai hiding (Middleware, Application) 39 | import qualified Network.Wai as Wai 40 | import qualified Network.Wai.Handler.Warp as W (Settings, defaultSettings, InvalidRequest(..)) 41 | import Network.Wai.Parse (FileInfo) 42 | import qualified Network.Wai.Parse as WPS (ParseRequestBodyOptions, RequestParseException(..)) 43 | 44 | import UnliftIO.Exception (Handler(..), catch, catches, StringException(..)) 45 | 46 | 47 | 48 | 49 | --------------------- Options ----------------------- 50 | data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner 51 | , settings :: W.Settings -- ^ Warp 'Settings' 52 | -- Note: to work around an issue in warp, 53 | -- the default FD cache duration is set to 0 54 | -- so changes to static files are always picked 55 | -- up. This likely has performance implications, 56 | -- so you may want to modify this for production 57 | -- servers using `setFdCacheDuration`. 58 | } 59 | 60 | defaultOptions :: Options 61 | defaultOptions = Options 1 W.defaultSettings 62 | 63 | newtype RouteOptions = RouteOptions { maxRequestBodySize :: Maybe Kilobytes -- max allowed request size in KB 64 | } 65 | 66 | defaultRouteOptions :: RouteOptions 67 | defaultRouteOptions = RouteOptions Nothing 68 | 69 | type Kilobytes = Int 70 | ----- Transformer Aware Applications/Middleware ----- 71 | type Middleware m = Application m -> Application m 72 | type Application m = Request -> m Response 73 | 74 | ------------------ Scotty Request Body -------------------- 75 | 76 | data BodyChunkBuffer = BodyChunkBuffer { hasFinishedReadingChunks :: Bool -- ^ whether we've reached the end of the stream yet 77 | , chunksReadSoFar :: [BS.ByteString] 78 | } 79 | -- | 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. 80 | -- 81 | -- Introduced in (#308) 82 | data BodyInfo = BodyInfo { bodyInfoReadProgress :: MVar Int -- ^ index into the stream read so far 83 | , bodyInfoChunkBuffer :: MVar BodyChunkBuffer 84 | , bodyInfoDirectChunkRead :: IO BS.ByteString -- ^ can be called to get more chunks 85 | } 86 | 87 | --------------- Scotty Applications ----------------- 88 | 89 | data ScottyState m = 90 | ScottyState { middlewares :: [Wai.Middleware] 91 | , routes :: [BodyInfo -> Middleware m] 92 | , handler :: Maybe (ErrorHandler m) 93 | , routeOptions :: RouteOptions 94 | } 95 | 96 | defaultScottyState :: ScottyState m 97 | defaultScottyState = ScottyState [] [] Nothing defaultRouteOptions 98 | 99 | addMiddleware :: Wai.Middleware -> ScottyState m -> ScottyState m 100 | addMiddleware m s@(ScottyState {middlewares = ms}) = s { middlewares = m:ms } 101 | 102 | addRoute :: (BodyInfo -> Middleware m) -> ScottyState m -> ScottyState m 103 | addRoute r s@(ScottyState {routes = rs}) = s { routes = r:rs } 104 | 105 | setHandler :: Maybe (ErrorHandler m) -> ScottyState m -> ScottyState m 106 | setHandler h s = s { handler = h } 107 | 108 | updateMaxRequestBodySize :: RouteOptions -> ScottyState m -> ScottyState m 109 | updateMaxRequestBodySize RouteOptions { .. } s@ScottyState { routeOptions = ro } = 110 | let ro' = ro { maxRequestBodySize = maxRequestBodySize } 111 | in s { routeOptions = ro' } 112 | 113 | newtype ScottyT m a = 114 | ScottyT { runS :: ReaderT Options (State (ScottyState m)) a } 115 | deriving ( Functor, Applicative, Monad ) 116 | 117 | 118 | ------------------ Scotty Errors -------------------- 119 | 120 | -- | Internal exception mechanism used to modify the request processing flow. 121 | -- 122 | -- The exception constructor is not exposed to the user and all exceptions of this type are caught 123 | -- and processed within the 'runAction' function. 124 | data ActionError 125 | = AERedirect Status T.Text -- ^ Redirect 126 | | AENext -- ^ Stop processing this route and skip to the next one 127 | | AEFinish -- ^ Stop processing the request 128 | deriving (Show, Typeable) 129 | instance E.Exception ActionError 130 | 131 | tryNext :: MonadUnliftIO m => m a -> m Bool 132 | tryNext io = catch (io >> pure True) $ 133 | \case 134 | AENext -> pure False 135 | _ -> pure True 136 | 137 | -- | Specializes a 'Handler' to the 'ActionT' monad 138 | type ErrorHandler m = Handler (ActionT m) () 139 | 140 | -- | Thrown e.g. when a request is too large 141 | data ScottyException 142 | = RequestTooLarge 143 | | MalformedJSON LBS8.ByteString T.Text 144 | | FailedToParseJSON LBS8.ByteString T.Text 145 | | MalformedForm T.Text 146 | | PathParameterNotFound T.Text 147 | | QueryParameterNotFound T.Text 148 | | FormFieldNotFound T.Text 149 | | FailedToParseParameter T.Text T.Text T.Text 150 | | WarpRequestException W.InvalidRequest 151 | | WaiRequestParseException WPS.RequestParseException -- request parsing 152 | | ResourceTException RT.InvalidAccess -- use after free 153 | deriving (Show, Typeable) 154 | instance E.Exception ScottyException 155 | 156 | ------------------ Scotty Actions ------------------- 157 | type Param = (T.Text, T.Text) 158 | 159 | -- | Type parameter @t@ is the file content. Could be @()@ when not needed or a @FilePath@ for temp files instead. 160 | type File t = (T.Text, FileInfo t) 161 | 162 | data ActionEnv = Env { envReq :: Request 163 | , envPathParams :: [Param] 164 | , envQueryParams :: [Param] 165 | , envFormDataAction :: RT.InternalState -> WPS.ParseRequestBodyOptions -> IO ([Param], [File FilePath]) 166 | , envBody :: IO LBS8.ByteString 167 | , envBodyChunk :: IO BS.ByteString 168 | , envResponse :: TVar ScottyResponse 169 | } 170 | 171 | 172 | 173 | 174 | formParamsAndFilesWith :: MonadUnliftIO m => 175 | RT.InternalState 176 | -> WPS.ParseRequestBodyOptions 177 | -> ActionT m ([Param], [File FilePath]) 178 | formParamsAndFilesWith istate prbo = action `catch` (\(e :: RT.InvalidAccess) -> E.throw $ ResourceTException e) 179 | where 180 | action = do 181 | act <- ActionT $ asks envFormDataAction 182 | liftIO $ act istate prbo 183 | 184 | getResponse :: MonadIO m => ActionEnv -> m ScottyResponse 185 | getResponse ae = liftIO $ readTVarIO (envResponse ae) 186 | 187 | getResponseAction :: (MonadIO m) => ActionT m ScottyResponse 188 | getResponseAction = do 189 | ae <- ActionT ask 190 | getResponse ae 191 | 192 | modifyResponse :: (MonadIO m) => (ScottyResponse -> ScottyResponse) -> ActionT m () 193 | modifyResponse f = do 194 | tv <- ActionT $ asks envResponse 195 | liftIO $ atomically $ modifyTVar' tv f 196 | 197 | data BodyPartiallyStreamed = BodyPartiallyStreamed deriving (Show, Typeable) 198 | 199 | instance E.Exception BodyPartiallyStreamed 200 | 201 | data Content = ContentBuilder Builder 202 | | ContentFile FilePath 203 | | ContentStream StreamingBody 204 | | ContentResponse Response 205 | 206 | data ScottyResponse = SR { srStatus :: Status 207 | , srHeaders :: ResponseHeaders 208 | , srContent :: Content 209 | } 210 | 211 | setContent :: Content -> ScottyResponse -> ScottyResponse 212 | setContent c sr = sr { srContent = c } 213 | 214 | setHeaderWith :: ([(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)]) -> ScottyResponse -> ScottyResponse 215 | setHeaderWith f sr = sr { srHeaders = f (srHeaders sr) } 216 | 217 | setStatus :: Status -> ScottyResponse -> ScottyResponse 218 | setStatus s sr = sr { srStatus = s } 219 | 220 | 221 | -- | The default response has code 200 OK and empty body 222 | defaultScottyResponse :: ScottyResponse 223 | defaultScottyResponse = SR status200 [] (ContentBuilder mempty) 224 | 225 | 226 | newtype ActionT m a = ActionT { runAM :: ReaderT ActionEnv m a } 227 | deriving newtype (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadThrow, MonadCatch, MonadBase b, MonadBaseControl b, MonadTransControl, MonadUnliftIO) 228 | 229 | withActionEnv :: Monad m => 230 | (ActionEnv -> ActionEnv) -> ActionT m a -> ActionT m a 231 | withActionEnv f (ActionT r) = ActionT $ local f r 232 | 233 | instance MonadReader r m => MonadReader r (ActionT m) where 234 | ask = ActionT $ lift ask 235 | local f = ActionT . mapReaderT (local f) . runAM 236 | 237 | -- | MonadFail instance for ActionT that converts 'fail' calls into Scotty exceptions 238 | -- which allows these failures to be caught by Scotty's error handling system 239 | -- and properly returned as HTTP 500 responses. The instance throws a 'StringException' 240 | -- containing both the failure message and a call stack for debugging purposes. 241 | instance (MonadIO m) => MonadFail (ActionT m) where 242 | fail msg = E.throw $ StringException msg callStack 243 | 244 | -- | 'empty' throws 'ActionError' 'AENext', whereas '(<|>)' catches any 'ActionError's or 'StatusError's in the first action and proceeds to the second one. 245 | instance (MonadUnliftIO m) => Alternative (ActionT m) where 246 | empty = E.throw AENext 247 | a <|> b = do 248 | ok <- tryAnyStatus a 249 | if ok then a else b 250 | instance (MonadUnliftIO m) => MonadPlus (ActionT m) where 251 | mzero = empty 252 | mplus = (<|>) 253 | 254 | -- | catches either ActionError (thrown by 'next'), 255 | -- 'ScottyException' (thrown if e.g. a query parameter is not found) 256 | tryAnyStatus :: MonadUnliftIO m => m a -> m Bool 257 | tryAnyStatus io = (io >> pure True) `catches` [h1, h2] 258 | where 259 | h1 = Handler $ \(_ :: ActionError) -> pure False 260 | h2 = Handler $ \(_ :: ScottyException) -> pure False 261 | 262 | instance (Semigroup a) => Semigroup (ScottyT m a) where 263 | x <> y = (<>) <$> x <*> y 264 | 265 | instance 266 | ( Monoid a 267 | ) => Monoid (ScottyT m a) where 268 | mempty = return mempty 269 | 270 | instance 271 | ( Monad m 272 | , Semigroup a 273 | ) => Semigroup (ActionT m a) where 274 | x <> y = (<>) <$> x <*> y 275 | 276 | instance 277 | ( Monad m, Monoid a 278 | ) => Monoid (ActionT m a) where 279 | mempty = return mempty 280 | 281 | ------------------ Scotty Routes -------------------- 282 | data RoutePattern = Capture T.Text 283 | | Literal T.Text 284 | | Function (Request -> Maybe [Param]) 285 | 286 | instance IsString RoutePattern where 287 | fromString = Capture . T.pack 288 | 289 | 290 | -------------------------------------------------------------------------------- /Web/Scotty/Route.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, 2 | OverloadedStrings, RankNTypes, ScopedTypeVariables #-} 3 | module Web.Scotty.Route 4 | ( get, post, put, delete, patch, options, addroute, matchAny, notFound, 5 | capture, regex, function, literal 6 | ) where 7 | 8 | import Control.Arrow ((***)) 9 | import Control.Concurrent.STM (newTVarIO) 10 | import Control.Monad.IO.Class (MonadIO(..)) 11 | import UnliftIO (MonadUnliftIO(..)) 12 | import qualified Control.Monad.Reader as MR 13 | import qualified Control.Monad.State as MS 14 | import Control.Monad.Trans.Resource (InternalState) 15 | 16 | import Data.String (fromString) 17 | import qualified Data.Text as T 18 | 19 | import Network.HTTP.Types 20 | import Network.Wai (Request(..)) 21 | 22 | import qualified Text.Regex as Regex 23 | 24 | import Web.Scotty.Action 25 | 26 | import Web.Scotty.Internal.Types (Options, RoutePattern(..), RouteOptions, ActionEnv(..), ScottyState(..), ScottyT(..), ErrorHandler, Middleware, BodyInfo, File, handler, addRoute, defaultScottyResponse) 27 | 28 | import Web.Scotty.Util (decodeUtf8Lenient) 29 | import Web.Scotty.Body (cloneBodyInfo, getBodyAction, getBodyChunkAction, getFormParamsAndFilesAction) 30 | 31 | 32 | {- $setup 33 | >>> :{ 34 | import Control.Monad.IO.Class (MonadIO(..)) 35 | import qualified Network.HTTP.Client as H 36 | import qualified Network.HTTP.Types as H 37 | import qualified Network.Wai as W (httpVersion) 38 | import qualified Data.ByteString.Lazy.Char8 as LBS (unpack) 39 | import qualified Data.Text as T (pack) 40 | import Control.Concurrent (ThreadId, forkIO, killThread) 41 | import Control.Exception (bracket) 42 | import qualified Web.Scotty as S (ScottyM, scottyOpts, get, text, regex, pathParam, Options(..), defaultOptions) 43 | -- | GET an HTTP path 44 | curl :: MonadIO m => 45 | String -- ^ path 46 | -> m String -- ^ response body 47 | curl path = liftIO $ do 48 | req0 <- H.parseRequest path 49 | let req = req0 { H.method = "GET"} 50 | mgr <- H.newManager H.defaultManagerSettings 51 | (LBS.unpack . H.responseBody) <$> H.httpLbs req mgr 52 | -- | 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. 53 | withScotty :: S.ScottyM () 54 | -> IO a -- ^ inner action, e.g. 'curl "localhost:3000/"' 55 | -> IO a 56 | withScotty serv act = bracket (forkIO $ S.scottyOpts (S.defaultOptions{ S.verbose = 0 }) serv) killThread (\_ -> act) 57 | :} 58 | -} 59 | 60 | -- | get = 'addroute' 'GET' 61 | get :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () 62 | get = addroute GET 63 | 64 | -- | post = 'addroute' 'POST' 65 | post :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () 66 | post = addroute POST 67 | 68 | -- | put = 'addroute' 'PUT' 69 | put :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () 70 | put = addroute PUT 71 | 72 | -- | delete = 'addroute' 'DELETE' 73 | delete :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () 74 | delete = addroute DELETE 75 | 76 | -- | patch = 'addroute' 'PATCH' 77 | patch :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () 78 | patch = addroute PATCH 79 | 80 | -- | options = 'addroute' 'OPTIONS' 81 | options :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () 82 | options = addroute OPTIONS 83 | 84 | -- | Add a route that matches regardless of the HTTP verb. 85 | matchAny :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () 86 | matchAny pat action = 87 | ScottyT $ do 88 | serverOptions <- MR.ask 89 | MS.modify $ \s -> 90 | addRoute 91 | (route serverOptions (routeOptions s) (handler s) Nothing pat action) 92 | s 93 | 94 | -- | Specify an action to take if nothing else is found. Note: this _always_ matches, 95 | -- so should generally be the last route specified. 96 | notFound :: (MonadUnliftIO m) => ActionT m () -> ScottyT m () 97 | notFound action = matchAny (Function (\req -> Just [("path", path req)])) (status status404 >> action) 98 | 99 | {- | Define a route with a 'StdMethod', a route pattern representing the path spec, 100 | and an 'Action' which may modify the response. 101 | 102 | > get "/" $ text "beam me up!" 103 | 104 | The path spec can include values starting with a colon, which are interpreted 105 | as /captures/. These are parameters that can be looked up with 'pathParam'. 106 | 107 | >>> :{ 108 | let server = S.get "/foo/:bar" (S.pathParam "bar" >>= S.text) 109 | in do 110 | withScotty server $ curl "http://localhost:3000/foo/something" 111 | :} 112 | "something" 113 | -} 114 | addroute :: (MonadUnliftIO m) => StdMethod -> RoutePattern -> ActionT m () -> ScottyT m () 115 | addroute method pat action = 116 | ScottyT $ do 117 | serverOptions <- MR.ask 118 | MS.modify $ \s -> 119 | addRoute 120 | (route serverOptions (routeOptions s) (handler s) (Just method) pat action) 121 | s 122 | 123 | 124 | route :: (MonadUnliftIO m) => 125 | Options 126 | -> RouteOptions 127 | -> Maybe (ErrorHandler m) -> Maybe StdMethod -> RoutePattern -> ActionT m () -> BodyInfo -> Middleware m 128 | route serverOpts opts h method pat action bodyInfo app req = 129 | let tryNext = app req 130 | -- We match all methods in the case where 'method' is 'Nothing'. 131 | -- See https://github.com/scotty-web/scotty/issues/196 and 'matchAny' 132 | methodMatches :: Bool 133 | methodMatches = maybe True (\x -> (Right x == parseMethod (requestMethod req))) method 134 | 135 | in if methodMatches 136 | then case matchRoute pat req of 137 | Just captures -> do 138 | -- The user-facing API for "body" and "bodyReader" involve an IO action that 139 | -- reads the body/chunks thereof only once, so we shouldn't pass in our BodyInfo 140 | -- directly; otherwise, the body might get consumed and then it would be unavailable 141 | -- if `next` is called and we try to match further routes. 142 | -- Instead, make a "cloned" copy of the BodyInfo that allows the IO actions to be called 143 | -- without messing up the state of the original BodyInfo. 144 | cbi <- cloneBodyInfo bodyInfo 145 | 146 | env <- mkEnv cbi req captures opts 147 | res <- runAction serverOpts h env action 148 | 149 | maybe tryNext return res 150 | Nothing -> tryNext 151 | else tryNext 152 | 153 | matchRoute :: RoutePattern -> Request -> Maybe [Param] 154 | matchRoute (Literal pat) req | pat == path req = Just [] 155 | | otherwise = Nothing 156 | matchRoute (Function fun) req = fun req 157 | matchRoute (Capture pat) req = go (T.split (=='/') pat) (compress $ "":pathInfo req) [] -- add empty segment to simulate being at the root 158 | where go [] [] prs = Just prs -- request string and pattern match! 159 | go [] r prs | T.null (mconcat r) = Just prs -- in case request has trailing slashes 160 | | otherwise = Nothing -- request string is longer than pattern 161 | go p [] prs | T.null (mconcat p) = Just prs -- in case pattern has trailing slashes 162 | | otherwise = Nothing -- request string is not long enough 163 | go (p:ps) (r:rs) prs = case T.uncons p of 164 | Just (':', name) -> go ps rs $ (name, r) : prs -- p is a capture, add to params 165 | _ | p == r -> go ps rs prs -- equal literals, keeping checking 166 | | otherwise -> Nothing -- both literals, but unequal, fail 167 | compress ("":rest@("":_)) = compress rest 168 | compress (x:xs) = x : compress xs 169 | compress [] = [] 170 | 171 | -- Pretend we are at the top level. 172 | path :: Request -> T.Text 173 | path = T.cons '/' . T.intercalate "/" . pathInfo 174 | 175 | -- | Parse the request and construct the initial 'ActionEnv' with a default 200 OK response 176 | mkEnv :: MonadIO m => 177 | BodyInfo 178 | -> Request 179 | -> [Param] 180 | -> RouteOptions 181 | -> m ActionEnv 182 | mkEnv bodyInfo req pathps opts = do 183 | let 184 | getFormData :: InternalState -> ParseRequestBodyOptions -> IO ([Param], [File FilePath]) 185 | getFormData istate prbo = getFormParamsAndFilesAction istate prbo req bodyInfo opts 186 | queryps = parseEncodedParams $ queryString req 187 | responseInit <- liftIO $ newTVarIO defaultScottyResponse 188 | return $ Env req pathps queryps getFormData (getBodyAction bodyInfo opts) (getBodyChunkAction bodyInfo) responseInit 189 | 190 | 191 | 192 | parseEncodedParams :: Query -> [Param] 193 | parseEncodedParams qs = [ ( decodeUtf8Lenient k, maybe "" decodeUtf8Lenient v) | (k,v) <- qs ] 194 | 195 | {- | Match requests using a regular expression. 196 | Named captures are not yet supported. 197 | 198 | >>> :{ 199 | let server = S.get (S.regex "^/f(.*)r$") $ do 200 | cap <- S.pathParam "1" 201 | S.text cap 202 | in do 203 | withScotty server $ curl "http://localhost:3000/foo/bar" 204 | :} 205 | "oo/ba" 206 | -} 207 | regex :: String -> RoutePattern 208 | regex pat = Function $ \ req -> fmap (map (T.pack . show *** T.pack) . zip [0 :: Int ..] . strip) 209 | (Regex.matchRegexAll rgx $ T.unpack $ path req) 210 | where rgx = Regex.mkRegex pat 211 | strip (_, match, _, subs) = match : subs 212 | 213 | -- | Standard Sinatra-style route. Named captures are prepended with colons. 214 | -- This is the default route type generated by OverloadedString routes. i.e. 215 | -- 216 | -- > get (capture "/foo/:bar") $ ... 217 | -- 218 | -- and 219 | -- 220 | -- > {-# LANGUAGE OverloadedStrings #-} 221 | -- > ... 222 | -- > get "/foo/:bar" $ ... 223 | -- 224 | -- are equivalent. 225 | capture :: String -> RoutePattern 226 | capture = fromString 227 | 228 | {- | Build a route based on a function which can match using the entire 'Request' object. 229 | 'Nothing' indicates the route does not match. A 'Just' value indicates 230 | a successful match, optionally returning a list of key-value pairs accessible by 'param'. 231 | 232 | >>> :{ 233 | let server = S.get (function $ \req -> Just [("version", T.pack $ show $ W.httpVersion req)]) $ do 234 | v <- S.pathParam "version" 235 | S.text v 236 | in do 237 | withScotty server $ curl "http://localhost:3000/" 238 | :} 239 | "HTTP/1.1" 240 | -} 241 | function :: (Request -> Maybe [Param]) -> RoutePattern 242 | function = Function 243 | 244 | -- | Build a route that requires the requested path match exactly, without captures. 245 | literal :: String -> RoutePattern 246 | literal = Literal . T.pack 247 | -------------------------------------------------------------------------------- /Web/Scotty/Session.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | {- | 5 | Module : Web.Scotty.Session 6 | Copyright : (c) 2025 Tushar Adhatrao, 7 | (c) 2025 Marco Zocca 8 | 9 | License : BSD-3-Clause 10 | Maintainer : 11 | Stability : experimental 12 | Portability : GHC 13 | 14 | This module provides session management functionality for Scotty web applications. 15 | 16 | ==Example usage: 17 | 18 | @ 19 | \{\-\# LANGUAGE OverloadedStrings \#\-\} 20 | 21 | import Web.Scotty 22 | import Web.Scotty.Session 23 | import Control.Monad.IO.Class (liftIO) 24 | main :: IO () 25 | main = do 26 | -- Create a session jar 27 | sessionJar <- createSessionJar 28 | scotty 3000 $ do 29 | -- Route to create a session 30 | get "/create" $ do 31 | sess <- createUserSession sessionJar "user data" 32 | html $ "Session created with ID: " <> sessId sess 33 | -- Route to read a session 34 | get "/read" $ do 35 | eSession <- getUserSession sessionJar 36 | case eSession of 37 | Left _-> html "No session found or session expired." 38 | Right sess -> html $ "Session content: " <> sessContent sess 39 | @ 40 | -} 41 | module Web.Scotty.Session ( 42 | Session (..), 43 | SessionId, 44 | SessionJar, 45 | SessionStatus, 46 | 47 | -- * Create Session Jar 48 | createSessionJar, 49 | 50 | -- * Create session 51 | createUserSession, 52 | createSession, 53 | 54 | -- * Read session 55 | readUserSession, 56 | readSession, 57 | getUserSession, 58 | getSession, 59 | 60 | -- * Add session 61 | addSession, 62 | 63 | -- * Delte session 64 | deleteSession, 65 | 66 | -- * Helper functions 67 | maintainSessions, 68 | ) where 69 | 70 | import Control.Concurrent 71 | import Control.Concurrent.STM 72 | import Control.Monad 73 | import Control.Monad.IO.Class (MonadIO (..)) 74 | import qualified Data.HashMap.Strict as HM 75 | import qualified Data.Text as T 76 | import Data.Time (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) 77 | import System.Random (randomRIO) 78 | import Web.Scotty.Action (ActionT) 79 | import Web.Scotty.Cookie 80 | 81 | -- | Type alias for session identifiers. 82 | type SessionId = T.Text 83 | 84 | -- | Status of a session lookup. 85 | data SessionStatus = SessionNotFound | SessionExpired 86 | deriving (Show, Eq) 87 | 88 | -- | Represents a session containing an ID, expiration time, and content. 89 | data Session a = Session 90 | { sessId :: SessionId 91 | -- ^ Unique identifier for the session. 92 | , sessExpiresAt :: UTCTime 93 | -- ^ Expiration time of the session. 94 | , sessContent :: a 95 | -- ^ Content stored in the session. 96 | } 97 | deriving (Eq, Show) 98 | 99 | -- | Type for session storage, a transactional variable containing a map of session IDs to sessions. 100 | type SessionJar a = TVar (HM.HashMap SessionId (Session a)) 101 | 102 | -- | Creates a new session jar and starts a background thread to maintain it. 103 | createSessionJar :: IO (SessionJar a) 104 | createSessionJar = do 105 | storage <- newTVarIO HM.empty 106 | _ <- forkIO $ maintainSessions storage 107 | return storage 108 | 109 | -- | Continuously removes expired sessions from the session jar. 110 | maintainSessions :: SessionJar a -> IO () 111 | maintainSessions sessionJar = 112 | forever $ do 113 | now <- getCurrentTime 114 | let stillValid sess = sessExpiresAt sess > now 115 | atomically $ modifyTVar sessionJar $ \m -> HM.filter stillValid m 116 | threadDelay 1000000 117 | 118 | 119 | -- | Adds or overwrites a new session to the session jar. 120 | addSession :: SessionJar a -> Session a -> IO () 121 | addSession sessionJar sess = 122 | atomically $ modifyTVar sessionJar $ \m -> HM.insert (sessId sess) sess m 123 | 124 | -- | Retrieves a session by its ID from the session jar. 125 | getSession :: (MonadIO m) => SessionJar a -> SessionId -> ActionT m (Either SessionStatus (Session a)) 126 | getSession sessionJar sId = 127 | do 128 | s <- liftIO $ readTVarIO sessionJar 129 | case HM.lookup sId s of 130 | Nothing -> pure $ Left SessionNotFound 131 | Just sess -> do 132 | now <- liftIO getCurrentTime 133 | if sessExpiresAt sess < now 134 | then deleteSession sessionJar (sessId sess) >> pure (Left SessionExpired) 135 | else pure $ Right sess 136 | 137 | -- | Deletes a session by its ID from the session jar. 138 | deleteSession :: (MonadIO m) => SessionJar a -> SessionId -> ActionT m () 139 | deleteSession sessionJar sId = 140 | liftIO $ 141 | atomically $ 142 | modifyTVar sessionJar $ 143 | HM.delete sId 144 | 145 | {- | Retrieves the current user's session based on the "sess_id" cookie. 146 | | Returns `Left SessionStatus` if the session is expired or does not exist. 147 | -} 148 | getUserSession :: (MonadIO m) => SessionJar a -> ActionT m (Either SessionStatus (Session a)) 149 | getUserSession sessionJar = do 150 | getCookie "sess_id" >>= \case 151 | Nothing -> pure $ Left SessionNotFound 152 | Just sid -> lookupSession sid 153 | where 154 | lookupSession = getSession sessionJar 155 | 156 | -- | Reads the content of a session by its ID. 157 | readSession :: (MonadIO m) => SessionJar a -> SessionId -> ActionT m (Either SessionStatus a) 158 | readSession sessionJar sId = do 159 | res <- getSession sessionJar sId 160 | return $ sessContent <$> res 161 | 162 | -- | Reads the content of the current user's session. 163 | readUserSession :: (MonadIO m) => SessionJar a -> ActionT m (Either SessionStatus a) 164 | readUserSession sessionJar = do 165 | res <- getUserSession sessionJar 166 | return $ sessContent <$> res 167 | 168 | -- | The time-to-live for sessions, in seconds. 169 | sessionTTL :: NominalDiffTime 170 | sessionTTL = 36000 -- in seconds 171 | 172 | -- | Creates a new session for a user, storing the content and setting a cookie. 173 | createUserSession :: (MonadIO m) => 174 | SessionJar a -- ^ SessionJar, which can be created by createSessionJar 175 | -> Maybe Int -- ^ Optional expiration time (in seconds) 176 | -> a -- ^ Content 177 | -> ActionT m (Session a) 178 | createUserSession sessionJar mbExpirationTime content = do 179 | sess <- liftIO $ createSession sessionJar mbExpirationTime content 180 | setSimpleCookie "sess_id" (sessId sess) 181 | return sess 182 | 183 | -- | Creates a new session with a generated ID, sets its expiration, 184 | -- | and adds it to the session jar. 185 | createSession :: SessionJar a -> Maybe Int -> a -> IO (Session a) 186 | createSession sessionJar mbExpirationTime content = do 187 | sId <- liftIO $ T.pack <$> replicateM 32 (randomRIO ('a', 'z')) 188 | now <- getCurrentTime 189 | let expiresAt = addUTCTime (maybe sessionTTL fromIntegral mbExpirationTime) now 190 | sess = Session sId expiresAt content 191 | liftIO $ addSession sessionJar sess 192 | return $ Session sId expiresAt content 193 | -------------------------------------------------------------------------------- /Web/Scotty/Trans.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, RankNTypes #-} 2 | {-# language LambdaCase #-} 3 | -- | It should be noted that most of the code snippets below depend on the 4 | -- OverloadedStrings language pragma. 5 | -- 6 | -- The functions in this module allow an arbitrary monad to be embedded 7 | -- in Scotty's monad transformer stack, e.g. for complex endpoint configuration, 8 | -- interacting with databases etc. 9 | -- 10 | -- Scotty is set up by default for development mode. For production servers, 11 | -- you will likely want to modify 'settings' and the 'defaultHandler'. See 12 | -- the comments on each of these functions for more information. 13 | -- 14 | -- 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. 15 | module Web.Scotty.Trans 16 | ( -- * Running 'scotty' servers 17 | scottyT 18 | , scottyOptsT 19 | , scottySocketT 20 | , Options(..), defaultOptions 21 | -- ** scotty-to-WAI 22 | , scottyAppT 23 | -- * Defining Middleware and Routes 24 | -- 25 | -- | 'Middleware' and routes are run in the order in which they 26 | -- are defined. All middleware is run first, followed by the first 27 | -- route that matches. If no route matches, a 404 response is given. 28 | , middleware, get, post, put, delete, patch, options, addroute, matchAny, notFound, setMaxRequestBodySize 29 | -- ** Route Patterns 30 | , capture, regex, function, literal 31 | -- ** Accessing the Request and its fields 32 | , request, Lazy.header, Lazy.headers, body, bodyReader 33 | , jsonData, formData 34 | 35 | -- ** Accessing Path, Form and Query Parameters 36 | , pathParam, captureParam, formParam, queryParam 37 | , pathParamMaybe, captureParamMaybe, formParamMaybe, queryParamMaybe 38 | , pathParams, captureParams, formParams, queryParams 39 | -- *** Files 40 | , files, filesOpts 41 | -- ** Modifying the Response 42 | , status, Lazy.addHeader, Lazy.setHeader 43 | -- ** Redirecting 44 | , Lazy.redirect, Lazy.redirect300, Lazy.redirect301, Lazy.redirect302, Lazy.redirect303 45 | , Lazy.redirect304, Lazy.redirect307, Lazy.redirect308 46 | -- ** Setting Response Body 47 | -- 48 | -- | Note: only one of these should be present in any given route 49 | -- definition, as they completely replace the current 'Response' body. 50 | , Lazy.text, Lazy.html, file, json, stream, raw, nested 51 | -- ** Accessing the fields of the Response 52 | , getResponseHeaders, getResponseStatus, getResponseContent 53 | -- ** Exceptions 54 | , throw, next, finish, defaultHandler 55 | , liftIO, catch 56 | , ScottyException(..) 57 | -- * Parsing Parameters 58 | , Param, Parsable(..), readEither 59 | -- * Types 60 | , RoutePattern, File, Content(..), Kilobytes, ErrorHandler, Handler(..) 61 | -- * Monad Transformers 62 | , ScottyT, ActionT 63 | , ScottyState, defaultScottyState 64 | -- ** Functions from Cookie module 65 | , setSimpleCookie, getCookie, getCookies, deleteCookie, makeSimpleCookie 66 | -- ** Session Management 67 | , Session (..), SessionId, SessionJar, createSessionJar, 68 | createUserSession, createSession, readUserSession, 69 | readSession, getUserSession, getSession, addSession, deleteSession, maintainSessions 70 | ) where 71 | 72 | import Blaze.ByteString.Builder (fromByteString) 73 | import Blaze.ByteString.Builder.Char8 (fromString) 74 | 75 | import Control.Exception (assert) 76 | import Control.Monad (when) 77 | import Control.Monad.Reader (runReaderT) 78 | import Control.Monad.State.Strict (execState, modify) 79 | import Control.Monad.IO.Class 80 | 81 | import Network.HTTP.Types (status404, status413, status500) 82 | import Network.Socket (Socket) 83 | import qualified Network.Wai as W (Application, Middleware, Response, responseBuilder) 84 | import Network.Wai.Handler.Warp (Port, runSettings, runSettingsSocket, setPort, getPort) 85 | 86 | import Web.Scotty.Action 87 | import Web.Scotty.Route 88 | 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(..)) 89 | import Web.Scotty.Trans.Lazy as Lazy 90 | import Web.Scotty.Util (socketDescription) 91 | import Web.Scotty.Body (newBodyInfo) 92 | 93 | import UnliftIO.Exception (Handler(..), catch) 94 | import Web.Scotty.Cookie (setSimpleCookie,getCookie,getCookies,deleteCookie,makeSimpleCookie) 95 | import Web.Scotty.Session (Session (..), SessionId, SessionJar, createSessionJar, 96 | createUserSession, createSession, readUserSession, 97 | readSession, getUserSession, getSession, addSession, deleteSession, maintainSessions) 98 | 99 | 100 | -- | Run a scotty application using the warp server. 101 | -- NB: scotty p === scottyT p id 102 | scottyT :: (Monad m, MonadIO n) 103 | => Port 104 | -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action. 105 | -> ScottyT m () 106 | -> n () 107 | scottyT p = scottyOptsT $ defaultOptions { settings = setPort p (settings defaultOptions) } 108 | 109 | -- | Run a scotty application using the warp server, passing extra options. 110 | -- NB: scottyOpts opts === scottyOptsT opts id 111 | scottyOptsT :: (Monad m, MonadIO n) 112 | => Options 113 | -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action. 114 | -> ScottyT m () 115 | -> n () 116 | scottyOptsT opts runActionToIO s = do 117 | when (verbose opts > 0) $ 118 | liftIO $ putStrLn $ "Setting phasers to stun... (port " ++ show (getPort (settings opts)) ++ ") (ctrl-c to quit)" 119 | liftIO . runSettings (settings opts) =<< scottyAppT opts runActionToIO s 120 | 121 | -- | Run a scotty application using the warp server, passing extra options, and 122 | -- listening on the provided socket. 123 | -- NB: scottySocket opts sock === scottySocketT opts sock id 124 | scottySocketT :: (Monad m, MonadIO n) 125 | => Options 126 | -> Socket 127 | -> (m W.Response -> IO W.Response) 128 | -> ScottyT m () 129 | -> n () 130 | scottySocketT opts sock runActionToIO s = do 131 | when (verbose opts > 0) $ do 132 | d <- liftIO $ socketDescription sock 133 | liftIO $ putStrLn $ "Setting phasers to stun... (" ++ d ++ ") (ctrl-c to quit)" 134 | liftIO . runSettingsSocket (settings opts) sock =<< scottyAppT opts runActionToIO s 135 | 136 | -- | Turn a scotty application into a WAI 'Application', which can be 137 | -- run with any WAI handler. 138 | -- NB: scottyApp === scottyAppT id 139 | scottyAppT :: (Monad m, Monad n) 140 | => Options 141 | -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action. 142 | -> ScottyT m () 143 | -> n W.Application 144 | scottyAppT opts runActionToIO defs = do 145 | let s = execState (runReaderT (runS defs) opts) defaultScottyState 146 | let rapp req callback = do 147 | bodyInfo <- newBodyInfo req 148 | resp <- runActionToIO (applyAll notFoundApp ([midd bodyInfo | midd <- routes s]) req) 149 | `catch` unhandledExceptionHandler 150 | callback resp 151 | return $ applyAll rapp (middlewares s) 152 | 153 | -- | Exception handler in charge of 'ScottyException' that's not caught by 'scottyExceptionHandler' 154 | unhandledExceptionHandler :: MonadIO m => ScottyException -> m W.Response 155 | unhandledExceptionHandler = \case 156 | RequestTooLarge -> return $ W.responseBuilder status413 ct "Request is too big Jim!" 157 | e -> return $ W.responseBuilder status500 ct $ "Internal Server Error: " <> fromString (show e) 158 | where 159 | ct = [("Content-Type", "text/plain")] 160 | 161 | applyAll :: Foldable t => a -> t (a -> a) -> a 162 | applyAll = foldl (flip ($)) 163 | 164 | notFoundApp :: Monad m => Application m 165 | notFoundApp _ = return $ W.responseBuilder status404 [("Content-Type","text/html")] 166 | $ fromByteString "

404: File Not Found!

" 167 | 168 | -- | Global handler for user-defined exceptions. 169 | defaultHandler :: (Monad m) => ErrorHandler m -> ScottyT m () 170 | defaultHandler f = ScottyT $ modify $ setHandler $ Just f 171 | 172 | -- | Use given middleware. Middleware is nested such that the first declared 173 | -- is the outermost middleware (it has first dibs on the request and last action 174 | -- on the response). Every middleware is run on each request. 175 | middleware :: W.Middleware -> ScottyT m () 176 | middleware = ScottyT . modify . addMiddleware 177 | 178 | -- | Set global size limit for the request body. Requests with body size exceeding the limit will not be 179 | -- processed and an HTTP response 413 will be returned to the client. Size limit needs to be greater than 0, 180 | -- otherwise the application will terminate on start. 181 | setMaxRequestBodySize :: Kilobytes -- ^ Request size limit 182 | -> ScottyT m () 183 | setMaxRequestBodySize i = assert (i > 0) $ ScottyT . modify . updateMaxRequestBodySize $ defaultRouteOptions { maxRequestBodySize = Just i } 184 | 185 | -------------------------------------------------------------------------------- /Web/Scotty/Trans/Lazy.hs: -------------------------------------------------------------------------------- 1 | module Web.Scotty.Trans.Lazy where 2 | 3 | import Control.Monad (join) 4 | import Control.Monad.IO.Class 5 | import Data.Bifunctor (bimap) 6 | import qualified Data.Text.Lazy as T 7 | 8 | import qualified Web.Scotty.Action as Base 9 | import Web.Scotty.Internal.Types 10 | 11 | -- | Synonym for 'redirect302'. 12 | -- If you are unsure which redirect to use, you probably want this one. 13 | -- 14 | -- > redirect "http://www.google.com" 15 | -- 16 | -- OR 17 | -- 18 | -- > redirect "/foo/bar" 19 | redirect :: (Monad m) => T.Text -> ActionT m a 20 | redirect = redirect302 21 | 22 | -- | Redirect to given URL with status 300 (Multiple Choices). Like throwing 23 | -- an uncatchable exception. Any code after the call to 24 | -- redirect will not be run. 25 | redirect300 :: (Monad m) => T.Text -> ActionT m a 26 | redirect300 = Base.redirect300 . T.toStrict 27 | 28 | -- | Redirect to given URL with status 301 (Moved Permanently). Like throwing 29 | -- an uncatchable exception. Any code after the call to 30 | -- redirect will not be run. 31 | redirect301 :: (Monad m) => T.Text -> ActionT m a 32 | redirect301 = Base.redirect301 . T.toStrict 33 | 34 | -- | Redirect to given URL with status 302 (Found). Like throwing 35 | -- an uncatchable exception. Any code after the call to 36 | -- redirect will not be run. 37 | redirect302 :: (Monad m) => T.Text -> ActionT m a 38 | redirect302 = Base.redirect302 . T.toStrict 39 | 40 | -- | Redirect to given URL with status 303 (See Other). Like throwing 41 | -- an uncatchable exception. Any code after the call to 42 | -- redirect will not be run. 43 | redirect303 :: (Monad m) => T.Text -> ActionT m a 44 | redirect303 = Base.redirect303 . T.toStrict 45 | 46 | -- | Redirect to given URL with status 304 (Not Modified). Like throwing 47 | -- an uncatchable exception. Any code after the call to 48 | -- redirect will not be run. 49 | redirect304 :: (Monad m) => T.Text -> ActionT m a 50 | redirect304 = Base.redirect304 . T.toStrict 51 | 52 | -- | Redirect to given URL with status 307 (Temporary Redirect). Like throwing 53 | -- an uncatchable exception. Any code after the call to 54 | -- redirect will not be run. 55 | redirect307 :: (Monad m) => T.Text -> ActionT m a 56 | redirect307 = Base.redirect307 . T.toStrict 57 | 58 | -- | Redirect to given URL with status 308 (Permanent Redirect). Like throwing 59 | -- an uncatchable exception. Any code after the call to 60 | -- redirect will not be run. 61 | redirect308 :: (Monad m) => T.Text -> ActionT m a 62 | redirect308 = Base.redirect308 . T.toStrict 63 | 64 | -- | Get a request header. Header name is case-insensitive. 65 | header :: (Monad m) => T.Text -> ActionT m (Maybe T.Text) 66 | header h = fmap T.fromStrict <$> Base.header (T.toStrict h) 67 | 68 | -- | Get all the request headers. Header names are case-insensitive. 69 | headers :: (Monad m) => ActionT m [(T.Text, T.Text)] 70 | headers = map (join bimap T.fromStrict) <$> Base.headers 71 | 72 | -- | Add to the response headers. Header names are case-insensitive. 73 | addHeader :: MonadIO m => T.Text -> T.Text -> ActionT m () 74 | addHeader k v = Base.addHeader (T.toStrict k) (T.toStrict v) 75 | 76 | -- | Set one of the response headers. Will override any previously set value for that header. 77 | -- Header names are case-insensitive. 78 | setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m () 79 | setHeader k v = Base.addHeader (T.toStrict k) (T.toStrict v) 80 | 81 | text :: (MonadIO m) => T.Text -> ActionT m () 82 | text = Base.textLazy 83 | 84 | html :: (MonadIO m) => T.Text -> ActionT m () 85 | html = Base.htmlLazy 86 | -------------------------------------------------------------------------------- /Web/Scotty/Trans/Strict.hs: -------------------------------------------------------------------------------- 1 | -- | This module is essentially identical to 'Web.Scotty.Trans', except that 2 | -- some functions take/return strict Text instead of the lazy ones. 3 | -- 4 | -- It should be noted that most of the code snippets below depend on the 5 | -- OverloadedStrings language pragma. 6 | -- 7 | -- The functions in this module allow an arbitrary monad to be embedded 8 | -- in Scotty's monad transformer stack in order that Scotty be combined 9 | -- with other DSLs. 10 | -- 11 | -- Scotty is set up by default for development mode. For production servers, 12 | -- you will likely want to modify 'settings' and the 'defaultHandler'. See 13 | -- the comments on each of these functions for more information. 14 | module Web.Scotty.Trans.Strict 15 | ( -- * scotty-to-WAI 16 | scottyT, scottyAppT, scottyOptsT, scottySocketT, Options(..), defaultOptions 17 | -- * Defining Middleware and Routes 18 | -- 19 | -- | 'Middleware' and routes are run in the order in which they 20 | -- are defined. All middleware is run first, followed by the first 21 | -- route that matches. If no route matches, a 404 response is given. 22 | , middleware, get, post, put, delete, patch, options, addroute, matchAny, notFound, setMaxRequestBodySize 23 | -- ** Route Patterns 24 | , capture, regex, function, literal 25 | -- ** Accessing the Request, Captures, and Query Parameters 26 | , request, Base.header, Base.headers, body, bodyReader 27 | , captureParam, formParam, queryParam 28 | , captureParamMaybe, formParamMaybe, queryParamMaybe 29 | , captureParams, formParams, queryParams 30 | , jsonData, files 31 | -- ** Modifying the Response 32 | , status, Base.addHeader, Base.setHeader 33 | -- ** Redirecting 34 | , Base.redirect, Base.redirect300, Base.redirect301, Base.redirect302, Base.redirect303 35 | , Base.redirect304, Base.redirect307, Base.redirect308 36 | -- ** Setting Response Body 37 | -- 38 | -- | Note: only one of these should be present in any given route 39 | -- definition, as they completely replace the current 'Response' body. 40 | , Base.text, Base.html, file, json, stream, raw, nested 41 | , textLazy 42 | , htmlLazy 43 | -- ** Accessing the fields of the Response 44 | , getResponseHeaders, getResponseStatus, getResponseContent 45 | -- ** Exceptions 46 | , throw, next, finish, defaultHandler 47 | , ScottyException(..) 48 | -- * Parsing Parameters 49 | , Param, Parsable(..), readEither 50 | -- * Types 51 | , RoutePattern, File, Content(..), Kilobytes, ErrorHandler, Handler(..) 52 | -- * Monad Transformers 53 | , ScottyT, ActionT 54 | , ScottyState, defaultScottyState 55 | ) where 56 | import Web.Scotty.Action as Base 57 | import Web.Scotty.Trans 58 | -------------------------------------------------------------------------------- /Web/Scotty/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# options_ghc -Wno-unused-imports #-} 4 | module Web.Scotty.Util 5 | ( lazyTextToStrictByteString 6 | , strictByteStringToLazyText 7 | , decodeUtf8Lenient 8 | , mkResponse 9 | , replace 10 | , add 11 | , addIfNotPresent 12 | , socketDescription 13 | , readRequestBody 14 | ) where 15 | 16 | import Network.Socket (SockAddr(..), Socket, getSocketName, socketPort) 17 | import Network.Wai 18 | 19 | import Control.Exception 20 | import Control.Monad (when) 21 | import qualified Data.ByteString as B 22 | import qualified Data.Text as TP (Text, pack) 23 | import qualified Data.Text.Lazy as TL 24 | import Data.Text.Encoding as ES 25 | import qualified Data.Text.Encoding.Error as ES 26 | 27 | import Web.Scotty.Internal.Types 28 | 29 | lazyTextToStrictByteString :: TL.Text -> B.ByteString 30 | lazyTextToStrictByteString = ES.encodeUtf8 . TL.toStrict 31 | 32 | strictByteStringToLazyText :: B.ByteString -> TL.Text 33 | strictByteStringToLazyText = TL.fromStrict . ES.decodeUtf8With ES.lenientDecode 34 | 35 | #if !MIN_VERSION_text(2,0,0) 36 | decodeUtf8Lenient :: B.ByteString -> TP.Text 37 | decodeUtf8Lenient = ES.decodeUtf8With ES.lenientDecode 38 | #endif 39 | 40 | -- Note: we currently don't support responseRaw, which may be useful 41 | -- for websockets. However, we always read the request body, which 42 | -- is incompatible with responseRaw responses. 43 | mkResponse :: ScottyResponse -> Response 44 | mkResponse sr = case srContent sr of 45 | ContentBuilder b -> responseBuilder s h b 46 | ContentFile f -> responseFile s h f Nothing 47 | ContentStream str -> responseStream s h str 48 | ContentResponse res -> res 49 | where s = srStatus sr 50 | h = srHeaders sr 51 | 52 | -- Note: we assume headers are not sensitive to order here (RFC 2616 specifies they are not) 53 | replace :: Eq a => a -> b -> [(a,b)] -> [(a,b)] 54 | replace k v = add k v . filter ((/= k) . fst) 55 | 56 | add :: a -> b -> [(a,b)] -> [(a,b)] 57 | add k v m = (k,v):m 58 | 59 | addIfNotPresent :: Eq a => a -> b -> [(a,b)] -> [(a,b)] 60 | addIfNotPresent k v = go 61 | where go [] = [(k,v)] 62 | go l@((x,y):r) 63 | | x == k = l 64 | | otherwise = (x,y) : go r 65 | 66 | -- Assemble a description from the Socket's PortID. 67 | socketDescription :: Socket -> IO String 68 | socketDescription sock = do 69 | sockName <- getSocketName sock 70 | case sockName of 71 | SockAddrUnix u -> return $ "unix socket " ++ u 72 | _ -> fmap (\port -> "port " ++ show port) $ socketPort sock 73 | 74 | -- | return request body or throw a 'ScottyException' if request body too big 75 | readRequestBody :: IO B.ByteString -- ^ body chunk reader 76 | -> ([B.ByteString] -> IO [B.ByteString]) 77 | -> Maybe Kilobytes -- ^ max body size 78 | -> IO [B.ByteString] 79 | readRequestBody rbody prefix maxSize = do 80 | b <- rbody 81 | if B.null b then 82 | prefix [] 83 | else 84 | do 85 | checkBodyLength maxSize 86 | readRequestBody rbody (prefix . (b:)) maxSize 87 | where checkBodyLength :: Maybe Kilobytes -> IO () 88 | checkBodyLength = \case 89 | Just maxSize' -> do 90 | bodySoFar <- prefix [] 91 | when (bodySoFar `isBigger` maxSize') readUntilEmpty 92 | Nothing -> return () 93 | isBigger bodySoFar maxSize' = (B.length . B.concat $ bodySoFar) > maxSize' * 1024 -- XXX this looks both inefficient and wrong 94 | readUntilEmpty = do 95 | b <- rbody 96 | if B.null b 97 | then throwIO RequestTooLarge 98 | else readUntilEmpty 99 | 100 | 101 | -------------------------------------------------------------------------------- /bench/Main.hs: -------------------------------------------------------------------------------- 1 | {-# language 2 | OverloadedStrings 3 | , GeneralizedNewtypeDeriving 4 | #-} 5 | 6 | module Main (main) where 7 | 8 | import Control.Monad 9 | import Data.Functor.Identity 10 | import Lucid.Base 11 | import Lucid.Html5 12 | import Web.Scotty 13 | import Web.Scotty.Internal.Types 14 | import qualified Control.Monad.Reader as R 15 | import qualified Control.Monad.State.Lazy as SL 16 | import qualified Control.Monad.State.Strict as SS 17 | import qualified Data.ByteString.Lazy as BL 18 | 19 | import Weigh 20 | 21 | main :: IO () 22 | main = do 23 | mainWith $ do 24 | setColumns [Case,Allocated,GCs,Live,Check,Max,MaxOS] 25 | setFormat Markdown 26 | io "ScottyM Strict" BL.putStr 27 | (SS.evalState 28 | (R.runReaderT (runS $ renderBST htmlScotty) defaultOptions) 29 | defaultScottyState) 30 | io "ScottyM Lazy" BL.putStr 31 | (SL.evalState (runScottyLazy $ renderBST htmlScottyLazy) defaultScottyState) 32 | io "Identity" BL.putStr 33 | (runIdentity $ renderBST htmlIdentity) 34 | 35 | 36 | htmlTest :: Monad m => HtmlT m () 37 | htmlTest = replicateM_ 2 $ div_ $ do 38 | replicateM_ 1000 $ div_ $ do 39 | replicateM_ 10000 $ div_ "test" 40 | 41 | htmlIdentity :: HtmlT Identity () 42 | htmlIdentity = htmlTest 43 | {-# noinline htmlIdentity #-} 44 | 45 | htmlScotty :: HtmlT ScottyM () 46 | htmlScotty = htmlTest 47 | {-# noinline htmlScotty #-} 48 | 49 | htmlScottyLazy :: HtmlT ScottyLazy () 50 | htmlScottyLazy = htmlTest 51 | {-# noinline htmlScottyLazy #-} 52 | 53 | newtype ScottyLazy a = ScottyLazy 54 | { runScottyLazy:: SL.State (ScottyState IO) a } 55 | deriving (Functor,Applicative,Monad) 56 | 57 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | no-tests-no-benchmarks: False 2 | unconstrained: False 3 | local-ghc-options: -Werror 4 | benchmarks: >=8.2 5 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | ./examples 3 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | ## next [????.??.??] 2 | 3 | * Added sessions (#317). 4 | * Fixed cookie example from `Cookie` module documentation. `getCookie` Function would return strict variant of `Text`. Will convert it into lazy variant using `fromStrict`. 5 | * Exposed simple functions of `Cookie` module via `Web.Scotty` & `Web.Scotty.Trans`. 6 | * Add tests for URL encoding of query parameters and form parameters. Add `formData` action for decoding `FromForm` instances (#321). 7 | * Add explicit redirect functions for all redirect status codes. 8 | * Added ActionM variants for cookie module functions (#406). 9 | 10 | ### Breaking changes 11 | * 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. 12 | * 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. 13 | * Remove deprecated exports (#408) `liftAndCatchIO`, `param`, `params`, `raise`, `raiseStatus`, `rescue` from `Web.Scotty` and `Web.Scotty.Trans`. 14 | * Remove deprecated `StatusError` type from `Scotty.Internal.Types`. 15 | * Remove typeclass instance `MonadError StatusError (ActionT m)` from `Scotty.Internal.Types`. 16 | 17 | ## 0.22 [2024.03.09] 18 | 19 | ### New 20 | * add `instance Parsable UTCTime` (#250) 21 | * 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. 22 | 23 | ### Fixes 24 | * `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). 25 | * 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) 26 | * Accept text-2.1 (#364) 27 | * Remove dependency upper bounds on `text` and `bytestring` (#371) 28 | * When in 'verbose' mode any unhandled exceptions are printed to stderr as well (#374) 29 | 30 | ### Breaking changes 31 | * 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) 32 | * 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). 33 | 34 | 35 | 36 | ## 0.21 [2023.12.17] 37 | ### New 38 | * add `getResponseHeaders`, `getResponseStatus`, `getResponseContent` (#214) 39 | * add `captureParamMaybe`, `formParamMaybe`, `queryParamMaybe` (#322) 40 | * add `Web.Scotty.Trans.Strict` and `Web.Scotty.Trans.Lazy` (#334) 41 | * renamed `captureParam`, `captureParamMaybe`, and `captureParams` to `pathParam`, `pathParamMaybe`, `pathParams` respectively, keeping the old names as their synonyms (#344) 42 | 43 | ### Deprecated 44 | * deprecate `rescue` and `liftAndCatchIO` (#332) 45 | * Deprecate `StatusError`, `raise` and `raiseStatus` (#351) 46 | 47 | ### Fixes 48 | * Reverted the `MonadReader` instance of `ActionT` so that it inherits the base monad (#342) 49 | * Scotty's API such as `queryParam` now throws `ScottyException` rather than `StatusException`. 50 | Uncaught exceptions are handled by `scottyExceptionHandler`, resembling the existing behaviour 51 | 52 | ### Breaking changes 53 | * `File` type: the first component of the tuple is strict text now (used to be lazy prior to 0.21) (#370) 54 | 55 | ### Documentation 56 | * Add doctest, refactor some inline examples into doctests (#353) 57 | * document "`defaultHandler` only applies to endpoints defined after it" (#237) 58 | 59 | 60 | 61 | ## 0.20.1 [2023.10.03] 62 | * remove dependencies on 'base-compat' and 'base-compat-batteries' (#318) 63 | * re-add MonadFail (ActionT m) instance (#325) 64 | * re-add MonadError (ActionT m) instance, but the error type is now specialized to 'StatusError' (#325) 65 | * raise lower bound on base ( > 4.14 ) to reflect support for GHC >= 8.10 (#325). 66 | 67 | 68 | ## 0.20 [2023.10.02] 69 | * Drop support for GHC < 8.10 and modernise the CI pipeline (#300). 70 | * Adds a new `nested` handler that allows you to place an entire WAI Application under a Scotty route (#233). 71 | * 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`. 72 | * Add `Scotty.Cookie` module (#293). 73 | * Change body parsing behaviour such that calls to `next` don't result in POST request bodies disappearing (#147). 74 | * (Internal) Remove unused type `RequestBodyState` (#313) 75 | * Rewrite `ActionT` using the "ReaderT pattern" (#310) https://www.fpcomplete.com/blog/readert-design-pattern/ 76 | 77 | Breaking: 78 | 79 | * (#310) Introduce `unliftio` as a dependency, and base exception handling on `catch`. 80 | * (#310) Clarify the exception handling mechanism of ActionT, ScottyT. `rescue` changes signature to use proper `Exception` types rather than strings. Remove `ScottyError` typeclass. 81 | * (#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. 82 | * (#310) MonadError e (ActionT m) instance removed 83 | * (#310) MonadFail (ActionT m) instance is missing by mistake. 84 | 85 | ## 0.12.1 [2022.11.17] 86 | * Fix CPP bug that prevented tests from building on Windows. 87 | * Allow building with `transformers-0.6.*` and `mtl-2.3.*`. Because the 88 | `MonadTrans t` class gained a `forall m. Monad m => Monad (t m)` superclass 89 | in `transformers-0.6.0.0`, the `MonadTrans` and `MonadTransControl` instances 90 | for `ActionT e` now have a `ScottyError e` instance context to match the 91 | `Monad` instance. 92 | 93 | ## 0.12 [2020.05.16] 94 | * Provide `MonadReader` and `MonadState` instances for `ActionT`. 95 | * Add HTTP Status code as a field to `ActionError`, and add 96 | a sister function to `raise`, `raiseStatus`. This makes 97 | throwing a specific error code and exiting much cleaner, and 98 | avoids the strange defaulting to HTTP 500. This will make internal 99 | functions easier to implement with the right status codes 'thrown', 100 | such as `jsonData`. 101 | * Correct http statuses returned by `jsonData` (#228). 102 | * Better error message when no data is provided to `jsonData` (#226). 103 | * Add `Semigroup` and `Monoid` instances for `ActionT` and `ScottyT` 104 | * ScottyT: Use strict StateT instead of lazy 105 | * Handle adjacent slashes in the request path as one (thanks @SkyWriter) 106 | 107 | ## 0.11.5 [2019.09.07] 108 | * Allow building the test suite with `hspec-wai-0.10`. 109 | 110 | ## 0.11.4 [2019.05.02] 111 | * Allow building with `base-4.13` (GHC 8.8). 112 | 113 | ## 0.11.3 [2019.01.08] 114 | * Drop the test suite's dependency on `hpc-coveralls`, which is unmaintained 115 | and does not build with GHC 8.4 or later. 116 | 117 | ## 0.11.2 [2018.07.02] 118 | * Migrate from `Network` to `Network.Socket` to avoid deprecation warnings. 119 | 120 | ## 0.11.1 [2018.04.07] 121 | * Add `MonadThrow` and `MonadCatch` instances for `ActionT` [abhinav] 122 | * Fix `matchAny` so that all methods are matched, not just standard ones 123 | [taphu] 124 | 125 | ## 0.11.0 126 | * IO exceptions are no longer automatically turned into ScottyErrors by 127 | `liftIO`. Use `liftAndCatchIO` to get that behavior. 128 | * New `finish` function. 129 | * Text values are now leniently decoded from ByteStrings. 130 | * Added `MonadFail` instance for `ScottyT` 131 | * Lots of bound bumps on dependencies. 132 | 133 | ## 0.10.2 134 | * Removed debug statement from routes 135 | 136 | ## 0.10.1 137 | * `Parsable` instances for `Word`, `Word8`, `Word16`, `Word32`, `Word64` 138 | [adamflott] 139 | * `Parsable` instances for `Int8`, `Int16`, `Int32`, `Int64`, and `Natural` 140 | * Removed redundant `Monad` constraint on `middleware` 141 | 142 | ## 0.10.0 143 | 144 | * The monad parameters to `ScottyT` have been decoupled, causing the type 145 | of the `ScottyT` constructor to change. As a result, `ScottyT` is no 146 | longer a `MonadTrans` instance, and the type signatures of`scottyT`, 147 | `scottyAppT`, and `scottyOptsT` have been simplified. [ehamberg] 148 | 149 | * `socketDescription` no longer uses the deprecated `PortNum` constructor. 150 | Instead, it uses the `Show` instance for `PortNumber`. This changes the 151 | bytes from host to network order, so the output of `socketDescription` 152 | could change. [ehamberg] 153 | 154 | * `Alternative`, `MonadPlus` instances for `ActionT` 155 | 156 | * `scotty` now depends on `transformers-compat`. As a result, `ActionT` now 157 | uses `ExceptT`, regardless of which version of `transformers` is used. 158 | As a result, several functions in `Web.Scotty.Trans` no longer require a 159 | `ScottyError` constraint, since `ExceptT` does not require an `Error` 160 | constraint (unlike `ErrorT`). 161 | 162 | * Added support for OPTIONS routes via the `options` function [alvare] 163 | 164 | * Add `scottySocket` and `scottySocketT`, exposing Warp Unix socket support 165 | [hakujin] 166 | 167 | * `Parsable` instance for lazy `ByteString` [tattsun] 168 | 169 | * Added streaming uploads via the `bodyReader` function, which retrieves chunks 170 | of the request body. [edofic] 171 | - `ActionEnv` had a `getBodyChunk` field added (in 172 | `Web.Scotty.Internal.Types`) 173 | - `RequestBodyState` and `BodyPartiallyStreamed` added to 174 | `Web.Scotty.Internal.Types` 175 | 176 | * `jsonData` uses `aeson`'s `eitherDecode` instead of just `decode` [k-bx] 177 | 178 | ## 0.9.1 179 | 180 | * text/html/json only set Content-Type header when not already set 181 | 182 | ## 0.9.0 183 | 184 | * Add `charset=utf-8` to `Content-Type` for `text`, `html` and `json` 185 | 186 | * Assume HTTP status 500 for `defaultHandler` 187 | 188 | * Remove deprecated `source` method. 189 | 190 | * No longer depend on conduit. 191 | 192 | ## 0.8.2 193 | 194 | * Bump `aeson` upper bound 195 | 196 | * Fix `mtl` related deprecation warnings 197 | 198 | ## 0.8.1 199 | 200 | * Export internal types 201 | 202 | * Added `MonadBase`, `MonadTransControl` and `MonadBaseControl` instances for 203 | `ActionT` 204 | 205 | ## 0.8.0 206 | 207 | * Upgrade to wai/wai-extra/warp 3.0 208 | 209 | * No longer depend on conduit-extra. 210 | 211 | * The `source` response method has been deprecated in favor 212 | of a new `stream` response, matching changes in WAI 3.0. 213 | 214 | * Removed the deprecated `reqHeader` function. 215 | 216 | ## 0.7.3 217 | 218 | * Bump upper bound for case-insensitive, mtl and transformers. 219 | 220 | ## 0.7.2 221 | 222 | * Bump lower bound on conduit, add conduit-extra to cabal build depends. 223 | 224 | ## 0.7.1 225 | 226 | * Default warp settings now use `setFdCacheDuration 0` to work around a warp 227 | issue where file changes are not getting picked up. 228 | 229 | ## 0.7.0 230 | 231 | * Renamed `reqHeader` to `header`. Added `headers` function to get all headers. 232 | 233 | * Changed `MonadIO` instance for `ActionT` such that IO exceptions are lifted 234 | into `ScottyError`s via `stringError`. 235 | 236 | * Make `Bool` parsing case-insensitive. Goal: support both Haskell's True/False 237 | and Javascript's true/false. Thanks to Ben Gamari for suggesting this. 238 | 239 | * Bump `aeson`/`text` upper bounds. 240 | 241 | * Bump `wai`/`wai-extra`/`warp` bounds, including new lower bound for `warp`, which fixes a security issue related to Slowloris protection. 242 | 243 | ## 0.6.2 244 | 245 | * Bump upper bound for `text`. 246 | 247 | ## 0.6.1 248 | 249 | * Match changes in `wai-extra`. 250 | 251 | ## 0.6.0 252 | 253 | * The Scotty transformers (`ScottyT` and `ActionT`) are now parameterized 254 | over a custom exception type, allowing one to extend Scotty's `ErrorT` 255 | layer with something richer than `Text` errors. See the `exceptions` 256 | example for use. `ScottyM` and `ActionM` remain specialized to `Text` 257 | exceptions for simplicity. 258 | 259 | * Both monads are now instances of `Functor` and `Applicative`. 260 | 261 | * There is a new `cookies` example. 262 | 263 | * Internals brought up-to-date with WAI 2.0 and related packages. 264 | 265 | ## 0.5.0 266 | 267 | * The Scotty monads (`ScottyM` and `ActionM`) are now monad transformers, 268 | allowing Scotty applications to be embedded in arbitrary `MonadIO`s. 269 | The old API continues to be exported from `Web.Scotty` where: 270 | 271 | type ScottyM = ScottyT IO 272 | type ActionM = ActionT IO 273 | 274 | The new transformers are found in `Web.Scotty.Trans`. See the 275 | `globalstate` example for use. Special thanks to Dan Frumin (co-dan) 276 | for much of the legwork here. 277 | 278 | * Added support for HTTP PATCH method. 279 | 280 | * Removed lambda action syntax. This will return when we have a better 281 | story for typesafe routes. 282 | 283 | * `reqHeader :: Text -> ActionM Text` ==> 284 | `reqHeader :: Text -> ActionM (Maybe Text)` 285 | 286 | * New `raw` method to set body to a raw `ByteString` 287 | 288 | * Parse error thrown by `jsonData` now includes the body it couldn't parse. 289 | 290 | * `header` split into `setHeader` and `addHeader`. The former replaces 291 | a response header (original behavior). The latter adds a header (useful 292 | for multiple `Set-Cookie`s, for instance). 293 | -------------------------------------------------------------------------------- /doctest/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | #if __GLASGOW_HASKELL__ >= 946 5 | import Test.DocTest (doctest) 6 | 7 | -- 1. Our current doctests require a number of imports that scotty doesn't need 8 | -- 2. declaring doctest helper functions in this module doesn't seem to work 9 | -- 3. cabal tests cannot have exposed modules? 10 | -- 4. GHCi only started supporting multiline imports since 9.4.6 ( https://gitlab.haskell.org/ghc/ghc/-/issues/20473 ) 11 | -- so lacking a better option we no-op doctest for older GHCs 12 | 13 | main :: IO () 14 | main = doctest [ 15 | "Web/Scotty.hs" 16 | , "Web/Scotty/Trans.hs" 17 | , "-XOverloadedStrings" 18 | , "-XLambdaCase" 19 | ] 20 | #else 21 | main :: IO () 22 | main = pure () 23 | #endif 24 | -------------------------------------------------------------------------------- /examples/404.html: -------------------------------------------------------------------------------- 1 |

This is a 404 page!

2 | -------------------------------------------------------------------------------- /examples/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012-2017 Andrew Farmer 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above 11 | copyright notice, this list of conditions and the following 12 | disclaimer in the documentation and/or other materials provided 13 | with the distribution. 14 | 15 | * Neither the name of Andrew Farmer nor the names of other 16 | contributors may be used to endorse or promote products derived 17 | from this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /examples/basic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# language DeriveAnyClass #-} 3 | {-# language ScopedTypeVariables #-} 4 | module Main (main) where 5 | 6 | import Web.Scotty 7 | 8 | import Network.Wai.Middleware.RequestLogger -- install wai-extra if you don't have this 9 | 10 | import Control.Exception (Exception(..)) 11 | import Control.Monad 12 | -- import Control.Monad.Trans 13 | import System.Random (newStdGen, randomRs) 14 | 15 | import Network.HTTP.Types (status302) 16 | 17 | import Data.Text.Lazy (pack) 18 | import Data.Text.Lazy.Encoding (decodeUtf8) 19 | import Data.String (fromString) 20 | import Data.Typeable (Typeable) 21 | 22 | data Err = Boom | UserAgentNotFound | NeverReached deriving (Show, Typeable, Exception) 23 | 24 | 25 | main :: IO () 26 | main = scotty 3000 $ do 27 | -- Add any WAI middleware, they are run top-down. 28 | middleware logStdoutDev 29 | 30 | -- get (function $ \req -> Just [("version", T.pack $ show $ httpVersion req)]) $ do 31 | -- v <- param "version" 32 | -- text v 33 | 34 | -- To demonstrate that routes are matched top-down. 35 | get "/" $ text "foobar" 36 | get "/" $ text "barfoo" 37 | 38 | -- Looking for a parameter in the path. Since the path pattern does not 39 | -- contain the parameter name 'p', the server responds with 500 Server Error. 40 | get "/foo_fail" $ do 41 | v <- pathParam "p" 42 | html $ mconcat ["

", v, "

"] 43 | 44 | -- Looking for a parameter 'p' in the path. 45 | get "/foo_path/:p" $ do 46 | v <- pathParam "p" 47 | html $ mconcat ["

", v, "

"] 48 | 49 | -- Looking for a parameter 'p' in the query string. 50 | get "/foo_query" $ do 51 | v <- queryParam "p" 52 | html $ mconcat ["

", v, "

"] 53 | 54 | -- An uncaught error becomes a 500 page. 55 | get "/raise" $ throw Boom 56 | 57 | -- You can set status and headers directly. 58 | get "/redirect-custom" $ do 59 | status status302 60 | setHeader "Location" "http://www.google.com" 61 | -- note first arg to header is NOT case-sensitive 62 | 63 | -- redirects preempt execution 64 | get "/redirect" $ do 65 | void $ redirect "http://www.google.com" 66 | throw NeverReached 67 | 68 | -- Of course you can catch your own errors. 69 | get "/rescue" $ do 70 | (do void $ throw Boom; redirect "http://www.we-never-go-here.com") 71 | `catch` (\(e :: Err) -> text $ "we recovered from " `mappend` pack (show e)) 72 | 73 | -- Parts of the URL that start with a colon match 74 | -- any string, and capture that value as a parameter. 75 | -- URL captures take precedence over query string parameters. 76 | get "/foo/:bar/required" $ do 77 | v <- pathParam "bar" 78 | html $ mconcat ["

", v, "

"] 79 | 80 | -- Files are streamed directly to the client. 81 | get "/404" $ file "404.html" 82 | 83 | -- 'next' stops execution of the current action and keeps pattern matching routes. 84 | get "/random" $ do 85 | void next 86 | redirect "http://www.we-never-go-here.com" 87 | 88 | -- You can do IO with liftIO, and you can return JSON content. 89 | get "/random" $ do 90 | g <- liftIO newStdGen 91 | json $ take 20 $ randomRs (1::Int,100) g 92 | 93 | get "/ints/:is" $ do 94 | is <- pathParam "is" 95 | json $ [(1::Int)..10] ++ is 96 | 97 | get "/setbody" $ do 98 | html $ mconcat ["
" 99 | ,"" 100 | ,"" 101 | ,"
" 102 | ] 103 | 104 | -- Read and decode the request body as UTF-8 105 | post "/readbody" $ do 106 | b <- body 107 | text $ decodeUtf8 b 108 | 109 | -- Look up a request header 110 | get "/header" $ do 111 | agent <- header "User-Agent" 112 | maybe (throw UserAgentNotFound) text agent 113 | 114 | -- Make a request to this URI, then type a line in the terminal, which 115 | -- will be the response. Using ctrl-c will cause getLine to fail. 116 | -- This demonstrates that IO exceptions are lifted into ActionM exceptions. 117 | -- 118 | -- (#310) we don't catch async exceptions, so ctrl-c just exits the program 119 | get "/iofail" $ do 120 | msg <- liftIO $ liftM fromString getLine 121 | text msg 122 | 123 | {- If you don't want to use Warp as your webserver, 124 | you can use any WAI handler. 125 | 126 | import Network.Wai.Handler.FastCGI (run) 127 | 128 | main = do 129 | myApp <- scottyApp $ do 130 | get "/" $ text "hello world" 131 | 132 | run myApp 133 | -} 134 | 135 | -------------------------------------------------------------------------------- /examples/bodyecho.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import Web.Scotty 5 | 6 | -- import Control.Monad.IO.Class (liftIO) 7 | import qualified Blaze.ByteString.Builder as B 8 | import qualified Data.ByteString as BS 9 | import qualified Data.ByteString.Lazy as BSL 10 | import qualified Data.Text.Lazy as T 11 | 12 | main :: IO () 13 | main = scotty 3000 $ do 14 | post "/echo" $ do 15 | rd <- bodyReader 16 | stream $ ioCopy rd $ return () 17 | 18 | post "/count" $ do 19 | wb <- body -- this must happen before first 'rd' 20 | rd <- bodyReader 21 | let step acc = do 22 | chunk <- rd 23 | putStrLn "got a chunk" 24 | let len = BS.length chunk 25 | if len > 0 26 | then step $ acc + len 27 | else return acc 28 | len <- liftIO $ step 0 29 | text $ T.pack $ "uploaded " ++ show len ++ " bytes, wb len is " ++ show (BSL.length wb) 30 | 31 | 32 | ioCopy :: IO BS.ByteString -> IO () -> (B.Builder -> IO ()) -> IO () -> IO () 33 | ioCopy reader close write flush = step >> flush where 34 | step = do chunk <- reader 35 | if (BS.length chunk > 0) 36 | then (write $ B.insertByteString chunk) >> step 37 | else close 38 | -------------------------------------------------------------------------------- /examples/cookies.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | -- This examples requires you to: cabal install blaze-html 3 | module Main (main) where 4 | 5 | import Control.Monad (forM_) 6 | 7 | import qualified Text.Blaze.Html5 as H 8 | import Text.Blaze.Html5.Attributes 9 | import Text.Blaze.Html.Renderer.Text (renderHtml) 10 | import Web.Scotty -- Web.Scotty exports setSimpleCookie,getCookies 11 | import Web.Scotty.Cookie (CookiesText) 12 | 13 | renderCookiesTable :: CookiesText -> H.Html 14 | renderCookiesTable cs = 15 | H.table $ do 16 | H.tr $ do 17 | H.th "name" 18 | H.th "value" 19 | forM_ cs $ \(name', val) -> do 20 | H.tr $ do 21 | H.td (H.toMarkup name') 22 | H.td (H.toMarkup val) 23 | 24 | main :: IO () 25 | main = scotty 3000 $ do 26 | get "/" $ do 27 | cookies <- getCookies 28 | html $ renderHtml $ do 29 | renderCookiesTable cookies 30 | H.form H.! method "post" H.! action "/set-a-cookie" $ do 31 | H.input H.! type_ "text" H.! name "name" 32 | H.input H.! type_ "text" H.! name "value" 33 | H.input H.! type_ "submit" H.! value "set a cookie" 34 | 35 | post "/set-a-cookie" $ do 36 | name' <- pathParam "name" 37 | value' <- pathParam "value" 38 | setSimpleCookie name' value' 39 | redirect "/" 40 | -------------------------------------------------------------------------------- /examples/exceptions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} 2 | {-# language DeriveAnyClass #-} 3 | {-# language LambdaCase #-} 4 | module Main (main) where 5 | 6 | import Control.Exception (Exception(..)) 7 | import Control.Monad.IO.Class 8 | import Control.Monad.IO.Unlift (MonadUnliftIO(..)) 9 | 10 | import Data.String (fromString) 11 | import Data.Typeable 12 | 13 | import Network.HTTP.Types 14 | import Network.Wai.Middleware.RequestLogger 15 | 16 | import System.Random 17 | 18 | import Web.Scotty.Trans 19 | 20 | -- | A custom exception type. 21 | data Except = Forbidden | NotFound Int | StringEx String 22 | deriving (Show, Eq, Typeable, Exception) 23 | 24 | -- | User-defined exceptions should have an associated Handler: 25 | handleEx :: MonadIO m => ErrorHandler m 26 | handleEx = Handler $ \case 27 | Forbidden -> do 28 | status status403 29 | html "

Scotty Says No

" 30 | NotFound i -> do 31 | status status404 32 | html $ fromString $ "

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

" 33 | StringEx s -> do 34 | status status500 35 | html $ fromString $ "

" ++ s ++ "

" 36 | 37 | main :: IO () 38 | main = do 39 | scottyT 3000 id server -- note: we use 'id' since we don't have to run any effects at each action 40 | 41 | -- Any custom monad stack will need to implement 'MonadUnliftIO' 42 | server :: MonadUnliftIO m => ScottyT m () 43 | server = do 44 | middleware logStdoutDev 45 | 46 | defaultHandler handleEx -- define what to do with uncaught exceptions 47 | 48 | get "/" $ do 49 | html $ mconcat ["Option 1 (Not Found)" 50 | ,"
" 51 | ,"Option 2 (Forbidden)" 52 | ,"
" 53 | ,"Option 3 (Random)" 54 | ] 55 | 56 | get "/switch/:val" $ do 57 | v <- pathParam "val" 58 | _ <- if even v then throw Forbidden else throw (NotFound v) 59 | text "this will never be reached" 60 | 61 | get "/random" $ do 62 | rBool <- liftIO randomIO 63 | i <- liftIO randomIO 64 | let catchOne Forbidden = html "

Forbidden was randomly thrown, but we caught it." 65 | catchOne other = throw other 66 | throw (if rBool then Forbidden else NotFound i) `catch` catchOne 67 | -------------------------------------------------------------------------------- /examples/globalstate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} 2 | -- An example of embedding a custom monad into 3 | -- Scotty's transformer stack, using ReaderT to provide access 4 | -- to a TVar containing global state. 5 | -- 6 | -- Note: this example is somewhat simple, as our top level 7 | -- is IO itself. The types of 'scottyT' and 'scottyAppT' are 8 | -- general enough to allow a Scotty application to be 9 | -- embedded into any MonadIO monad. 10 | module Main (main) where 11 | 12 | import Control.Concurrent.STM 13 | import Control.Monad.IO.Unlift (MonadUnliftIO(..)) 14 | import Control.Monad.Reader 15 | 16 | import Data.String 17 | 18 | import Network.Wai.Middleware.RequestLogger 19 | 20 | import Web.Scotty.Trans 21 | 22 | newtype AppState = AppState { tickCount :: Int } 23 | 24 | defaultAppState :: AppState 25 | defaultAppState = AppState 0 26 | 27 | -- Why 'ReaderT (TVar AppState)' rather than 'StateT AppState'? 28 | -- With a state transformer, 'runActionToIO' (below) would have 29 | -- to provide the state to _every action_, and save the resulting 30 | -- state, using an MVar. This means actions would be blocking, 31 | -- effectively meaning only one request could be serviced at a time. 32 | -- The 'ReaderT' solution means only actions that actually modify 33 | -- the state need to block/retry. 34 | -- 35 | -- Also note: your monad must be an instance of 'MonadIO' for 36 | -- Scotty to use it. 37 | newtype WebM a = WebM { runWebM :: ReaderT (TVar AppState) IO a } 38 | deriving (Applicative, Functor, Monad, MonadIO, MonadReader (TVar AppState), MonadUnliftIO) 39 | 40 | -- Scotty's monads are layered on top of our custom monad. 41 | -- We define this synonym for lift in order to be explicit 42 | -- about when we are operating at the 'WebM' layer. 43 | webM :: MonadTrans t => WebM a -> t WebM a 44 | webM = lift 45 | 46 | -- Some helpers to make this feel more like a state monad. 47 | gets :: (AppState -> b) -> WebM b 48 | gets f = ask >>= liftIO . readTVarIO >>= return . f 49 | 50 | modify :: (AppState -> AppState) -> WebM () 51 | modify f = ask >>= liftIO . atomically . flip modifyTVar' f 52 | 53 | main :: IO () 54 | main = do 55 | sync <- newTVarIO defaultAppState 56 | -- 'runActionToIO' is called once per action. 57 | let runActionToIO m = runReaderT (runWebM m) sync 58 | 59 | scottyT 3000 runActionToIO app 60 | 61 | -- This app doesn't use raise/rescue, so the exception 62 | -- type is ambiguous. We can fix it by putting a type 63 | -- annotation just about anywhere. In this case, we'll 64 | -- just do it on the entire app. 65 | app :: ScottyT WebM () 66 | app = do 67 | middleware logStdoutDev 68 | get "/" $ do 69 | c <- webM $ gets tickCount 70 | text $ fromString $ show c 71 | 72 | get "/plusone" $ do 73 | webM $ modify $ \ st -> st { tickCount = tickCount st + 1 } 74 | redirect "/" 75 | 76 | get "/plustwo" $ do 77 | webM $ modify $ \ st -> st { tickCount = tickCount st + 2 } 78 | redirect "/" 79 | -------------------------------------------------------------------------------- /examples/gzip.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import Network.Wai.Middleware.RequestLogger 5 | import Network.Wai.Middleware.Gzip 6 | 7 | import Web.Scotty 8 | 9 | main :: IO () 10 | main = scotty 3000 $ do 11 | -- Note that files are not gzip'd by the default settings. 12 | middleware $ gzip $ def { gzipFiles = GzipCompress } 13 | middleware logStdoutDev 14 | 15 | -- gzip a normal response 16 | get "/" $ text "It works" 17 | 18 | -- gzip a file response (note non-default gzip settings above) 19 | get "/afile" $ do 20 | setHeader "content-type" "text/plain" 21 | file "gzip.hs" 22 | -------------------------------------------------------------------------------- /examples/nested.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Web.Scotty 6 | import Network.Wai 7 | import qualified Data.Text.Lazy as TL 8 | import Network.HTTP.Types.Status 9 | import Data.Monoid (mconcat) 10 | 11 | simpleApp :: Application 12 | simpleApp _ respond = do 13 | putStrLn "I've done some IO here" 14 | respond $ responseLBS 15 | status200 16 | [("Content-Type", "text/plain")] 17 | "Hello, Web!" 18 | 19 | scottApp :: IO Application 20 | scottApp = scottyApp $ do 21 | 22 | get "/" $ do 23 | html $ mconcat ["

Scotty, beam me up!

"] 24 | 25 | get "/other/test/:word" $ do 26 | beam <- param "word" 27 | html $ mconcat ["

Scotty, ", beam, " me up!

"] 28 | 29 | get "/test/:word" $ do 30 | beam <- param "word" 31 | html $ mconcat ["

Scotty, ", beam, " me up!

"] 32 | 33 | get "/nested" $ nested simpleApp 34 | get "/other/nested" $ nested simpleApp 35 | 36 | notFound $ do 37 | r <- request 38 | html (TL.pack (show (pathInfo r))) 39 | 40 | -- For example, returns path info: ["other","qwer","adxf","jkashdfljhaslkfh","qwer"] 41 | -- for request http://localhost:3000/other/qwer/adxf/jkashdfljhaslkfh/qwer 42 | 43 | main :: IO () 44 | main = do 45 | 46 | otherApp <- scottApp 47 | 48 | scotty 3000 $ do 49 | 50 | get "/" $ do 51 | html $ mconcat ["

Scotty, beam me up!

"] 52 | 53 | get "/test/:word" $ do 54 | beam <- param "word" 55 | html $ mconcat ["

Scotty, ", beam, " me up!

"] 56 | 57 | get "/simple" $ nested simpleApp 58 | 59 | get "/other" $ nested otherApp 60 | 61 | get (regex "/other/.*") $ nested otherApp 62 | 63 | 64 | -------------------------------------------------------------------------------- /examples/options.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import Web.Scotty 5 | 6 | import Network.Wai.Middleware.RequestLogger -- install wai-extra if you don't have this 7 | 8 | import Network.Wai.Handler.Warp (setPort) 9 | 10 | -- Set some Scotty settings 11 | opts :: Options 12 | opts = defaultOptions { verbose = 0 13 | , settings = setPort 4000 $ settings defaultOptions 14 | } 15 | 16 | -- This won't display anything at startup, and will listen on localhost:4000 17 | main :: IO () 18 | main = scottyOpts opts $ do 19 | middleware logStdoutDev 20 | 21 | get "/" $ text "hello world" 22 | -------------------------------------------------------------------------------- /examples/reader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | {- 5 | An example of embedding a custom monad into Scotty's transformer 6 | stack, using ReaderT to provide access to a global state. 7 | -} 8 | module Main where 9 | 10 | import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, asks, lift, runReaderT) 11 | import Control.Monad.IO.Unlift (MonadUnliftIO(..)) 12 | import Data.Text.Lazy (pack) 13 | import Web.Scotty.Trans (ScottyT, defaultOptions, get, scottyOptsT, text) 14 | 15 | data Config = Config 16 | { environment :: String 17 | } deriving (Eq, Read, Show) 18 | 19 | newtype ConfigM a = ConfigM 20 | { runConfigM :: ReaderT Config IO a 21 | } deriving (Applicative, Functor, Monad, MonadIO, MonadReader Config, MonadUnliftIO) 22 | 23 | application :: ScottyT ConfigM () 24 | application = do 25 | get "/" $ do 26 | e <- lift $ asks environment 27 | text $ pack $ show e 28 | 29 | main :: IO () 30 | main = scottyOptsT defaultOptions runIO application where 31 | runIO :: ConfigM a -> IO a 32 | runIO m = runReaderT (runConfigM m) config 33 | 34 | config :: Config 35 | config = Config 36 | { environment = "Development" 37 | } 38 | -------------------------------------------------------------------------------- /examples/scotty-examples.cabal: -------------------------------------------------------------------------------- 1 | Name: scotty-examples 2 | Version: 0.1 3 | Synopsis: scotty examples 4 | Homepage: https://github.com/scotty-web/scotty 5 | Bug-reports: https://github.com/scotty-web/scotty/issues 6 | License: BSD3 7 | License-file: LICENSE 8 | Author: Andrew Farmer 9 | Maintainer: Andrew Farmer 10 | Copyright: (c) 2012-Present, Andrew Farmer and the Scotty contributors 11 | Category: Web 12 | Stability: experimental 13 | Build-type: Simple 14 | Cabal-version: >= 1.10 15 | Description: Example programs using @scotty@ 16 | tested-with: GHC == 8.10.7 17 | , GHC == 9.0.2 18 | , GHC == 9.2.8 19 | , GHC == 9.4.6 20 | , GHC == 9.6.2 21 | 22 | executable scotty-basic 23 | main-is: basic.hs 24 | default-language: Haskell2010 25 | hs-source-dirs: . 26 | build-depends: base >= 4.6 && < 5, 27 | http-types, 28 | mtl, 29 | random, 30 | scotty, 31 | text, 32 | wai-extra 33 | GHC-options: -Wall -threaded 34 | 35 | executable scotty-bodyecho 36 | main-is: bodyecho.hs 37 | default-language: Haskell2010 38 | hs-source-dirs: . 39 | build-depends: base >= 4.6 && < 5, 40 | blaze-builder, 41 | bytestring, 42 | scotty, 43 | transformers, 44 | text 45 | GHC-options: -Wall -threaded 46 | 47 | executable scotty-cookies 48 | main-is: cookies.hs 49 | default-language: Haskell2010 50 | hs-source-dirs: . 51 | build-depends: base >= 4.6 && < 5, 52 | blaze-builder, 53 | blaze-html, 54 | bytestring, 55 | cookie, 56 | scotty, 57 | text 58 | GHC-options: -Wall -threaded 59 | 60 | executable scotty-exceptions 61 | main-is: exceptions.hs 62 | default-language: Haskell2010 63 | hs-source-dirs: . 64 | build-depends: base >= 4.6 && < 5, 65 | http-types, 66 | random, 67 | scotty, 68 | transformers, 69 | unliftio-core, 70 | wai-extra 71 | GHC-options: -Wall -threaded 72 | 73 | executable scotty-globalstate 74 | main-is: globalstate.hs 75 | default-language: Haskell2010 76 | hs-source-dirs: . 77 | build-depends: base >= 4.6 && < 5, 78 | mtl, 79 | scotty, 80 | stm, 81 | text, 82 | transformers, 83 | unliftio-core >= 0.2, 84 | wai-extra 85 | GHC-options: -Wall -threaded 86 | 87 | executable scotty-gzip 88 | main-is: gzip.hs 89 | default-language: Haskell2010 90 | hs-source-dirs: . 91 | build-depends: base >= 4.6 && < 5, 92 | scotty, 93 | wai-extra 94 | GHC-options: -Wall -threaded 95 | 96 | executable scotty-options 97 | main-is: options.hs 98 | default-language: Haskell2010 99 | hs-source-dirs: . 100 | build-depends: base >= 4.6 && < 5, 101 | scotty, 102 | wai-extra, 103 | warp 104 | GHC-options: -Wall -threaded 105 | 106 | executable scotty-reader 107 | main-is: reader.hs 108 | default-language: Haskell2010 109 | hs-source-dirs: . 110 | build-depends: base >= 4.6 && < 5, 111 | mtl, 112 | scotty, 113 | text, 114 | unliftio-core >= 0.2 115 | GHC-options: -Wall -threaded 116 | 117 | executable scotty-upload 118 | main-is: upload.hs 119 | default-language: Haskell2010 120 | hs-source-dirs: . 121 | build-depends: base >= 4.6 && < 5, 122 | blaze-html, 123 | bytestring, 124 | filepath, 125 | scotty, 126 | text, 127 | transformers, 128 | wai-extra, 129 | wai-middleware-static 130 | GHC-options: -Wall -threaded 131 | 132 | executable scotty-urlshortener 133 | main-is: urlshortener.hs 134 | default-language: Haskell2010 135 | hs-source-dirs: . 136 | build-depends: base >= 4.6 && < 5, 137 | blaze-html, 138 | containers, 139 | scotty, 140 | text, 141 | transformers, 142 | wai-extra, 143 | wai-middleware-static 144 | GHC-options: -Wall -threaded 145 | 146 | source-repository head 147 | type: git 148 | location: https://github.com/scotty-web/scotty 149 | subdir: examples 150 | -------------------------------------------------------------------------------- /examples/session.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import Web.Scotty 5 | import qualified Data.Text.Lazy as LT 6 | import qualified Data.Text as T 7 | 8 | main :: IO () 9 | main = do 10 | sessionJar <- liftIO createSessionJar :: IO (SessionJar T.Text) 11 | scotty 3000 $ do 12 | -- Login route 13 | get "/login" $ do 14 | username <- queryParam "username" :: ActionM String 15 | password <- queryParam "password" :: ActionM String 16 | if username == "foo" && password == "bar" 17 | then do 18 | _ <- createUserSession sessionJar Nothing "foo" 19 | text "Login successful!" 20 | else 21 | text "Invalid username or password." 22 | -- Dashboard route 23 | get "/dashboard" $ do 24 | mUser <- readUserSession sessionJar 25 | case mUser of 26 | Nothing -> text "Hello, user." 27 | Just userName -> text $ "Hello, " <> LT.fromStrict userName <> "." 28 | -- Logout route 29 | get "/logout" $ do 30 | deleteCookie "sess_id" 31 | text "Logged out successfully." 32 | -------------------------------------------------------------------------------- /examples/static/jquery-json.js: -------------------------------------------------------------------------------- 1 | 2 | (function($){var escapeable=/["\\\x00-\x1f\x7f-\x9f]/g,meta={'\b':'\\b','\t':'\\t','\n':'\\n','\f':'\\f','\r':'\\r','"':'\\"','\\':'\\\\'};$.toJSON=typeof JSON==='object'&&JSON.stringify?JSON.stringify:function(o){if(o===null){return'null';} 3 | var type=typeof o;if(type==='undefined'){return undefined;} 4 | if(type==='number'||type==='boolean'){return''+o;} 5 | if(type==='string'){return $.quoteString(o);} 6 | if(type==='object'){if(typeof o.toJSON==='function'){return $.toJSON(o.toJSON());} 7 | if(o.constructor===Date){var month=o.getUTCMonth()+1,day=o.getUTCDate(),year=o.getUTCFullYear(),hours=o.getUTCHours(),minutes=o.getUTCMinutes(),seconds=o.getUTCSeconds(),milli=o.getUTCMilliseconds();if(month<10){month='0'+month;} 8 | if(day<10){day='0'+day;} 9 | if(hours<10){hours='0'+hours;} 10 | if(minutes<10){minutes='0'+minutes;} 11 | if(seconds<10){seconds='0'+seconds;} 12 | if(milli<100){milli='0'+milli;} 13 | if(milli<10){milli='0'+milli;} 14 | return'"'+year+'-'+month+'-'+day+'T'+ 15 | hours+':'+minutes+':'+seconds+'.'+milli+'Z"';} 16 | if(o.constructor===Array){var ret=[];for(var i=0;i)) 22 | 23 | {-| NB : the file paths where files are saved and looked up are relative, so make sure 24 | to run this program from the root directory of the 'scotty' repo, or adjust the paths 25 | accordingly. 26 | -} 27 | 28 | main :: IO () 29 | main = scotty 3000 $ do 30 | middleware logStdoutDev 31 | middleware $ staticPolicy (noDots >-> addBase "examples/uploads") 32 | 33 | get "/" $ do 34 | html $ renderHtml 35 | $ H.html $ do 36 | H.body $ do 37 | H.form H.! method "post" H.! enctype "multipart/form-data" H.! action "/upload" $ do 38 | H.input H.! type_ "file" H.! name "file_1" 39 | H.br 40 | H.input H.! type_ "file" H.! name "file_2" 41 | H.br 42 | H.input H.! type_ "submit" 43 | 44 | post "/upload" $ do 45 | filesOpts defaultParseRequestBodyOptions $ \_ fs -> do 46 | let 47 | fs' = [(fieldName, BS.unpack (fileName fi), fileContent fi) | (fieldName, fi) <- fs] 48 | -- write the files to disk, so they can be served by the static middleware 49 | for_ fs' $ \(_, fnam, fpath) -> do 50 | -- copy temp file to local dir 51 | liftIO (do 52 | fc <- B.readFile fpath 53 | B.writeFile ("examples" "uploads" fnam) fc 54 | ) `catch` (\(e :: SomeException) -> do 55 | liftIO $ putStrLn $ unwords ["upload: something went wrong while saving temp files :", show e] 56 | ) 57 | -- generate list of links to the files just uploaded 58 | html $ mconcat [ mconcat [ TL.fromStrict fName 59 | , ": " 60 | , renderHtml $ H.a (H.toHtml fn) H.! (href $ H.toValue fn) >> H.br 61 | ] 62 | | (fName,fn,_) <- fs' ] 63 | -------------------------------------------------------------------------------- /examples/uploads/.keep: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scotty-web/scotty/dbbfea99f3aed7c530313cb9248375c354d512e1/examples/uploads/.keep -------------------------------------------------------------------------------- /examples/urlshortener.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# language DeriveAnyClass #-} 3 | {-# language LambdaCase #-} 4 | -- {-# language ScopedTypeVariables #-} 5 | module Main (main) where 6 | 7 | import Web.Scotty 8 | 9 | import Control.Concurrent.MVar 10 | import Control.Exception (Exception(..)) 11 | import qualified Data.Map as M 12 | import qualified Data.Text.Lazy as T 13 | import Data.Typeable (Typeable) 14 | 15 | import Network.Wai.Middleware.RequestLogger 16 | import Network.Wai.Middleware.Static 17 | 18 | import qualified Text.Blaze.Html5 as H 19 | import Text.Blaze.Html5.Attributes 20 | -- Note: 21 | -- Scotty does not require blaze-html or 22 | -- wai-middleware-static, but this example does 23 | -- cabal install blaze-html wai-middleware-static 24 | import Text.Blaze.Html.Renderer.Text (renderHtml) 25 | 26 | -- TODO: 27 | -- Implement some kind of session (#317) and/or cookies 28 | -- Add links 29 | 30 | data SessionError = UrlHashNotFound Int deriving (Typeable, Exception) 31 | instance Show SessionError where 32 | show = \case 33 | UrlHashNotFound hash -> unwords ["URL hash #", show hash, " not found in database!"] 34 | 35 | main :: IO () 36 | main = do 37 | m <- newMVar (0::Int, M.empty :: M.Map Int T.Text) 38 | scotty 3000 $ do 39 | middleware logStdoutDev 40 | middleware static 41 | 42 | get "/" $ do 43 | html $ renderHtml 44 | $ H.html $ do 45 | H.body $ do 46 | H.form H.! method "post" H.! action "/shorten" $ do 47 | H.input H.! type_ "text" H.! name "url" 48 | H.input H.! type_ "submit" 49 | 50 | post "/shorten" $ do 51 | url <- formParam "url" 52 | liftIO $ modifyMVar_ m $ \(i,db) -> return (i+1, M.insert i (T.pack url) db) 53 | redirect "/list" 54 | 55 | -- We have to be careful here, because this route can match pretty much anything. 56 | -- Thankfully, the type system knows that 'hash' must be an Int, so this route 57 | -- only matches if 'parseParam' can successfully parse the hash capture as an Int. 58 | -- Otherwise, the pattern match will fail and Scotty will continue matching 59 | -- subsequent routes. 60 | get "/:hash" $ do 61 | hash <- captureParam "hash" 62 | (_,db) <- liftIO $ readMVar m 63 | case M.lookup hash db of 64 | Nothing -> throw $ UrlHashNotFound hash 65 | Just url -> redirect url 66 | 67 | -- We put /list down here to show that it will not match the '/:hash' route above. 68 | get "/list" $ do 69 | (_,db) <- liftIO $ readMVar m 70 | json $ M.toList db 71 | -------------------------------------------------------------------------------- /scotty.cabal: -------------------------------------------------------------------------------- 1 | Name: scotty 2 | Version: 0.22 3 | Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp 4 | Homepage: https://github.com/scotty-web/scotty 5 | Bug-reports: https://github.com/scotty-web/scotty/issues 6 | License: BSD3 7 | License-file: LICENSE 8 | Author: Andrew Farmer 9 | Maintainer: The Scotty maintainers 10 | Copyright: (c) 2012-Present, Andrew Farmer and the Scotty contributors 11 | Category: Web 12 | Stability: experimental 13 | Build-type: Simple 14 | Cabal-version: >= 1.10 15 | Description: 16 | A Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp. 17 | . 18 | @ 19 | {-# LANGUAGE OverloadedStrings #-} 20 | . 21 | import Web.Scotty 22 | . 23 | main = scotty 3000 $ 24 | get "/:word" $ do 25 | beam <- pathParam "word" 26 | html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"] 27 | @ 28 | . 29 | . 30 | Scotty is the cheap and cheerful way to write RESTful, declarative web applications. 31 | . 32 | * A page is as simple as defining the verb, url pattern, and Text content. 33 | . 34 | * It is template-language agnostic. Anything that returns a Text value will do. 35 | . 36 | * Conforms to WAI Application interface. 37 | . 38 | * Uses very fast Warp webserver by default. 39 | . 40 | As for the name: Sinatra + Warp = Scotty. 41 | . 42 | [WAI] 43 | . 44 | [Warp] 45 | tested-with: GHC == 8.10.7 46 | , GHC == 9.0.2 47 | , GHC == 9.2.8 48 | , GHC == 9.4.6 49 | , GHC == 9.6.4 50 | , GHC == 9.8.2 51 | Extra-source-files: 52 | README.md 53 | changelog.md 54 | examples/404.html 55 | examples/LICENSE 56 | examples/*.hs 57 | examples/static/jquery.js 58 | examples/static/jquery-json.js 59 | examples/uploads/.keep 60 | 61 | Library 62 | Exposed-modules: Web.Scotty 63 | Web.Scotty.Trans 64 | Web.Scotty.Trans.Strict 65 | Web.Scotty.Internal.Types 66 | Web.Scotty.Cookie 67 | Web.Scotty.Session 68 | other-modules: Web.Scotty.Action 69 | Web.Scotty.Body 70 | Web.Scotty.Route 71 | Web.Scotty.Trans.Lazy 72 | Web.Scotty.Util 73 | default-language: Haskell2010 74 | build-depends: aeson >= 0.6.2.1 && < 2.3, 75 | base >= 4.14 && < 5, 76 | blaze-builder >= 0.3.3.0 && < 0.5, 77 | bytestring >= 0.10.0.2 , 78 | case-insensitive >= 1.0.0.1 && < 1.3, 79 | cookie >= 0.4, 80 | exceptions >= 0.7 && < 0.11, 81 | http-api-data >= 0.5.1, 82 | http-types >= 0.9.1 && < 0.13, 83 | monad-control >= 1.0.0.3 && < 1.1, 84 | mtl >= 2.1.2 && < 2.4, 85 | network >= 2.6.0.2 && < 3.2, 86 | regex-compat >= 0.95.1 && < 0.96, 87 | resourcet, 88 | stm, 89 | text >= 0.11.3.1 , 90 | time >= 1.8, 91 | transformers >= 0.3.0.0 && < 0.7, 92 | transformers-base >= 0.4.1 && < 0.5, 93 | unliftio >= 0.2, 94 | unordered-containers >= 0.2.10.0 && < 0.3, 95 | wai >= 3.0.0 && < 3.3, 96 | wai-extra >= 3.1.14, 97 | warp >= 3.0.13, 98 | random >= 1.0.0.0 99 | 100 | if impl(ghc < 8.0) 101 | build-depends: fail 102 | 103 | if impl(ghc < 7.10) 104 | build-depends: nats >= 0.1 && < 2 105 | 106 | GHC-options: -Wall -fno-warn-orphans 107 | 108 | test-suite spec 109 | main-is: Spec.hs 110 | other-modules: Web.ScottySpec 111 | Test.Hspec.Wai.Extra 112 | type: exitcode-stdio-1.0 113 | default-language: Haskell2010 114 | hs-source-dirs: test 115 | build-depends: async, 116 | base, 117 | bytestring, 118 | directory, 119 | hspec == 2.*, 120 | hspec-wai >= 0.6.3, 121 | http-api-data, 122 | http-types, 123 | lifted-base, 124 | network, 125 | scotty, 126 | text, 127 | time, 128 | wai, 129 | wai-extra 130 | build-tool-depends: hspec-discover:hspec-discover == 2.* 131 | GHC-options: -Wall -threaded -fno-warn-orphans 132 | 133 | test-suite doctest 134 | main-is: Main.hs 135 | type: exitcode-stdio-1.0 136 | default-language: Haskell2010 137 | GHC-options: -Wall -threaded -fno-warn-orphans 138 | hs-source-dirs: doctest 139 | build-depends: base 140 | , bytestring 141 | , doctest >= 0.20.1 142 | , http-client 143 | , http-types 144 | , scotty 145 | , text 146 | , wai 147 | 148 | benchmark weigh 149 | main-is: Main.hs 150 | type: exitcode-stdio-1.0 151 | default-language: Haskell2010 152 | hs-source-dirs: bench 153 | build-depends: base, 154 | scotty, 155 | lucid, 156 | bytestring, 157 | mtl, 158 | resourcet, 159 | text, 160 | transformers, 161 | weigh >= 0.0.16 && <0.1 162 | GHC-options: -Wall -O2 -threaded 163 | 164 | source-repository head 165 | type: git 166 | location: git://github.com/scotty-web/scotty.git 167 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/Test/Hspec/Wai/Extra.hs: -------------------------------------------------------------------------------- 1 | -- | This should be in 'hspec-wai', PR pending as of Feb 2024 : https://github.com/hspec/hspec-wai/pull/77 2 | -- 3 | -- NB the code below has been changed wrt PR 77 and works in the scotty test suite as well. 4 | 5 | {-# language OverloadedStrings #-} 6 | module Test.Hspec.Wai.Extra (postMultipartForm, FileMeta(..)) where 7 | 8 | import qualified Data.Char as Char 9 | import Data.List (intersperse) 10 | 11 | import Data.ByteString (ByteString) 12 | import qualified Data.ByteString.Builder as Builder 13 | import qualified Data.ByteString.Lazy as LB 14 | 15 | import Data.Word (Word8) 16 | 17 | import Network.HTTP.Types (methodPost, hContentType) 18 | import Network.Wai.Test (SResponse) 19 | 20 | import Test.Hspec.Wai (request) 21 | import Test.Hspec.Wai.Internal (WaiSession) 22 | 23 | -- | @POST@ a @multipart/form-data@ form which might include files. 24 | -- 25 | -- The @Content-Type@ is set to @multipart/form-data; boundary=@ where @bd@ is the part separator without the @--@ prefix. 26 | postMultipartForm :: ByteString -- ^ path 27 | -> ByteString -- ^ part separator without any dashes 28 | -> [(FileMeta, ByteString, ByteString, ByteString)] -- ^ (file metadata, field MIME type, field name, field contents) 29 | -> WaiSession st SResponse 30 | postMultipartForm path sbs = 31 | request methodPost path [(hContentType, "multipart/form-data; boundary=" <> sbs)] . formMultipartQuery sbs 32 | 33 | -- | Encode the body of a multipart form post 34 | -- 35 | -- schema from : https://swagger.io/docs/specification/describing-request-body/multipart-requests/ 36 | formMultipartQuery :: ByteString -- ^ part separator without any dashes 37 | -> [(FileMeta, ByteString, ByteString, ByteString)] -- ^ (file metadata, field MIME type, field name, field contents) 38 | -> LB.ByteString 39 | formMultipartQuery sbs = Builder.toLazyByteString . mconcat . intersperse newline . encodeAll 40 | where 41 | encodeAll fs = map encodeFile fs <> [sepEnd] 42 | encodeFile (fieldMeta, ty, n, payload) = mconcat $ [ 43 | sep 44 | , newline 45 | , kv "Content-Disposition" ("form-data;" <> " name=" <> quoted n <> encodeMPField fieldMeta) 46 | , newline 47 | , kv "Content-Type" (Builder.byteString ty) 48 | , newline, newline 49 | , Builder.byteString payload 50 | ] 51 | sep = Builder.byteString ("--" <> sbs) 52 | sepEnd = Builder.byteString ("--" <> sbs <> "--") 53 | encodeMPField FMFormField = mempty 54 | encodeMPField (FMFile fname) = "; filename=" <> quoted fname 55 | quoted x = Builder.byteString ("\"" <> x <> "\"") 56 | kv k v = k <> ": " <> v 57 | newline = Builder.word8 (ord '\n') 58 | 59 | 60 | data FileMeta = FMFormField -- ^ any form field except a file 61 | | FMFile ByteString -- ^ file name 62 | 63 | 64 | ord :: Char -> Word8 65 | ord = fromIntegral . Char.ord 66 | -------------------------------------------------------------------------------- /test/Web/ScottySpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, CPP, ScopedTypeVariables, DeriveGeneric #-} 2 | module Web.ScottySpec (main, spec) where 3 | 4 | import Test.Hspec 5 | import Test.Hspec.Wai (WaiSession, with, request, get, post, put, patch, delete, options, (<:>), shouldRespondWith, matchHeaders, matchBody, matchStatus) 6 | import Test.Hspec.Wai.Extra (postMultipartForm, FileMeta(..)) 7 | 8 | import Control.Applicative 9 | import Control.Monad 10 | import Data.Char 11 | import Data.String 12 | import Data.Text.Lazy (Text) 13 | import qualified Data.Text.Lazy as TL 14 | import qualified Data.Text as T 15 | import qualified Data.Text.Lazy.Encoding as TLE 16 | import Data.Time (UTCTime(..)) 17 | import Data.Time.Calendar (fromGregorian) 18 | import Data.Time.Clock (secondsToDiffTime) 19 | 20 | import GHC.Generics (Generic) 21 | 22 | import Network.HTTP.Types 23 | import Network.Wai (Application, Request(queryString), responseLBS) 24 | import Network.Wai.Parse (defaultParseRequestBodyOptions) 25 | import Network.Wai.Test (SResponse) 26 | import qualified Control.Exception.Lifted as EL 27 | import qualified Control.Exception as E 28 | 29 | import Web.FormUrlEncoded (FromForm) 30 | import Web.Scotty as Scotty hiding (get, post, put, patch, delete, request, options) 31 | import qualified Web.Scotty as Scotty 32 | import qualified Web.Scotty.Cookie as SC (getCookie, setSimpleCookie, deleteCookie) 33 | 34 | #if !defined(mingw32_HOST_OS) 35 | import Control.Concurrent.Async (withAsync) 36 | import Control.Exception (bracketOnError) 37 | import qualified Data.ByteString as BS 38 | import Data.ByteString (ByteString) 39 | import qualified Data.ByteString.Lazy as LBS 40 | import Network.Socket (Family(..), SockAddr(..), Socket, SocketOption(..), SocketType(..), bind, close, connect, listen, maxListenQueue, setSocketOption, socket) 41 | import Network.Socket.ByteString (send, recv) 42 | import System.Directory (removeFile) 43 | #endif 44 | 45 | main :: IO () 46 | main = hspec spec 47 | 48 | availableMethods :: [StdMethod] 49 | availableMethods = [GET, POST, HEAD, PUT, PATCH, DELETE, OPTIONS] 50 | 51 | data SearchForm = SearchForm 52 | { sfQuery :: Text 53 | , sfYear :: Int 54 | } deriving (Generic) 55 | 56 | instance FromForm SearchForm where 57 | 58 | postForm :: ByteString -> LBS.ByteString -> WaiSession st SResponse 59 | postForm p = request "POST" p [("Content-Type","application/x-www-form-urlencoded")] 60 | 61 | spec :: Spec 62 | spec = do 63 | let withApp = with . scottyApp 64 | describe "ScottyM" $ do 65 | forM_ [ 66 | ("GET", Scotty.get, get) 67 | , ("POST", Scotty.post, (`post` "")) 68 | , ("PUT", Scotty.put, (`put` "")) 69 | , ("PATCH", Scotty.patch, (`patch` "")) 70 | , ("DELETE", Scotty.delete, delete) 71 | , ("OPTIONS", Scotty.options, options) 72 | ] $ \(method, route, makeRequest) -> do 73 | describe (map toLower method) $ do 74 | withApp (route "/scotty" $ html "") $ do 75 | it ("adds route for " ++ method ++ " requests") $ do 76 | makeRequest "/scotty" `shouldRespondWith` 200 77 | 78 | withApp (route "/scotty" $ html "") $ do 79 | it ("properly handles extra slash routes for " ++ method ++ " requests") $ do 80 | makeRequest "//scotty" `shouldRespondWith` 200 81 | 82 | withApp (route "/:paramName" $ captureParam "paramName" >>= text) $ do 83 | it ("captures route parameters for " ++ method ++ " requests when parameter matches its name") $ do 84 | makeRequest "/:paramName" `shouldRespondWith` ":paramName" 85 | it ("captures route parameters for " ++ method ++ " requests with url encoded '/' in path") $ do 86 | makeRequest "/a%2Fb" `shouldRespondWith` "a/b" 87 | 88 | describe "addroute" $ do 89 | forM_ availableMethods $ \method -> do 90 | withApp (addroute method "/scotty" $ html "") $ do 91 | it ("can be used to add route for " ++ show method ++ " requests") $ do 92 | request (renderStdMethod method) "/scotty" [] "" `shouldRespondWith` 200 93 | 94 | describe "matchAny" $ do 95 | withApp (matchAny "/scotty" $ html "") $ do 96 | forM_ ("NONSTANDARD" : fmap renderStdMethod availableMethods) $ \method -> do 97 | it ("adds route that matches " ++ show method ++ " requests") $ do 98 | request method "/scotty" [] "" `shouldRespondWith` 200 99 | 100 | describe "notFound" $ do 101 | withApp (notFound $ html "my custom not found page") $ do 102 | it "adds handler for requests that do not match any route" $ do 103 | get "/somewhere" `shouldRespondWith` "my custom not found page" {matchStatus = 404} 104 | 105 | withApp (notFound $ status status400 >> html "my custom not found page") $ do 106 | it "allows to customize the HTTP status code" $ do 107 | get "/somewhere" `shouldRespondWith` "my custom not found page" {matchStatus = 400} 108 | 109 | context "when not specified" $ do 110 | withApp (return ()) $ do 111 | it "returns 404 when no route matches" $ do 112 | get "/" `shouldRespondWith` "

404: File Not Found!

" {matchStatus = 404} 113 | 114 | describe "defaultHandler" $ do 115 | withApp (do 116 | let h = Handler (\(e :: E.ArithException) -> status status500 >> text (TL.pack $ show e)) 117 | defaultHandler h 118 | Scotty.get "/" (throw E.DivideByZero)) $ do 119 | it "sets custom exception handler" $ do 120 | get "/" `shouldRespondWith` "divide by zero" {matchStatus = 500} 121 | withApp (do 122 | let h = Handler (\(_ :: E.ArithException) -> status status503) 123 | defaultHandler h 124 | Scotty.get "/" (liftIO $ E.throwIO E.DivideByZero)) $ do 125 | it "allows to customize the HTTP status code" $ do 126 | get "/" `shouldRespondWith` "" {matchStatus = 503} 127 | withApp (do 128 | let h = Handler (\(_ :: E.SomeException) -> setHeader "Location" "/c" >> status status500) 129 | defaultHandler h 130 | Scotty.get "/a" (redirect "/b")) $ do 131 | it "should give priority to actionErrorHandlers" $ do 132 | get "/a" `shouldRespondWith` 302 { matchHeaders = ["Location" <:> "/b"] } 133 | 134 | context "when not specified" $ do 135 | withApp (Scotty.get "/" $ throw E.DivideByZero) $ do 136 | it "returns 500 on exceptions" $ do 137 | get "/" `shouldRespondWith` 500 138 | context "only applies to endpoints defined after it (#237)" $ do 139 | withApp (do 140 | let h = Handler (\(_ :: E.SomeException) -> status status503 >> text "ok") 141 | Scotty.get "/a" (throw E.DivideByZero) 142 | defaultHandler h 143 | Scotty.get "/b" (throw E.DivideByZero) 144 | ) $ do 145 | it "doesn't catch an exception before the handler is set" $ do 146 | get "/a" `shouldRespondWith` 500 147 | it "catches an exception after the handler is set" $ do 148 | get "/b" `shouldRespondWith` "ok" {matchStatus = 503} 149 | 150 | 151 | describe "setMaxRequestBodySize" $ do 152 | let 153 | large = TLE.encodeUtf8 . TL.pack . concat $ [show c | c <- ([1..4500]::[Integer])] 154 | smol = TLE.encodeUtf8 . TL.pack . concat $ [show c | c <- ([1..50]::[Integer])] 155 | withApp (do 156 | Scotty.setMaxRequestBodySize 1 157 | Scotty.post "/upload" $ do 158 | _ <- files 159 | status status200 160 | ) $ do 161 | context "application/x-www-form-urlencoded" $ do 162 | it "should return 200 OK if the request body size is below 1 KB" $ do 163 | request "POST" "/upload" [("Content-Type","application/x-www-form-urlencoded")] 164 | smol `shouldRespondWith` 200 165 | it "should return 413 (Content Too Large) if the request body size is above 1 KB" $ do 166 | request "POST" "/upload" [("Content-Type","application/x-www-form-urlencoded")] 167 | large `shouldRespondWith` 413 168 | 169 | withApp (Scotty.post "/" $ status status200) $ do 170 | context "(counterexample)" $ do 171 | it "doesn't throw an uncaught exception if the body is large" $ do 172 | request "POST" "/" [("Content-Type","application/x-www-form-urlencoded")] 173 | large `shouldRespondWith` 200 174 | withApp (Scotty.setMaxRequestBodySize 1 >> Scotty.post "/upload" (do status status200)) $ do 175 | context "multipart/form-data; boundary=--33" $ do 176 | 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 177 | request "POST" "/upload" [("Content-Type","multipart/form-data; boundary=--33")] 178 | large `shouldRespondWith` 200 179 | 180 | describe "middleware" $ do 181 | context "can rewrite the query string (#348)" $ do 182 | withApp (do 183 | Scotty.middleware $ \app req sendResponse -> 184 | app req{queryString = [("query", Just "haskell")]} sendResponse 185 | Scotty.matchAny "/search" $ queryParam "query" >>= text 186 | ) $ do 187 | it "returns query parameter with given name" $ do 188 | get "/search" `shouldRespondWith` "haskell" 189 | 190 | describe "ActionM" $ do 191 | context "MonadBaseControl instance" $ do 192 | withApp (Scotty.get "/" $ (undefined `EL.catch` ((\_ -> html "") :: E.SomeException -> ActionM ()))) $ do 193 | it "catches SomeException and returns 200" $ do 194 | get "/" `shouldRespondWith` 200 195 | withApp (Scotty.get "/" $ EL.throwIO E.DivideByZero) $ do 196 | it "returns 500 on uncaught exceptions" $ do 197 | get "/" `shouldRespondWith` 500 198 | 199 | context "Alternative instance" $ do 200 | withApp (Scotty.get "/" $ empty >>= text) $ 201 | it "empty without any route following returns a 404" $ 202 | get "/" `shouldRespondWith` 404 203 | withApp (Scotty.get "/dictionary" $ empty <|> queryParam "word1" >>= text) $ 204 | it "empty throws Next" $ do 205 | get "/dictionary?word1=x" `shouldRespondWith` "x" 206 | withApp (Scotty.get "/dictionary" $ queryParam "word1" <|> empty <|> queryParam "word2" >>= text) $ 207 | it "<|> skips the left route if that fails" $ do 208 | get "/dictionary?word2=y" `shouldRespondWith` "y" 209 | get "/dictionary?word1=a&word2=b" `shouldRespondWith` "a" 210 | 211 | context "MonadFail instance" $ do 212 | withApp (Scotty.get "/" $ fail "boom!") $ do 213 | it "returns 500 if not caught" $ 214 | get "/" `shouldRespondWith` 500 215 | withApp (Scotty.get "/" $ fail "boom!" `catch` (\(_ :: E.SomeException) -> do 216 | status status200 217 | text "ok")) $ 218 | it "can catch the Exception thrown by fail" $ do 219 | get "/" `shouldRespondWith` 200 { matchBody = "ok"} 220 | 221 | describe "redirect" $ do 222 | withApp ( 223 | do 224 | Scotty.get "/a" $ redirect "/b" 225 | ) $ do 226 | it "Responds with a 302 Redirect" $ do 227 | get "/a" `shouldRespondWith` 302 { matchHeaders = ["Location" <:> "/b"] } 228 | 229 | describe "redirect300" $ do 230 | withApp ( 231 | do 232 | Scotty.get "/a" $ redirect300 "/b" 233 | ) $ do 234 | it "Responds with a 300 Redirect" $ do 235 | get "/a" `shouldRespondWith` 300 { matchHeaders = ["Location" <:> "/b"] } 236 | 237 | 238 | describe "redirect301" $ do 239 | withApp ( 240 | do 241 | Scotty.get "/a" $ redirect301 "/b" 242 | ) $ do 243 | it "Responds with a 301 Redirect" $ do 244 | get "/a" `shouldRespondWith` 301 { matchHeaders = ["Location" <:> "/b"] } 245 | 246 | describe "redirect302" $ do 247 | withApp ( 248 | do 249 | Scotty.get "/a" $ redirect302 "/b" 250 | ) $ do 251 | it "Responds with a 302 Redirect" $ do 252 | get "/a" `shouldRespondWith` 302 { matchHeaders = ["Location" <:> "/b"] } 253 | 254 | 255 | describe "redirect303" $ do 256 | withApp ( 257 | do 258 | Scotty.delete "/a" $ redirect303 "/b" 259 | ) $ do 260 | it "Responds with a 303 as passed in" $ do 261 | delete "/a" `shouldRespondWith` 303 { matchHeaders = ["Location" <:> "/b"]} 262 | 263 | describe "redirect304" $ do 264 | withApp ( 265 | do 266 | Scotty.get "/a" $ redirect304 "/b" 267 | ) $ do 268 | it "Responds with a 304 Redirect" $ do 269 | get "/a" `shouldRespondWith` 304 { matchHeaders = ["Location" <:> "/b"] } 270 | 271 | describe "redirect307" $ do 272 | withApp ( 273 | do 274 | Scotty.get "/a" $ redirect307 "/b" 275 | ) $ do 276 | it "Responds with a 307 Redirect" $ do 277 | get "/a" `shouldRespondWith` 307 { matchHeaders = ["Location" <:> "/b"] } 278 | 279 | describe "redirect308" $ do 280 | withApp ( 281 | do 282 | Scotty.get "/a" $ redirect308 "/b" 283 | ) $ do 284 | it "Responds with a 308 Redirect" $ do 285 | get "/a" `shouldRespondWith` 308 { matchHeaders = ["Location" <:> "/b"] } 286 | 287 | describe "Parsable" $ do 288 | it "parses a UTCTime string" $ do 289 | parseParam "2023-12-18T00:38:00Z" `shouldBe` Right (UTCTime (fromGregorian 2023 12 18) (secondsToDiffTime (60 * 38)) ) 290 | 291 | describe "captureParam" $ do 292 | withApp ( 293 | do 294 | Scotty.get "/search/:q" $ do 295 | _ :: Int <- captureParam "q" 296 | text "int" 297 | Scotty.get "/search/:q" $ do 298 | _ :: String <- captureParam "q" 299 | text "string" 300 | Scotty.get "/search-time/:q" $ do 301 | t :: UTCTime <- captureParam "q" 302 | text $ TL.pack (show t) 303 | ) $ do 304 | it "responds with 200 OK iff at least one route matches at the right type" $ do 305 | get "/search/42" `shouldRespondWith` 200 { matchBody = "int" } 306 | get "/search/potato" `shouldRespondWith` 200 { matchBody = "string" } 307 | get "/search-time/2023-12-18T00:38:00Z" `shouldRespondWith` 200 {matchBody = "2023-12-18 00:38:00 UTC"} 308 | withApp ( 309 | do 310 | Scotty.get "/search/:q" $ do 311 | v <- captureParam "q" 312 | json (v :: Int) 313 | ) $ do 314 | it "responds with 404 Not Found if no route matches at the right type" $ do 315 | get "/search/potato" `shouldRespondWith` 404 316 | withApp ( 317 | do 318 | Scotty.matchAny "/search/:q" $ do 319 | v <- captureParam "zzz" 320 | json (v :: Int) 321 | ) $ do 322 | it "responds with 500 Server Error if the parameter cannot be found in the capture" $ do 323 | get "/search/potato" `shouldRespondWith` 500 324 | context "recover from missing parameter exception" $ do 325 | withApp (Scotty.get "/search/:q" $ 326 | (captureParam "z" >>= text) `catch` (\(_::ScottyException) -> text "z") 327 | ) $ do 328 | it "catches a StatusError" $ do 329 | get "/search/xxx" `shouldRespondWith` 200 { matchBody = "z"} 330 | 331 | describe "queryParam" $ do 332 | withApp (Scotty.get "/search" $ queryParam "query" >>= text) $ do 333 | it "returns query parameter with given name" $ do 334 | get "/search?query=haskell" `shouldRespondWith` "haskell" 335 | it "decodes URL-encoding" $ do 336 | get "/search?query=Kurf%C3%BCrstendamm" `shouldRespondWith` "Kurfürstendamm" 337 | withApp (Scotty.matchAny "/search" (do 338 | v <- queryParam "query" 339 | json (v :: Int) )) $ do 340 | it "responds with 200 OK if the query parameter can be parsed at the right type" $ do 341 | get "/search?query=42" `shouldRespondWith` 200 342 | it "responds with 400 Bad Request if the query parameter cannot be parsed at the right type" $ do 343 | get "/search?query=potato" `shouldRespondWith` 400 344 | context "recover from type mismatch parameter exception" $ do 345 | withApp (Scotty.get "/search" $ 346 | (queryParam "z" >>= (\v -> json (v :: Int))) `catch` (\(_::ScottyException) -> text "z") 347 | ) $ do 348 | it "catches a ScottyException" $ do 349 | get "/search?query=potato" `shouldRespondWith` 200 { matchBody = "z"} 350 | 351 | describe "formData" $ do 352 | withApp (Scotty.post "/search" $ formData >>= (text . sfQuery)) $ do 353 | it "decodes the form" $ do 354 | postForm "/search" "sfQuery=Haskell&sfYear=2024" `shouldRespondWith` "Haskell" 355 | 356 | it "decodes URL-encoding" $ do 357 | postForm "/search" "sfQuery=Kurf%C3%BCrstendamm&sfYear=2024" `shouldRespondWith` "Kurfürstendamm" 358 | 359 | it "returns 400 when the form is malformed" $ do 360 | postForm "/search" "sfQuery=Haskell" `shouldRespondWith` 400 361 | 362 | describe "formParam" $ do 363 | withApp (Scotty.post "/search" $ formParam "query" >>= text) $ do 364 | it "returns form parameter with given name" $ do 365 | postForm "/search" "query=haskell" `shouldRespondWith` "haskell" 366 | 367 | it "replaces non UTF-8 bytes with Unicode replacement character" $ do 368 | postForm "/search" "query=\xe9" `shouldRespondWith` "\xfffd" 369 | 370 | it "decodes URL-encoding" $ do 371 | postForm "/search" "query=Kurf%C3%BCrstendamm" `shouldRespondWith` "Kurfürstendamm" 372 | withApp (Scotty.post "/search" (do 373 | v <- formParam "query" 374 | json (v :: Int))) $ do 375 | it "responds with 200 OK if the form parameter can be parsed at the right type" $ do 376 | postForm "/search" "query=42" `shouldRespondWith` 200 377 | it "responds with 400 Bad Request if the form parameter cannot be parsed at the right type" $ do 378 | postForm "/search" "query=potato" `shouldRespondWith` 400 379 | 380 | withApp (do 381 | Scotty.post "/" $ next 382 | Scotty.post "/" $ do 383 | p :: Int <- formParam "p" 384 | json p 385 | ) $ do 386 | it "preserves the body of a POST request even after 'next' (#147)" $ do 387 | postForm "/" "p=42" `shouldRespondWith` "42" 388 | context "recover from type mismatch parameter exception" $ do 389 | withApp (Scotty.post "/search" $ 390 | (formParam "z" >>= (\v -> json (v :: Int))) `catch` (\(_::ScottyException) -> text "z") 391 | ) $ do 392 | it "catches a StatusError" $ do 393 | postForm "/search" "z=potato" `shouldRespondWith` 200 { matchBody = "z"} 394 | 395 | describe "captureParamMaybe" $ do 396 | withApp ( 397 | do 398 | Scotty.get "/a/:q" $ do 399 | mx <- captureParamMaybe "q" 400 | case mx of 401 | Just (_ :: Int) -> status status200 402 | Nothing -> status status500 403 | Scotty.get "/b/:q" $ do 404 | mx <- captureParamMaybe "z" 405 | case mx of 406 | Just (_ :: TL.Text) -> text "impossible" >> status status500 407 | Nothing -> status status200 408 | ) $ do 409 | it "responds with 200 OK if the parameter can be parsed at the right type, 500 otherwise" $ do 410 | get "/a/potato" `shouldRespondWith` 500 411 | get "/a/42" `shouldRespondWith` 200 412 | it "responds with 200 OK if the parameter is not found" $ do 413 | get "/b/potato" `shouldRespondWith` 200 414 | 415 | describe "files" $ do 416 | withApp (Scotty.post "/files" $ do 417 | fs <- files 418 | text $ TL.pack $ show $ length fs) $ do 419 | context "small number of files" $ do 420 | it "loads uploaded files in memory" $ do 421 | postMultipartForm "/files" "ABC123" [ 422 | (FMFile "file1.txt", "text/plain;charset=UTF-8", "first_file", "xxx") 423 | ] `shouldRespondWith` 200 { matchBody = "1"} 424 | context "file name too long (> 32 bytes)" $ do 425 | it "responds with 413 - Request Too Large" $ do 426 | postMultipartForm "/files" "ABC123" [ 427 | (FMFile "file.txt", "text/plain;charset=UTF-8", "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzx", "xxx") 428 | ] `shouldRespondWith` 413 429 | context "large number of files (> 10)" $ do 430 | it "responds with 413 - Request Too Large" $ do 431 | postMultipartForm "/files" "ABC123" [ 432 | (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), 433 | (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), 434 | (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), 435 | (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), 436 | (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), 437 | (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), 438 | (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), 439 | (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), 440 | (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), 441 | (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx"), 442 | (FMFile "file1.txt", "text/plain;charset=UTF-8", "file", "xxx") 443 | ] `shouldRespondWith` 413 444 | 445 | 446 | describe "filesOpts" $ do 447 | let 448 | postMpForm = postMultipartForm "/files" "ABC123" [ 449 | (FMFile "file1.txt", "text/plain;charset=UTF-8", "first_file", "xxx"), 450 | (FMFile "file2.txt", "text/plain;charset=UTF-8", "second_file", "yyy") 451 | ] 452 | processForm = do 453 | filesOpts defaultParseRequestBodyOptions $ \_ fs -> do 454 | text $ TL.pack $ show $ length fs 455 | withApp (Scotty.post "/files" processForm 456 | ) $ do 457 | it "loads uploaded files in memory" $ do 458 | postMpForm `shouldRespondWith` 200 { matchBody = "2"} 459 | context "preserves the body of a POST request even after 'next' (#147)" $ do 460 | withApp (do 461 | Scotty.post "/files" next 462 | Scotty.post "/files" processForm) $ do 463 | it "loads uploaded files in memory" $ do 464 | postMpForm `shouldRespondWith` 200 { matchBody = "2"} 465 | 466 | 467 | describe "text" $ do 468 | let modernGreekText :: IsString a => a 469 | modernGreekText = "νέα ελληνικά" 470 | 471 | withApp (Scotty.get "/scotty" $ text modernGreekText) $ do 472 | it "sets body to given text" $ do 473 | get "/scotty" `shouldRespondWith` modernGreekText 474 | 475 | it "sets Content-Type header to \"text/plain; charset=utf-8\"" $ do 476 | get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} 477 | 478 | withApp (Scotty.get "/scotty" $ setHeader "Content-Type" "text/somethingweird" >> text modernGreekText) $ do 479 | it "doesn't override a previously set Content-Type header" $ do 480 | get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/somethingweird"]} 481 | 482 | describe "html" $ do 483 | let russianLanguageTextInHtml :: IsString a => a 484 | russianLanguageTextInHtml = "

ру́сский язы́к

" 485 | 486 | withApp (Scotty.get "/scotty" $ html russianLanguageTextInHtml) $ do 487 | it "sets body to given text" $ do 488 | get "/scotty" `shouldRespondWith` russianLanguageTextInHtml 489 | 490 | it "sets Content-Type header to \"text/html; charset=utf-8\"" $ do 491 | get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/html; charset=utf-8"]} 492 | 493 | withApp (Scotty.get "/scotty" $ setHeader "Content-Type" "text/somethingweird" >> html russianLanguageTextInHtml) $ do 494 | it "doesn't override a previously set Content-Type header" $ do 495 | get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/somethingweird"]} 496 | 497 | describe "json" $ do 498 | withApp (Scotty.get "/scotty" $ setHeader "Content-Type" "text/somethingweird" >> json (Just (5::Int))) $ do 499 | it "doesn't override a previously set Content-Type header" $ do 500 | get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/somethingweird"]} 501 | 502 | describe "finish" $ do 503 | withApp (Scotty.get "/scotty" $ finish) $ do 504 | it "responds with 200 by default" $ do 505 | get "/scotty" `shouldRespondWith` 200 506 | 507 | withApp (Scotty.get "/scotty" $ status status400 >> finish >> status status200) $ do 508 | it "stops the execution of an action" $ do 509 | get "/scotty" `shouldRespondWith` 400 510 | 511 | describe "setSimpleCookie" $ do 512 | withApp (Scotty.get "/scotty" $ SC.setSimpleCookie "foo" "bar") $ do 513 | it "responds with a Set-Cookie header" $ do 514 | get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Set-Cookie" <:> "foo=bar"]} 515 | 516 | describe "getCookie" $ do 517 | withApp (Scotty.get "/scotty" $ do 518 | mt <- SC.getCookie "foo" 519 | case mt of 520 | Just "bar" -> Scotty.status status200 521 | _ -> Scotty.status status400 ) $ do 522 | it "finds the right cookie in the request headers" $ do 523 | request "GET" "/scotty" [("Cookie", "foo=bar")] "" `shouldRespondWith` 200 524 | 525 | describe "deleteCookie" $ do 526 | withApp (Scotty.get "/scotty" $ SC.deleteCookie "foo") $ do 527 | it "responds with a Set-Cookie header with expiry date Jan 1, 1970" $ do 528 | get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Set-Cookie" <:> "foo=; Expires=Thu, 01-Jan-1970 00:00:00 GMT"]} 529 | 530 | describe "nested" $ do 531 | let 532 | simpleApp :: Application 533 | simpleApp _ respond = do 534 | putStrLn "I've done some IO here" 535 | respond $ responseLBS 536 | status200 537 | [("Content-Type", "text/plain")] 538 | "Hello, Web!" 539 | 540 | withApp (Scotty.get "/nested" (nested simpleApp)) $ do 541 | it "responds with the expected simpleApp response" $ do 542 | get "/nested" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/plain"], matchBody = "Hello, Web!"} 543 | 544 | describe "Session Management" $ do 545 | withApp (Scotty.get "/scotty" $ do 546 | sessionJar <- liftIO createSessionJar 547 | sess <- createUserSession sessionJar Nothing ("foo" :: T.Text) 548 | mRes <- readSession sessionJar (sessId sess) 549 | case mRes of 550 | Left _ -> Scotty.status status400 551 | Right res -> do 552 | if res /= "foo" then Scotty.status status400 553 | else text "all good" 554 | ) $ do 555 | it "Roundtrip of session by adding and fetching a value" $ do 556 | get "/scotty" `shouldRespondWith` 200 557 | 558 | -- Unix sockets not available on Windows 559 | #if !defined(mingw32_HOST_OS) 560 | describe "scottySocket" . 561 | it "works with a unix socket" . 562 | withServer (Scotty.get "/scotty" $ html "") . 563 | E.bracket (socket AF_UNIX Stream 0) close $ \sock -> do 564 | connect sock $ SockAddrUnix socketPath 565 | _ <- send sock "GET /scotty HTTP/1.1\r\n\n" 566 | r1 <- recv sock 1024 567 | _ <- send sock "GET /four-oh-four HTTP/1.1\r\n\n" 568 | r2 <- recv sock 1024 569 | (BS.take (BS.length ok) r1, BS.take (BS.length no) r2) `shouldBe` (ok, no) 570 | where ok, no :: ByteString 571 | ok = "HTTP/1.1 200 OK" 572 | no = "HTTP/1.1 404 Not Found" 573 | 574 | socketPath :: FilePath 575 | socketPath = "/tmp/scotty-test.socket" 576 | 577 | withServer :: ScottyM () -> IO a -> IO a 578 | withServer actions inner = E.bracket 579 | (listenOn socketPath) 580 | (\sock -> close sock >> removeFile socketPath) 581 | (\sock -> withAsync (Scotty.scottySocket defaultOptions sock actions) $ const inner) 582 | 583 | -- See https://github.com/haskell/network/issues/318 584 | listenOn :: String -> IO Socket 585 | listenOn path = 586 | bracketOnError 587 | (socket AF_UNIX Stream 0) 588 | close 589 | (\sock -> do 590 | setSocketOption sock ReuseAddr 1 591 | bind sock (SockAddrUnix path) 592 | listen sock maxListenQueue 593 | return sock 594 | ) 595 | #endif 596 | 597 | --------------------------------------------------------------------------------