eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Use parseRequest

Browse source
This commit is contained in:
Oleg Grenrus 2016-07-10 23:28:51 +03:00 committed by Sönke Hahn
parent ecfa78d222
commit 197ed0548a
1 changed files with 13 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

24
servant-client/src/Servant/Common/Req.hs
View file

@ -103,7 +103,7 @@ setRQBody b t req = req { reqBody = Just (b, t) }
reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
reqToRequest req (BaseUrl reqScheme reqHost reqPort path) = 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 where url = show $ nullURI { uriScheme = case reqScheme of
Http -> "http:" Http -> "http:"
@ -129,8 +129,18 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
| not . null . reqAccept $ req] } | not . null . reqAccept $ req] }
toProperHeader (name, val) = toProperHeader (name, val) =
(fromString name, encodeUtf8 val) (fromString name, encodeUtf8 val)
#if !MIN_VERSION_http_client(0,4,30) #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 #endif
@ -147,8 +157,7 @@ performRequest :: Method -> Req -> Manager -> BaseUrl
performRequest reqMethod req manager reqHost = do performRequest reqMethod req manager reqHost = do
partialRequest <- liftIO $ reqToRequest req reqHost partialRequest <- liftIO $ reqToRequest req reqHost
let request = disableStatusCheck $ let request = partialRequest { Client.method = reqMethod }
partialRequest { Client.method = reqMethod }
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
case eResponse of case eResponse of
@ -169,13 +178,6 @@ performRequest reqMethod req manager reqHost = do
throwE $ FailureResponse status ct body throwE $ FailureResponse status ct body
return (status_code, body, ct, hdrs, response) 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 => performRequestCT :: MimeUnrender ct result =>
Proxy ct -> Method -> Req -> Manager -> BaseUrl Proxy ct -> Method -> Req -> Manager -> BaseUrl
-> ClientM ([HTTP.Header], result) -> ClientM ([HTTP.Header], result)