diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index 285927dc..54bc2fe2 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -63,4 +63,6 @@ test-suite spec servant, servant-server, servant-mock, - aeson + aeson, + bytestring-conversion, + wai diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index 7d17dca5..d2808be2 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -7,6 +7,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + +#include "overlapping-compat.h" + -- | -- Module : Servant.Mock -- Copyright : 2015 Alp Mestanogullari @@ -144,6 +147,12 @@ instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes => HasMock (Verb method status ctypes a) where mock _ = mockArbitrary +instance OVERLAPPING_ + (GetHeaders (Headers headerTypes a), Arbitrary (HList headerTypes), + Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a) + => HasMock (Verb method status ctypes (Headers headerTypes a)) where + mock _ = mockArbitrary + instance HasMock Raw where mock _ = \_req respond -> do bdy <- genBody @@ -165,5 +174,3 @@ instance Arbitrary (HList '[]) where instance (Arbitrary a, Arbitrary (HList hs)) => Arbitrary (HList (Header h a ': hs)) where arbitrary = HCons <$> fmap Header arbitrary <*> arbitrary - - diff --git a/servant-mock/test/Servant/MockSpec.hs b/servant-mock/test/Servant/MockSpec.hs index 34c94304..ff7d9694 100644 --- a/servant-mock/test/Servant/MockSpec.hs +++ b/servant-mock/test/Servant/MockSpec.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} @@ -7,8 +6,11 @@ module Servant.MockSpec where import Data.Aeson as Aeson +import Data.ByteString.Conversion.To import Data.Proxy +import Data.String import GHC.Generics +import Network.Wai import Servant.API import Test.Hspec hiding (pending) import Test.Hspec.Wai @@ -23,11 +25,24 @@ _ = mock comprehensiveAPI data Body = Body | ArbitraryBody - deriving (Generic, ToJSON) + deriving (Generic) + +instance ToJSON Body instance Arbitrary Body where arbitrary = return ArbitraryBody +data TestHeader + = TestHeader + | ArbitraryHeader + deriving (Show) + +instance ToByteString TestHeader where + builder = fromString . show + +instance Arbitrary TestHeader where + arbitrary = return ArbitraryHeader + spec :: Spec spec = do describe "mock" $ do @@ -40,3 +55,28 @@ spec = do get "/" `shouldRespondWith` 200{ matchBody = Just $ Aeson.encode ArbitraryBody } + + context "response headers" $ do + let withHeader :: Proxy (Get '[JSON] (Headers '[Header "foo" TestHeader] Body)) + withHeader = Proxy + withoutHeader :: Proxy (Get '[JSON] (Headers '[] Body)) + withoutHeader = Proxy + toApp :: HasMock api => Proxy api -> IO Application + toApp api = return $ serve api (mock api) + with (toApp withHeader) $ do + it "serves arbitrary response bodies" $ do + get "/" `shouldRespondWith` 200{ + matchHeaders = return $ MatchHeader $ \ h -> + if h == [("Content-Type", "application/json"), ("foo", "ArbitraryHeader")] + then Nothing + else Just ("headers not correct\n") + } + + with (toApp withoutHeader) $ do + it "works for no additional headers" $ do + get "/" `shouldRespondWith` 200{ + matchHeaders = return $ MatchHeader $ \ h -> + if h == [("Content-Type", "application/json")] + then Nothing + else Just ("headers not correct\n") + } diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs index 68c5fbc1..2eade8e0 100644 --- a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs @@ -22,7 +22,7 @@ type ComprehensiveAPI = -- Raw :<|> RemoteHost :> GET :<|> ReqBody '[JSON] Int :> GET :<|> --- Get '[JSON] (Headers '[Header "foo" Int] ()) :<|> + Get '[JSON] (Headers '[Header "foo" Int] ()) :<|> "foo" :> GET :<|> Vault :> GET :<|> Verb 'POST 204 '[JSON] () :<|>