Spock-core 0.14.0.0 → 0.14.0.1
raw patch · 16 files changed
+1429/−1184 lines, 16 filesdep ~reroutesetup-changednew-uploaderPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
Dependency ranges changed: reroute
API changes (from Hackage documentation)
+ Web.Spock.Core: AvLeft :: a -> AltVar a b
+ Web.Spock.Core: AvRight :: b -> AltVar a b
+ Web.Spock.Core: data AltVar a b
Files
- LICENSE +1/−1
- Setup.hs +1/−0
- Spock-core.cabal +4/−4
- src/Web/Spock/Action.hs +61/−21
- src/Web/Spock/Core.hs +136/−93
- src/Web/Spock/Internal/Config.hs +13/−15
- src/Web/Spock/Internal/Cookies.hs +64/−65
- src/Web/Spock/Internal/CoreAction.hs +198/−142
- src/Web/Spock/Internal/Util.hs +29/−29
- src/Web/Spock/Internal/Wire.hs +450/−406
- src/Web/Spock/Routing.hs +13/−10
- test/Spec.hs +5/−5
- test/Web/Spock/FrameworkSpecHelper.hs +178/−158
- test/Web/Spock/Internal/CookiesSpec.hs +75/−69
- test/Web/Spock/Internal/UtilSpec.hs +25/−19
- test/Web/Spock/SafeSpec.hs +176/−147
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2013 - 2017, Alexander Thiemann <mail@athiemann.net>+Copyright (c) 2013 - 2021, Alexander Thiemann <mail@athiemann.net> All rights reserved.
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
Spock-core.cabal view
@@ -1,5 +1,5 @@ name: Spock-core-version: 0.14.0.0+version: 0.14.0.1 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 - 2020 Alexander Thiemann+copyright: (c) 2013 - 2021 Alexander Thiemann category: Web build-type: Simple-cabal-version: >=2.0-tested-with: GHC==8.8.4+cabal-version: 2.0+tested-with: GHC==8.8.4, GHC==9.2.2 extra-source-files: README.md
src/Web/Spock/Action.hs view
@@ -5,28 +5,68 @@ {-# 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, paramsGet, paramsPost, 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- , respondApp, respondMiddleware- -- * Middleware helpers- , middlewarePass, modifyVault, queryVault- -- * Basic HTTP-Auth- , requireBasicAuth, withBasicAuthData- )+ ( -- * Action types+ ActionT,+ W.ActionCtxT,++ -- * Handling requests+ request,+ header,+ rawHeader,+ cookies,+ cookie,+ reqMethod,+ preferredFormat,+ ClientPreferredFormat (..),+ body,+ jsonBody,+ jsonBody',+ files,+ UploadedFile (..),+ params,+ paramsGet,+ paramsPost,+ 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,+ respondApp,+ respondMiddleware,++ -- * Middleware helpers+ middlewarePass,+ modifyVault,+ queryVault,++ -- * Basic HTTP-Auth+ requireBasicAuth,+ withBasicAuthData,+ ) where import Web.Spock.Internal.CoreAction
src/Web/Spock/Core.hs view
@@ -6,112 +6,150 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+ module Web.Spock.Core- ( -- * Lauching Spock- runSpock, runSpockNoBanner, spockAsApp- -- * Spock's route definition monad- , spockT, spockConfigT, SpockT, SpockCtxT- -- * Defining routes- , Path, root, Var, var, static, (<//>), wildcard- -- * Rendering routes- , renderRoute- -- * Hooking routes- , prehook- , get, post, getpost, head, put, delete, patch, hookRoute, hookRouteCustom, hookAny, hookAnyCustom- , hookRouteAll- , hookAnyAll- , Http.StdMethod (..)- -- * Adding Wai.Middleware- , middleware- -- * Actions- , module Web.Spock.Action- -- * Config- , SpockConfig (..), defaultSpockConfig- -- * Internals- , hookRoute', hookAny', SpockMethod(..), W.HttpMethod(..)- )-where+ ( -- * Lauching Spock+ runSpock,+ runSpockNoBanner,+ spockAsApp, + -- * Spock's route definition monad+ spockT,+ spockConfigT,+ SpockT,+ SpockCtxT, -import Web.Spock.Action-import Web.Spock.Internal.Wire (SpockMethod(..))-import Web.Spock.Routing+ -- * Defining routes+ Path,+ root,+ Var,+ AltVar (..),+ var,+ static,+ (<//>),+ wildcard, + -- * Rendering routes+ renderRoute,++ -- * Hooking routes+ prehook,+ get,+ post,+ getpost,+ head,+ put,+ delete,+ patch,+ hookRoute,+ hookRouteCustom,+ hookAny,+ hookAnyCustom,+ hookRouteAll,+ hookAnyAll,+ Http.StdMethod (..),++ -- * Adding Wai.Middleware+ middleware,++ -- * Actions+ module Web.Spock.Action,++ -- * Config+ SpockConfig (..),+ defaultSpockConfig,++ -- * Internals+ hookRoute',+ hookAny',+ SpockMethod (..),+ W.HttpMethod (..),+ )+where+ import Control.Applicative import Control.Monad.Reader import Data.HVect hiding (head)+import qualified Data.Text as T+import qualified Network.HTTP.Types as Http import Network.HTTP.Types.Method-import Prelude hiding (head, uncurry, curry)+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp import System.IO import Web.HttpApiData import Web.Routing.Combinators hiding (renderRoute)+import qualified Web.Routing.Combinators as COMB import Web.Routing.Router (swapMonad)+import qualified Web.Routing.Router as AR import Web.Routing.SafeRouting+import Web.Spock.Action 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 Network.Wai.Handler.Warp as Warp-import qualified Web.Routing.Combinators as COMB-import qualified Web.Routing.Router as AR+import Web.Spock.Internal.Wire (SpockMethod (..)) import qualified Web.Spock.Internal.Wire as W+import Web.Spock.Routing+import Prelude hiding (curry, head, uncurry) type SpockT = SpockCtxT () -newtype LiftHooked ctx m =- LiftHooked { unLiftHooked :: forall a. ActionCtxT ctx m a -> ActionCtxT () m a }+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+ LiftHooked $ baseHook . nextHook -newtype SpockCtxT ctx m a- = SpockCtxT- { runSpockT :: W.SpockAllT m (ReaderT (LiftHooked ctx m) m) a- } deriving (Monad, Functor, Applicative, MonadIO)+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+ lift = SpockCtxT . lift . lift instance RouteM SpockCtxT where- addMiddleware = SpockCtxT . AR.middleware- wireAny m action =- SpockCtxT $- do hookLift <- lift $ asks unLiftHooked- case m of- MethodAny ->- do forM_ allStdMethods $ \mReg ->- AR.hookAny mReg (hookLift . action)- AR.hookAnyMethod (hookLift . action)- _ -> AR.hookAny m (hookLift . action)- withPrehook = withPrehookImpl- wireRoute = wireRouteImpl+ addMiddleware = SpockCtxT . AR.middleware+ wireAny m action =+ SpockCtxT $+ do+ hookLift <- lift $ asks (\x -> unLiftHooked x)+ case m of+ MethodAny ->+ do+ forM_ allStdMethods $ \mReg ->+ AR.hookAny mReg (hookLift . action)+ AR.hookAnyMethod (hookLift . action)+ _ -> 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+ 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)- case m of- MethodAny ->- do forM_ allStdMethods $ \mReg ->- AR.hookRoute mReg (toInternalPath path) (HVectElim' $ curry $ actionPacker action)- AR.hookRouteAnyMethod (toInternalPath path) (HVectElim' $ curry $ actionPacker action)- _ -> AR.hookRoute m (toInternalPath path) (HVectElim' $ curry $ actionPacker action)+ SpockCtxT $+ do+ hookLift <- lift $ asks (\x -> unLiftHooked x)+ let actionPacker :: HVectElim xs (ActionCtxT ctx m ()) -> HVect xs -> ActionCtxT () m ()+ actionPacker act captures = hookLift (uncurry act captures)+ case m of+ MethodAny ->+ do+ forM_ allStdMethods $ \mReg ->+ AR.hookRoute mReg (toInternalPath path) (HVectElim' $ curry $ actionPacker action)+ AR.hookRouteAnyMethod (toInternalPath path) (HVectElim' $ curry $ actionPacker action)+ _ -> AR.hookRoute m (toInternalPath path) (HVectElim' $ curry $ actionPacker action) allStdMethods :: [SpockMethod] allStdMethods = MethodStandard <$> [minBound .. maxBound]@@ -119,15 +157,17 @@ -- | Run a Spock application. Basically just a wrapper around 'Warp.run'. runSpock :: Warp.Port -> IO Wai.Middleware -> IO () runSpock port mw =- do hPutStrLn stderr ("Spock is running on port " ++ show port)- app <- spockAsApp mw- Warp.run port app+ do+ hPutStrLn stderr ("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+ do+ app <- spockAsApp mw+ Warp.run port app -- | Convert a middleware to an application. All failing requests will -- result in a 404 page@@ -137,21 +177,24 @@ -- | 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 ::+ (MonadIO m) =>+ (forall a. m a -> IO a) ->+ SpockT m () ->+ IO Wai.Middleware spockT = spockConfigT defaultSpockConfig -- | 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 ::+ forall m.+ MonadIO m =>+ SpockConfig ->+ (forall a. m a -> IO a) ->+ SpockT m () ->+ IO Wai.Middleware spockConfigT (SpockConfig maxRequestSize errorAction logError) liftFun app =- W.buildMiddleware internalConfig liftFun (baseAppHook app)+ W.buildMiddleware internalConfig liftFun (baseAppHook app) where internalConfig = W.SpockConfigInternal maxRequestSize errorHandler logError errorHandler status = spockAsApp $ W.buildMiddleware W.defaultSpockConfigInternal id $ baseAppHook $ errorApp status@@ -160,10 +203,10 @@ 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)+ 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, RouteM t, Monad m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
src/Web/Spock/Internal/Config.hs view
@@ -1,26 +1,24 @@ {-# LANGUAGE RankNTypes #-}-module Web.Spock.Internal.Config where -import qualified Web.Spock.Internal.Wire as W+module Web.Spock.Internal.Config where +import qualified Data.Text as T+import qualified Data.Text.IO as T import Data.Word import Network.HTTP.Types.Status import System.IO import Web.Spock.Internal.CoreAction-import qualified Data.Text as T-import qualified Data.Text.IO as T-+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`- , sc_logError :: T.Text -> IO ()- -- ^ Function that should be called to log errors.- }+data SpockConfig = SpockConfig+ { -- | Maximum request size in bytes+ sc_maxRequestSize :: Maybe Word64,+ -- | Error handler. Given status is set in response by default, but you+ -- can always override it with `setStatus`+ sc_errorHandler :: Status -> W.ActionCtxT () IO (),+ -- | Function that should be called to log errors.+ sc_logError :: T.Text -> IO ()+ } -- | Default Spock configuration. No restriction on maximum request size; error -- handler simply prints status message as plain text and all errors are logged
src/Web/Spock/Internal/Cookies.hs view
@@ -1,46 +1,46 @@ {-# 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 Data.Time+import qualified Network.HTTP.Types.URI as URI (urlDecode, urlEncode) 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)- }+data CookieSettings = CookieSettings+ { -- | cookie expiration setting, see 'CookieEOL'+ cs_EOL :: CookieEOL,+ -- | a path for the cookie+ cs_path :: Maybe BS.ByteString,+ -- | a domain for the cookie. 'Nothing' means no domain is set+ cs_domain :: Maybe BS.ByteString,+ -- | whether the cookie should be set as HttpOnly+ cs_HTTPOnly :: Bool,+ -- | whether the cookie should be marked secure (sent over HTTPS only)+ cs_secure :: Bool+ } -- | 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+ = -- | a point in time in UTC until the cookie is valid+ CookieValidUntil UTCTime+ | -- | a period (in seconds) for which the cookie is valid+ CookieValidFor NominalDiffTime+ | -- | the cookie expires with the browser session+ CookieValidForSession+ | -- | the cookie will have an expiration date in the far future+ CookieValidForever -- | Default cookie settings, equals --@@ -51,56 +51,55 @@ -- > , 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 "/"+ 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+ map (\(a, b) -> (T.decodeUtf8 a, T.decodeUtf8 $ URI.urlDecode True b))+ . C.parseCookies generateCookieHeaderString ::- T.Text- -> T.Text- -> CookieSettings- -> UTCTime- -> BS.ByteString+ 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+ 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 2147483000)+ 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
@@ -1,30 +1,59 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DoAndIfThenElse #-}+ module Web.Spock.Internal.CoreAction- ( ActionT- , UploadedFile (..)- , request, header, rawHeader, cookie, cookies, body, jsonBody, jsonBody'- , reqMethod- , files, params, param, param', paramsGet, paramsPost- , 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(..)- , respondApp, respondMiddleware- )+ ( ActionT,+ UploadedFile (..),+ request,+ header,+ rawHeader,+ cookie,+ cookies,+ body,+ jsonBody,+ jsonBody',+ reqMethod,+ files,+ params,+ param,+ param',+ paramsGet,+ paramsPost,+ 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 (..),+ respondApp,+ respondMiddleware,+ ) 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@@ -34,13 +63,6 @@ import Control.Monad.RWS.Strict (runRWST) import Control.Monad.Reader import Control.Monad.State hiding (get, put)-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.HttpApiData import qualified Control.Monad.State as ST import qualified Data.Aeson as A import qualified Data.ByteString as BS@@ -48,10 +70,20 @@ import qualified Data.ByteString.Lazy as BSL import qualified Data.CaseInsensitive as CI import qualified Data.HashMap.Strict as HM+import Data.Maybe+import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T+import Data.Time import qualified Data.Vault.Lazy as V+import Network.HTTP.Types.Header (HeaderName, ResponseHeaders)+import Network.HTTP.Types.Status import qualified Network.Wai as Wai+import Web.HttpApiData+import Web.Spock.Internal.Cookies+import Web.Spock.Internal.Util+import Web.Spock.Internal.Wire+import Prelude hiding (head) -- | Get the original Wai Request object request :: MonadIO m => ActionCtxT ctx m Wai.Request@@ -61,23 +93,24 @@ -- | 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))+ 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+ 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+ 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'@@ -88,34 +121,39 @@ -- | Get the raw request body body :: MonadIO m => ActionCtxT ctx m BS.ByteString body =- do b <- asks ri_reqBody- liftIO $ loadCacheVar (rb_value b)+ do+ b <- asks ri_reqBody+ liftIO $ loadCacheVar (rb_value b) {-# 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+ 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+ 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 =- do b <- asks ri_reqBody- liftIO $ loadCacheVar (rb_files b)+ do+ b <- asks ri_reqBody+ liftIO $ loadCacheVar (rb_files b) {-# INLINE files #-} -- | Get all request GET params@@ -126,41 +164,46 @@ -- | 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)+ 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 =- do g <- paramsGet- p <- paramsPost- return $ g ++ p+ do+ g <- paramsGet+ p <- paramsPost+ return $ g ++ p {-# INLINE params #-} -- | 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 <- params- return $ join $ fmap (either (const Nothing) Just . parseQueryParam) (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' :: (FromHttpApiData 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+ 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 }+ modify $ \rs -> rs {rs_status = s} {-# INLINE setStatus #-} -- | Set a response header. If the response header@@ -173,11 +216,11 @@ 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+ 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 ()@@ -187,11 +230,11 @@ -- | 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)- }+ 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 ()@@ -201,11 +244,11 @@ -- | 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)- }+ 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@@ -242,68 +285,75 @@ -- | 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+ 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+ 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+ 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+ 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+ 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+ 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+ 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+ 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+ 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+ response $ \status headers -> Wai.responseStream status headers val {-# INLINE stream #-} -- | Convenience Basic authentification@@ -316,37 +366,38 @@ -- > 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 ->+ withBasicAuthData $ \mAuthHeader -> case mAuthHeader of Nothing ->- authFailed 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+ 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))+ 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@@ -356,46 +407,50 @@ -- | 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+ 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+ 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)+ 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 $- maybe [] parseCookies $- lookup "cookie" (Wai.requestHeaders req)+ do+ req <- request+ return $+ maybe [] parseCookies $+ lookup "cookie" (Wai.requestHeaders req) {-# INLINE cookies #-} -- | Read a cookie. The cookie value will already be urldecoded. Note that it is@@ -403,6 +458,7 @@ -- handler. cookie :: MonadIO m => T.Text -> ActionCtxT ctx m (Maybe T.Text) cookie name =- do allCookies <- cookies- return $ lookup name allCookies+ do+ allCookies <- cookies+ return $ lookup name allCookies {-# INLINE cookie #-}
src/Web/Spock/Internal/Util.hs view
@@ -1,47 +1,47 @@ {-# LANGUAGE OverloadedStrings #-}+ module Web.Spock.Internal.Util where +import qualified Data.HashMap.Strict as HM import Data.Maybe+import qualified Data.Text as T 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)+ = 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)+ 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-+ 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)+ 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
@@ -1,20 +1,21 @@-{-# OPTIONS_GHC -Wno-warnings-deprecations #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# OPTIONS_GHC -Wno-warnings-deprecations #-}+ module Web.Spock.Internal.Wire where import Control.Applicative@@ -23,226 +24,227 @@ import Control.Concurrent.STM import Control.Exception import Control.Monad.Base-import Control.Monad.RWS.Strict hiding ((<>)) #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.Control-import Control.Monad.Trans.Resource-import Data.Hashable-import Data.IORef-import Data.Maybe-import Data.Semigroup-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.IO-import Web.Routing.Router+ import qualified Control.Monad.Morph as MM+import Control.Monad.RWS.Strict hiding ((<>))+import Control.Monad.Reader.Class ()+import Control.Monad.Trans.Control+import Control.Monad.Trans.Resource 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 Data.Hashable+import Data.IORef+import Data.Maybe+import Data.Semigroup import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T+import Data.Typeable import qualified Data.Vault.Lazy as V+import Data.Word+import GHC.Generics+import Network.HTTP.Types.Header (ResponseHeaders)+import Network.HTTP.Types.Method+import Network.HTTP.Types.Status import qualified Network.Wai as Wai import qualified Network.Wai.Parse as P+import System.IO+import Web.Routing.Router -newtype HttpMethod- = HttpMethod { unHttpMethod :: StdMethod }- deriving (Show, Eq, Bounded, Enum, Generic)+newtype HttpMethod = HttpMethod {unHttpMethod :: StdMethod}+ deriving (Show, Eq, Bounded, Enum, Generic) instance Hashable HttpMethod where- hashWithSalt = hashUsing (fromEnum . unHttpMethod)+ 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- -- | Match any HTTP verb- | MethodAny- deriving (Eq, Generic)+ = -- | Standard HTTP Verbs from 'StdMethod'+ MethodStandard !HttpMethod+ | -- | Custom HTTP Verbs using 'T.Text'+ MethodCustom !T.Text+ | -- | Match any HTTP verb+ MethodAny+ deriving (Eq, Generic) instance Hashable SpockMethod -data UploadedFile- = UploadedFile- { uf_name :: !T.Text- , uf_contentType :: !T.Text- , uf_tempLocation :: !FilePath- } deriving Show+data UploadedFile = UploadedFile+ { uf_name :: !T.Text,+ uf_contentType :: !T.Text,+ uf_tempLocation :: !FilePath+ }+ deriving (Show) -data VaultIf- = VaultIf- { vi_modifyVault :: (V.Vault -> V.Vault) -> IO ()- , vi_lookupKey :: forall a. V.Key a -> IO (Maybe a)- }+data VaultIf = VaultIf+ { vi_modifyVault :: (V.Vault -> V.Vault) -> IO (),+ 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- }+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- }+ 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)+ 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) $+ 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)+ 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 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_getParams :: ![(T.Text, T.Text)]- , ri_reqBody :: !RequestBody- , ri_vaultIf :: !VaultIf- , ri_context :: !ctx- }+data RequestInfo ctx = RequestInfo+ { ri_method :: !SpockMethod,+ ri_request :: !Wai.Request,+ ri_getParams :: ![(T.Text, T.Text)],+ ri_reqBody :: !RequestBody,+ 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)+ = 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"+ 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- ]+ 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)+ = 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 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- | ActionMiddleware !(IO Wai.Middleware)- | ActionApplication !(IO Wai.Application)- deriving Typeable+ = ActionRedirect !T.Text+ | ActionTryNext+ | ActionError String+ | ActionDone+ | ActionMiddlewarePass+ | ActionMiddleware !(IO Wai.Middleware)+ | ActionApplication !(IO Wai.Application)+ deriving (Typeable) instance Semigroup ActionInterupt where- _ <> a = a+ _ <> a = a instance Monoid ActionInterupt where- mempty = ActionDone- mappend = (<>)+ mempty = ActionDone+ mappend = (<>) #if MIN_VERSION_mtl(2,2,0) type ErrorT = ExceptT@@ -263,314 +265,356 @@ 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- )+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+ lift = ActionCtxT . lift . lift instance MM.MFunctor (ActionCtxT ctx) where- hoist f m = ActionCtxT (MM.hoist (MM.hoist f) (runActionCtxT m))+ hoist f m = ActionCtxT (MM.hoist (MM.hoist f) (runActionCtxT m)) instance MonadTransControl (ActionCtxT ctx) where- type StT (ActionCtxT ctx) a = (Either ActionInterupt a, ResponseState, ())- liftWith f =- ActionCtxT . toErrorT . RWST $ \requestInfo responseState ->- fmap- (\x -> (pure x, responseState, ()))- (f $ \(ActionCtxT lala) -> runRWST (runErrorT lala) requestInfo responseState)- restoreT mSt = ActionCtxT . toErrorT $ RWST (\_ _ -> mSt)+ type StT (ActionCtxT ctx) a = (Either ActionInterupt a, ResponseState, ())+ liftWith f =+ ActionCtxT . toErrorT . RWST $ \requestInfo responseState ->+ fmap+ (\x -> (pure x, responseState, ()))+ (f $ \(ActionCtxT lala) -> runRWST (runErrorT lala) requestInfo responseState)+ restoreT mSt = ActionCtxT . toErrorT $ RWST (\_ _ -> mSt) instance MonadBase b m => MonadBase b (ActionCtxT ctx m) where- liftBase = liftBaseDefault+ liftBase = liftBaseDefault instance MonadBaseControl b m => MonadBaseControl b (ActionCtxT ctx m) where- type StM (ActionCtxT ctx m) a = ComposeSt (ActionCtxT ctx) m a- liftBaseWith = defaultLiftBaseWith- restoreM = defaultRestoreM+ type StM (ActionCtxT ctx m) a = ComposeSt (ActionCtxT ctx) m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM -data SpockConfigInternal- = SpockConfigInternal- { sci_maxRequestSize :: Maybe Word64- , sci_errorHandler :: Status -> IO Wai.Application- , sci_logError :: T.Text -> IO ()- }+data SpockConfigInternal = SpockConfigInternal+ { sci_maxRequestSize :: Maybe Word64,+ sci_errorHandler :: Status -> IO Wai.Application,+ sci_logError :: T.Text -> IO ()+ } defaultSpockConfigInternal :: SpockConfigInternal defaultSpockConfigInternal =- SpockConfigInternal Nothing defaultErrorHandler (T.hPutStrLn stderr)- where- defaultErrorHandler status = return $ \_ respond ->- do let errorMessage =- "Error handler failed with status code " ++ show (statusCode status)- respond $ Wai.responseLBS status500 [] $ BSLC.pack errorMessage+ SpockConfigInternal Nothing defaultErrorHandler (T.hPutStrLn stderr)+ 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+ 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+ 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>"- ]- }+ { 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+ ResponseState { rs_responseHeaders =- HM.empty- , rs_multiResponseHeaders =- HM.empty- , rs_status = status200- , rs_responseBody = ResponseBody $ \status headers ->+ HM.empty,+ rs_multiResponseHeaders =+ HM.empty,+ rs_status = status200,+ rs_responseBody = ResponseBody $ \status headers -> Wai.responseLBS status headers $- BSL.empty+ BSL.empty } type SpockAllT n m a = RegistryT (ActionT n) () Wai.Middleware SpockMethod m a -middlewareToApp :: Wai.Middleware- -> Wai.Application+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"+ 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)+ InternalState -> SpockMethod -> Wai.Request -> IO (RequestInfo (), TVar V.Vault) makeActionEnvironment st stdMethod 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)- }- getParams =- map (\(k, mV) -> (T.decodeUtf8 k, T.decodeUtf8 $ fromMaybe BS.empty mV)) $ Wai.queryString req- rbValue <-- newCacheVar $- do let parseBody = Wai.getRequestBodyChunk 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_getParams = getParams- , ri_reqBody = reqBody- , ri_vaultIf = vaultIf- , ri_context = ()- }- , vaultVar- )+ do+ vaultVar <- liftIO $ newTVarIO (Wai.vault req)+ let vaultIf =+ VaultIf+ { vi_modifyVault = atomically . modifyTVar' vaultVar,+ vi_lookupKey = \k -> V.lookup k <$> atomically (readTVar vaultVar)+ }+ getParams =+ map (\(k, mV) -> (T.decodeUtf8 k, T.decodeUtf8 $ fromMaybe BS.empty mV)) $ Wai.queryString req+ rbValue <-+ newCacheVar $+ do+ let parseBody = Wai.getRequestBodyChunk 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_getParams = getParams,+ ri_reqBody = reqBody,+ ri_vaultIf = vaultIf,+ ri_context = ()+ },+ vaultVar+ ) -applyAction :: MonadIO m- => SpockConfigInternal- -> Wai.Request- -> RequestInfo ()- -> [ActionT m ()]- -> m (Maybe ResponseVal)+applyAction ::+ MonadIO m =>+ SpockConfigInternal ->+ Wai.Request ->+ RequestInfo () ->+ [ActionT m ()] ->+ m (Maybe ResponseVal) applyAction config _ _ [] =- return $ Just $ getErrorHandler config status404+ 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 $ sci_logError config $- T.pack $- "Spock Error while handling "- ++ show (Wai.pathInfo req) ++ ": " ++ errorMsg- return $ Just $ getErrorHandler config status500- Left ActionDone ->- 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)+ 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 $+ sci_logError config $+ T.pack $+ "Spock Error while handling "+ ++ show (Wai.pathInfo req)+ ++ ": "+ ++ errorMsg+ return $ Just $ getErrorHandler config status500+ Left ActionDone ->+ 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) -handleRequest- :: MonadIO m- => SpockConfigInternal- -> SpockMethod- -> (forall a. m a -> IO a)- -> [ActionT m ()]- -> InternalState- -> Wai.Application -> Wai.Application+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+ 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+ 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) ->- do mRespState <-- registryLift (applyAction config req mkEnv allActions) `catches`- [ Handler $ \(_ :: SizeException) ->- return (Just $ getErrorHandler config status413)- , Handler $ \(e :: SomeException) ->- do sci_logError config $ T.pack $- "Spock Error while handling " ++ show (Wai.pathInfo req)- ++ ": " ++ show e- return $ Just $ getErrorHandler config status500- ]- 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+ do+ actEnv <-+ (Left <$> makeActionEnvironment st stdMethod req)+ `catch` \(_ :: SizeException) ->+ return (Right $ getErrorHandler config status413)+ case actEnv of+ Left (mkEnv, vaultVar) ->+ do+ mRespState <-+ registryLift (applyAction config req mkEnv allActions)+ `catches` [ Handler $ \(_ :: SizeException) ->+ return (Just $ getErrorHandler config status413),+ Handler $ \(e :: SomeException) ->+ do+ sci_logError config $+ T.pack $+ "Spock Error while handling " ++ show (Wai.pathInfo req)+ ++ ": "+ ++ show e+ return $ Just $ getErrorHandler config status500+ ]+ 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)+ = 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.getRequestBodyChunk req- total <-- atomicModifyIORef currentSize $ \sz ->- let !nextSize = sz + fromIntegral (BS.length bs)- in (nextSize, nextSize)- if total > maxSize- then throwIO SizeException- else return bs- }-+ do+ currentSize <- newIORef 0+ return $+ req+ { Wai.requestBody =+ do+ bs <- Wai.getRequestBodyChunk 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 ::+ 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+ 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)+ case parseMethod method of+ Left _ ->+ cnt (MethodCustom $ T.decodeUtf8 method)+ Right stdMethod ->+ cnt (MethodStandard $ HttpMethod stdMethod)
src/Web/Spock/Routing.hs view
@@ -1,19 +1,22 @@ {-# LANGUAGE DataKinds #-}-module Web.Spock.Routing where -import Web.Spock.Action-import Web.Spock.Internal.Wire (SpockMethod(..))+module Web.Spock.Routing where import Control.Monad.Trans import Data.HVect hiding (head)-import Web.Routing.Combinators import qualified Data.Text as T import qualified Network.Wai as Wai+import Web.Routing.Combinators+import Web.Spock.Action+import Web.Spock.Internal.Wire (SpockMethod (..)) class RouteM t where- addMiddleware :: Monad m => Wai.Middleware -> 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 ()+ addMiddleware :: Monad m => Wai.Middleware -> 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 ()
test/Spec.hs view
@@ -1,13 +1,13 @@ module Main where +import Test.Hspec 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+ do+ Web.Spock.Internal.CookiesSpec.spec+ Web.Spock.Internal.UtilSpec.spec+ Web.Spock.SafeSpec.spec
test/Web/Spock/FrameworkSpecHelper.hs view
@@ -1,9 +1,8 @@ {-# 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@@ -12,15 +11,18 @@ #else import Data.Monoid #endif-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 Data.Word+import Network.HTTP.Types.Header+import Network.HTTP.Types.Method import qualified Network.Wai as Wai+import Test.Hspec+import Test.Hspec.Wai statusBodyMatch :: Int -> BSLC.ByteString -> ResponseMatcher #if MIN_VERSION_hspec_wai(0,8,0)@@ -37,164 +39,179 @@ sizeLimitSpec :: (Word64 -> IO Wai.Application) -> Spec sizeLimitSpec app =- with (app maxSize) $+ 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" $+ 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 = statusBodyMatch- maxSize = 1024- okBs = BSLC.replicate (fromIntegral maxSize - 50) 'i'- okBs2 = BSLC.replicate (fromIntegral maxSize) 'j'- tooLongBs = BSLC.replicate (fromIntegral maxSize + 100) 'k'-+ where+ matcher = statusBodyMatch+ 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+ with app $+ do+ routingSpec+ actionSpec+ headerTest+ cookieTest -routingSpec :: SpecWith Wai.Application+routingSpec :: SpecWith (st, Wai.Application) routingSpec =- 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 "matches regardless of the VERB" $- do get "/all/verbs" `shouldRespondWith` "ok" { matchStatus = 200 }- post "/all/verbs" "" `shouldRespondWith` "ok" { matchStatus = 200 }- request "FIZZBUZZ" "/all/verbs" [] "" `shouldRespondWith` "ok" { matchStatus = 200 }- request "NOTIFY" "/all/verbs" [] "" `shouldRespondWith` "ok" { 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 })+ 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 "matches regardless of the VERB" $+ do+ get "/all/verbs" `shouldRespondWith` "ok" {matchStatus = 200}+ post "/all/verbs" "" `shouldRespondWith` "ok" {matchStatus = 200}+ request "FIZZBUZZ" "/all/verbs" [] "" `shouldRespondWith` "ok" {matchStatus = 200}+ request "NOTIFY" "/all/verbs" [] "" `shouldRespondWith` "ok" {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 }-+ 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 :: SpecWith (st, 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))+ 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 :: SpecWith (st, 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+ 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 (st, 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"- ]- }+ 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 =@@ -203,13 +220,16 @@ #else MatchHeader $ \headers -> #endif- 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+ 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
@@ -1,99 +1,105 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-module Web.Spock.Internal.CookiesSpec (spec) where -import Web.Spock.Internal.Cookies+module Web.Spock.Internal.CookiesSpec (spec) where import Control.Monad+import qualified Data.ByteString as BS import Data.Time import Test.Hspec-import qualified Data.ByteString as BS+import Web.Spock.Internal.Cookies spec :: Spec spec =- do describe "Generating Cookies" $- do describe "with the default settings" $- do let generated = g "foo" "bar" def+ 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 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 a max-age key" $+ generated `shouldNotContain'` "Max-Age=" - it "should not generate an expires key" $- generated `shouldNotContain'` "Expires="+ it "should not generate an expires key" $+ generated `shouldNotContain'` "Expires=" - it "should generate a root path" $- generated `shouldContainOnce` "Path=/"+ it "should generate a root path" $+ generated `shouldContainOnce` "Path=/" - it "should not generate a domain pair" $- generated `shouldNotContain'` "Domain="+ 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 httponly key" $+ generated `shouldNotContain'` "HttpOnly" - it "should not generate a secure key" $- generated `shouldNotContain'` "Secure"+ 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) }+ 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 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"+ 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) }+ 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 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"+ 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 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 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 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 "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 "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;%")]+ 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+ 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
@@ -1,26 +1,32 @@ {-# LANGUAGE OverloadedStrings #-}-module Web.Spock.Internal.UtilSpec (spec) where -import Web.Spock.Internal.Util+module Web.Spock.Internal.UtilSpec (spec) where import Test.Hspec+import Web.Spock.Internal.Util 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+ 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
@@ -1,203 +1,232 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE CPP #-}+ module Web.Spock.SafeSpec (spec) where -import Web.Spock.Core-import Web.Spock.FrameworkSpecHelper+#if MIN_VERSION_base(4,11,0)+#else+import Data.Monoid+#endif +import qualified Control.Exception as Exception import Control.Exception.Base import Control.Monad import Control.Monad.Base import Control.Monad.Trans.Control import Control.Monad.Trans.Reader import Data.Aeson-#if MIN_VERSION_base(4,11,0)-#else-import Data.Monoid-#endif-import GHC.Generics-import Network.HTTP.Types.Status-import Test.Hspec-import qualified Control.Exception as Exception import qualified Data.ByteString.Lazy.Char8 as BSLC import qualified Data.Text as T import qualified Data.Text.Encoding as T+import GHC.Generics+import Network.HTTP.Types.Status import qualified Network.Wai as Wai+import Test.Hspec import qualified Test.Hspec.Wai as Test+import Web.Spock.Core+import Web.Spock.FrameworkSpecHelper -data SampleJson- = SampleJson- { sampleJson :: T.Text- } deriving (Show, Eq, Generic)+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"- 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"- 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- 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"- hookRouteAll ("all" <//> "verbs") $ text "ok"- hookRouteCustom "NOTIFY" ("notify" <//> var) $ \notification -> text notification- hookAny GET $ text . T.intercalate "/"- hookAnyCustom "MYVERB" $ text . T.intercalate "/"- get ("wai" <//> wildcard) $ \_ ->- respondApp dummyWai+ 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"+ 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+ 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"+ hookRouteAll ("all" <//> "verbs") $ text "ok"+ 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)+ respond $ Wai.responseLBS status200 [] (BSLC.pack $ show $ Wai.pathInfo req) 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"+ 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" -data InstancesTestException = InstancesTestException deriving Show+data InstancesTestException = InstancesTestException deriving (Show)+ instance Exception InstancesTestException instancesApp :: SpockCtxT () (ReaderT T.Text IO) () instancesApp =- do get ("instances" <//> "monad-base") $ text =<< liftBase (pure "ok")- get ("instances" <//> "monad-base-control") $- do res <-- catch'- (throwIO' InstancesTestException)- (\(_ :: InstancesTestException) -> pure "ok")- text res- get ("instances" <//> "monad-trans-control") $- do res <- liftWith (\run -> ask >>= run . text)- restoreT $ pure res- where- -- This is 'catch' from 'Control.Exception.Lifted'.- catch' :: (MonadBaseControl IO m, Exception e) => m a -> (e -> m a) -> m a- catch' a handler =- control $ \runInIO ->- Exception.catch (runInIO a) (\e -> runInIO $ handler e)-- -- This is 'throwIO' from 'Control.Exception.Lifted'.- throwIO' :: (MonadBase IO m, Exception e) => e -> m a- throwIO' = liftBase . Exception.throwIO+ do+ get ("instances" <//> "monad-base") $ text =<< liftBase (pure "ok")+ get ("instances" <//> "monad-base-control") $+ do+ res <-+ catch'+ (throwIO' InstancesTestException)+ (\(_ :: InstancesTestException) -> pure "ok")+ text res+ get ("instances" <//> "monad-trans-control") $+ do+ res <- liftWith (\run -> ask >>= run . text)+ restoreT $ pure res+ where+ -- This is 'catch' from 'Control.Exception.Lifted'.+ catch' :: (MonadBaseControl IO m, Exception e) => m a -> (e -> m a) -> m a+ catch' a handler =+ control $ \runInIO ->+ Exception.catch (runInIO a) (\e -> runInIO $ handler e) + -- This is 'throwIO' from 'Control.Exception.Lifted'.+ throwIO' :: (MonadBase IO m, Exception e) => e -> m a+ throwIO' = liftBase . Exception.throwIO instancesSpec :: Spec instancesSpec =- describe "Instances for ActionT are correct" $+ describe "Instances for ActionT are correct" $ Test.with (spockAsApp $ spockT (flip runReaderT "ok") instancesApp) $- do it "MonadBase" $- Test.request "GET" "/instances/monad-base" [] "" `Test.shouldRespondWith` "ok"- it "MonadBaseControl" $- Test.request "GET" "/instances/monad-base-control" [] "" `Test.shouldRespondWith` "ok"- it "MonadTransControl" $- Test.request "GET" "/instances/monad-trans-control" [] "" `Test.shouldRespondWith` "ok"+ do+ it "MonadBase" $+ Test.request "GET" "/instances/monad-base" [] "" `Test.shouldRespondWith` "ok"+ it "MonadBaseControl" $+ Test.request "GET" "/instances/monad-base-control" [] "" `Test.shouldRespondWith` "ok"+ it "MonadTransControl" $+ Test.request "GET" "/instances/monad-trans-control" [] "" `Test.shouldRespondWith` "ok" 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"+ 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" $+ describe "Contexts" $ Test.with (spockAsApp $ spockT id ctxApp) $- it "should work" $- do Test.request "GET" "/test" [] "" `Test.shouldRespondWith` "Missing ApiKey"+ 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- instancesSpec- 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"+ describe "SafeRouting" $+ do+ frameworkSpec (spockAsApp $ spockT id app)+ ctxSpec+ instancesSpec+ 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 }+ specConfig = defaultSpockConfig {sc_errorHandler = errorHandler} errorHandler status = case statusCode status of 500 -> text "SERVER ERROR" 404 -> text "NOT FOUND"