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]