diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013 - 2016, Alexander Thiemann +Copyright (c) 2013 - 2017, Alexander Thiemann 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 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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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). diff --git a/Spock-core.cabal b/Spock-core.cabal --- a/Spock-core.cabal +++ b/Spock-core.cabal @@ -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 maintainer: Alexander Thiemann -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, diff --git a/src/Web/Spock/Action.hs b/src/Web/Spock/Action.hs --- a/src/Web/Spock/Action.hs +++ b/src/Web/Spock/Action.hs @@ -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 diff --git a/src/Web/Spock/Core.hs b/src/Web/Spock/Core.hs --- a/src/Web/Spock/Core.hs +++ b/src/Web/Spock/Core.hs @@ -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) diff --git a/src/Web/Spock/Internal/CoreAction.hs b/src/Web/Spock/Internal/CoreAction.hs --- a/src/Web/Spock/Internal/CoreAction.hs +++ b/src/Web/Spock/Internal/CoreAction.hs @@ -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 #-} diff --git a/src/Web/Spock/Internal/Wire.hs b/src/Web/Spock/Internal/Wire.hs --- a/src/Web/Spock/Internal/Wire.hs +++ b/src/Web/Spock/Internal/Wire.hs @@ -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) diff --git a/src/Web/Spock/Routing.hs b/src/Web/Spock/Routing.hs new file mode 100644 --- /dev/null +++ b/src/Web/Spock/Routing.hs @@ -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 () diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/test/Web/Spock/FrameworkSpecHelper.hs b/test/Web/Spock/FrameworkSpecHelper.hs --- a/test/Web/Spock/FrameworkSpecHelper.hs +++ b/test/Web/Spock/FrameworkSpecHelper.hs @@ -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 " diff --git a/test/Web/Spock/SafeSpec.hs b/test/Web/Spock/SafeSpec.hs --- a/test/Web/Spock/SafeSpec.hs +++ b/test/Web/Spock/SafeSpec.hs @@ -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" -