Spock-core (empty) → 0.11.0.0
raw patch · 16 files changed
+1946/−0 lines, 16 filesdep +Spock-coredep +aesondep +basesetup-changed
Dependencies added: Spock-core, aeson, base, base64-bytestring, bytestring, case-insensitive, containers, cookie, directory, hashable, hspec, hspec-wai, http-types, hvect, mtl, old-locale, path-pieces, reroute, resourcet, stm, text, time, transformers, unordered-containers, vault, wai, wai-extra, warp
Files
- LICENSE +30/−0
- README.md +141/−0
- Setup.hs +2/−0
- Spock-core.cabal +87/−0
- src/Web/Spock/Action.hs +32/−0
- src/Web/Spock/Core.hs +232/−0
- src/Web/Spock/Internal/Config.hs +24/−0
- src/Web/Spock/Internal/Cookies.hs +106/−0
- src/Web/Spock/Internal/CoreAction.hs +384/−0
- src/Web/Spock/Internal/Util.hs +47/−0
- src/Web/Spock/Internal/Wire.hs +443/−0
- test/Spec.hs +1/−0
- test/Web/Spock/FrameworkSpecHelper.hs +170/−0
- test/Web/Spock/Internal/CookiesSpec.hs +99/−0
- test/Web/Spock/Internal/UtilSpec.hs +26/−0
- test/Web/Spock/SafeSpec.hs +122/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013 - 2016, Alexander Thiemann <mail@athiemann.net>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Alexander Thiemann <mail@agrafix.net> nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,141 @@+Spock+=====++[](https://travis-ci.org/agrafix/Spock)+[](http://hackage.haskell.org/package/Spock)++## Intro++Hackage: [Spock](http://hackage.haskell.org/package/Spock)+Stackage: [Spock](https://www.stackage.org/package/Spock)++Another Haskell web framework for rapid development+++## Library Usage Example++```haskell+{-# LANGUAGE OverloadedStrings #-}+import Web.Spock++import qualified Data.Text as T++main =+ runSpock 3000 $ spockT id $+ do get ("echo" <//> var) $ \something ->+ text $ T.concat ["Echo: ", something]++```++## Install++* Using cabal: `cabal install Spock`+* Using Stack: `stack install Spock`+* From Source (cabal): `git clone https://github.com/agrafix/Spock.git && cd Spock && cabal install`+* From Source (stack): `git clone https://github.com/agrafix/Spock.git && cd Spock && stack build`++## Mailing list++Please join our mailing list at haskell-spock@googlegroups.com++## Features++Another Haskell web framework for rapid development: This toolbox provides+everything you need to get a quick start into web hacking with haskell:++* fast typesafe routing+* middleware+* json+* sessions+* cookies+* database helper+* csrf-protection+* typesafe contexts++## Important Links++* [Tutorial](https://www.spock.li/tutorial/)+* [Type-safe routing in Spock](https://www.spock.li/2015/04/19/type-safe_routing.html)+* [Taking Authentication to the next Level](https://www.spock.li/2015/08/23/taking_authentication_to_the_next_level.html)++### Talks++* English: [Spock - Powerful Elegent Web Applications using Haskell](https://www.youtube.com/watch?v=kNqsOBrCbLo) (by Alexander Thiemann)+* English: [Beginning Web Programming in Haskell (using Spock)](https://www.youtube.com/watch?v=GobPiGL9jJ4) (by Ollie Charles)+* German: [Moderne typsichere Web-Entwicklung mit Haskell](https://dl.dropboxusercontent.com/u/15078797/talks/typesafe-webdev-2015.pdf) (by Alexander Thiemann)+* German: [reroute-talk](https://github.com/timjb/reroute-talk) (by Tim Baumann)++## Candy++### Extensions++The following Spock extensions exist:++* Background workers for Spock: [Spock-worker](http://hackage.haskell.org/package/Spock-worker)+* Digestive functors for Spock: [Spock-digestive](http://hackage.haskell.org/package/Spock-digestive)++### Works well with Spock++* User management [users](http://hackage.haskell.org/package/users)+* Data validation [validate-input](http://hackage.haskell.org/package/validate-input)+* Blaze bootstrap helpers [blaze-bootstrap](http://hackage.haskell.org/package/blaze-bootstrap)+* digestive-forms bootstrap helpers [digestive-bootstrap](http://hackage.haskell.org/package/digestive-bootstrap)++### SSL / HTTPS++If you'd like to use your application via HTTPS, there are two options:++* Use nginx/haproxy/... as reverse proxy in front of the Spock application.+* Convert the Spock application to a `wai`-application using the `spockAsApp`. Then use the `warp-tls` package to run it.++### Benchmarks++See the [Spock-bench repository](https://github.com/agrafix/Spock-bench) to reproduce.++| Framework | GHC | Version | simple route | route with one param | deeply nested route |+|-----------|--------|----------|---------------------------|---------------------------|---------------------|+| Spock | 7.10.2 | 0.11.0.0 | **69243** | **65835** | **64763** |+| scotty | 7.10.2 | 0.10.2 | 66441 | 65357 | 9542 |+| snap | 7.10.2 | 0.9.8.0 | 39964 | 35566 | 38356 |+| fn | 7.10.2 | 0.2.0.2 | 63083 | 63183 | 22346 |+| servant | 7.10.2 | 0.7 | 66041 | 65590 | 64606 |++## Example Projects++* [funblog](https://github.com/agrafix/funblog)+* [makeci](https://github.com/openbrainsrc/makeci)+* [curry-recipes](https://github.com/timjb/reroute-talk/tree/06574561918b50c1809f1e24ec7faeff731fddcf/curry-recipes)++## Notes++Since version 0.11.0.0 Spock drops simple routing in favor of typesafe routing and drops safe actions in favor of the "usual" way of csrf protection with a token.++Since version 0.7.0.0 Spock supports typesafe routing. If you wish to continue using the untyped version of Spock you can Use `Web.Spock.Simple`. The implementation of the routing is implemented in a separate haskell package called `reroute`.++Since version 0.5.0.0 Spock is no longer built on top of scotty. The+design and interface is still influenced by scotty, but the internal+implementation differs from scotty's.++## Thanks to++* Tim Baumann [Github](https://github.com/timjb) (lot's of help with typesafe routing)+* Tom Nielsen [Github](https://github.com/glutamate) (much feedback and small improvements)+* ... and all other awesome [contributors](https://github.com/agrafix/Spock/graphs/contributors)!++## Hacking++Pull requests are welcome! Please consider creating an issue beforehand, so we can discuss what you would like to do. Code should be written in a consistent style throughout the project. Avoid whitespace that is sensible to conflicts. (E.g. alignment of `=` signs in functions definitions) Note that by sending a pull request you agree that your contribution can be released under the BSD3 License as part of the `Spock` package or related packages.+++## Misc++### Supported GHC Versions++* 7.8.4+* 7.10.2+* 8.0++### License++Released under the BSD3 license.+(c) 2013 - 2016 Alexander Thiemann
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Spock-core.cabal view
@@ -0,0 +1,87 @@+name: Spock-core+version: 0.11.0.0+synopsis: Another Haskell web framework for rapid development+description: Barebones high performance type safe web framework+Homepage: https://www.spock.li+Bug-reports: https://github.com/agrafix/Spock/issues+license: BSD3+license-file: LICENSE+author: Alexander Thiemann <mail@athiemann.net>+maintainer: Alexander Thiemann <mail@athiemann.net>+copyright: (c) 2013 - 2016 Alexander Thiemann+category: Web+build-type: Simple+cabal-version: >=1.8+tested-with: GHC==7.8.4, GHC==7.10.2, GHC==8.0.1++extra-source-files:+ README.md++library+ hs-source-dirs: src+ exposed-modules:+ Web.Spock.Core,+ Web.Spock.Action,+ Web.Spock.Internal.Cookies,+ Web.Spock.Internal.Util+ other-modules:+ Web.Spock.Internal.Config,+ Web.Spock.Internal.CoreAction,+ Web.Spock.Internal.Wire+ build-depends:+ aeson >= 0.7,+ base >= 4 && < 5,+ base64-bytestring >=1.0,+ bytestring >=0.10,+ case-insensitive >=1.1,+ containers >=0.5,+ cookie >=0.4,+ directory >=1.2,+ hashable >=1.2,+ http-types >=0.8,+ hvect >= 0.2,+ mtl >=2.1,+ path-pieces >=0.1.4,+ old-locale >=1.0,+ reroute >=0.3.1,+ resourcet >= 0.4,+ stm >=2.4,+ text >= 0.11.3.1,+ time >=1.4,+ transformers >=0.3,+ unordered-containers >=0.2,+ vault >=0.3,+ wai >=3.0,+ wai-extra >=3.0,+ warp >=3.0+ ghc-options: -auto-all -Wall -fno-warn-orphans++test-suite spockcoretests+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules:+ Web.Spock.FrameworkSpecHelper,+ Web.Spock.Internal.CookiesSpec,+ Web.Spock.Internal.UtilSpec,+ Web.Spock.SafeSpec+ build-depends:+ base,+ bytestring,+ base64-bytestring >=1.0,+ hspec >= 2.0,+ hspec-wai >= 0.6,+ http-types,+ Spock-core,+ reroute,+ text,+ time,+ transformers >=0.3,+ unordered-containers,+ wai++ ghc-options: -Wall -fno-warn-orphans++source-repository head+ type: git+ location: https://github.com/agrafix/Spock
+ src/Web/Spock/Action.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Web.Spock.Action+ ( -- * Action types+ ActionT, W.ActionCtxT+ -- * Handling requests+ , request, header, rawHeader, cookies, cookie, reqMethod+ , preferredFormat, ClientPreferredFormat(..)+ , body, jsonBody, jsonBody'+ , files, UploadedFile (..)+ , params, param, param'+ -- * Working with context+ , getContext, runInContext+ -- * Sending responses+ , setStatus, setHeader, redirect, jumpNext, CookieSettings(..), defaultCookieSettings+ , CookieEOL(..), setCookie, deleteCookie, bytes, lazyBytes+ , setRawMultiHeader, MultiHeader(..)+ , text, html, file, json, stream, response+ -- * Middleware helpers+ , middlewarePass, modifyVault, queryVault+ -- * Basic HTTP-Auth+ , requireBasicAuth, withBasicAuthData+ )+where++import Web.Spock.Internal.CoreAction+import qualified Web.Spock.Internal.Wire as W
+ src/Web/Spock/Core.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Web.Spock.Core+ ( -- * Lauching Spock+ runSpock, runSpockNoBanner, spockAsApp+ -- * Spock's route definition monad+ , spockT, spockLimT, spockConfigT, SpockT, SpockCtxT+ -- * Defining routes+ , Path, root, Var, var, static, (<//>)+ -- * Rendering routes+ , renderRoute+ -- * Hooking routes+ , subcomponent, prehook+ , get, post, getpost, head, put, delete, patch, hookRoute, hookRouteCustom, hookAny, hookAnyCustom+ , Http.StdMethod (..)+ -- * Adding Wai.Middleware+ , middleware+ -- * Actions+ , module Web.Spock.Action+ -- * Config+ , SpockConfig (..), defaultSpockConfig+ -- * Internals+ , hookRoute', hookAny', SpockMethod(..), W.HttpMethod(..)+ )+where+++import Web.Spock.Action+import Web.Spock.Internal.Wire (SpockMethod(..))++import Control.Applicative+import Control.Monad.Reader+import Data.HVect hiding (head)+import Data.Word+import Network.HTTP.Types.Method+import Prelude hiding (head, uncurry, curry)+import Web.Routing.Combinators hiding (renderRoute)+import Web.Routing.Router (swapMonad)+import Web.Routing.SafeRouting+import Web.Spock.Internal.Config+import qualified Data.Text as T+import qualified Network.HTTP.Types as Http+import qualified Network.Wai as Wai+import qualified Web.Routing.Combinators as COMB+import qualified Web.Routing.Router as AR+import qualified Web.Spock.Internal.Wire as W+import qualified Network.Wai.Handler.Warp as Warp++type SpockT = SpockCtxT ()++newtype LiftHooked ctx m =+ LiftHooked { unLiftHooked :: forall a. ActionCtxT ctx m a -> ActionCtxT () m a }++injectHook :: LiftHooked ctx m -> (forall a. ActionCtxT ctx' m a -> ActionCtxT ctx m a) -> LiftHooked ctx' m+injectHook (LiftHooked baseHook) nextHook =+ LiftHooked $ baseHook . nextHook++newtype SpockCtxT ctx m a+ = SpockCtxT+ { runSpockT :: W.SpockAllT m (ReaderT (LiftHooked ctx m) m) a+ } deriving (Monad, Functor, Applicative, MonadIO)++instance MonadTrans (SpockCtxT ctx) where+ lift = SpockCtxT . lift . lift++-- | Run a Spock application. Basically just a wrapper around 'Warp.run'.+runSpock :: Warp.Port -> IO Wai.Middleware -> IO ()+runSpock port mw =+ do putStrLn ("Spock is running on port " ++ show port)+ app <- spockAsApp mw+ Warp.run port app++-- | Like 'runSpock', but does not display the banner "Spock is running on port XXX" on stdout.+runSpockNoBanner :: Warp.Port -> IO Wai.Middleware -> IO ()+runSpockNoBanner port mw =+ do app <- spockAsApp mw+ Warp.run port app++-- | Convert a middleware to an application. All failing requests will+-- result in a 404 page+spockAsApp :: IO Wai.Middleware -> IO Wai.Application+spockAsApp = liftM W.middlewareToApp++-- | Create a raw spock application with custom underlying monad+-- Use 'runSpock' to run the app or 'spockAsApp' to create a @Wai.Application@+-- The first argument is request size limit in bytes. Set to 'Nothing' to disable.+spockT :: (MonadIO m)+ => (forall a. m a -> IO a)+ -> SpockT m ()+ -> IO Wai.Middleware+spockT = spockConfigT defaultSpockConfig++-- | Like 'spockT', but first argument is request size limit in bytes. Set to 'Nothing' to disable.+{-# DEPRECATED spockLimT "Consider using spockConfigT instead" #-}+spockLimT :: forall m .MonadIO m+ => Maybe Word64+ -> (forall a. m a -> IO a)+ -> SpockT m ()+ -> IO Wai.Middleware+spockLimT mSizeLimit =+ let spockConfigWithLimit = defaultSpockConfig { sc_maxRequestSize = mSizeLimit }+ in spockConfigT spockConfigWithLimit++-- | Like 'spockT', but with additional configuration for request size and error+-- handlers passed as first parameter.+spockConfigT :: forall m .MonadIO m+ => SpockConfig+ -> (forall a. m a -> IO a)+ -> SpockT m ()+ -> IO Wai.Middleware+spockConfigT (SpockConfig maxRequestSize errorAction) liftFun app =+ W.buildMiddleware internalConfig liftFun (baseAppHook app)+ where+ internalConfig = W.SpockConfigInternal maxRequestSize errorHandler+ errorHandler status = spockAsApp $ W.buildMiddleware W.defaultSpockConfigInternal id $ baseAppHook $ errorApp status+ errorApp status = mapM_ (\method -> hookAny method $ \_ -> errorAction' status) [minBound .. maxBound]+ errorAction' status = setStatus status >> errorAction status++baseAppHook :: forall m. MonadIO m => SpockT m () -> W.SpockAllT m m ()+baseAppHook app =+ swapMonad lifter (runSpockT app)+ where+ lifter :: forall b. ReaderT (LiftHooked () m) m b -> m b+ lifter action = runReaderT action (LiftHooked id)++-- | Specify an action that will be run when the HTTP verb 'GET' and the given route match+get :: (HasRep xs, MonadIO m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()+get = hookRoute GET++-- | Specify an action that will be run when the HTTP verb 'POST' and the given route match+post :: (HasRep xs, MonadIO m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()+post = hookRoute POST++-- | Specify an action that will be run when the HTTP verb 'GET'/'POST' and the given route match+getpost :: (HasRep xs, MonadIO m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()+getpost r a = hookRoute POST r a >> hookRoute GET r a++-- | Specify an action that will be run when the HTTP verb 'HEAD' and the given route match+head :: (HasRep xs, MonadIO m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()+head = hookRoute HEAD++-- | Specify an action that will be run when the HTTP verb 'PUT' and the given route match+put :: (HasRep xs, MonadIO m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()+put = hookRoute PUT++-- | Specify an action that will be run when the HTTP verb 'DELETE' and the given route match+delete :: (HasRep xs, MonadIO m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()+delete = hookRoute DELETE++-- | Specify an action that will be run when the HTTP verb 'PATCH' and the given route match+patch :: (HasRep xs, MonadIO m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()+patch = hookRoute PATCH++-- | Specify an action that will be run before all subroutes. It can modify the requests current context+prehook :: forall m ctx ctx'. MonadIO m => ActionCtxT ctx m ctx' -> SpockCtxT ctx' m () -> SpockCtxT ctx m ()+prehook hook (SpockCtxT hookBody) =+ SpockCtxT $+ do prevHook <- lift ask+ let newHook :: ActionCtxT ctx' m a -> ActionCtxT ctx m a+ newHook act =+ do newCtx <- hook+ runInContext newCtx act+ hookLift :: forall a. ReaderT (LiftHooked ctx' m) m a -> ReaderT (LiftHooked ctx m) m a+ hookLift a =+ lift $ runReaderT a (injectHook prevHook newHook)+ swapMonad hookLift hookBody++-- | Specify an action that will be run when a standard HTTP verb and the given route match+hookRoute :: forall xs ctx m ps. (HasRep xs, Monad m) => StdMethod -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()+hookRoute = hookRoute' . MethodStandard . W.HttpMethod++-- | Specify an action that will be run when a custom HTTP verb and the given route match+hookRouteCustom :: forall xs ctx m ps. (HasRep xs, Monad m) => T.Text -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()+hookRouteCustom = hookRoute' . MethodCustom++-- | Specify an action that will be run when a HTTP verb and the given route match+hookRoute' :: forall xs ctx m ps. (HasRep xs, Monad m) => SpockMethod -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()+hookRoute' m path action =+ SpockCtxT $+ do hookLift <- lift $ asks unLiftHooked+ let actionPacker :: HVectElim xs (ActionCtxT ctx m ()) -> HVect xs -> ActionCtxT () m ()+ actionPacker act captures = hookLift (uncurry act captures)+ AR.hookRoute m (toInternalPath path) (HVectElim' $ curry $ actionPacker action)++-- | Specify an action that will be run when a standard HTTP verb matches but no defined route matches.+-- The full path is passed as an argument+hookAny :: Monad m => StdMethod -> ([T.Text] -> ActionCtxT ctx m ()) -> SpockCtxT ctx m ()+hookAny = hookAny' . MethodStandard . W.HttpMethod++-- | Specify an action that will be run when a custom HTTP verb matches but no defined route matches.+-- The full path is passed as an argument+hookAnyCustom :: Monad m => T.Text -> ([T.Text] -> ActionCtxT ctx m ()) -> SpockCtxT ctx m ()+hookAnyCustom = hookAny' . MethodCustom++-- | Specify an action that will be run when a HTTP verb matches but no defined route matches.+-- The full path is passed as an argument+hookAny' :: Monad m => SpockMethod -> ([T.Text] -> ActionCtxT ctx m ()) -> SpockCtxT ctx m ()+hookAny' m action =+ SpockCtxT $+ do hookLift <- lift $ asks unLiftHooked+ AR.hookAny m (hookLift . action)++-- | Define a subcomponent. Usage example:+--+-- > subcomponent "site" $+-- > do get "home" homeHandler+-- > get ("misc" <//> var) $ -- ...+-- > subcomponent "admin" $+-- > do get "home" adminHomeHandler+--+-- The request \/site\/home will be routed to homeHandler and the+-- request \/admin\/home will be routed to adminHomeHandler+subcomponent :: Monad m => Path '[] 'Open -> SpockCtxT ctx m () -> SpockCtxT ctx m ()+subcomponent p (SpockCtxT subapp) = SpockCtxT $ AR.subcomponent (toInternalPath p) subapp++-- | Hook wai middleware into Spock+middleware :: Monad m => Wai.Middleware -> SpockCtxT ctx m ()+middleware = SpockCtxT . AR.middleware++-- | Combine two path components+(<//>) :: Path as 'Open -> Path bs ps -> Path (Append as bs) ps+(<//>) = (</>)++-- | Render a route applying path pieces+renderRoute :: Path as 'Open -> HVectElim as T.Text+renderRoute route = curryExpl (pathToRep route) (T.cons '/' . COMB.renderRoute route)
+ src/Web/Spock/Internal/Config.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE RankNTypes #-}+module Web.Spock.Internal.Config where++import Data.Word+import Network.HTTP.Types.Status+import Web.Spock.Internal.CoreAction+import qualified Web.Spock.Internal.Wire as W+++data SpockConfig+ = SpockConfig+ { sc_maxRequestSize :: Maybe Word64+ -- ^ Maximum request size in bytes+ , sc_errorHandler :: Status -> W.ActionCtxT () IO ()+ -- ^ Error handler. Given status is set in response by default, but you+ -- can always override it with `setStatus`+ }++-- | Default Spock configuration. No restriction on maximum request size; error+-- handler simply prints status message as plain text.+defaultSpockConfig :: SpockConfig+defaultSpockConfig = SpockConfig Nothing defaultHandler+ where+ defaultHandler = bytes . statusMessage
+ src/Web/Spock/Internal/Cookies.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Web.Spock.Internal.Cookies where++import Data.Time+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Web.Cookie as C+import qualified Network.HTTP.Types.URI as URI (urlEncode, urlDecode)+#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative+#endif+++-- | Cookie settings+data CookieSettings+ = CookieSettings+ { cs_EOL :: CookieEOL+ -- ^ cookie expiration setting, see 'CookieEOL'+ , cs_path :: Maybe BS.ByteString+ -- ^ a path for the cookie+ , cs_domain :: Maybe BS.ByteString+ -- ^ a domain for the cookie. 'Nothing' means no domain is set+ , cs_HTTPOnly :: Bool+ -- ^ whether the cookie should be set as HttpOnly+ , cs_secure :: Bool+ -- ^ whether the cookie should be marked secure (sent over HTTPS only)+ }++-- | Setting cookie expiration+data CookieEOL+ = CookieValidUntil UTCTime+ -- ^ a point in time in UTC until the cookie is valid+ | CookieValidFor NominalDiffTime+ -- ^ a period (in seconds) for which the cookie is valid+ | CookieValidForSession+ -- ^ the cookie expires with the browser session+ | CookieValidForever+ -- ^ the cookie will have an expiration date in the far future++-- | Default cookie settings, equals+--+-- > CookieSettings+-- > { cs_EOL = CookieValidForSession+-- > , cs_HTTPOnly = False+-- > , cs_secure = False+-- > , cs_domain = Nothing+-- > , cs_path = Just "/"+-- > }+--+defaultCookieSettings :: CookieSettings+defaultCookieSettings =+ CookieSettings+ { cs_EOL = CookieValidForSession+ , cs_HTTPOnly = False+ , cs_secure = False+ , cs_domain = Nothing+ , cs_path = Just "/"+ }++parseCookies :: BS.ByteString -> [(T.Text, T.Text)]+parseCookies =+ map (\(a, b) -> (T.decodeUtf8 a, T.decodeUtf8 $ URI.urlDecode True b)) .+ C.parseCookies++generateCookieHeaderString ::+ T.Text+ -> T.Text+ -> CookieSettings+ -> UTCTime+ -> BS.ByteString+generateCookieHeaderString name value cs now =+ let farFuture =+ -- don't forget to bump this ...+ UTCTime (fromGregorian 2030 1 1) 0+ (expire, maxAge) =+ case cs_EOL cs of+ CookieValidUntil t ->+ (Just t, Just (t `diffUTCTime` now))+ CookieValidFor x ->+ (Just (x `addUTCTime` now), Just x)+ CookieValidForSession ->+ (Nothing, Nothing)+ CookieValidForever ->+ (Just farFuture, Just (farFuture `diffUTCTime` now))+ adjustMaxAge t =+ if t < 0 then 0 else t+ cookieVal =+ C.def+ { C.setCookieName = T.encodeUtf8 name+ , C.setCookieValue = URI.urlEncode True $ T.encodeUtf8 value+ , C.setCookiePath = cs_path cs+ , C.setCookieExpires = expire+ , C.setCookieMaxAge = (fromRational . adjustMaxAge . toRational) <$> maxAge+ , C.setCookieDomain = cs_domain cs+ , C.setCookieHttpOnly = cs_HTTPOnly cs+ , C.setCookieSecure = cs_secure cs+ }+ in renderCookie cookieVal++renderCookie :: C.SetCookie -> BS.ByteString+renderCookie = BSL.toStrict . B.toLazyByteString . C.renderSetCookie
+ src/Web/Spock/Internal/CoreAction.hs view
@@ -0,0 +1,384 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE RecordWildCards #-}+module Web.Spock.Internal.CoreAction+ ( ActionT+ , UploadedFile (..)+ , request, header, rawHeader, cookie, cookies, body, jsonBody, jsonBody'+ , reqMethod+ , files, params, param, param', setStatus, setHeader, redirect+ , setRawMultiHeader, MultiHeader(..)+ , CookieSettings(..), CookieEOL(..), defaultCookieSettings+ , setCookie, deleteCookie+ , jumpNext, middlewarePass, modifyVault, queryVault+ , bytes, lazyBytes, text, html, file, json, stream, response+ , requireBasicAuth, withBasicAuthData+ , getContext, runInContext+ , preferredFormat, ClientPreferredFormat(..)+ )+where++import Web.Spock.Internal.Cookies+import Web.Spock.Internal.Util+import Web.Spock.Internal.Wire++import Control.Monad+#if MIN_VERSION_mtl(2,2,0)+import Control.Monad.Except+#else+import Control.Monad.Error+#endif+import Control.Monad.Reader+import Control.Monad.RWS.Strict (runRWST)+import Control.Monad.State hiding (get, put)+import qualified Control.Monad.State as ST+import Data.Maybe+import Data.Monoid+import Data.Time+import Network.HTTP.Types.Header (HeaderName, ResponseHeaders)+import Network.HTTP.Types.Status+import Prelude hiding (head)+import Web.PathPieces+import qualified Data.Aeson as A+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Lazy as BSL+import qualified Data.CaseInsensitive as CI+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Vault.Lazy as V+import qualified Network.Wai as Wai++-- | Get the original Wai Request object+request :: MonadIO m => ActionCtxT ctx m Wai.Request+request = asks ri_request+{-# INLINE request #-}++-- | Read a header+header :: MonadIO m => T.Text -> ActionCtxT ctx m (Maybe T.Text)+header t =+ liftM (fmap T.decodeUtf8) $ rawHeader (CI.mk (T.encodeUtf8 t))+{-# INLINE header #-}++-- | Read a header without converting it to text+rawHeader :: MonadIO m => HeaderName -> ActionCtxT ctx m (Maybe BS.ByteString)+rawHeader t =+ liftM (lookup t . Wai.requestHeaders) request+{-# INLINE rawHeader #-}++-- | Tries to dected the preferred format of the response using the Accept header+preferredFormat :: MonadIO m => ActionCtxT ctx m ClientPreferredFormat+preferredFormat =+ do mAccept <- header "accept"+ case mAccept of+ Nothing -> return PrefUnknown+ Just t ->+ return $ detectPreferredFormat t+{-# INLINE preferredFormat #-}++-- | Returns the current request method, e.g. 'GET'+reqMethod :: MonadIO m => ActionCtxT ctx m SpockMethod+reqMethod = asks ri_method+{-# INLINE reqMethod #-}++-- | Get the raw request body+body :: MonadIO m => ActionCtxT ctx m BS.ByteString+body =+ do req <- request+ let parseBody = liftIO $ Wai.requestBody req+ parseAll chunks =+ do bs <- parseBody+ if BS.null bs+ then return chunks+ else parseAll (chunks `BS.append` bs)+ parseAll BS.empty+{-# INLINE body #-}++-- | Parse the request body as json+jsonBody :: (MonadIO m, A.FromJSON a) => ActionCtxT ctx m (Maybe a)+jsonBody =+ do b <- body+ return $ A.decodeStrict b+{-# INLINE jsonBody #-}++-- | Parse the request body as json and fails with 400 status code on error+jsonBody' :: (MonadIO m, A.FromJSON a) => ActionCtxT ctx m a+jsonBody' =+ do b <- body+ case A.eitherDecodeStrict' b of+ Left err ->+ do setStatus status400+ text (T.pack $ "Failed to parse json: " ++ err)+ Right val ->+ return val+{-# INLINE jsonBody' #-}++-- | Get uploaded files+files :: MonadIO m => ActionCtxT ctx m (HM.HashMap T.Text UploadedFile)+files =+ asks ri_files+{-# INLINE files #-}++-- | Get all request params+params :: MonadIO m => ActionCtxT ctx m [(T.Text, T.Text)]+params = asks ri_queryParams+{-# INLINE params #-}++-- | Read a request param. Spock looks in route captures first (in simple routing), then in POST variables and at last in GET variables+param :: (PathPiece p, MonadIO m) => T.Text -> ActionCtxT ctx m (Maybe p)+param k =+ do qp <- asks ri_queryParams+ return $ join $ fmap fromPathPiece (lookup k qp)+{-# INLINE param #-}++-- | Like 'param', but outputs an error when a param is missing+param' :: (PathPiece p, MonadIO m) => T.Text -> ActionCtxT ctx m p+param' k =+ do mParam <- param k+ case mParam of+ Nothing ->+ do setStatus status500+ text (T.concat [ "Missing parameter ", k ])+ Just val ->+ return val+{-# INLINE param' #-}++-- | Set a response status+setStatus :: MonadIO m => Status -> ActionCtxT ctx m ()+setStatus s =+ modify $ \rs -> rs { rs_status = s }+{-# INLINE setStatus #-}++-- | Set a response header. If the response header+-- is allowed to occur multiple times (as in RFC 2616), it will+-- be appended. Otherwise the previous value is overwritten.+-- See 'setMultiHeader'.+setHeader :: MonadIO m => T.Text -> T.Text -> ActionCtxT ctx m ()+setHeader k v = setRawHeader (CI.mk $ T.encodeUtf8 k) (T.encodeUtf8 v)+{-# INLINE setHeader #-}++setRawHeader :: MonadIO m => CI.CI BS.ByteString -> BS.ByteString -> ActionCtxT ctx m ()+setRawHeader k v =+ case HM.lookup k multiHeaderMap of+ Just mhk ->+ setRawMultiHeader mhk v+ Nothing ->+ setRawHeaderUnsafe k v++-- | Set a response header that can occur multiple times. (eg: Cache-Control)+setMultiHeader :: MonadIO m => MultiHeader -> T.Text -> ActionCtxT ctx m ()+setMultiHeader k v = setRawMultiHeader k (T.encodeUtf8 v)+{-# INLINE setMultiHeader #-}++-- | Set a response header that can occur multiple times. (eg: Cache-Control)+setRawMultiHeader :: MonadIO m => MultiHeader -> BS.ByteString -> ActionCtxT ctx m ()+setRawMultiHeader k v =+ modify $ \rs ->+ rs+ { rs_multiResponseHeaders =+ HM.insertWith (++) k [v] (rs_multiResponseHeaders rs)+ }++-- | INTERNAL: Unsafely set a header (no checking if the header can occur multiple times)+setHeaderUnsafe :: MonadIO m => T.Text -> T.Text -> ActionCtxT ctx m ()+setHeaderUnsafe k v = setRawHeaderUnsafe (CI.mk $ T.encodeUtf8 k) (T.encodeUtf8 v)+{-# INLINE setHeaderUnsafe #-}++-- | INTERNAL: Unsafely set a header (no checking if the header can occur multiple times)+setRawHeaderUnsafe :: MonadIO m => CI.CI BS.ByteString -> BS.ByteString -> ActionCtxT ctx m ()+setRawHeaderUnsafe k v =+ modify $ \rs ->+ rs+ { rs_responseHeaders =+ HM.insert k v (rs_responseHeaders rs)+ }++-- | Abort the current action and jump the next one matching the route+jumpNext :: MonadIO m => ActionCtxT ctx m a+jumpNext = throwError ActionTryNext+{-# INLINE jumpNext #-}++-- | Redirect to a given url+redirect :: MonadIO m => T.Text -> ActionCtxT ctx m a+redirect = throwError . ActionRedirect+{-# INLINE redirect #-}++-- | If the Spock application is used as a middleware, you can use+-- this to pass request handling to the underlying application.+-- If Spock is not uses as a middleware, or there is no underlying application+-- this will result in 404 error.+middlewarePass :: MonadIO m => ActionCtxT ctx m a+middlewarePass = throwError ActionMiddlewarePass+{-# INLINE middlewarePass #-}++-- | Modify the vault (useful for sharing data between middleware and app)+modifyVault :: MonadIO m => (V.Vault -> V.Vault) -> ActionCtxT ctx m ()+modifyVault f =+ do vaultIf <- asks ri_vaultIf+ liftIO $ vi_modifyVault vaultIf f+{-# INLINE modifyVault #-}++-- | Query the vault+queryVault :: MonadIO m => V.Key a -> ActionCtxT ctx m (Maybe a)+queryVault k =+ do vaultIf <- asks ri_vaultIf+ liftIO $ vi_lookupKey vaultIf k+{-# INLINE queryVault #-}++-- | Use a custom 'Wai.Response' generator as response body.+response :: MonadIO m => (Status -> ResponseHeaders -> Wai.Response) -> ActionCtxT ctx m a+response val =+ do modify $ \rs -> rs { rs_responseBody = ResponseBody val }+ throwError ActionDone+{-# INLINE response #-}++-- | Send a 'ByteString' as response body. Provide your own "Content-Type"+bytes :: MonadIO m => BS.ByteString -> ActionCtxT ctx m a+bytes val =+ lazyBytes $ BSL.fromStrict val+{-# INLINE bytes #-}++-- | Send a lazy 'ByteString' as response body. Provide your own "Content-Type"+lazyBytes :: MonadIO m => BSL.ByteString -> ActionCtxT ctx m a+lazyBytes val =+ response $ \status headers -> Wai.responseLBS status headers val+{-# INLINE lazyBytes #-}++-- | Send text as a response body. Content-Type will be "text/plain"+text :: MonadIO m => T.Text -> ActionCtxT ctx m a+text val =+ do setHeaderUnsafe "Content-Type" "text/plain; charset=utf-8"+ bytes $ T.encodeUtf8 val+{-# INLINE text #-}++-- | Send a text as response body. Content-Type will be "text/html"+html :: MonadIO m => T.Text -> ActionCtxT ctx m a+html val =+ do setHeaderUnsafe "Content-Type" "text/html; charset=utf-8"+ bytes $ T.encodeUtf8 val+{-# INLINE html #-}++-- | Send a file as response+file :: MonadIO m => T.Text -> FilePath -> ActionCtxT ctx m a+file contentType filePath =+ do setHeaderUnsafe "Content-Type" contentType+ response $ \status headers -> Wai.responseFile status headers filePath Nothing+{-# INLINE file #-}++-- | Send json as response. Content-Type will be "application/json"+json :: (A.ToJSON a, MonadIO m) => a -> ActionCtxT ctx m b+json val =+ do setHeaderUnsafe "Content-Type" "application/json; charset=utf-8"+ lazyBytes $ A.encode val+{-# INLINE json #-}++-- | Use a 'Wai.StreamingBody' to generate a response.+stream :: MonadIO m => Wai.StreamingBody -> ActionCtxT ctx m a+stream val =+ response $ \status headers -> Wai.responseStream status headers val+{-# INLINE stream #-}++-- | Convenience Basic authentification+-- provide a title for the prompt and a function to validate+-- user and password. Usage example:+--+-- > get ("auth" <//> var <//> var) $ \user pass ->+-- > let checker user' pass' =+-- > unless (user == user' && pass == pass') $+-- > do setStatus status401+-- > text "err"+-- > in requireBasicAuth "Foo" checker $ \() -> text "ok"+--+requireBasicAuth :: MonadIO m => T.Text -> (T.Text -> T.Text -> ActionCtxT ctx m b) -> (b -> ActionCtxT ctx m a) -> ActionCtxT ctx m a+requireBasicAuth realmTitle authFun cont =+ withBasicAuthData $ \mAuthHeader ->+ case mAuthHeader of+ Nothing ->+ authFailed Nothing+ Just (user, pass) ->+ authFun user pass >>= cont+ where+ authFailed mMore =+ do setStatus status401+ setMultiHeader MultiHeaderWWWAuth ("Basic realm=\"" <> realmTitle <> "\"")+ text $ "Authentication required. " <> fromMaybe "" mMore++-- | "Lower level" basic authentification handeling. Does not set any headers that will promt+-- browser users, only looks for an "Authorization" header in the request and breaks it into+-- username and passwort component if present+withBasicAuthData :: MonadIO m => (Maybe (T.Text, T.Text) -> ActionCtxT ctx m a) -> ActionCtxT ctx m a+withBasicAuthData handler =+ do mAuthHeader <- header "Authorization"+ case mAuthHeader of+ Nothing ->+ handler Nothing+ Just authHeader ->+ let (_, rawValue) =+ T.breakOn " " authHeader+ (user, rawPass) =+ (T.breakOn ":" . T.decodeUtf8 . B64.decodeLenient . T.encodeUtf8 . T.strip) rawValue+ pass = T.drop 1 rawPass+ in handler (Just (user, pass))++-- | Get the context of the current request+getContext :: MonadIO m => ActionCtxT ctx m ctx+getContext = asks ri_context+{-# INLINE getContext #-}++-- | Run an Action in a different context+runInContext :: MonadIO m => ctx' -> ActionCtxT ctx' m a -> ActionCtxT ctx m a+runInContext newCtx action =+ do currentEnv <- ask+ currentRespState <- ST.get+ (r, newRespState, _) <-+ lift $+ do let env =+ currentEnv+ { ri_context = newCtx+ }+ runRWST (runErrorT $ runActionCtxT action) env currentRespState+ ST.put newRespState+ case r of+ Left interupt ->+ throwError interupt+ Right d -> return d+{-# INLINE runInContext #-}++-- | Set a cookie. The cookie value will be urlencoded.+setCookie :: MonadIO m => T.Text -> T.Text -> CookieSettings -> ActionCtxT ctx m ()+setCookie name value cs =+ do now <- liftIO getCurrentTime+ setRawMultiHeader MultiHeaderSetCookie $+ generateCookieHeaderString name value cs now+{-# INLINE setCookie #-}++-- | Delete a cookie+deleteCookie :: MonadIO m => T.Text -> ActionCtxT ctx m ()+deleteCookie name =+ setCookie name T.empty cs+ where+ cs = defaultCookieSettings { cs_EOL = CookieValidUntil epoch }+ epoch = UTCTime (fromGregorian 1970 1 1) (secondsToDiffTime 0)+{-# INLINE deleteCookie #-}++-- | Read all cookies. The cookie value will already be urldecoded.+cookies :: MonadIO m => ActionCtxT ctx m [(T.Text, T.Text)]+cookies =+ do req <- request+ return $+ fromMaybe [] $+ fmap parseCookies $+ lookup "cookie" (Wai.requestHeaders req)+{-# INLINE cookies #-}++-- | Read a cookie. The cookie value will already be urldecoded. Note that it is+-- more efficient to use 'cookies' if you need do access many cookies during a request+-- handler.+cookie :: MonadIO m => T.Text -> ActionCtxT ctx m (Maybe T.Text)+cookie name =+ do allCookies <- cookies+ return $ lookup name allCookies+{-# INLINE cookie #-}
+ src/Web/Spock/Internal/Util.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}+module Web.Spock.Internal.Util where++import Data.Maybe+import Network.HTTP.Types+import Network.Wai.Internal+import qualified Data.Text as T+import qualified Data.HashMap.Strict as HM++data ClientPreferredFormat+ = PrefJSON+ | PrefXML+ | PrefHTML+ | PrefText+ | PrefUnknown+ deriving (Show, Eq)++mimeMapping :: HM.HashMap T.Text ClientPreferredFormat+mimeMapping =+ HM.fromList+ [ ("application/json", PrefJSON)+ , ("text/javascript", PrefJSON)+ , ("text/json", PrefJSON)+ , ("application/javascript", PrefJSON)+ , ("application/xml", PrefXML)+ , ("text/xml", PrefXML)+ , ("text/plain", PrefText)+ , ("text/html", PrefHTML)+ , ("application/xhtml+xml", PrefHTML)+ ]++detectPreferredFormat :: T.Text -> ClientPreferredFormat+detectPreferredFormat t =+ let (mimeTypeStr, _) = T.breakOn ";" t+ mimeTypes = map (T.toLower . T.strip) $ T.splitOn "," mimeTypeStr+ firstMatch [] = PrefUnknown+ firstMatch (x:xs) = fromMaybe (firstMatch xs) (HM.lookup x mimeMapping)+ in firstMatch mimeTypes+++mapReqHeaders :: (ResponseHeaders -> ResponseHeaders) -> Response -> Response+mapReqHeaders f resp =+ case resp of+ (ResponseFile s h b1 b2) -> ResponseFile s (f h) b1 b2+ (ResponseBuilder s h b) -> ResponseBuilder s (f h) b+ (ResponseStream s h b) -> ResponseStream s (f h) b+ (ResponseRaw x r) -> ResponseRaw x (mapReqHeaders f r)
+ src/Web/Spock/Internal/Wire.hs view
@@ -0,0 +1,443 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Web.Spock.Internal.Wire where++import Control.Arrow ((***))+import Control.Applicative+import Control.Concurrent.STM+import Control.Exception+import Control.Monad.RWS.Strict+#if MIN_VERSION_mtl(2,2,0)+import Control.Monad.Except+#else+import Control.Monad.Error+#endif+import Control.Monad.Reader.Class ()+import Control.Monad.Trans.Resource+import Data.Hashable+import Data.IORef+import Data.Maybe+import Data.Typeable+import Data.Word+import GHC.Generics+import Network.HTTP.Types.Header (ResponseHeaders)+import Network.HTTP.Types.Method+import Network.HTTP.Types.Status+#if MIN_VERSION_base(4,6,0)+import Prelude+#else+import Prelude hiding (catch)+#endif+import System.Directory+import Web.Routing.Router+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as BSLC+import qualified Data.CaseInsensitive as CI+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Vault.Lazy as V+import qualified Network.Wai as Wai+import qualified Network.Wai.Parse as P++newtype HttpMethod+ = HttpMethod { unHttpMethod :: StdMethod }+ deriving (Show, Eq, Generic)++instance Hashable HttpMethod where+ hashWithSalt = hashUsing (fromEnum . unHttpMethod)++-- | The 'SpockMethod' allows safe use of http verbs via the 'MethodStandard' constructor and 'StdMethod',+-- and custom verbs via the 'MethodCustom' constructor.+data SpockMethod+ -- | Standard HTTP Verbs from 'StdMethod'+ = MethodStandard !HttpMethod+ -- | Custom HTTP Verbs using 'T.Text'+ | MethodCustom !T.Text+ deriving (Eq, Generic)++instance Hashable SpockMethod++data UploadedFile+ = UploadedFile+ { uf_name :: !T.Text+ , uf_contentType :: !T.Text+ , uf_tempLocation :: !FilePath+ }++data VaultIf+ = VaultIf+ { vi_modifyVault :: (V.Vault -> V.Vault) -> IO ()+ , vi_lookupKey :: forall a. V.Key a -> IO (Maybe a)+ }++data RequestInfo ctx+ = RequestInfo+ { ri_method :: !SpockMethod+ , ri_request :: !Wai.Request+ , ri_queryParams :: [(T.Text, T.Text)]+ , ri_files :: !(HM.HashMap T.Text UploadedFile)+ , ri_vaultIf :: !VaultIf+ , ri_context :: !ctx+ }++newtype ResponseBody = ResponseBody (Status -> ResponseHeaders -> Wai.Response)++data MultiHeader+ = MultiHeaderCacheControl+ | MultiHeaderConnection+ | MultiHeaderContentEncoding+ | MultiHeaderContentLanguage+ | MultiHeaderPragma+ | MultiHeaderProxyAuthenticate+ | MultiHeaderTrailer+ | MultiHeaderTransferEncoding+ | MultiHeaderUpgrade+ | MultiHeaderVia+ | MultiHeaderWarning+ | MultiHeaderWWWAuth+ | MultiHeaderSetCookie+ deriving (Show, Eq, Enum, Bounded, Generic)++instance Hashable MultiHeader++multiHeaderCI :: MultiHeader -> CI.CI BS.ByteString+multiHeaderCI mh =+ case mh of+ MultiHeaderCacheControl -> "Cache-Control"+ MultiHeaderConnection -> "Connection"+ MultiHeaderContentEncoding -> "Content-Encoding"+ MultiHeaderContentLanguage -> "Content-Language"+ MultiHeaderPragma -> "Pragma"+ MultiHeaderProxyAuthenticate -> "Proxy-Authenticate"+ MultiHeaderTrailer -> "Trailer"+ MultiHeaderTransferEncoding -> "Transfer-Encoding"+ MultiHeaderUpgrade -> "Upgrade"+ MultiHeaderVia -> "Via"+ MultiHeaderWarning -> "Warning"+ MultiHeaderWWWAuth -> "WWW-Authenticate"+ MultiHeaderSetCookie -> "Set-Cookie"++multiHeaderMap :: HM.HashMap (CI.CI BS.ByteString) MultiHeader+multiHeaderMap =+ HM.fromList $ flip map allHeaders $ \mh ->+ (multiHeaderCI mh, mh)+ where+ -- this is a nasty hack until we know more about the origin of+ -- uncaught exception: ErrorCall (toEnum{MultiHeader}: tag (-12565) is outside of enumeration's range (0,12))+ -- see: https://ghc.haskell.org/trac/ghc/ticket/10792 and https://github.com/agrafix/Spock/issues/44+ allHeaders =+ [ MultiHeaderCacheControl+ , MultiHeaderConnection+ , MultiHeaderContentEncoding+ , MultiHeaderContentLanguage+ , MultiHeaderPragma+ , MultiHeaderProxyAuthenticate+ , MultiHeaderTrailer+ , MultiHeaderTransferEncoding+ , MultiHeaderUpgrade+ , MultiHeaderVia+ , MultiHeaderWarning+ , MultiHeaderWWWAuth+ , MultiHeaderSetCookie+ ]++data ResponseVal+ = ResponseValState !ResponseState+ | ResponseHandler !(IO Wai.Application)++data ResponseState+ = ResponseState+ { rs_responseHeaders :: !(HM.HashMap (CI.CI BS.ByteString) BS.ByteString)+ , rs_multiResponseHeaders :: !(HM.HashMap MultiHeader [BS.ByteString])+ , rs_status :: !Status+ , rs_responseBody :: !ResponseBody+ }++data ActionInterupt+ = ActionRedirect !T.Text+ | ActionTryNext+ | ActionError String+ | ActionDone+ | ActionMiddlewarePass+ deriving (Show, Typeable)++instance Monoid ActionInterupt where+ mempty = ActionDone+ mappend _ a = a++#if MIN_VERSION_mtl(2,2,0)+type ErrorT = ExceptT+runErrorT :: ExceptT e m a -> m (Either e a)+runErrorT = runExceptT+#else+instance Error ActionInterupt where+ noMsg = ActionError "Unkown Internal Action Error"+ strMsg = ActionError+#endif++type ActionT = ActionCtxT ()++newtype ActionCtxT ctx m a+ = ActionCtxT+ { runActionCtxT :: ErrorT ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a }+ deriving ( Monad, Functor, Applicative, Alternative, MonadIO+ , MonadReader (RequestInfo ctx), MonadState ResponseState+ , MonadError ActionInterupt+ )++instance MonadTrans (ActionCtxT ctx) where+ lift = ActionCtxT . lift . lift++data SpockConfigInternal+ = SpockConfigInternal+ { sci_maxRequestSize :: Maybe Word64+ , sci_errorHandler :: Status -> IO Wai.Application+ }++defaultSpockConfigInternal :: SpockConfigInternal+defaultSpockConfigInternal = SpockConfigInternal Nothing defaultErrorHandler+ where+ defaultErrorHandler status = return $ \_ respond -> do+ let errorMessage = "Error handler failed with status code " ++ (show $ statusCode status)+ respond $ Wai.responseLBS status500 [] $ BSLC.pack errorMessage++respStateToResponse :: ResponseVal -> Wai.Response+respStateToResponse (ResponseValState (ResponseState headers multiHeaders status (ResponseBody body))) =+ let mkMultiHeader (k, vals) =+ let kCi = multiHeaderCI k+ in map (\v -> (kCi, v)) vals+ outHeaders =+ HM.toList headers+ ++ (concatMap mkMultiHeader $ HM.toList multiHeaders)+ in body status outHeaders+respStateToResponse _ = error "ResponseState expected"++errorResponse :: Status -> BSL.ByteString -> ResponseVal+errorResponse s e =+ ResponseValState $+ ResponseState+ { rs_responseHeaders =+ HM.singleton "Content-Type" "text/html"+ , rs_multiResponseHeaders =+ HM.empty+ , rs_status = s+ , rs_responseBody = ResponseBody $ \status headers ->+ Wai.responseLBS status headers $+ BSL.concat [ "<html><head><title>"+ , e+ , "</title></head><body><h1>"+ , e+ , "</h1></body></html>"+ ]+ }++defResponse :: ResponseState+defResponse =+ ResponseState+ { rs_responseHeaders =+ HM.empty+ , rs_multiResponseHeaders =+ HM.empty+ , rs_status = status200+ , rs_responseBody = ResponseBody $ \status headers ->+ Wai.responseLBS status headers $+ BSL.empty+ }++type SpockAllT n m a = RegistryT (ActionT n) () Wai.Middleware SpockMethod m a++middlewareToApp :: Wai.Middleware+ -> Wai.Application+middlewareToApp mw =+ mw fallbackApp+ where+ fallbackApp :: Wai.Application+ fallbackApp _ respond = respond notFound+ notFound = respStateToResponse $ errorResponse status404 "404 - File not found"++makeActionEnvironment :: InternalState -> SpockMethod -> Wai.Request -> IO (RequestInfo (), TVar V.Vault, IO ())+makeActionEnvironment st stdMethod req =+ do (bodyParams, bodyFiles) <- P.parseRequestBody (P.tempFileBackEnd st) req+ vaultVar <- liftIO $ newTVarIO (Wai.vault req)+ let vaultIf =+ VaultIf+ { vi_modifyVault = atomically . modifyTVar' vaultVar+ , vi_lookupKey = \k -> V.lookup k <$> atomically (readTVar vaultVar)+ }+ uploadedFiles =+ HM.fromList $+ map (\(k, fileInfo) ->+ ( T.decodeUtf8 k+ , UploadedFile (T.decodeUtf8 $ P.fileName fileInfo) (T.decodeUtf8 $ P.fileContentType fileInfo) (P.fileContent fileInfo)+ )+ ) bodyFiles+ postParams =+ map (T.decodeUtf8 *** T.decodeUtf8) bodyParams+ getParams =+ map (\(k, mV) -> (T.decodeUtf8 k, T.decodeUtf8 $ fromMaybe BS.empty mV)) $ Wai.queryString req+ queryParams = postParams ++ getParams+ return ( RequestInfo+ { ri_method = stdMethod+ , ri_request = req+ , ri_queryParams = queryParams+ , ri_files = uploadedFiles+ , ri_vaultIf = vaultIf+ , ri_context = ()+ }+ , vaultVar+ , removeUploadedFiles uploadedFiles+ )++removeUploadedFiles :: HM.HashMap k UploadedFile -> IO ()+removeUploadedFiles uploadedFiles =+ forM_ (HM.elems uploadedFiles) $ \uploadedFile ->+ do stillThere <- doesFileExist (uf_tempLocation uploadedFile)+ when stillThere $ liftIO $ removeFile (uf_tempLocation uploadedFile)++applyAction :: MonadIO m+ => SpockConfigInternal+ -> Wai.Request+ -> RequestInfo ()+ -> [ActionT m ()]+ -> m (Maybe ResponseVal)+applyAction config _ _ [] =+ return $ Just $ getErrorHandler config status404+applyAction config req env (selectedAction : xs) =+ do (r, respState, _) <-+ runRWST (runErrorT $ runActionCtxT selectedAction) env defResponse+ case r of+ Left (ActionRedirect loc) ->+ return $ Just $+ ResponseValState $+ respState+ { rs_status = status302+ , rs_responseBody =+ ResponseBody $ \status headers ->+ Wai.responseLBS status (("Location", T.encodeUtf8 loc) : headers) BSL.empty+ }+ Left ActionTryNext ->+ applyAction config req env xs+ Left (ActionError errorMsg) ->+ do liftIO $ putStrLn $ "Spock Error while handling "+ ++ show (Wai.pathInfo req) ++ ": " ++ errorMsg+ return $ Just $ getErrorHandler config status500+ Left ActionDone ->+ return $ Just (ResponseValState respState)+ Left ActionMiddlewarePass ->+ return Nothing+ Right () ->+ return $ Just (ResponseValState respState)++handleRequest+ :: MonadIO m+ => SpockConfigInternal+ -> SpockMethod+ -> (forall a. m a -> IO a)+ -> [ActionT m ()]+ -> InternalState+ -> Wai.Application -> Wai.Application+handleRequest config stdMethod registryLift allActions st coreApp req respond =+ do reqGo <-+ case sci_maxRequestSize config of+ Nothing -> return req+ Just lim -> requestSizeCheck lim req+ handleRequest' config stdMethod registryLift allActions st coreApp reqGo respond++handleRequest' ::+ MonadIO m+ => SpockConfigInternal+ -> SpockMethod+ -> (forall a. m a -> IO a)+ -> [ActionT m ()]+ -> InternalState+ -> Wai.Application -> Wai.Application+handleRequest' config stdMethod registryLift allActions st coreApp req respond =+ do actEnv <-+ (Left <$> makeActionEnvironment st stdMethod req)+ `catch` \(_ :: SizeException) ->+ return (Right $ getErrorHandler config status413)+ case actEnv of+ Left (mkEnv, vaultVar, cleanUp) ->+ do mRespState <-+ registryLift (applyAction config req mkEnv allActions) `catches`+ [ Handler $ \(_ :: SizeException) ->+ return (Just $ getErrorHandler config status413)+ , Handler $ \(e :: SomeException) ->+ do putStrLn $ "Spock Error while handling " ++ show (Wai.pathInfo req) ++ ": " ++ show e+ return $ Just $ getErrorHandler config status500+ ]+ cleanUp+ case mRespState of+ Just (ResponseHandler responseHandler) ->+ responseHandler >>= \app -> app req respond+ Just respState ->+ respond $ respStateToResponse respState+ Nothing ->+ do newVault <- atomically $ readTVar vaultVar+ let req' = req { Wai.vault = V.union newVault (Wai.vault req) }+ coreApp req' respond+ Right respState ->+ respond $ respStateToResponse respState++getErrorHandler :: SpockConfigInternal -> Status -> ResponseVal+getErrorHandler config = ResponseHandler . sci_errorHandler config++data SizeException+ = SizeException+ deriving (Show, Typeable)++instance Exception SizeException++requestSizeCheck :: Word64 -> Wai.Request -> IO Wai.Request+requestSizeCheck maxSize req =+ do currentSize <- newIORef 0+ return $ req+ { Wai.requestBody =+ do bs <- Wai.requestBody req+ total <-+ atomicModifyIORef currentSize $ \sz ->+ let !nextSize = sz + fromIntegral (BS.length bs)+ in (nextSize, nextSize)+ if total > maxSize+ then throwIO SizeException+ else return bs+ }+++buildMiddleware :: forall m. (MonadIO m)+ => SpockConfigInternal+ -> (forall a. m a -> IO a)+ -> SpockAllT m m ()+ -> IO Wai.Middleware+buildMiddleware config registryLift spockActions =+ do (_, getMatchingRoutes, middlewares) <-+ registryLift $ runRegistry spockActions+ let spockMiddleware = foldl (.) id middlewares+ app :: Wai.Application -> Wai.Application+ app coreApp req respond =+ withSpockMethod (Wai.requestMethod req) $+ \method ->+ do let allActions = getMatchingRoutes method (Wai.pathInfo req)+ runResourceT $ withInternalState $ \st ->+ handleRequest config method registryLift allActions st coreApp req respond+ return $ spockMiddleware . app++withSpockMethod :: forall t. Method -> (SpockMethod -> t) -> t+withSpockMethod method cnt =+ case parseMethod method of+ Left _ ->+ cnt (MethodCustom $ T.decodeUtf8 method)+ Right stdMethod ->+ cnt (MethodStandard $ HttpMethod stdMethod)
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Web/Spock/FrameworkSpecHelper.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE OverloadedStrings #-}+module Web.Spock.FrameworkSpecHelper where++import Test.Hspec+import Test.Hspec.Wai++import Data.Monoid+import Data.Word+import Network.HTTP.Types.Header+import Network.HTTP.Types.Method+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Lazy.Char8 as BSLC+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.Wai as Wai++sizeLimitSpec :: (Word64 -> IO Wai.Application) -> Spec+sizeLimitSpec app =+ with (app maxSize) $+ describe "Request size limit" $+ do it "allows small enough requests the way" $+ do post "/size" okBs `shouldRespondWith` matcher 200 okBs+ post "/size" okBs2 `shouldRespondWith` matcher 200 okBs2+ it "denys large requests the way" $+ post "/size" tooLongBs `shouldRespondWith` 413+ where+ matcher s b =+ ResponseMatcher+ { matchStatus = s+ , matchBody = Just b+ , matchHeaders = []+ }+ maxSize = 1024+ okBs = BSLC.replicate (fromIntegral maxSize - 50) 'i'+ okBs2 = BSLC.replicate (fromIntegral maxSize) 'j'+ tooLongBs = BSLC.replicate (fromIntegral maxSize + 100) 'k'+++frameworkSpec :: IO Wai.Application -> Spec+frameworkSpec app =+ with app $+ do routingSpec+ actionSpec+ headerTest+ cookieTest++routingSpec :: SpecWith Wai.Application+routingSpec =+ describe "Routing Framework" $+ do it "allows root actions" $+ get "/" `shouldRespondWith` "root" { matchStatus = 200 }+ it "routes different HTTP-verbs to different actions" $+ do verbTest get "GET"+ verbTest (`post` "") "POST"+ verbTest (`put` "") "PUT"+ verbTest delete "DELETE"+ verbTest (`patch` "") "PATCH"+ verbTestGp get "GETPOST"+ verbTestGp (`post` "") "GETPOST"+ it "can extract params from routes" $+ get "/param-test/42" `shouldRespondWith` "int42" { matchStatus = 200 }+ it "can handle multiple matching routes" $+ get "/param-test/static" `shouldRespondWith` "static" { matchStatus = 200 }+ it "ignores trailing slashes" $+ get "/param-test/static/" `shouldRespondWith` "static" { matchStatus = 200 }+ it "works with subcomponents" $+ do get "/subcomponent/foo" `shouldRespondWith` "foo" { matchStatus = 200 }+ get "/subcomponent/subcomponent2/bar" `shouldRespondWith` "bar" { matchStatus = 200 }+ it "allows the definition of a fallback handler" $+ get "/askldjas/aklsdj" `shouldRespondWith` "askldjas/aklsdj" { matchStatus = 200 }+ it "allows the definition of a fallback handler for custom verb" $+ request "MYVERB" "/askldjas/aklsdj" [] "" `shouldRespondWith` "askldjas/aklsdj" { matchStatus = 200 }+ it "detected the preferred format" $+ request "GET" "/preferred-format" [("Accept", "text/html,application/xml;q=0.9,image/webp,*/*;q=0.8")] "" `shouldRespondWith` "html" { matchStatus = 200 }+ it "/test-slash and test-noslash are the same thing" $+ do get "/test-slash" `shouldRespondWith` "ok" { matchStatus = 200 }+ get "test-slash" `shouldRespondWith` "ok" { matchStatus = 200 }+ get "/test-noslash" `shouldRespondWith` "ok" { matchStatus = 200 }+ get "test-noslash" `shouldRespondWith` "ok" { matchStatus = 200 }+ it "allows custom verbs" $+ request "NOTIFY" "/notify/itnotifies" [] "" `shouldRespondWith` "itnotifies" { matchStatus = 200 }+ where+ verbTestGp verb verbVerbose =+ verb "/verb-test-gp" `shouldRespondWith` (verbVerbose { matchStatus = 200 })+ verbTest verb verbVerbose =+ verb "/verb-test" `shouldRespondWith` (verbVerbose { matchStatus = 200 })++errorHandlerSpec :: IO Wai.Application -> Spec+errorHandlerSpec app =+ with app $ describe "Error Handler" $+ do it "handles non-existing routes correctly" $+ do get "/non/existing/route" `shouldRespondWith` "NOT FOUND" { matchStatus = 404 }+ post "/non/existing/route" "" `shouldRespondWith` "NOT FOUND" { matchStatus = 404 }+ put "/non/existing/route" "" `shouldRespondWith` "NOT FOUND" { matchStatus = 404 }+ patch "/non/existing/route" "" `shouldRespondWith` "NOT FOUND" { matchStatus = 404 }+ it "handles server errors correctly" $+ get "/failing/route" `shouldRespondWith` "SERVER ERROR" { matchStatus = 500 }+ it "does not interfere with user emitted errors" $+ get "/user/error" `shouldRespondWith` "UNAUTHORIZED" { matchStatus = 403 }+++actionSpec :: SpecWith Wai.Application+actionSpec =+ describe "Action Framework" $+ do it "handles auth correctly" $+ do request methodGet "/auth/user/pass" [mkAuthHeader "user" "pass"] "" `shouldRespondWith` "ok" { matchStatus = 200 }+ request methodGet "/auth/user/pass" [mkAuthHeader "user" ""] "" `shouldRespondWith` "err" { matchStatus = 401 }+ request methodGet "/auth/user/pass" [mkAuthHeader "" ""] "" `shouldRespondWith` "err" { matchStatus = 401 }+ request methodGet "/auth/user/pass" [mkAuthHeader "asd" "asd"] "" `shouldRespondWith` "err" { matchStatus = 401 }+ request methodGet "/auth/user/pass" [] "" `shouldRespondWith` "Authentication required. " { matchStatus = 401 }+ where+ mkAuthHeader :: BS.ByteString -> BS.ByteString -> Header+ mkAuthHeader user pass =+ ("Authorization", "Basic " <> (B64.encode $ user <> ":" <> pass))++cookieTest :: SpecWith Wai.Application+cookieTest =+ describe "Cookies" $+ do it "sets single cookies correctly" $+ get "/cookie/single" `shouldRespondWith`+ "set"+ { matchStatus = 200+ , matchHeaders =+ [ matchCookie "single" "test"+ ]+ }+ it "sets multiple cookies correctly" $+ get "/cookie/multiple" `shouldRespondWith`+ "set"+ { matchStatus = 200+ , matchHeaders =+ [ matchCookie "multiple1" "test1"+ , matchCookie "multiple2" "test2"+ ]+ }+headerTest :: SpecWith Wai.Application+headerTest =+ describe "Headers" $+ do it "supports custom headers" $+ get "/set-header" `shouldRespondWith`+ "ok"+ { matchStatus = 200+ , matchHeaders =+ [ "X-FooBar" <:> "Baz"+ ]+ }+ it "supports multi headers" $+ get "/set-multi-header" `shouldRespondWith`+ "ok"+ { matchStatus = 200+ , matchHeaders =+ [ "Content-Language" <:> "de"+ , "Content-Language" <:> "en"+ ]+ }++matchCookie :: T.Text -> T.Text -> MatchHeader+matchCookie name val =+ MatchHeader $ \headers ->+ let relevantHeaders = filter (\h -> fst h == "Set-Cookie") headers+ loop [] =+ Just ("No cookie named " ++ T.unpack name ++ " with value "+ ++ T.unpack val ++ " found")+ loop (x:xs) =+ let (cname, cval) = T.breakOn "=" $ fst $ T.breakOn ";" $ T.decodeUtf8 $ snd x+ in if cname == name && cval == "=" <> val+ then Nothing+ else loop xs+ in loop relevantHeaders
+ test/Web/Spock/Internal/CookiesSpec.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Web.Spock.Internal.CookiesSpec (spec) where++import Web.Spock.Internal.Cookies++import Control.Monad+import Data.Time+import Test.Hspec+import qualified Data.ByteString as BS++spec :: Spec+spec =+ do describe "Generating Cookies" $+ do describe "with the default settings" $+ do let generated = g "foo" "bar" def++ it "should generate the name-value pair" $+ generated `shouldContainOnce` "foo=bar"++ it "should not generate a max-age key" $+ generated `shouldNotContain'` "Max-Age="++ it "should not generate an expires key" $+ generated `shouldNotContain'` "Expires="++ it "should generate a root path" $+ generated `shouldContainOnce` "Path=/"++ it "should not generate a domain pair" $+ generated `shouldNotContain'` "Domain="++ it "should not generate a httponly key" $+ generated `shouldNotContain'` "HttpOnly"++ it "should not generate a secure key" $+ generated `shouldNotContain'` "Secure"++ describe "when setting an expiration time in the future" $+ do let generated = g "foo" "bar" def { cs_EOL = CookieValidUntil (UTCTime (fromGregorian 2016 1 1) 0) }++ it "should set the correct expires key" $+ generated `shouldContainOnce` "Expires=Fri, 01-Jan-2016 00:00:00 GMT"++ it "should set the correct max-age key" $+ generated `shouldContainOnce` "Max-Age=10465200"++ describe "when setting an expiration time in the past" $+ do let generated = g "foo" "bar" def { cs_EOL = CookieValidUntil (UTCTime (fromGregorian 1970 1 1) 0) }++ it "should set the correct expires key" $+ generated `shouldContainOnce` "Expires=Thu, 01-Jan-1970 00:00:00 GMT"++ it "should set the max-age key to 0" $+ generated `shouldContainOnce` "Max-Age=0"++ describe "when setting the path" $+ it "should generate the correct path pair" $+ g "foo" "bar" def { cs_path = Just "/the-path" } `shouldContainOnce` "Path=/the-path"++ describe "when setting the domain" $+ it "should generate the correct domain pair" $+ g "foo" "bar" def { cs_domain = Just "example.org" } `shouldContainOnce` "Domain=example.org"++ describe "when setting the httponly option" $+ it "should generate the httponly key" $+ g "foo" "bar" def { cs_HTTPOnly = True } `shouldContainOnce` "HttpOnly"++ describe "when setting the secure option" $+ it "should generate the secure key" $+ g "foo" "bar" def { cs_secure = True } `shouldContainOnce` "Secure"++ describe "cookie value" $+ it "should be urlencoded" $+ g "foo" "most+special chars;%бисквитки" def `shouldContainOnce`+ "foo=most%2Bspecial%20chars%3B%25%D0%B1%D0%B8%D1%81%D0%BA%D0%B2%D0%B8%D1%82%D0%BA%D0%B8"++ describe "Parsing cookies" $+ do it "should parse urlencoded multiple cookies" $+ parseCookies "foo=bar;quux=h&m" `shouldBe` [("foo", "bar"), ("quux", "h&m")]+ it "should handle spacing between cookies" $+ parseCookies "foo=bar; quux=bim" `shouldBe` [("foo", "bar"), ("quux", "bim")]+ it "should parse urlencoded values" $+ parseCookies "foo=most%2Bspecial%20chars%3B%25" `shouldBe` [("foo", "most+special chars;%")]++ it "should parse urlencoded utf-8 content" $+ parseCookies "foo=%D0%B1%D0%B8%D1%81%D0%BA%D0%B2%D0%B8%D1%82%D0%BA%D0%B8" `shouldBe` [("foo", "бисквитки")]+ where+ g n v cs = generateCookieHeaderString n v cs t+ def = defaultCookieSettings+ t = UTCTime (fromGregorian 2015 9 1) (21*60*60)+ shouldContainOnce haystack needle =+ let snb actual notExpected =+ unless (actual /= notExpected) $+ expectationFailure $+ "Failed to find " ++ show needle ++ " in " ++ show haystack+ in snd (BS.breakSubstring needle haystack) `snb` BS.empty+ shouldNotContain' haystack needle =+ snd (BS.breakSubstring needle haystack) `shouldBe` BS.empty
+ test/Web/Spock/Internal/UtilSpec.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}+module Web.Spock.Internal.UtilSpec (spec) where++import Web.Spock.Internal.Util++import Test.Hspec++spec :: Spec+spec =+ describe "Utils" $+ do describe "detectPreferredFormat" $+ do it "should detect json-only requests" $+ do detectPreferredFormat "application/json, text/javascript, */*; q=0.01" `shouldBe` PrefJSON+ detectPreferredFormat "application/json;" `shouldBe` PrefJSON+ detectPreferredFormat "text/javascript;" `shouldBe` PrefJSON+ it "should detect browsers as html clients" $+ do detectPreferredFormat "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8" `shouldBe` PrefHTML+ detectPreferredFormat "text/html;" `shouldBe` PrefHTML+ detectPreferredFormat "application/xhtml+xml;" `shouldBe` PrefHTML+ it "should detect xml-only requests" $+ do detectPreferredFormat "application/xml, text/xml, */*; q=0.01" `shouldBe` PrefXML+ detectPreferredFormat "application/xml;" `shouldBe` PrefXML+ detectPreferredFormat "text/xml;" `shouldBe` PrefXML+ it "should detect text-only requests" $+ do detectPreferredFormat "text/plain, */*; q=0.01" `shouldBe` PrefText+ detectPreferredFormat "text/plain;" `shouldBe` PrefText
+ test/Web/Spock/SafeSpec.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DoAndIfThenElse #-}+module Web.Spock.SafeSpec (spec) where++import Web.Spock.Core+import Web.Spock.FrameworkSpecHelper++import Control.Exception.Base+import Control.Monad+import Data.Monoid+import Network.HTTP.Types.Status+import Test.Hspec+import qualified Data.Text as T+import qualified Test.Hspec.Wai as Test++app :: SpockT IO ()+app =+ do get root $ text "root"+ get "verb-test" $ text "GET"+ post "verb-test" $ text "POST"+ getpost "verb-test-gp" $ text "GETPOST"+ put "verb-test" $ text "PUT"+ delete "verb-test" $ text "DELETE"+ patch "verb-test" $ text "PATCH"+ get "test-slash" $ text "ok"+ get "/test-noslash" $ text "ok"+ get ("param-test" <//> var) $ \(i :: Int) ->+ text $ "int" <> T.pack (show i)+ get ("param-test" <//> "static") $+ text "static"+ get ("cookie" <//> "single") $+ do setCookie "single" "test" defaultCookieSettings { cs_EOL = CookieValidFor 3600 }+ text "set"+ get ("cookie" <//> "multiple") $+ do setCookie "multiple1" "test1" defaultCookieSettings { cs_EOL = CookieValidFor 3600 }+ setCookie "multiple2" "test2" defaultCookieSettings { cs_EOL = CookieValidFor 3600 }+ text "set"+ get "set-header" $+ do setHeader "X-FooBar" "Baz"+ text "ok"+ get "set-multi-header" $+ do setHeader "Content-Language" "de"+ setHeader "Content-Language" "en"+ text "ok"+ subcomponent "/subcomponent" $+ do get "foo" $ text "foo"+ subcomponent "/subcomponent2" $+ get "bar" $ text "bar"+ get "preferred-format" $+ do fmt <- preferredFormat+ case fmt of+ PrefHTML -> text "html"+ x -> text (T.pack (show x))+ get ("auth" <//> var <//> var) $ \user pass ->+ let checker user' pass' =+ unless (user == user' && pass == pass') $+ do setStatus status401+ text "err"+ in requireBasicAuth "Foo" checker $ \() -> text "ok"+ hookRouteCustom "NOTIFY" ("notify" <//> var) $ \notification -> text notification+ hookAny GET $ text . T.intercalate "/"+ hookAnyCustom "MYVERB" $ text . T.intercalate "/"++routeRenderingSpec :: Spec+routeRenderingSpec =+ describe "Route Rendering" $+ do it "should work with argument-less routes" $+ do renderRoute "foo" `shouldBe` "/foo"+ renderRoute "/foo" `shouldBe` "/foo"+ renderRoute "/foo/" `shouldBe` "/foo"+ renderRoute ("foo" <//> "bar") `shouldBe` "/foo/bar"+ it "should work with routes with args" $+ do let r1 = var :: Var Int+ renderRoute r1 1 `shouldBe` "/1"+ let r2 = "blog" <//> (var :: Var Int)+ renderRoute r2 2 `shouldBe` "/blog/2"+ let r3 = "blog" <//> (var :: Var Int) <//> (var :: Var T.Text)+ renderRoute r3 2 "BIIM" `shouldBe` "/blog/2/BIIM"++ctxApp :: SpockT IO ()+ctxApp =+ prehook hook $+ do get "test" $ getContext >>= text+ post "test" $ getContext >>= text+ where+ hook =+ do sid <- header "X-ApiKey"+ case sid of+ Just s -> return s+ Nothing -> text "Missing ApiKey"++ctxSpec :: Spec+ctxSpec =+ describe "Contexts" $+ Test.with (spockAsApp $ spockT id ctxApp) $+ it "should work" $+ do Test.request "GET" "/test" [] "" `Test.shouldRespondWith` "Missing ApiKey"+ Test.request "GET" "/test" [("X-ApiKey", "foo")] "" `Test.shouldRespondWith` "foo"+ Test.request "POST" "/test" [("X-ApiKey", "foo")] "" `Test.shouldRespondWith` "foo"++spec :: Spec+spec =+ describe "SafeRouting" $+ do frameworkSpec (spockAsApp $ spockT id app)+ ctxSpec+ routeRenderingSpec+ sizeLimitSpec $ \lim -> spockAsApp $ spockConfigT (defaultSpockConfig { sc_maxRequestSize = Just lim }) id $+ post "size" $ body >>= bytes+ errorHandlerSpec $ spockAsApp $ spockConfigT specConfig id $ do+ get ("failing" <//> "route") $+ throw Overflow+ get ("user" <//> "error") $+ do setStatus status403+ text "UNAUTHORIZED"+ where+ specConfig = defaultSpockConfig { sc_errorHandler = errorHandler }+ errorHandler status = case statusCode status of+ 500 -> text "SERVER ERROR"+ 404 -> text "NOT FOUND"+ _ -> text "OTHER ERROR"+