Spock-core 0.11.0.0 → 0.12.0.0

raw patch · 11 files changed

+361/−243 lines, 11 filesdep +http-api-datadep +superbufferdep −path-piecesdep ~aesondep ~bytestringdep ~hvectPVP ok

version bump matches the API change (PVP)

Dependencies added: http-api-data, superbuffer

Dependencies removed: path-pieces

Dependency ranges changed: aeson, bytestring, hvect, reroute

API changes (from Hackage documentation)

Files

• LICENSE +2/−2
• README.md +9/−133
• Spock-core.cabal +8/−5
• src/Web/Spock/Action.hs +2/−1
• src/Web/Spock/Core.hs +60/−42
• src/Web/Spock/Internal/CoreAction.hs +47/−23
• src/Web/Spock/Internal/Wire.hs +119/−25
• src/Web/Spock/Routing.hs +20/−0
• test/Spec.hs +13/−1
• test/Web/Spock/FrameworkSpecHelper.hs +43/−6
• test/Web/Spock/SafeSpec.hs +38/−5

@@ -1,4 +1,4 @@-Copyright (c) 2013 - 2016, Alexander Thiemann <mail@athiemann.net>+Copyright (c) 2013 - 2017, Alexander Thiemann <mail@athiemann.net>  All rights reserved. @@ -13,7 +13,7 @@       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+    * Neither the name of Alexander Thiemann nor the names of other       contributors may be used to endorse or promote products derived       from this software without specific prior written permission. 

@@ -1,141 +1,17 @@-Spock-=====+Spock-core+==========  [![Build Status](https://travis-ci.org/agrafix/Spock.svg)](https://travis-ci.org/agrafix/Spock)-[![Hackage](https://img.shields.io/hackage/v/Spock.svg)](http://hackage.haskell.org/package/Spock)+[![Hackage](https://img.shields.io/hackage/v/Spock-core.svg)](http://hackage.haskell.org/package/Spock-core)  ## 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+Hackage: [Spock-core](http://hackage.haskell.org/package/Spock-core)+Stackage: [Spock-core](https://www.stackage.org/package/Spock-core) -* 7.8.4-* 7.10.2-* 8.0+Documentation: [Spock-core 0.12.0.0](https://spockdocs.s3.eu-central-1.amazonaws.com/Spock-core-0.12.0.0/Web-Spock-Core.html) -### License+`Spock-core` is the "low level" platform powering [Spock](https://www.stackage.org/package/Spock). You can use it standalone if you+do not need the framework to provide you features like session management, database pooling, csrf protection and more. -Released under the BSD3 license.-(c) 2013 - 2016 Alexander Thiemann+For more information please visit our homepage at [www.spock.li](https://www.spock.li).

@@ -1,5 +1,5 @@ name:                Spock-core-version:             0.11.0.0+version:             0.12.0.0 synopsis:            Another Haskell web framework for rapid development description:         Barebones high performance type safe web framework Homepage:            https://www.spock.li@@ -8,11 +8,11 @@ license-file:        LICENSE author:              Alexander Thiemann <mail@athiemann.net> maintainer:          Alexander Thiemann <mail@athiemann.net>-copyright:           (c) 2013 - 2016 Alexander Thiemann+copyright:           (c) 2013 - 2017 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+tested-with:         GHC==7.10.2, GHC==8.0.1  extra-source-files:     README.md@@ -22,6 +22,7 @@   exposed-modules:                        Web.Spock.Core,                        Web.Spock.Action,+                       Web.Spock.Routing,                        Web.Spock.Internal.Cookies,                        Web.Spock.Internal.Util   other-modules:@@ -39,13 +40,14 @@                        directory >=1.2,                        hashable >=1.2,                        http-types >=0.8,-                       hvect >= 0.2,+                       hvect >= 0.4,                        mtl >=2.1,-                       path-pieces >=0.1.4,+                       http-api-data >= 0.2,                        old-locale >=1.0,                        reroute >=0.3.1,                        resourcet >= 0.4,                        stm >=2.4,+                       superbuffer >= 0.2,                        text >= 0.11.3.1,                        time >=1.4,                        transformers >=0.3,@@ -66,6 +68,7 @@                        Web.Spock.Internal.UtilSpec,                        Web.Spock.SafeSpec   build-depends:+                       aeson,                        base,                        bytestring,                        base64-bytestring >=1.0,

@@ -13,7 +13,7 @@     , preferredFormat, ClientPreferredFormat(..)     , body, jsonBody, jsonBody'     , files, UploadedFile (..)-    , params, param, param'+    , params, paramsGet, paramsPost, param, param'      -- * Working with context     , getContext, runInContext      -- * Sending responses@@ -21,6 +21,7 @@     , CookieEOL(..), setCookie, deleteCookie, bytes, lazyBytes     , setRawMultiHeader, MultiHeader(..)     , text, html, file, json, stream, response+    , respondApp, respondMiddleware       -- * Middleware helpers     , middlewarePass, modifyVault, queryVault       -- * Basic HTTP-Auth

@@ -12,7 +12,7 @@       -- * Spock's route definition monad     , spockT, spockLimT, spockConfigT, SpockT, SpockCtxT       -- * Defining routes-    , Path, root, Var, var, static, (<//>)+    , Path, root, Var, var, static, (<//>), wildcard       -- * Rendering routes     , renderRoute       -- * Hooking routes@@ -33,6 +33,7 @@  import Web.Spock.Action import Web.Spock.Internal.Wire (SpockMethod(..))+import Web.Spock.Routing  import Control.Applicative import Control.Monad.Reader@@ -40,6 +41,7 @@ import Data.Word import Network.HTTP.Types.Method import Prelude hiding (head, uncurry, curry)+import Web.HttpApiData import Web.Routing.Combinators hiding (renderRoute) import Web.Routing.Router (swapMonad) import Web.Routing.SafeRouting@@ -47,10 +49,10 @@ import qualified Data.Text as T import qualified Network.HTTP.Types as Http import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp 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 () @@ -69,6 +71,39 @@ instance MonadTrans (SpockCtxT ctx) where     lift = SpockCtxT . lift . lift +instance RouteM SpockCtxT where+    addMiddleware = SpockCtxT . AR.middleware+    inSubcomponent p (SpockCtxT subapp) =+        SpockCtxT $ AR.subcomponent (toInternalPath p) subapp+    wireAny m action =+        SpockCtxT $+        do hookLift <- lift $ asks unLiftHooked+           AR.hookAny m (hookLift . action)+    withPrehook = withPrehookImpl+    wireRoute = wireRouteImpl++withPrehookImpl :: forall m ctx ctx'. MonadIO m => ActionCtxT ctx m ctx' -> SpockCtxT ctx' m () -> SpockCtxT ctx m ()+withPrehookImpl 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++wireRouteImpl :: forall xs ctx m ps. (HasRep xs, Monad m) => SpockMethod -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()+wireRouteImpl 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)++ -- | Run a Spock application. Basically just a wrapper around 'Warp.run'. runSpock :: Warp.Port -> IO Wai.Middleware -> IO () runSpock port mw =@@ -130,81 +165,63 @@       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 :: (HasRep xs, RouteM t, Monad m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t 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 :: (HasRep xs, RouteM t, Monad m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t 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 :: (HasRep xs, RouteM t, Monad m, Monad (t ctx m)) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t 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 :: (HasRep xs, RouteM t, Monad m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t 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 :: (HasRep xs, RouteM t, Monad m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t 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 :: (HasRep xs, RouteM t, Monad m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t 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 :: (HasRep xs, RouteM t, Monad m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t 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+prehook :: (RouteM t, MonadIO m) => ActionCtxT ctx m ctx' -> t ctx' m () -> t ctx m ()+prehook = withPrehook  -- | 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 :: (HasRep xs, RouteM t, Monad m) => StdMethod -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t 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 :: (HasRep xs, RouteM t, Monad m) => T.Text -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t 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)+hookRoute' :: (HasRep xs, RouteM t, Monad m) => SpockMethod -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()+hookRoute' = wireRoute  -- | 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 :: (RouteM t, Monad m) => StdMethod -> ([T.Text] -> ActionCtxT ctx m ()) -> t 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 :: (RouteM t, Monad m) => T.Text -> ([T.Text] -> ActionCtxT ctx m ()) -> t 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)+hookAny' :: (RouteM t, Monad m) => SpockMethod -> ([T.Text] -> ActionCtxT ctx m ()) -> t ctx m ()+hookAny' = wireAny  -- | Define a subcomponent. Usage example: --@@ -216,17 +233,18 @@ -- -- 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+subcomponent :: (RouteM t, Monad m) => Path '[] 'Open -> t ctx m () -> t ctx m ()+subcomponent = inSubcomponent+{-# DEPRECATED subcomponent "Subcomponents will be removed in the next major release. They break route rendering and should not be used. Consider creating helper functions for reusable route components" #-}  -- | Hook wai middleware into Spock-middleware :: Monad m => Wai.Middleware -> SpockCtxT ctx m ()-middleware = SpockCtxT . AR.middleware+middleware :: (RouteM t, Monad m) => Wai.Middleware -> t ctx m ()+middleware = addMiddleware  -- | 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 :: AllHave ToHttpApiData as => Path as 'Open -> HVectElim as T.Text renderRoute route = curryExpl (pathToRep route) (T.cons '/' . COMB.renderRoute route)

@@ -2,13 +2,13 @@ {-# 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+    , files, params, param, param', paramsGet, paramsPost+    , setStatus, setHeader, redirect     , setRawMultiHeader, MultiHeader(..)     , CookieSettings(..), CookieEOL(..), defaultCookieSettings     , setCookie, deleteCookie@@ -17,6 +17,7 @@     , requireBasicAuth, withBasicAuthData     , getContext, runInContext     , preferredFormat, ClientPreferredFormat(..)+    , respondApp, respondMiddleware     ) where @@ -30,17 +31,17 @@ #else import Control.Monad.Error #endif-import Control.Monad.Reader import Control.Monad.RWS.Strict (runRWST)+import Control.Monad.Reader 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 Web.HttpApiData+import qualified Control.Monad.State as ST import qualified Data.Aeson as A import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64@@ -87,14 +88,8 @@ -- | 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+    do b <- asks ri_reqBody+       liftIO $ loadCacheVar (rb_value b) {-# INLINE body #-}  -- | Parse the request body as json@@ -119,23 +114,39 @@ -- | Get uploaded files files :: MonadIO m => ActionCtxT ctx m (HM.HashMap T.Text UploadedFile) files =-    asks ri_files+    do b <- asks ri_reqBody+       liftIO $ loadCacheVar (rb_files b) {-# INLINE files #-} --- | Get all request params+-- | Get all request GET params+paramsGet :: MonadIO m => ActionCtxT ctx m [(T.Text, T.Text)]+paramsGet = asks ri_getParams+{-# INLINE paramsGet #-}++-- | Get all request POST params+paramsPost :: MonadIO m => ActionCtxT ctx m [(T.Text, T.Text)]+paramsPost =+    do b <- asks ri_reqBody+       liftIO $ loadCacheVar (rb_postParams b)+{-# INLINE paramsPost #-}++-- | Get all request (POST + GET) params params :: MonadIO m => ActionCtxT ctx m [(T.Text, T.Text)]-params = asks ri_queryParams+params =+    do g <- paramsGet+       p <- paramsPost+       return $ g ++ p {-# 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)+-- | Read a request param. Spock looks POST variables first and then in GET variables+param :: (FromHttpApiData p, MonadIO m) => T.Text -> ActionCtxT ctx m (Maybe p) param k =-    do qp <- asks ri_queryParams-       return $ join $ fmap fromPathPiece (lookup k qp)+    do qp <- params+       return $ join $ fmap (either (const Nothing) Just . parseQueryParam) (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' :: (FromHttpApiData p, MonadIO m) => T.Text -> ActionCtxT ctx m p param' k =     do mParam <- param k        case mParam of@@ -206,6 +217,20 @@ redirect = throwError . ActionRedirect {-# INLINE redirect #-} +-- | Respond to the request by running an 'Wai.Application'. This is+-- usefull in combination with wildcard routes. This can not be used+-- in combination with other request consuming combinators+-- like 'jsonBody', 'body', 'paramsPost', ...+respondApp :: Monad m => Wai.Application -> ActionCtxT ctx m a+respondApp = throwError . ActionApplication . return++-- | Respond to the request by running a 'Wai.Middleware'. This is+-- usefull in combination with wildcard routes. This can not be used+-- in combination with other request consuming combinators+-- like 'jsonBody', 'body', 'paramsPost', ...+respondMiddleware :: Monad m => Wai.Middleware -> ActionCtxT ctx m a+respondMiddleware = throwError . ActionMiddleware . return+ -- | 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@@ -369,8 +394,7 @@ cookies =     do req <- request        return $-           fromMaybe [] $-           fmap parseCookies $+           maybe [] parseCookies $            lookup "cookie" (Wai.requestHeaders req) {-# INLINE cookies #-} 

@@ -1,3 +1,4 @@+{-# LANGUAGE GADTs #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -12,8 +13,9 @@ {-# LANGUAGE TypeOperators #-} module Web.Spock.Internal.Wire where -import Control.Arrow ((***)) import Control.Applicative+import Control.Arrow ((***))+import Control.Concurrent.MVar import Control.Concurrent.STM import Control.Exception import Control.Monad.RWS.Strict@@ -43,6 +45,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC+import qualified Data.ByteString.SuperBuffer as SB import qualified Data.CaseInsensitive as CI import qualified Data.HashMap.Strict as HM import qualified Data.Text as T@@ -74,7 +77,7 @@    { uf_name :: !T.Text    , uf_contentType :: !T.Text    , uf_tempLocation :: !FilePath-   }+   } deriving Show  data VaultIf    = VaultIf@@ -82,12 +85,58 @@    , vi_lookupKey :: forall a. V.Key a -> IO (Maybe a)    } +data CacheVar v+    = forall r. CacheVar+    { cv_lock :: !(MVar ())+    , cv_makeVal :: !(IO r)+    , cv_value :: !(IORef (Maybe r))+    , cv_read :: r -> v+    }++instance Functor CacheVar where+    fmap f (CacheVar lock makeVal valRef readV) =+        CacheVar+        { cv_lock = lock+        , cv_makeVal = makeVal+        , cv_value = valRef+        , cv_read = f . readV+        }++newCacheVar :: IO v -> IO (CacheVar v)+newCacheVar makeVal =+    do lock <- newEmptyMVar+       valueR <- newIORef Nothing+       return (CacheVar lock makeVal valueR id)++loadCacheVarOpt :: CacheVar v -> IO (Maybe v)+loadCacheVarOpt (CacheVar lock _ valRef readV) =+    bracket_ (putMVar lock ()) (takeMVar lock) $+    fmap readV <$> readIORef valRef++loadCacheVar :: CacheVar v -> IO v+loadCacheVar (CacheVar lock makeVal valRef readV) =+    bracket_ (putMVar lock ()) (takeMVar lock) $+    do val <- readIORef valRef+       case val of+         Just v -> return (readV v)+         Nothing ->+             do v <- makeVal+                writeIORef valRef (Just v)+                return (readV v)++data RequestBody+    = RequestBody+    { rb_value :: CacheVar BS.ByteString+    , rb_postParams :: CacheVar [(T.Text, T.Text)]+    , rb_files :: CacheVar (HM.HashMap T.Text UploadedFile)+    }+ 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_getParams :: ![(T.Text, T.Text)]+   , ri_reqBody :: !RequestBody    , ri_vaultIf :: !VaultIf    , ri_context :: !ctx    }@@ -171,7 +220,9 @@     | ActionError String     | ActionDone     | ActionMiddlewarePass-    deriving (Show, Typeable)+    | ActionMiddleware !(IO Wai.Middleware)+    | ActionApplication !(IO Wai.Application)+    deriving Typeable  instance Monoid ActionInterupt where     mempty = ActionDone@@ -269,42 +320,78 @@  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)+    do 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+       rbValue <-+           newCacheVar $+           do let parseBody = Wai.requestBody req+                  bodyLength = Wai.requestBodyLength req+                  buffStart =+                      case bodyLength of+                        Wai.ChunkedBody -> 1024+                        Wai.KnownLength x -> fromIntegral x+              SB.withBuffer buffStart $ \sb ->+                  do let loop =+                             do b <- parseBody+                                if BS.null b then pure () else (SB.appendBuffer sb b >> loop)+                     loop+       bodyTuple <-+           newCacheVar $+           case P.getRequestBodyType req of+             Nothing -> return ([], HM.empty)+             Just rbt ->+                 do bodyBs <- loadCacheVar rbValue+                    bodyRef <- newIORef (Just bodyBs)+                    let loader =+                            do mb <- readIORef bodyRef+                               case mb of+                                 Just b -> writeIORef bodyRef Nothing >> pure b+                                 Nothing -> pure BS.empty+                    (bodyParams, bodyFiles) <-+                        P.sinkRequestBody (P.tempFileBackEnd st) rbt loader+                    let uploadedFiles =+                            HM.fromList $+                            flip map bodyFiles $ \(k, fileInfo) ->+                            ( T.decodeUtf8 k+                            , UploadedFile (T.decodeUtf8 $ P.fileName fileInfo)+                                (T.decodeUtf8 $ P.fileContentType fileInfo) (P.fileContent fileInfo)+                            )+                        postParams =+                            map (T.decodeUtf8 *** T.decodeUtf8) bodyParams+                    return (postParams, uploadedFiles)+       let reqBody =+               RequestBody+               { rb_value = rbValue+               , rb_files = fmap snd bodyTuple+               , rb_postParams = fmap fst bodyTuple+               }        return ( RequestInfo                 { ri_method = stdMethod                 , ri_request = req-                , ri_queryParams = queryParams-                , ri_files = uploadedFiles+                , ri_getParams = getParams+                , ri_reqBody = reqBody                 , ri_vaultIf = vaultIf                 , ri_context = ()                 }               , vaultVar-              , removeUploadedFiles uploadedFiles+              , removeUploadedFiles (rb_files reqBody)               ) -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)+removeUploadedFiles :: CacheVar (HM.HashMap k UploadedFile) -> IO ()+removeUploadedFiles uploadedFilesRef =+    do cvals <- loadCacheVarOpt uploadedFilesRef+       case cvals of+         Nothing -> return ()+         Just uploadedFiles ->+             forM_ (HM.elems uploadedFiles) $ \uploadedFile ->+             do stillThere <- doesFileExist (uf_tempLocation uploadedFile)+                when stillThere $ liftIO $ removeFile (uf_tempLocation uploadedFile)  applyAction :: MonadIO m             => SpockConfigInternal@@ -337,6 +424,13 @@              return $ Just (ResponseValState respState)          Left ActionMiddlewarePass ->              return Nothing+         Left (ActionApplication app) ->+             return $ Just (ResponseHandler app)+         Left (ActionMiddleware getMiddleware) ->+             return $ Just $ ResponseHandler $+                do errHandler <- sci_errorHandler config status404+                   mw <- getMiddleware+                   return $ mw errHandler          Right () ->              return $ Just (ResponseValState respState) 

@@ -0,0 +1,20 @@+{-# LANGUAGE DataKinds #-}+module Web.Spock.Routing where++import Web.Spock.Action+import Web.Spock.Internal.Wire (SpockMethod(..))++import Control.Monad.Trans+import Data.HVect hiding (head)+import Web.Routing.Combinators+import qualified Network.Wai as Wai+import qualified Data.Text as T++class RouteM t where+    addMiddleware :: Monad m => Wai.Middleware -> t ctx m ()+    inSubcomponent :: Monad m => Path '[] 'Open -> t ctx m () -> t ctx m ()+    withPrehook :: MonadIO m => ActionCtxT ctx m ctx' -> t ctx' m () -> t ctx m ()+    wireAny ::+        Monad m => SpockMethod -> ([T.Text] -> ActionCtxT ctx m ()) -> t ctx m ()+    wireRoute ::+        (Monad m, HasRep xs) => SpockMethod -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()

@@ -1,1 +1,13 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+module Main where++import qualified Web.Spock.Internal.CookiesSpec+import qualified Web.Spock.Internal.UtilSpec+import qualified Web.Spock.SafeSpec++import Test.Hspec++main :: IO ()+main = hspec $+    do Web.Spock.Internal.CookiesSpec.spec+       Web.Spock.Internal.UtilSpec.spec+       Web.Spock.SafeSpec.spec

@@ -1,8 +1,12 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Web.Spock.FrameworkSpecHelper where  import Test.Hspec import Test.Hspec.Wai+#if MIN_VERSION_hspec_wai(0,8,0)+import Test.Hspec.Wai.Matcher+#endif  import Data.Monoid import Data.Word@@ -15,6 +19,19 @@ import qualified Data.Text.Encoding as T import qualified Network.Wai as Wai +statusBodyMatch :: Int -> BSLC.ByteString -> ResponseMatcher+#if MIN_VERSION_hspec_wai(0,8,0)+statusBodyMatch s b =+    ResponseMatcher+    { matchStatus = s+    , matchBody = bodyEquals b+    , matchHeaders = []+    }+#else+statusBodyMatch s b =+    ResponseMatcher { matchStatus = s, matchBody = Just b, matchHeaders = [] }+#endif+ sizeLimitSpec :: (Word64 -> IO Wai.Application) -> Spec sizeLimitSpec app =     with (app maxSize) $@@ -25,12 +42,7 @@        it "denys large requests the way" $           post "/size" tooLongBs `shouldRespondWith` 413     where-      matcher s b =-          ResponseMatcher-          { matchStatus = s-          , matchBody = Just b-          , matchHeaders = []-          }+      matcher = statusBodyMatch       maxSize = 1024       okBs = BSLC.replicate (fromIntegral maxSize - 50) 'i'       okBs2 = BSLC.replicate (fromIntegral maxSize) 'j'@@ -50,6 +62,27 @@     describe "Routing Framework" $       do it "allows root actions" $             get "/" `shouldRespondWith` "root" { matchStatus = 200 }+         it "allows access to get params" $+            get "/get-params?foo=bar" `shouldRespondWith` "[(\"foo\",\"bar\")]" { matchStatus = 200 }+         it "supports wai app responses" $+             do get "/wai/foo" `shouldRespondWith` "[\"wai\",\"foo\"]" { matchStatus = 200 }+                get "/wai/foo/bar" `shouldRespondWith` "[\"wai\",\"foo\",\"bar\"]" { matchStatus = 200 }+         it "allows access to post params" $+            postHtmlForm "/post-params" [("foo", "bar")]+                `shouldRespondWith` "[(\"foo\",\"bar\")]" { matchStatus = 200 }+         it "allows access to empty post params" $+            postHtmlForm "/post-params" []+                `shouldRespondWith` "[]" { matchStatus = 200 }+         it "allows broken body for post params" $+             post "/post-params" ""+                `shouldRespondWith` "[]" { matchStatus = 200 }+         it "allows json body" $+             post "/json" "{ \"sampleJson\": \"foo\"}"+                 `shouldRespondWith` "foo" { matchStatus = 200 }+         it "allows raw body" $+             post "/raw-body" "raw" `shouldRespondWith` "raw" { matchStatus = 200 }+         it "allows empty raw body" $+             post "/raw-body" "" `shouldRespondWith` "" { matchStatus = 200 }          it "routes different HTTP-verbs to different actions" $             do verbTest get "GET"                verbTest (`post` "") "POST"@@ -157,7 +190,11 @@  matchCookie :: T.Text -> T.Text -> MatchHeader matchCookie name val =+#if MIN_VERSION_hspec_wai(0,8,0)+    MatchHeader $ \headers _ ->+#else     MatchHeader $ \headers ->+#endif         let relevantHeaders = filter (\h -> fst h == "Set-Cookie") headers             loop [] =                 Just ("No cookie named " ++ T.unpack name ++ " with value "

@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE DeriveGeneric #-} module Web.Spock.SafeSpec (spec) where  import Web.Spock.Core@@ -8,12 +9,25 @@  import Control.Exception.Base import Control.Monad+import Data.Aeson import Data.Monoid+import GHC.Generics import Network.HTTP.Types.Status import Test.Hspec+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 import qualified Test.Hspec.Wai as Test +data SampleJson+    = SampleJson+    { sampleJson :: T.Text+    } deriving (Show, Eq, Generic)++instance ToJSON SampleJson+instance FromJSON SampleJson+ app :: SpockT IO () app =     do get root $ text "root"@@ -43,10 +57,24 @@            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 "get-params" $+           do gp <- paramsGet+              text (T.pack $ show gp)+       post "post-params" $+           do gp <- paramsPost+              text (T.pack $ show gp)+       post "json" $+           do jbody <- jsonBody'+              text (sampleJson jbody)+       post "raw-body" $+           do b <- body+              text (T.decodeUtf8 b)+       let subcomp x =+               "subcomponent" <//> x+           subsubcomp x =+               subcomp ("subcomponent2" <//> x)+       get (subcomp "foo") $ text "foo"+       get (subsubcomp "bar") $ text "bar"        get "preferred-format" $          do fmt <- preferredFormat             case fmt of@@ -61,7 +89,13 @@        hookRouteCustom "NOTIFY" ("notify" <//> var) $ \notification -> text notification        hookAny GET $ text . T.intercalate "/"        hookAnyCustom "MYVERB" $ text . T.intercalate "/"+       get ("wai" <//> wildcard) $ \_ ->+           respondApp dummyWai +dummyWai :: Wai.Application+dummyWai req respond =+    respond $ Wai.responseLBS status200 [] (BSLC.pack $ show $ Wai.pathInfo req)+ routeRenderingSpec :: Spec routeRenderingSpec =     describe "Route Rendering" $@@ -119,4 +153,3 @@       500 -> text "SERVER ERROR"       404 -> text "NOT FOUND"       _ -> text "OTHER ERROR"-