summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBrendanHay <>2016-06-03 09:06:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-06-03 09:06:00 (GMT)
commited067ec1c0a09567518f6e7412c313c7721c3cc5 (patch)
treebe61660c5ea8c48a1249ced6294af87e15c0b10d
parent80ebc4ccf2c6b40c3c20a452213efc1fe890c50f (diff)
version 1.4.21.4.2
-rw-r--r--amazonka-core.cabal4
-rw-r--r--src/Network/AWS/Error.hs6
-rw-r--r--src/Network/AWS/Response.hs70
-rw-r--r--src/Network/AWS/Types.hs5
4 files changed, 47 insertions, 38 deletions
diff --git a/amazonka-core.cabal b/amazonka-core.cabal
index 32f6b6a..bc4aa2f 100644
--- a/amazonka-core.cabal
+++ b/amazonka-core.cabal
@@ -1,5 +1,5 @@
name: amazonka-core
-version: 1.4.1
+version: 1.4.2
synopsis: Core data types and functionality for Amazonka libraries.
homepage: https://github.com/brendanhay/amazonka
bug-reports: https://github.com/brendanhay/amazonka/issues
@@ -109,7 +109,7 @@ library
, time >= 1.2 && < 1.5
else
build-depends:
- time >= 1.5 && < 1.6
+ time >= 1.5
test-suite tests
type: exitcode-stdio-1.0
diff --git a/src/Network/AWS/Error.hs b/src/Network/AWS/Error.hs
index 8202f17..ad03ca6 100644
--- a/src/Network/AWS/Error.hs
+++ b/src/Network/AWS/Error.hs
@@ -40,8 +40,8 @@ httpStatus = _Error . f
-> TransportError <$> (StatusCodeException <$> g s <*> pure h <*> pure c)
TransportError e
-> pure (TransportError e)
- SerializeError (SerializeError' a s e)
- -> g s <&> \x -> SerializeError (SerializeError' a x e)
+ SerializeError (SerializeError' a s b e)
+ -> g s <&> \x -> SerializeError (SerializeError' a x b e)
ServiceError e
-> g (_serviceStatus e) <&> \x -> ServiceError (e { _serviceStatus = x })
@@ -132,6 +132,6 @@ decodeError :: Abbrev
decodeError a s h bs e
| LBS.null bs = parseRESTError a s h bs
| otherwise =
- either (SerializeError . SerializeError' a s)
+ either (SerializeError . SerializeError' a s (Just bs))
ServiceError
e
diff --git a/src/Network/AWS/Response.hs b/src/Network/AWS/Response.hs
index c34b504..2767ca7 100644
--- a/src/Network/AWS/Response.hs
+++ b/src/Network/AWS/Response.hs
@@ -14,6 +14,7 @@
--
module Network.AWS.Response where
+import Control.Applicative (pure)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
@@ -39,8 +40,8 @@ receiveNull :: MonadResource m
-> Proxy a
-> ClientResponse
-> m (Response a)
-receiveNull rs _ = receive $ \_ _ x ->
- liftResourceT (x $$+- return (Right rs))
+receiveNull rs _ = stream $ \_ _ x ->
+ liftResourceT (x $$+- pure (Right rs))
receiveEmpty :: MonadResource m
=> (Int -> ResponseHeaders -> () -> Either String (Rs a))
@@ -49,8 +50,8 @@ receiveEmpty :: MonadResource m
-> Proxy a
-> ClientResponse
-> m (Response a)
-receiveEmpty f _ = receive $ \s h x ->
- liftResourceT (x $$+- return (f s h ()))
+receiveEmpty f _ = stream $ \s h x ->
+ liftResourceT (x $$+- pure (f s h ()))
receiveXMLWrapper :: MonadResource m
=> Text
@@ -87,8 +88,9 @@ receiveBody :: MonadResource m
-> Proxy a
-> ClientResponse
-> m (Response a)
-receiveBody f _ = receive $ \s h x -> return (f s h (RsBody x))
+receiveBody f _ = stream $ \s h x -> pure (f s h (RsBody x))
+-- | Deserialise an entire response body, such as an XML or JSON payload.
deserialise :: MonadResource m
=> (LazyByteString -> Either String b)
-> (Int -> ResponseHeaders -> b -> Either String (Rs a))
@@ -97,34 +99,38 @@ deserialise :: MonadResource m
-> Proxy a
-> ClientResponse
-> m (Response a)
-deserialise g f l = receive $ \s h x -> do
- lbs <- sinkLBS x
- liftIO . l Debug . build $ "[Raw Response Body] {\n" <> lbs <> "\n}"
- return $! g lbs >>= f s h
+deserialise g f l Service{..} _ rs = do
+ let s = responseStatus rs
+ h = responseHeaders rs
+ x = responseBody rs
+ b <- sinkLBS x
+ if not (_svcCheck s)
+ then throwM (_svcError s h b)
+ else do
+ liftIO . l Debug . build $ "[Raw Response Body] {\n" <> b <> "\n}"
+ case g b >>= f (fromEnum s) h of
+ Right r -> pure (s, r)
+ Left e -> throwM . SerializeError $
+ SerializeError' _svcAbbrev s (Just b) e
-receive :: MonadResource m
- => (Int -> ResponseHeaders -> ResponseBody -> m (Either String (Rs a)))
- -> Service
- -> Proxy a
- -> ClientResponse
- -> m (Response a)
-receive f Service{..} _ rs
- | not (_svcCheck s) = sinkLBS x >>= serviceErr
- | otherwise = do
- p <- f (fromEnum s) h x
- either serializeErr
- (return . (s,))
- p
- where
- s = responseStatus rs
- h = responseHeaders rs
- x = responseBody rs
-
- serviceErr :: MonadThrow m => LazyByteString -> m a
- serviceErr = throwM . _svcError _svcAbbrev s h
-
- serializeErr :: MonadThrow m => String -> m a
- serializeErr e = throwM (SerializeError (SerializeError' _svcAbbrev s e))
+-- | Stream a raw response body, such as an S3 object payload.
+stream :: MonadResource m
+ => (Int -> ResponseHeaders -> ResponseBody -> m (Either String (Rs a)))
+ -> Service
+ -> Proxy a
+ -> ClientResponse
+ -> m (Response a)
+stream f Service{..} _ rs = do
+ let s = responseStatus rs
+ h = responseHeaders rs
+ x = responseBody rs
+ if not (_svcCheck s)
+ then sinkLBS x >>= throwM . _svcError s h
+ else do
+ e <- f (fromEnum s) h x
+ either (throwM . SerializeError . SerializeError' _svcAbbrev s Nothing)
+ (pure . (s,))
+ e
sinkLBS :: MonadResource m => ResponseBody -> m LazyByteString
sinkLBS bdy = liftResourceT (bdy $$+- Conduit.sinkLbs)
diff --git a/src/Network/AWS/Types.hs b/src/Network/AWS/Types.hs
index 89ff35a..76074eb 100644
--- a/src/Network/AWS/Types.hs
+++ b/src/Network/AWS/Types.hs
@@ -223,6 +223,8 @@ instance ToLog Error where
data SerializeError = SerializeError'
{ _serializeAbbrev :: !Abbrev
, _serializeStatus :: !Status
+ , _serializeBody :: Maybe LazyByteString
+ -- ^ The response body, if the response was not streaming.
, _serializeMessage :: String
} deriving (Eq, Show, Typeable)
@@ -232,6 +234,7 @@ instance ToLog SerializeError where
, " service = " <> build _serializeAbbrev
, " status = " <> build _serializeStatus
, " message = " <> build _serializeMessage
+ , " body = " <> build _serializeBody
, "}"
]
@@ -418,7 +421,7 @@ data Service = Service
, _svcEndpoint :: !(Region -> Endpoint)
, _svcTimeout :: !(Maybe Seconds)
, _svcCheck :: !(Status -> Bool)
- , _svcError :: !(Abbrev -> Status -> [Header] -> LazyByteString -> Error)
+ , _svcError :: !(Status -> [Header] -> LazyByteString -> Error)
, _svcRetry :: !Retry
}