packages feed

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 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 ()
src/Web/Spock/Shared.hs view
@@ -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