servant-mock: support for response headers
This commit is contained in:
parent
3fdaffa08d
commit
14aac5fc9f
4 changed files with 55 additions and 6 deletions
|
@ -63,4 +63,6 @@ test-suite spec
|
|||
servant,
|
||||
servant-server,
|
||||
servant-mock,
|
||||
aeson
|
||||
aeson,
|
||||
bytestring-conversion,
|
||||
wai
|
||||
|
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
@ -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")
|
||||
}
|
||||
|
|
|
@ -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] () :<|>
|
||||
|
|
Loading…
Reference in a new issue