From 2b737e4c1c4cc5d5058cbbef26a32f01ac74d4b0 Mon Sep 17 00:00:00 2001
From: "(cdep)illabout" <cdep.illabout@gmail.com>
Date: Thu, 14 Jul 2016 15:54:46 +0900
Subject: [PATCH] Accept multiple content-types in client.

When defining a route like the following,

```
type API = Get '[JSON, PlainText] Int
```

servant-client is only able to receive responses with the content type
that comes first in the list.  In this example, it will only be able to
receive `application/json` responses.

This PR changes it so that servant-client will accept _any_ content-type
in the list.

In the example above, it will accept responses with a content type of
`application/json` or `text/plain`.
---
 servant-client/src/Servant/Client.hs     | 17 +++++++------
 servant-client/src/Servant/Common/Req.hs | 31 ++++++++++++++++--------
 2 files changed, 30 insertions(+), 18 deletions(-)

diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs
index 18581075..35e05aad 100644
--- a/servant-client/src/Servant/Client.hs
+++ b/servant-client/src/Servant/Client.hs
@@ -39,6 +39,7 @@ import           Network.HTTP.Media
 import qualified Network.HTTP.Types         as H
 import qualified Network.HTTP.Types.Header  as HTTP
 import           Servant.API
+import           Servant.API.ContentTypes
 import           Servant.Client.Experimental.Auth
 import           Servant.Common.BaseUrl
 import           Servant.Common.BasicAuth
@@ -152,11 +153,11 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
 
 instance OVERLAPPABLE_
   -- Note [Non-Empty Content Types]
-  (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
-  ) => HasClient (Verb method status cts' a) where
-  type Client (Verb method status cts' a) = Manager -> BaseUrl -> ClientM a
+  ( AllMime cts, AllMimeUnrender cts a, ReflectMethod method
+  ) => HasClient (Verb method status cts a) where
+  type Client (Verb method status cts a) = Manager -> BaseUrl -> ClientM a
   clientWithRoute Proxy req manager baseurl =
-    snd <$> performRequestCT (Proxy :: Proxy ct) method req manager baseurl
+    snd <$> performRequestCT (Proxy :: Proxy cts) method req manager baseurl
       where method = reflectMethod (Proxy :: Proxy method)
 
 instance OVERLAPPING_
@@ -169,13 +170,13 @@ instance OVERLAPPING_
 
 instance OVERLAPPING_
   -- Note [Non-Empty Content Types]
-  ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)
-  ) => HasClient (Verb method status cts' (Headers ls a)) where
-  type Client (Verb method status cts' (Headers ls a))
+  ( AllMime cts, AllMimeUnrender cts a, BuildHeadersTo ls, ReflectMethod method
+  ) => HasClient (Verb method status cts (Headers ls a)) where
+  type Client (Verb method status cts (Headers ls a))
     = Manager -> BaseUrl -> ClientM (Headers ls a)
   clientWithRoute Proxy req manager baseurl = do
     let method = reflectMethod (Proxy :: Proxy method)
-    (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req manager baseurl
+    (hdrs, resp) <- performRequestCT (Proxy :: Proxy cts) method req manager baseurl
     return $ Headers { getResponse = resp
                      , getHeadersHList = buildHeadersTo hdrs
                      }
diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs
index eb921316..1524565c 100644
--- a/servant-client/src/Servant/Common/Req.hs
+++ b/servant-client/src/Servant/Common/Req.hs
@@ -12,7 +12,7 @@ import Control.Monad
 import Control.Monad.Catch (MonadThrow)
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
-import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)
+import Data.ByteString.Lazy hiding (any, foldr, pack, filter, map, null, elem)
 import Data.String
 import Data.String.Conversions
 import Data.Proxy
@@ -178,17 +178,28 @@ performRequest reqMethod req manager reqHost = do
         throwE $ FailureResponse status ct body
       return (status_code, body, ct, hdrs, response)
 
-performRequestCT :: MimeUnrender ct result =>
-  Proxy ct -> Method -> Req -> Manager -> BaseUrl
+performRequestCT :: (AllMime cts, AllMimeUnrender cts result) =>
+  Proxy cts -> Method -> Req -> Manager -> BaseUrl
     -> ClientM ([HTTP.Header], result)
-performRequestCT ct reqMethod req manager reqHost = do
-  let acceptCT = contentType ct
+performRequestCT cts reqMethod req manager reqHost = do
+  let acceptCTs = allMime cts
   (_status, respBody, respCT, hdrs, _response) <-
-    performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost
-  unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
-  case mimeUnrender ct respBody of
-    Left err -> throwE $ DecodeFailure err respCT respBody
-    Right val -> return (hdrs, val)
+    performRequest reqMethod (req { reqAccept = acceptCTs }) manager reqHost
+  unless (any (matches respCT) acceptCTs) $ throwE $ UnsupportedContentType respCT respBody
+  let unrenderedResp = allMimeUnrender cts respBody
+      firstSuccess = firstPred (either (const Nothing) Just) $ snd <$> unrenderedResp
+  case firstSuccess of
+    Nothing ->
+        let firstErr = firstPred (either Just (const Nothing)) $ snd <$> unrenderedResp
+        in case firstErr of
+            Nothing -> throwE $ DecodeFailure "failed to find the content-type render failure" respCT respBody
+            Just err -> throwE $ DecodeFailure err respCT respBody
+    Just val -> pure (hdrs, val)
+  where
+    -- In @firstPred f eitherList@, fold over a list of 'Either', returning the
+    -- first 'Just' value generated by the function @f@.
+    firstPred :: (Either e x -> Maybe a) -> [Either e x] -> Maybe a
+    firstPred f = foldr (\eith accum -> maybe accum Just $ f eith) Nothing
 
 performRequestNoBody :: Method -> Req -> Manager -> BaseUrl
   -> ClientM [HTTP.Header]