eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge pull request #1204 from przembot/fix/issue-1200

Browse source 
Fix Verb with headers checking content type differently (and add test for it)
This commit is contained in:
Alp Mestanogullari 2019-08-16 20:41:40 +02:00 committed by GitHub
commit 7de93f9a51
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
3 changed files with 12 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
servant-client-core/src/Servant/Client/Core/HasClient.hs
View file

@ -253,10 +253,8 @@ instance {-# OVERLAPPING #-}
{ requestMethod = method { requestMethod = method
, requestAccept = fromList $ toList accept , requestAccept = fromList $ toList accept
} }
case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of val <- response `decodedAs` (Proxy :: Proxy ct)
Left err -> throwClientError $ DecodeFailure (pack err) response return $ Headers { getResponse = val
Right val -> return $ Headers
{ getResponse = val
, getHeadersHList = buildHeadersTo . toList $ responseHeaders response , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
} }
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)

2
servant-client/test/Servant/ClientTestUtils.hs
View file

@ -168,6 +168,7 @@ type FailApi =
"get" :> Raw "get" :> Raw
:<|> "capture" :> Capture "name" String :> Raw :<|> "capture" :> Capture "name" String :> Raw
:<|> "body" :> Raw :<|> "body" :> Raw
:<|> "headers" :> Raw
failApi :: Proxy FailApi failApi :: Proxy FailApi
failApi = Proxy failApi = Proxy
@ -176,6 +177,7 @@ failServer = serve failApi (
(Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "") (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "")
:<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "") :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
:<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "") :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
:<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "")
) )
-- * basic auth stuff -- * basic auth stuff

6
servant-client/test/Servant/FailSpec.hs
View file

@ -67,6 +67,12 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
UnsupportedContentType "application/octet-stream" _ -> return () UnsupportedContentType "application/octet-stream" _ -> return ()
_ -> fail $ "expected UnsupportedContentType, but got " <> show res _ -> fail $ "expected UnsupportedContentType, but got " <> show res
it "reports UnsupportedContentType when there are response headers" $ \(_, baseUrl) -> do
Left res <- runClient getRespHeaders baseUrl
case res of
UnsupportedContentType "application/x-www-form-urlencoded" _ -> return ()
_ -> fail $ "expected UnsupportedContentType, but got " <> show res
it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
Left res <- runClient (getBody alice) baseUrl Left res <- runClient (getBody alice) baseUrl