From 197ed0548a0e6a5b6fcf7f9926b7a041ffd4b97f Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Sun, 10 Jul 2016 23:28:51 +0300
Subject: [PATCH] Use parseRequest

---
 servant-client/src/Servant/Common/Req.hs | 24 +++++++++++++-----------
 1 file changed, 13 insertions(+), 11 deletions(-)

diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs
index 6d922634..eb921316 100644
--- a/servant-client/src/Servant/Common/Req.hs
+++ b/servant-client/src/Servant/Common/Req.hs
@@ -103,7 +103,7 @@ setRQBody b t req = req { reqBody = Just (b, t) }
 
 reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
 reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
-    setheaders . setAccept . setrqb . setQS <$> parseUrlThrow url
+    setheaders . setAccept . setrqb . setQS <$> parseRequest url
 
   where url = show $ nullURI { uriScheme = case reqScheme of
                                   Http  -> "http:"
@@ -129,8 +129,18 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
                                               | not . null . reqAccept $ req] }
         toProperHeader (name, val) =
           (fromString name, encodeUtf8 val)
+
 #if !MIN_VERSION_http_client(0,4,30)
-        parseUrlThrow = parseUrl
+-- 'parseRequest' is introduced in http-client-0.4.30
+-- it differs from 'parseUrl', by not throwing exceptions on non-2xx http statuses
+--
+-- See for implementations:
+-- http://hackage.haskell.org/package/http-client-0.4.30/docs/src/Network-HTTP-Client-Request.html#parseRequest
+-- http://hackage.haskell.org/package/http-client-0.5.0/docs/src/Network-HTTP-Client-Request.html#parseRequest
+parseRequest :: MonadThrow m => String -> m Request
+parseRequest url = disableStatusCheck <$> parseUrl url
+  where
+    disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing }
 #endif
 
 
@@ -147,8 +157,7 @@ performRequest :: Method -> Req -> Manager -> BaseUrl
 performRequest reqMethod req manager reqHost = do
   partialRequest <- liftIO $ reqToRequest req reqHost
 
-  let request = disableStatusCheck $
-        partialRequest { Client.method = reqMethod }
+  let request = partialRequest { Client.method = reqMethod }
 
   eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
   case eResponse of
@@ -169,13 +178,6 @@ performRequest reqMethod req manager reqHost = do
         throwE $ FailureResponse status ct body
       return (status_code, body, ct, hdrs, response)
 
-disableStatusCheck :: Request -> Request
-#if MIN_VERSION_http_client(0,5,0)
-disableStatusCheck req = req { checkResponse = \ _req _res -> return () }
-#else
-disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing }
-#endif
-
 performRequestCT :: MimeUnrender ct result =>
   Proxy ct -> Method -> Req -> Manager -> BaseUrl
     -> ClientM ([HTTP.Header], result)