diff --git a/hspec-wai.cabal b/hspec-wai.cabal --- a/hspec-wai.cabal +++ b/hspec-wai.cabal @@ -1,9 +1,9 @@ --- This file has been generated from package.yaml by hpack version 0.11.0. +-- This file has been generated from package.yaml by hpack version 0.15.0. -- -- see: https://github.com/sol/hpack name: hspec-wai -version: 0.6.6 +version: 0.7.0 homepage: https://github.com/hspec/hspec-wai#readme bug-reports: https://github.com/hspec/hspec-wai/issues license: MIT @@ -42,15 +42,14 @@ , wai >= 3 , wai-extra >= 3 , hspec-core == 2.* - , hspec-expectations + , hspec-expectations >= 0.8.0 , QuickCheck - , with-location >= 0.1.0 exposed-modules: Test.Hspec.Wai Test.Hspec.Wai.QuickCheck Test.Hspec.Wai.Internal - other-modules: Test.Hspec.Wai.Matcher + other-modules: Test.Hspec.Wai.Util Paths_hspec_wai default-language: Haskell2010 @@ -60,7 +59,7 @@ main-is: Spec.hs hs-source-dirs: src - , test + test ghc-options: -Wall build-depends: base == 4.* @@ -73,9 +72,8 @@ , wai >= 3 , wai-extra >= 3 , hspec-core == 2.* - , hspec-expectations + , hspec-expectations >= 0.8.0 , QuickCheck - , with-location >= 0.1.0 , hspec , QuickCheck other-modules: diff --git a/src/Test/Hspec/Wai.hs b/src/Test/Hspec/Wai.hs --- a/src/Test/Hspec/Wai.hs +++ b/src/Test/Hspec/Wai.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} -- | Have a look at the for -- an example of how to use this library. module Test.Hspec.Wai ( @@ -21,8 +22,11 @@ -- * Matching on the response , shouldRespondWith + , ResponseMatcher(..) , MatchHeader(..) +, MatchBody(..) +, Body , (<:>) -- * Helpers and re-exports @@ -40,12 +44,11 @@ import Network.HTTP.Types import Network.Wai.Test hiding (request) import qualified Network.Wai.Test as Wai -import Data.WithLocation +import Test.Hspec.Expectations import Test.Hspec.Core.Spec hiding (pending, pendingWith) import qualified Test.Hspec.Core.Spec as Core import Test.Hspec.Core.Hooks -import Test.Hspec.Expectations (expectationFailure) import Test.Hspec.Wai.Util import Test.Hspec.Wai.Internal @@ -97,7 +100,7 @@ -- -- > get "/" `shouldRespondWith` "foo" {matchHeaders = ["Content-Type" <:> "text/plain"]} -- > -- matches if body is "foo", status is 200 and ther is a header field "Content-Type: text/plain" -shouldRespondWith :: WithLocation (WaiSession SResponse -> ResponseMatcher -> WaiExpectation) +shouldRespondWith :: HasCallStack => WaiSession SResponse -> ResponseMatcher -> WaiExpectation shouldRespondWith action matcher = do r <- action forM_ (match r matcher) (liftIO . expectationFailure) diff --git a/src/Test/Hspec/Wai/Internal.hs b/src/Test/Hspec/Wai/Internal.hs --- a/src/Test/Hspec/Wai/Internal.hs +++ b/src/Test/Hspec/Wai/Internal.hs @@ -22,12 +22,12 @@ import Test.Hspec.Wai.Util (formatHeader) -- | An expectation in the `WaiSession` monad. Failing expectations are --- communicated through exceptions (similar to `Expectation` and +-- communicated through exceptions (similar to `Test.Hspec.Expectations.Expectation` and -- `Test.HUnit.Base.Assertion`). type WaiExpectation = WaiSession () -- | A test --- session that carries the `Application` under test an some client state. +-- session that carries the `Application` under test and some client state. newtype WaiSession a = WaiSession {unWaiSession :: Session a} deriving (Functor, Applicative, Monad, MonadIO) diff --git a/src/Test/Hspec/Wai/Matcher.hs b/src/Test/Hspec/Wai/Matcher.hs --- a/src/Test/Hspec/Wai/Matcher.hs +++ b/src/Test/Hspec/Wai/Matcher.hs @@ -2,7 +2,10 @@ module Test.Hspec.Wai.Matcher ( ResponseMatcher(..) , MatchHeader(..) +, MatchBody(..) +, Body , (<:>) +, bodyEquals , match ) where @@ -13,6 +16,7 @@ import Data.Maybe import Data.String import Data.Text.Lazy.Encoding (encodeUtf8) +import qualified Data.Text.Lazy as T import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LB import Network.HTTP.Types @@ -20,19 +24,39 @@ import Test.Hspec.Wai.Util +type Body = LB.ByteString + data ResponseMatcher = ResponseMatcher { matchStatus :: Int , matchHeaders :: [MatchHeader] -, matchBody :: Maybe LB.ByteString +, matchBody :: MatchBody } -data MatchHeader = MatchHeader ([Header] -> Maybe String) +data MatchHeader = MatchHeader ([Header] -> Body -> Maybe String) +data MatchBody = MatchBody ([Header] -> Body -> Maybe String) + +bodyEquals :: Body -> MatchBody +bodyEquals body = MatchBody (\_ actual -> bodyMatcher actual body) + where + bodyMatcher :: Body -> Body -> Maybe String + bodyMatcher (toStrict -> actual) (toStrict -> expected) = actualExpected "body mismatch:" actual_ expected_ <$ guard (actual /= expected) + where + (actual_, expected_) = case (safeToString actual, safeToString expected) of + (Just x, Just y) -> (x, y) + _ -> (show actual, show expected) + +matchAny :: MatchBody +matchAny = MatchBody (\_ _ -> Nothing) + +instance IsString MatchBody where + fromString = bodyEquals . encodeUtf8 . T.pack + instance IsString ResponseMatcher where - fromString s = ResponseMatcher 200 [] (Just . encodeUtf8 . fromString $ s) + fromString = ResponseMatcher 200 [] . fromString instance Num ResponseMatcher where - fromInteger n = ResponseMatcher (fromInteger n) [] Nothing + fromInteger n = ResponseMatcher (fromInteger n) [] matchAny (+) = error "ResponseMatcher does not support (+)" (-) = error "ResponseMatcher does not support (-)" (*) = error "ResponseMatcher does not support (*)" @@ -40,34 +64,28 @@ signum = error "ResponseMatcher does not support `signum`" match :: SResponse -> ResponseMatcher -> Maybe String -match (SResponse (Status status _) headers body) (ResponseMatcher expectedStatus expectedHeaders expectedBody) = mconcat [ +match (SResponse (Status status _) headers body) (ResponseMatcher expectedStatus expectedHeaders (MatchBody bodyMatcher)) = mconcat [ actualExpected "status mismatch:" (show status) (show expectedStatus) <$ guard (status /= expectedStatus) - , checkHeaders headers expectedHeaders - , expectedBody >>= matchBody_ body + , checkHeaders headers body expectedHeaders + , bodyMatcher headers body ] - where - matchBody_ (toStrict -> actual) (toStrict -> expected) = actualExpected "body mismatch:" actual_ expected_ <$ guard (actual /= expected) - where - (actual_, expected_) = case (safeToString actual, safeToString expected) of - (Just x, Just y) -> (x, y) - _ -> (show actual, show expected) - actualExpected :: String -> String -> String -> String - actualExpected message actual expected = unlines [ - message - , " expected: " ++ expected - , " but got: " ++ actual - ] +actualExpected :: String -> String -> String -> String +actualExpected message actual expected = unlines [ + message + , " expected: " ++ expected + , " but got: " ++ actual + ] -checkHeaders :: [Header] -> [MatchHeader] -> Maybe String -checkHeaders headers m = case go m of +checkHeaders :: [Header] -> Body -> [MatchHeader] -> Maybe String +checkHeaders headers body m = case go m of [] -> Nothing xs -> Just (mconcat xs ++ "the actual headers were:\n" ++ unlines (map formatHeader headers)) where - go = catMaybes . map (\(MatchHeader p) -> p headers) + go = catMaybes . map (\(MatchHeader p) -> p headers body) (<:>) :: HeaderName -> ByteString -> MatchHeader -name <:> value = MatchHeader $ \headers -> guard (header `notElem` headers) >> (Just . unlines) [ +name <:> value = MatchHeader $ \headers _body -> guard (header `notElem` headers) >> (Just . unlines) [ "missing header:" , formatHeader header ]