@@ -19,6 +19,9 @@ import Control.Lens ((%~), (&))
1919import Control.Monad.Catch
2020import Control.Monad.IO.Class (MonadIO)
2121import Control.Monad.Trans.Resource (MonadResource (..))
22+import qualified Data.ByteString.Lazy as LBS
23+import Data.Conduit (($$+-))
24+import qualified Data.Conduit.List as Conduit
2225import Data.Default.Class (Default (..))
2326import Data.Monoid (Dual (..), Endo (..), (<>))
2427import qualified Data.Text.Encoding as Text
@@ -64,6 +67,8 @@ perform Env{..} x = catches go handlers
6467
6568 logDebug _envLogger rs -- debug:ClientResponse
6669
70+ statusCheck rs
71+
6772 r <- _cliResponse (responseBody rs)
6873
6974 pure $! case r of
@@ -80,7 +85,7 @@ perform Env{..} x = catches go handlers
8085 { Client.host = _svcHost
8186 , Client.port = _svcPort
8287 , Client.secure = _svcSecure
83− , Client.checkStatus = status
88+ , Client.checkStatus = \_ _ _ -> Nothing
8489 , Client.responseTimeout = timeout
8590 , Client.method = _cliMethod
8691 , Client.path = path
@@ -97,14 +102,16 @@ perform Env{..} x = catches go handlers
97102 . LText.toStrict
98103 $ Build.toLazyText (_svcPath <> _rqPath)
99104
100− status s hs _
101− | _cliCheck s = Nothing
102− | otherwise = Just . toException . ServiceError $ ServiceError'
103− { _serviceId = _svcId
104− , _serviceStatus = s
105− , _serviceHeaders = hs
106− , _serviceBody = Nothing
107− }
105+ statusCheck rs
106+ | _cliCheck (responseStatus rs) = pure ()
107+ | otherwise = do
108+ b <- LBS.fromChunks <$> (responseBody rs $$+- Conduit.consume)
109+ throwM . toException . ServiceError $ ServiceError'
110+ { _serviceId = _svcId
111+ , _serviceStatus = responseStatus rs
112+ , _serviceHeaders = responseHeaders rs
113+ , _serviceBody = Just b
114+ }
108115
109116 timeout = microseconds <$> _svcTimeout
110117