servant-mock: support for response headers

This commit is contained in:
Sönke Hahn 2016-01-18 13:22:58 +01:00
parent 3fdaffa08d
commit 14aac5fc9f
4 changed files with 55 additions and 6 deletions

View file

@ -63,4 +63,6 @@ test-suite spec
servant,
servant-server,
servant-mock,
aeson
aeson,
bytestring-conversion,
wai

View file

@ -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

View file

@ -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")
}

View file

@ -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] () :<|>