From 1abf84fecaae0ab95d583f958b78081dd51a583b Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Tue, 11 Oct 2016 08:20:21 +0300
Subject: [PATCH] servant-client asks for any content-type in Accept
 contentTypes ne-list

---
 servant-client/src/Servant/Client.hs     | 1 +
 servant-client/src/Servant/Common/Req.hs | 9 +++++----
 2 files changed, 6 insertions(+), 4 deletions(-)

diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs
index 7554c536..e77c1f16 100644
--- a/servant-client/src/Servant/Client.hs
+++ b/servant-client/src/Servant/Client.hs
@@ -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
                     )
diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs
index fb4b7716..57471967 100644
--- a/servant-client/src/Servant/Common/Req.hs
+++ b/servant-client/src/Servant/Common/Req.hs
@@ -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)