servant-mock: support for response headers

servant-mock/servant-mock.cabal

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

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

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

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