servant-client asks for any content-type in Accept contentTypes ne-list

This commit is contained in:
Oleg Grenrus 2016-10-11 08:20:21 +03:00
parent 148bb15635
commit 1abf84feca
2 changed files with 6 additions and 4 deletions

View file

@ -407,6 +407,7 @@ instance (MimeRender ct a, HasClient api)
clientWithRoute (Proxy :: Proxy api)
(let ctProxy = Proxy :: Proxy ct
in setRQBody (mimeRender ctProxy body)
-- We use first contentType from the Accept list
(contentType ctProxy)
req
)

View file

@ -13,6 +13,7 @@ import Prelude.Compat
import Control.Exception
import Control.Monad
import Control.Monad.Catch (MonadThrow, MonadCatch)
import Data.Foldable (toList)
#if MIN_VERSION_mtl(2,2,0)
import Control.Monad.Except (MonadError(..))
@ -25,7 +26,7 @@ import Control.Monad.Trans.Except
import GHC.Generics
import Control.Monad.IO.Class ()
import Control.Monad.Reader
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any)
import Data.String
import Data.String.Conversions
import Data.Proxy
@ -215,10 +216,10 @@ performRequest reqMethod req = do
performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req
-> ClientM ([HTTP.Header], result)
performRequestCT ct reqMethod req = do
let acceptCT = contentType ct
let acceptCTS = contentTypes ct
(_status, respBody, respCT, hdrs, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] })
unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody
performRequest reqMethod (req { reqAccept = toList acceptCTS })
unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of
Left err -> throwError $ DecodeFailure err respCT respBody
Right val -> return (hdrs, val)