Spock 0.7.12.0 → 0.8.0.0
raw patch · 11 files changed
+326/−56 lines, 11 filesdep ~bytestringPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: bytestring
API changes (from Hackage documentation)
+ Web.Spock.Safe: spockLimT :: MonadIO m => Maybe Word64 -> (forall a. m a -> IO a) -> SpockT m () -> IO Middleware
+ Web.Spock.Shared: SpockCfg :: st -> PoolOrConn conn -> SessionCfg sess -> Maybe Word64 -> SpockCfg conn sess st
+ Web.Spock.Shared: data SpockCfg conn sess st
+ Web.Spock.Shared: defaultSpockCfg :: sess -> PoolOrConn conn -> st -> SpockCfg conn sess st
+ Web.Spock.Shared: spc_database :: SpockCfg conn sess st -> PoolOrConn conn
+ Web.Spock.Shared: spc_initialState :: SpockCfg conn sess st -> st
+ Web.Spock.Shared: spc_maxRequestSize :: SpockCfg conn sess st -> Maybe Word64
+ Web.Spock.Shared: spc_sessionCfg :: SpockCfg conn sess st -> SessionCfg sess
+ Web.Spock.Simple: spockLimT :: MonadIO m => Maybe Word64 -> (forall a. m a -> IO a) -> SpockT m () -> IO Middleware
- Web.Spock.Safe: spock :: SessionCfg sess -> PoolOrConn conn -> st -> SpockM conn sess st () -> IO Middleware
+ Web.Spock.Safe: spock :: SpockCfg conn sess st -> SpockM conn sess st () -> IO Middleware
- Web.Spock.Simple: spock :: SessionCfg sess -> PoolOrConn conn -> st -> SpockM conn sess st () -> IO Middleware
+ Web.Spock.Simple: spock :: SpockCfg conn sess st -> SpockM conn sess st () -> IO Middleware
Files
- Spock.cabal +2/−1
- src/Web/Spock/Internal/Core.hs +10/−6
- src/Web/Spock/Internal/CoreAction.hs +33/−8
- src/Web/Spock/Internal/Types.hs +24/−0
- src/Web/Spock/Internal/Wire.hs +139/−27
- src/Web/Spock/Safe.hs +16/−6
- src/Web/Spock/Shared.hs +2/−0
- src/Web/Spock/Simple.hs +16/−7
- test/Web/Spock/FrameworkSpecHelper.hs +63/−0
- test/Web/Spock/SafeSpec.hs +9/−0
- test/Web/Spock/SimpleSpec.hs +12/−1
Spock.cabal view
@@ -1,5 +1,5 @@ name: Spock-version: 0.7.12.0+version: 0.8.0.0 synopsis: Another Haskell web framework for rapid development description: This toolbox provides everything you need to get a quick start into web hacking with haskell: .@@ -91,6 +91,7 @@ Web.Spock.SimpleSpec build-depends: base,+ bytestring, hspec >= 2.0, hspec-wai >= 0.6, http-types,
src/Web/Spock/Internal/Core.hs view
@@ -27,6 +27,7 @@ import Control.Monad.Trans.Reader import Control.Monad.Trans.Resource import Data.Pool+import Data.Word import Prelude hiding (head) import Web.Routing.AbstractRouter import qualified Network.Wai as Wai@@ -39,12 +40,10 @@ , RouteAppliedAction r ~ ActionT (WebStateM conn sess st) () ) => r- -> SessionCfg sess- -> PoolOrConn conn- -> st+ -> SpockCfg conn sess st -> SpockAllM r conn sess st () -> IO Wai.Middleware-spockAll regIf sessionCfg poolOrConn initialState defs =+spockAll regIf spockCfg defs = do sessionMgr <- createSessionManager sessionCfg connectionPool <- case poolOrConn of@@ -61,14 +60,19 @@ , web_sessionMgr = sessionMgr , web_state = initialState }- spockAllT regIf (\m -> runResourceT $ runReaderT (runWebStateT m) internalState) $+ spockAllT (spc_maxRequestSize spockCfg) regIf (\m -> runResourceT $ runReaderT (runWebStateT m) internalState) $ do defs middleware (sm_middleware sessionMgr)+ where+ sessionCfg = spc_sessionCfg spockCfg+ poolOrConn = spc_database spockCfg+ initialState = spc_initialState spockCfg -- | Run a raw spock server on a defined port. If you don't need -- a custom base monad you can just supply 'id' as lift function. spockAllT :: (MonadIO m, AbstractRouter r, RouteAppliedAction r ~ ActionT m ())- => r+ => Maybe Word64+ -> r -> (forall a. m a -> IO a) -> SpockAllT r m () -> IO Wai.Middleware
src/Web/Spock/Internal/CoreAction.hs view
@@ -168,16 +168,41 @@ modify $ \rs -> rs { rs_status = s } {-# INLINE setStatus #-} --- | Set a response header. Overwrites already defined headers+-- | Set a response header. If the response header+-- is allowed to occur multiple times (as in RFC 2616), it will+-- be appended. Otherwise the previous value is overwritten.+-- See 'setMultiHeader'. setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m () setHeader k v =+ do let ciVal = CI.mk $ T.encodeUtf8 k+ case HM.lookup ciVal multiHeaderMap of+ Just mhk ->+ setMultiHeader mhk v+ Nothing ->+ setHeaderUnsafe k v+{-# INLINE setHeader #-}++-- | INTERNAL: Set a response header that can occur multiple times. (eg: Cache-Control)+setMultiHeader :: MonadIO m => MultiHeader -> T.Text -> ActionT m ()+setMultiHeader k v = modify $ \rs -> rs+ { rs_multiResponseHeaders =+ HM.insertWith (++) k [T.encodeUtf8 v] (rs_multiResponseHeaders rs)+ }+{-# INLINE setMultiHeader #-}++-- | INTERNAL: Unsafely set a header (no checking if the header can occur multiple times)+setHeaderUnsafe :: MonadIO m => T.Text -> T.Text -> ActionT m ()+setHeaderUnsafe k v =+ modify $ \rs ->+ rs { rs_responseHeaders = HM.insert (CI.mk $ T.encodeUtf8 k) (T.encodeUtf8 v) (rs_responseHeaders rs) }-{-# INLINE setHeader #-}+{-# INLINE setHeaderUnsafe #-} + -- | Abort the current action and jump the next one matching the route jumpNext :: MonadIO m => ActionT m a jumpNext = throwError ActionTryNext@@ -226,7 +251,7 @@ -- | Set a cookie living until a specific 'UTCTime' setCookie' :: MonadIO m => T.Text -> T.Text -> UTCTime -> ActionT m () setCookie' name value validUntil =- setHeader "Set-Cookie" rendered+ setMultiHeader MultiHeaderSetCookie rendered where rendered = let formattedTime =@@ -262,28 +287,28 @@ -- | Send text as a response body. Content-Type will be "text/plain" text :: MonadIO m => T.Text -> ActionT m a text val =- do setHeader "Content-Type" "text/plain; charset=utf-8"+ 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 -> ActionT m a html val =- do setHeader "Content-Type" "text/html; charset=utf-8"+ 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 -> ActionT m a file contentType filePath =- do setHeader "Content-Type" contentType+ 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 -> ActionT m b json val =- do setHeader "Content-Type" "application/json; charset=utf-8"+ do setHeaderUnsafe "Content-Type" "application/json; charset=utf-8" lazyBytes $ A.encode val {-# INLINE json #-} @@ -320,5 +345,5 @@ where authFailed = do setStatus status401- setHeader "WWW-Authenticate" ("Basic realm=\"" <> realmTitle <> "\"")+ setMultiHeader MultiHeaderWWWAuth ("Basic realm=\"" <> realmTitle <> "\"") html "<h1>Authentication required.</h1>"
src/Web/Spock/Internal/Types.hs view
@@ -24,6 +24,7 @@ import Data.Pool import Data.Time.Clock ( UTCTime(..), NominalDiffTime ) import Data.Typeable+import Data.Word import Network.Wai import qualified Data.HashMap.Strict as HM import qualified Data.Text as T@@ -35,6 +36,29 @@ -- | The SpockAction is the monad of all route-actions. You have access -- to the database, session and state of your application. type SpockAction conn sess st = ActionT (WebStateM conn sess st)++-- | Spock configuration+data SpockCfg conn sess st+ = SpockCfg+ { spc_initialState :: st+ -- ^ initial application global state+ , spc_database :: PoolOrConn conn+ -- ^ See 'PoolOrConn'+ , spc_sessionCfg :: SessionCfg sess+ -- ^ See 'SessionCfg'+ , spc_maxRequestSize :: Maybe Word64+ -- ^ Maximum request size in bytes. 'Nothing' means no limit. Defaults to 5 MB in @defaultSpockCfg@.+ }++-- | Spock configuration with reasonable defaults+defaultSpockCfg :: sess -> PoolOrConn conn -> st -> SpockCfg conn sess st+defaultSpockCfg sess conn st =+ SpockCfg+ { spc_initialState = st+ , spc_database = conn+ , spc_sessionCfg = defaultSessionCfg sess+ , spc_maxRequestSize = Just (5 * 1024 * 1024)+ } -- | If Spock should take care of connection pooling, you need to configure -- it depending on what you need.
src/Web/Spock/Internal/Wire.hs view
@@ -1,7 +1,11 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}@@ -21,7 +25,11 @@ import Control.Monad.Reader.Class () import Control.Monad.Trans.Resource import Data.Hashable+import Data.IORef import Data.Maybe+import Data.Typeable+import Data.Word+import GHC.Generics import Network.HTTP.Types.Header (ResponseHeaders) import Network.HTTP.Types.Method import Network.HTTP.Types.Status@@ -69,9 +77,50 @@ newtype ResponseBody = ResponseBody (Status -> ResponseHeaders -> Wai.Response) +data MultiHeader+ = MultiHeaderCacheControl+ | MultiHeaderConnection+ | MultiHeaderContentEncoding+ | MultiHeaderContentLanguage+ | MultiHeaderPragma+ | MultiHeaderProxyAuthenticate+ | MultiHeaderTrailer+ | MultiHeaderTransferEncoding+ | MultiHeaderUpgrade+ | MultiHeaderVia+ | MultiHeaderWarning+ | MultiHeaderWWWAuth+ | MultiHeaderSetCookie+ deriving (Show, Eq, Enum, Bounded, Generic)++instance Hashable MultiHeader++multiHeaderCI :: MultiHeader -> CI.CI BS.ByteString+multiHeaderCI mh =+ case mh of+ MultiHeaderCacheControl -> "Cache-Control"+ MultiHeaderConnection -> "Connection"+ MultiHeaderContentEncoding -> "Content-Encoding"+ MultiHeaderContentLanguage -> "Content-Language"+ MultiHeaderPragma -> "Pragma"+ MultiHeaderProxyAuthenticate -> "Proxy-Authenticate"+ MultiHeaderTrailer -> "Trailer"+ MultiHeaderTransferEncoding -> "Transfer-Encoding"+ MultiHeaderUpgrade -> "Upgrade"+ MultiHeaderVia -> "Via"+ MultiHeaderWarning -> "Warning"+ MultiHeaderWWWAuth -> "WWW-Authenticate"+ MultiHeaderSetCookie -> "Set-Cookie"++multiHeaderMap :: HM.HashMap (CI.CI BS.ByteString) MultiHeader+multiHeaderMap =+ HM.fromList $ flip map [minBound..maxBound] $ \mh ->+ (multiHeaderCI mh, mh)+ 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 }@@ -82,7 +131,7 @@ | ActionError String | ActionDone | ActionMiddlewarePass- deriving (Show)+ deriving (Show, Typeable) instance Monoid ActionInterupt where mempty = ActionDone@@ -106,14 +155,22 @@ lift = ActionT . lift . lift respStateToResponse :: ResponseState -> Wai.Response-respStateToResponse (ResponseState headers status (ResponseBody body)) =- body status $ HM.toList headers+respStateToResponse (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 errorResponse :: Status -> BSL.ByteString -> ResponseState errorResponse s e = 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 $@@ -137,6 +194,10 @@ serverError = errorResponse status500 "500 - Internal Server Error!" +sizeError :: ResponseState+sizeError =+ errorResponse status413 "413 - Request body too large!"+ type SpockAllT r m a = RegistryT r Wai.Middleware StdMethod m a @@ -201,8 +262,13 @@ runRWST (runErrorT $ runActionT selectedAction) env defResp case r of Left (ActionRedirect loc) ->- return $ Just $ ResponseState (rs_responseHeaders respState) status302 $ ResponseBody $- \status headers -> Wai.responseLBS status (("Location", T.encodeUtf8 loc) : headers) BSL.empty+ return $ Just $+ respState+ { rs_status = status302+ , rs_responseBody =+ ResponseBody $ \status headers ->+ Wai.responseLBS status (("Location", T.encodeUtf8 loc) : headers) BSL.empty+ } Left ActionTryNext -> applyAction req mkEnv xs Left (ActionError errorMsg) ->@@ -216,32 +282,78 @@ Right () -> return $ Just respState -handleRequest :: MonadIO m => (forall a. m a -> IO a)- -> [(ParamMap, ActionT m ())]- -> InternalState- -> Wai.Application -> Wai.Application-handleRequest registryLift allActions st coreApp req respond =- do (mkEnv, vaultVar, cleanUp) <- makeActionEnvironment st req- mRespState <-- registryLift (applyAction req mkEnv allActions)- `catch` \(e :: SomeException) ->- do putStrLn $ "Spock Error while handling " ++ show (Wai.pathInfo req) ++ ": " ++ show e- return $ Just serverError- cleanUp- case mRespState of- Just respState ->+handleRequest+ :: MonadIO m+ => Maybe Word64+ -> (forall a. m a -> IO a)+ -> [(ParamMap, ActionT m ())]+ -> InternalState+ -> Wai.Application -> Wai.Application+handleRequest mLimit registryLift allActions st coreApp req respond =+ do reqGo <-+ case mLimit of+ Nothing -> return req+ Just lim -> requestSizeCheck lim req+ handleRequest' registryLift allActions st coreApp reqGo respond++handleRequest' :: MonadIO m => (forall a. m a -> IO a)+ -> [(ParamMap, ActionT m ())]+ -> InternalState+ -> Wai.Application -> Wai.Application+handleRequest' registryLift allActions st coreApp req respond =+ do actEnv <-+ (Left <$> makeActionEnvironment st req)+ `catch` \(_ :: SizeException) ->+ return (Right sizeError)+ case actEnv of+ Left (mkEnv, vaultVar, cleanUp) ->+ do mRespState <-+ registryLift (applyAction req mkEnv allActions)+ `catch` \(_ :: SizeException) ->+ return (Just sizeError)+ `catch` \(e :: SomeException) ->+ do putStrLn $ "Spock Error while handling " ++ show (Wai.pathInfo req) ++ ": " ++ show e+ return $ Just serverError+ cleanUp+ case mRespState of+ 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- Nothing ->- do newVault <- atomically $ readTVar vaultVar- let req' = req { Wai.vault = V.union newVault (Wai.vault req) }- coreApp req' respond +data SizeException+ = SizeException+ deriving (Show, Typeable)++instance Exception SizeException++requestSizeCheck :: Word64 -> Wai.Request -> IO Wai.Request+requestSizeCheck maxSize req =+ do currentSize <- newIORef 0+ return $ req+ { Wai.requestBody =+ do bs <- Wai.requestBody req+ total <-+ atomicModifyIORef currentSize $ \sz ->+ let !nextSize = sz + fromIntegral (BS.length bs)+ in (nextSize, nextSize)+ if total > maxSize+ then throwIO SizeException+ else return bs+ }++ buildMiddleware :: forall m r. (MonadIO m, AbstractRouter r, RouteAppliedAction r ~ ActionT m ())- => r+ => Maybe Word64+ -> r -> (forall a. m a -> IO a) -> SpockAllT r m () -> IO Wai.Middleware-buildMiddleware registryIf registryLift spockActions =+buildMiddleware mLimit registryIf registryLift spockActions = do (_, getMatchingRoutes, middlewares) <- registryLift $ runRegistry registryIf spockActions let spockMiddleware = foldl (.) id middlewares@@ -253,5 +365,5 @@ Right stdMethod -> do let allActions = getMatchingRoutes stdMethod (Wai.pathInfo req) runResourceT $ withInternalState $ \st ->- handleRequest registryLift allActions st coreApp req respond+ handleRequest mLimit registryLift allActions st coreApp req respond return $ spockMiddleware . app
src/Web/Spock/Safe.hs view
@@ -14,7 +14,7 @@ module Web.Spock.Safe ( -- * Spock's route definition monad spock, SpockM- , spockT, SpockT+ , spockT, spockLimT, SpockT -- * Defining routes , Path, root, Var, var, static, (<//>) -- * Rendering routes@@ -41,6 +41,7 @@ import Control.Monad.Trans import Data.HVect hiding (head) import Data.Monoid+import Data.Word import Network.HTTP.Types.Method import Prelude hiding (head) import Web.Routing.SafeRouting hiding (renderRoute)@@ -62,9 +63,9 @@ -- Spock works with database libraries that already implement connection pooling and -- with those that don't come with it out of the box. For more see the 'PoolOrConn' type. -- Use @runSpock@ to run the app or @spockAsApp@ to create a @Wai.Application@-spock :: SessionCfg sess -> PoolOrConn conn -> st -> SpockM conn sess st () -> IO Wai.Middleware-spock sessCfg poolOrConn initSt spockAppl =- C.spockAll SafeRouter sessCfg poolOrConn initSt (runSpockT spockAppl')+spock :: SpockCfg conn sess st -> SpockM conn sess st () -> IO Wai.Middleware+spock spockCfg spockAppl =+ C.spockAll SafeRouter spockCfg (runSpockT spockAppl') where spockAppl' = do hookSafeActions@@ -72,12 +73,21 @@ -- | 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 liftFun (SpockT app) =- C.spockAllT SafeRouter liftFun app+spockT = spockLimT Nothing++-- | Like @spockT@, but first argument is request size limit in bytes. Set to 'Nothing' to disable.+spockLimT :: (MonadIO m)+ => Maybe Word64+ -> (forall a. m a -> IO a)+ -> SpockT m ()+ -> IO Wai.Middleware+spockLimT mSizeLimit liftFun (SpockT app) =+ C.spockAllT mSizeLimit SafeRouter liftFun app -- | Specify an action that will be run when the HTTP verb 'GET' and the given route match get :: MonadIO m => Path xs -> HVectElim xs (ActionT m ()) -> SpockT m ()
@@ -21,6 +21,8 @@ , text, html, file, json, stream, response -- * Middleware helpers , middlewarePass, modifyVault, queryVault+ -- * Configuration+ , SpockCfg (..), defaultSpockCfg -- * Database , PoolOrConn (..), ConnBuilder (..), PoolCfg (..) -- * Accessing Database and State
src/Web/Spock/Simple.hs view
@@ -12,7 +12,7 @@ module Web.Spock.Simple ( -- * Spock's route definition monad spock, SpockM- , spockT, SpockT+ , spockT, spockLimT, SpockT -- * Defining routes , SpockRoute, (<//>) -- * Hooking routes@@ -36,6 +36,7 @@ import Control.Monad.Trans import Data.Monoid import Data.String+import Data.Word import Network.HTTP.Types.Method import Prelude hiding (head) import Web.Routing.TextRouting@@ -63,22 +64,30 @@ -- Spock works with database libraries that already implement connection pooling and -- with those that don't come with it out of the box. For more see the 'PoolOrConn' type. -- Use @runSpock@ to run the app or @spockAsApp@ to create a @Wai.Application@-spock :: SessionCfg sess -> PoolOrConn conn -> st -> SpockM conn sess st () -> IO Wai.Middleware-spock sessCfg poolOrConn initSt spockAppl =- C.spockAll TextRouter sessCfg poolOrConn initSt (runSpockT spockAppl')+spock :: SpockCfg conn sess st -> SpockM conn sess st () -> IO Wai.Middleware+spock cfg spockAppl =+ C.spockAll TextRouter cfg (runSpockT spockAppl') where spockAppl' = do hookSafeActions spockAppl -- | Create a raw spock application with custom underlying monad--- Use @runSpock@ to run the app or @spockAsApp@ to create a @Wai.Application@+-- Use @runSpock@ to run the app or @spockAsApp@ to create a @Wai.Application@. spockT :: (MonadIO m) => (forall a. m a -> IO a) -> SpockT m () -> IO Wai.Middleware-spockT liftFun (SpockT app) =- C.spockAllT TextRouter liftFun app+spockT = spockLimT Nothing++-- | Like @spockT@, but the first argument is request size limit in bytes. Set to 'Nothing' to disable.+spockLimT :: (MonadIO m)+ => Maybe Word64+ -> (forall a. m a -> IO a)+ -> SpockT m ()+ -> IO Wai.Middleware+spockLimT mSizeLimit liftFun (SpockT app) =+ C.spockAllT mSizeLimit TextRouter liftFun app -- | Combine two route components safely --
test/Web/Spock/FrameworkSpecHelper.hs view
@@ -4,13 +4,41 @@ import Test.Hspec import Test.Hspec.Wai +import Data.Monoid+import Data.Word+import qualified Data.ByteString.Lazy.Char8 as BSLC+import qualified Data.Text as T+import qualified Data.Text.Encoding as T import qualified Network.Wai as Wai +sizeLimitSpec :: (Word64 -> IO Wai.Application) -> Spec+sizeLimitSpec app =+ with (app maxSize) $+ describe "Request size limit" $+ do it "allows small enough requests the way" $+ do post "/size" okBs `shouldRespondWith` matcher 200 okBs+ post "/size" okBs2 `shouldRespondWith` matcher 200 okBs2+ it "denys large requests the way" $+ post "/size" tooLongBs `shouldRespondWith` 413+ where+ matcher s b =+ ResponseMatcher+ { matchStatus = s+ , matchBody = Just b+ , matchHeaders = []+ }+ maxSize = 1024+ okBs = BSLC.replicate (fromIntegral maxSize - 50) 'i'+ okBs2 = BSLC.replicate (fromIntegral maxSize) 'j'+ tooLongBs = BSLC.replicate (fromIntegral maxSize + 100) 'k'++ frameworkSpec :: IO Wai.Application -> Spec frameworkSpec app = with app $ do routingSpec actionSpec+ cookieTest routingSpec :: SpecWith Wai.Application routingSpec =@@ -52,3 +80,38 @@ actionSpec :: SpecWith Wai.Application actionSpec = describe "Action Framework" $ return ()++cookieTest :: SpecWith Wai.Application+cookieTest =+ describe "Cookies" $+ do it "sets single cookies correctly" $+ get "/cookie/single" `shouldRespondWith`+ "set"+ { matchStatus = 200+ , matchHeaders =+ [ matchCookie "single" "test"+ ]+ }+ it "sets multiple cookies correctly" $+ get "/cookie/multiple" `shouldRespondWith`+ "set"+ { matchStatus = 200+ , matchHeaders =+ [ matchCookie "multiple1" "test1"+ , matchCookie "multiple2" "test2"+ ]+ }++matchCookie :: T.Text -> T.Text -> MatchHeader+matchCookie name val =+ MatchHeader $ \headers ->+ let relevantHeaders = filter (\h -> fst h == "Set-Cookie") headers+ loop [] =+ Just ("No cookie named " ++ T.unpack name ++ " with value "+ ++ T.unpack val ++ " found")+ loop (x:xs) =+ let (cname, cval) = T.breakOn "=" $ fst $ T.breakOn ";" $ T.decodeUtf8 $ snd x+ in if cname == name && cval == "=" <> val+ then Nothing+ else loop xs+ in loop relevantHeaders
test/Web/Spock/SafeSpec.hs view
@@ -24,6 +24,13 @@ text $ "int" <> T.pack (show i) get ("param-test" <//> "static") $ text "static"+ get ("cookie" <//> "single") $+ do setCookie "single" "test" 3600+ text "set"+ get ("cookie" <//> "multiple") $+ do setCookie "multiple1" "test1" 3600+ setCookie "multiple2" "test2" 3600+ text "set" subcomponent "/subcomponent" $ do get "foo" $ text "foo" subcomponent "/subcomponent2" $@@ -56,3 +63,5 @@ describe "SafeRouting" $ do frameworkSpec (spockAsApp $ spockT id app) routeRenderingSpec+ sizeLimitSpec $ \lim -> spockAsApp $ spockLimT (Just lim) id $+ post "size" $ body >>= bytes
test/Web/Spock/SimpleSpec.hs view
@@ -34,7 +34,18 @@ case fmt of PrefHTML -> text "html" x -> text (T.pack (show x))+ get "/cookie/single" $+ do setCookie "single" "test" 3600+ text "set"+ get "/cookie/multiple" $+ do setCookie "multiple1" "test1" 3600+ setCookie "multiple2" "test2" 3600+ text "set" hookAny GET $ text . T.intercalate "/" spec :: Spec-spec = describe "SimpleRouting" $ frameworkSpec (spockAsApp $ spockT id app)+spec =+ describe "SimpleRouting" $+ do frameworkSpec (spockAsApp $ spockT id app)+ sizeLimitSpec $ \lim -> spockAsApp $ spockLimT (Just lim) id $+ post "/size" $ body >>= bytes