diff --git a/amazonka.cabal b/amazonka.cabal --- a/amazonka.cabal +++ b/amazonka.cabal @@ -1,5 +1,5 @@ name: amazonka -version: 1.1.0 +version: 1.2.0 synopsis: Comprehensive Amazon Web Services SDK homepage: https://github.com/brendanhay/amazonka license: OtherLicense @@ -54,7 +54,7 @@ , Network.AWS.Internal.Logger build-depends: - amazonka-core == 1.1.0.* + amazonka-core == 1.2.0.* , base >= 4.7 && < 5 , bytestring >= 0.9 , conduit >= 1.1 diff --git a/src/Control/Monad/Trans/AWS.hs b/src/Control/Monad/Trans/AWS.hs --- a/src/Control/Monad/Trans/AWS.hs +++ b/src/Control/Monad/Trans/AWS.hs @@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -59,20 +60,19 @@ , await - -- ** Overriding Service Configuration + -- ** Service Configuration -- $service + -- *** Overriding Defaults + , configure + , override + -- *** Scoped Actions + , reconfigure , within , once , timeout - -- *** Per Request - , sendWith - , paginateWith - , awaitWith - , presignWith - -- ** Streaming -- $streaming @@ -129,6 +129,10 @@ -- ** Constructing a Logger , newLogger + -- ** Endpoints + , Endpoint + , setEndpoint + -- * Re-exported Types , RqBody , RsBody @@ -162,6 +166,7 @@ import Network.AWS.Pager (AWSPager (..)) import Network.AWS.Prelude as AWS import qualified Network.AWS.Presign as Sign +import Network.AWS.Request (requestURL) import Network.AWS.Types hiding (LogLevel (..)) import Network.AWS.Waiter (Wait) @@ -181,8 +186,15 @@ throwM = lift . throwM instance MonadCatch m => MonadCatch (AWST m) where - catch (AWST m) f = AWST (m `catch` \e -> unAWST (f e)) + catch (AWST m) f = AWST (catch m (unAWST . f)) +instance MonadMask m => MonadMask (AWST m) where + mask a = AWST $ mask $ \u -> + unAWST $ a (AWST . u . unAWST) + + uninterruptibleMask a = AWST $ uninterruptibleMask $ \u -> + unAWST $ a (AWST . u . unAWST) + instance MonadBase b m => MonadBase b (AWST m) where liftBase = liftBaseDefault @@ -237,137 +249,62 @@ -- | Send a request, returning the associated response if successful. -- -- Throws 'Error'. --- --- /See:/ 'sendWith' send :: (AWSConstraint r m, AWSRequest a) => a -> m (Rs a) -send = sendWith id - --- | A variant of 'send' that allows modifying the default 'Service' definition --- used to configure the request. --- --- Throws 'Error'. -sendWith :: (AWSConstraint r m, AWSSigner (Sg s), AWSRequest a) - => (Service (Sv a) -> Service s) -- ^ Modify the default service configuration. - -> a -- ^ Request. - -> m (Rs a) -sendWith f x = do - e <- view environment - r <- retrier e s rq (perform e s rq) >>= hoistError - return (snd r) - where - rq = request x - s = f (serviceOf x) +send = retrier >=> fmap snd . hoistError -- | Repeatedly send a request, automatically setting markers and -- paginating over multiple responses while available. -- -- Throws 'Error'. --- --- /See:/ 'paginateWith' paginate :: (AWSConstraint r m, AWSPager a) => a -> Source m (Rs a) -paginate = paginateWith id - --- | A variant of 'paginate' that allows modifying the default 'Service' definition --- used to configure the request. --- --- Throws 'Error'. -paginateWith :: (AWSConstraint r m, AWSSigner (Sg s), AWSPager a) - => (Service (Sv a) -> Service s) -- ^ Modify the default service configuration. - -> a -- ^ Initial request. - -> Source m (Rs a) -paginateWith f = go +paginate = go where go !x = do - !y <- sendWith f x + !y <- send x yield y - maybe (pure ()) - go - (page x y) + maybe (pure ()) go (page x y) -- | Poll the API with the supplied request until a specific 'Wait' condition -- is fulfilled. -- -- Throws 'Error'. --- --- /See:/ 'awaitWith' await :: (AWSConstraint r m, AWSRequest a) => Wait a -> a -> m () -await = awaitWith id - --- | A variant of 'await' that allows modifying the default 'Service' definition --- used to configure the request. --- --- Throws 'Error'. -awaitWith :: (AWSConstraint r m, AWSSigner (Sg s), AWSRequest a) - => (Service (Sv a) -> Service s) -- ^ Modify the default service configuration. - -> Wait a -- ^ Polling, error and acceptance criteria. - -> a -- ^ Request to poll with. - -> m () -awaitWith f w x = do - e <- view environment - waiter e w rq (perform e s rq) >>= hoistError . maybe (Right ()) Left - where - rq = request x - s = f (serviceOf x) +await w = waiter w >=> hoistError . maybe (Right ()) Left -- | Presign an URL that is valid from the specified time until the -- number of seconds expiry has elapsed. --- --- /See:/ 'presign', 'presignWith' presignURL :: ( MonadIO m , MonadReader r m , HasEnv r - , AWSPresigner (Sg (Sv a)) , AWSRequest a ) => UTCTime -- ^ Signing time. -> Seconds -- ^ Expiry time. -> a -- ^ Request to presign. -> m ByteString -presignURL ts ex x = do - a <- view envAuth - r <- view envRegion - Sign.presignURL a r ts ex x +presignURL ts ex = liftM requestURL . presign ts ex -- | Presign an HTTP request that is valid from the specified time until the -- number of seconds expiry has elapsed. --- --- /See:/ 'presignWith' presign :: ( MonadIO m , MonadReader r m , HasEnv r - , AWSPresigner (Sg (Sv a)) , AWSRequest a ) => UTCTime -- ^ Signing time. -> Seconds -- ^ Expiry time. -> a -- ^ Request to presign. -> m ClientRequest -presign = presignWith id - --- | A variant of 'presign' that allows specifying the 'Service' definition --- used to configure the request. -presignWith :: ( MonadIO m - , MonadReader r m - , HasEnv r - , AWSPresigner (Sg s) - , AWSRequest a - ) - => (Service (Sv a) -> Service s) -- ^ Function to modify the service configuration. - -> UTCTime -- ^ Signing time. - -> Seconds -- ^ Expiry time. - -> a -- ^ Request to presign. - -> m ClientRequest -presignWith f ts ex x = do - a <- view envAuth - g <- view envRegion - Sign.presignWith f a g ts ex x +presign ts ex x = do + Env{..} <- view environment + Sign.presignWith (applyOverride _envOverride) _envAuth _envRegion ts ex x -- | Test whether the underlying host is running on EC2. -- This is memoised and any external check occurs for the first invocation only. @@ -426,8 +363,7 @@ or 'paginate' and the library will take care of serialisation/authentication and so forth. -The default 'Service' configuration for a request (or the supplied 'Service' configuration -when using the @*With@ variants) contains retry configuration that is used to +The default 'Service' configuration for a request contains retry configuration that is used to determine if a request can safely be retried and what kind of back off/on strategy should be used. (Usually exponential.) Typically services define retry strategies that handle throttling, general server @@ -464,13 +400,49 @@ -} {- $service -When a request is sent, various configuration values such as the endpoint, +When a request is sent, various values such as the endpoint, retry strategy, timeout and error handlers are taken from the associated 'Service' -configuration. +for a request. For example, 'DynamoDB' will use the 'Network.AWS.DynamoDB.dynamoDB' +configuration when sending 'PutItem', 'Query' and all other operations. -You can override the default configuration for a series of one or more actions -by using 'within', 'once' and 'timeout', or by using the @*With@ suffixed -functions on an individual request basis below. +You can modify a specific 'Service''s default configuration by using +'configure' or 'reconfigure'. To modify all configurations simultaneously, see 'override'. + +An example of how you might alter default configuration using these mechanisms +is demonstrated below. Firstly, the default 'dynamoDB' service is configured to +use non-SSL localhost as the endpoint: + +> let dynamo :: Service +> dynamo = setEndpoint False "localhost" 8000 dynamoDB + +The updated configuration is then passed to the 'Env' during setup: + +> e <- newEnv Frankfurt Discover <&> configure dynamo +> runAWS e $ do +> -- This S3 operation will communicate with remote AWS APIs. +> x <- send listBuckets +> +> -- DynamoDB operations will communicate with localhost:8000. +> y <- send listTables +> +> -- Any operations for services other than DynamoDB, are not affected. +> ... + +You can also scope the 'Endpoint' modifications (or any other 'Service' configuration) +to specific actions: + +> e <- newEnv Ireland Discover +> runAWS e $ do +> -- Service operations here will communicate with AWS, even DynamoDB. +> x <- send listTables +> +> reconfigure dynamo $ do +> -- In here, DynamoDB operations will communicate with localhost:8000, +> -- with operations for services not being affected. +> ... + +Functions such as 'within', 'once', and 'timeout' likewise modify the underlying +configuration for all service requests within their respective scope. -} {- $streaming diff --git a/src/Network/AWS.hs b/src/Network/AWS.hs --- a/src/Network/AWS.hs +++ b/src/Network/AWS.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} @@ -57,10 +58,15 @@ , await - -- ** Overriding Service Configuration + -- ** Service Configuration -- $service + -- *** Overriding Defaults + , Env.configure + , Env.override + -- *** Scoped Actions + , reconfigure , within , once , timeout @@ -120,6 +126,10 @@ -- ** Constructing a Logger , newLogger + -- ** Endpoints + , Endpoint + , AWST.setEndpoint + -- * Re-exported Types , RqBody , RsBody @@ -133,6 +143,7 @@ import Control.Applicative import Control.Monad.Catch (MonadCatch) +import Control.Monad.IO.Class (MonadIO) import Control.Monad.Morph (hoist) import qualified Control.Monad.RWS.Lazy as LRW import qualified Control.Monad.RWS.Strict as RW @@ -141,7 +152,6 @@ import Control.Monad.Trans.AWS (AWST) import qualified Control.Monad.Trans.AWS as AWST import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Cont (ContT) import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Identity (IdentityT) import Control.Monad.Trans.List (ListT) @@ -155,6 +165,7 @@ import Network.AWS.Auth import qualified Network.AWS.EC2.Metadata as EC2 import Network.AWS.Env (Env, HasEnv (..), newEnv) +import qualified Network.AWS.Env as Env import Network.AWS.Internal.Body import Network.AWS.Internal.Logger import Network.AWS.Pager (AWSPager) @@ -168,7 +179,8 @@ type AWS = AWST (ResourceT IO) -- | Monads in which 'AWS' actions may be embedded. -class (Functor m, Applicative m, Monad m) => MonadAWS m where +class (Functor m, Applicative m, Monad m, MonadIO m, MonadCatch m) => MonadAWS m + where -- | Lift a computation to the 'AWS' monad. liftAWS :: AWS a -> m a @@ -179,7 +191,6 @@ instance MonadAWS m => MonadAWS (ListT m) where liftAWS = lift . liftAWS instance MonadAWS m => MonadAWS (MaybeT m) where liftAWS = lift . liftAWS instance MonadAWS m => MonadAWS (ExceptT e m) where liftAWS = lift . liftAWS -instance MonadAWS m => MonadAWS (ContT r m) where liftAWS = lift . liftAWS instance MonadAWS m => MonadAWS (ReaderT r m) where liftAWS = lift . liftAWS instance MonadAWS m => MonadAWS (S.StateT s m) where liftAWS = lift . liftAWS instance MonadAWS m => MonadAWS (LS.StateT s m) where liftAWS = lift . liftAWS @@ -206,6 +217,16 @@ runAWS :: (MonadResource m, HasEnv r) => r -> AWS a -> m a runAWS e = liftResourceT . AWST.runAWST e +-- | Scope an action such that all requests belonging to the supplied service +-- will use this configuration instead of the default. +-- +-- It's suggested you use a modified version of the default service, such +-- as @Network.AWS.DynamoDB.dynamoDB@. +-- +-- /See:/ 'Env.configure'. +reconfigure :: MonadAWS m => Service -> AWS a -> m a +reconfigure s = liftAWS . AWST.reconfigure s + -- | Scope an action within the specific 'Region'. within :: MonadAWS m => Region -> AWS a -> m a within r = liftAWS . AWST.within r @@ -220,30 +241,22 @@ timeout s = liftAWS . AWST.timeout s -- | Send a request, returning the associated response if successful. --- --- /See:/ 'AWST.sendWith' send :: (MonadAWS m, AWSRequest a) => a -> m (Rs a) send = liftAWS . AWST.send -- | Repeatedly send a request, automatically setting markers and -- paginating over multiple responses while available. --- --- /See:/ 'AWST.paginateWith' paginate :: (MonadAWS m, AWSPager a) => a -> Source m (Rs a) paginate = hoist liftAWS . AWST.paginate -- | Poll the API with the supplied request until a specific 'Wait' condition -- is fulfilled. --- --- /See:/ 'AWST.awaitWith' await :: (MonadAWS m, AWSRequest a) => Wait a -> a -> m () await w = liftAWS . AWST.await w -- | Presign an URL that is valid from the specified time until the -- number of seconds expiry has elapsed. --- --- /See:/ 'AWST.presign', 'AWST.presignWith' -presignURL :: (MonadAWS m, AWSPresigner (Sg (Sv a)), AWSRequest a) +presignURL :: (MonadAWS m, AWSRequest a) => UTCTime -- ^ Signing time. -> Seconds -- ^ Expiry time. -> a -- ^ Request to presign. @@ -329,8 +342,7 @@ or 'paginate' and the library will take care of serialisation/authentication and so forth. -The default 'Service' configuration for a request (or the supplied 'Service' configuration -when using the @*With@ variants) contains retry configuration that is used to +The default 'Service' configuration for a request contains retry configuration that is used to determine if a request can safely be retried and what kind of back off/on strategy should be used. (Usually exponential.) Typically services define retry strategies that handle throttling, general server @@ -367,13 +379,49 @@ -} {- $service -When a request is sent, various configuration values such as the endpoint, +When a request is sent, various values such as the endpoint, retry strategy, timeout and error handlers are taken from the associated 'Service' -configuration. +for a request. For example, 'DynamoDB' will use the 'Network.AWS.DynamoDB.dynamoDB' +configuration when sending 'PutItem', 'Query' and all other operations. -You can override the default configuration for a series of one or more actions -by using 'within', 'once' and 'timeout', or by using the @*With@ suffixed -functions on an individual request basis below. +You can modify a specific 'Service''s default configuration by using +'configure' or 'reconfigure'. To modify all configurations simultaneously, see 'override'. + +An example of how you might alter default configuration using these mechanisms +is demonstrated below. Firstly, the default 'dynamoDB' service is configured to +use non-SSL localhost as the endpoint: + +> let dynamo :: Service +> dynamo = setEndpoint False "localhost" 8000 dynamoDB + +The updated configuration is then passed to the 'Env' during setup: + +> e <- newEnv Frankfurt Discover <&> configure dynamo +> runAWS e $ do +> -- This S3 operation will communicate with remote AWS APIs. +> x <- send listBuckets +> +> -- DynamoDB operations will communicate with localhost:8000. +> y <- send listTables +> +> -- Any operations for services other than DynamoDB, are not affected. +> ... + +You can also scope the 'Endpoint' modifications (or any other 'Service' configuration) +to specific actions: + +> e <- newEnv Ireland Discover +> runAWS e $ do +> -- Service operations here will communicate with AWS, even DynamoDB. +> x <- send listTables +> +> reconfigure dynamo $ do +> -- In here, DynamoDB operations will communicate with localhost:8000, +> -- with operations for services not being affected. +> ... + +Functions such as 'within', 'once', and 'timeout' likewise modify the underlying +configuration for all service requests within their respective scope. -} {- $streaming diff --git a/src/Network/AWS/Data.hs b/src/Network/AWS/Data.hs --- a/src/Network/AWS/Data.hs +++ b/src/Network/AWS/Data.hs @@ -18,7 +18,8 @@ -- * Text FromText (..) , fromText - , matchCI + , fromTextError + , takeLowerText , ToText (..) -- * ByteString diff --git a/src/Network/AWS/Env.hs b/src/Network/AWS/Env.hs --- a/src/Network/AWS/Env.hs +++ b/src/Network/AWS/Env.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -18,10 +19,16 @@ newEnv , newEnvWith - , Env (..) - , HasEnv (..) + , Env (..) + , HasEnv (..) + -- * Overriding Default Configuration + , Override (..) + , override + , configure + -- * Scoped Actions + , reconfigure , within , once , timeout @@ -34,6 +41,7 @@ import Control.Monad.IO.Class import Control.Monad.Reader import Control.Retry +import Data.Function (on) import Data.IORef import Data.Monoid import Network.AWS.Auth @@ -45,67 +53,50 @@ -- | The environment containing the parameters required to make AWS requests. data Env = Env - { _envRegion :: !Region - , _envLogger :: !Logger - , _envRetryCheck :: !(Int -> HttpException -> IO Bool) - , _envRetryPolicy :: !(Maybe RetryPolicy) - , _envTimeout :: !(Maybe Seconds) - , _envManager :: !Manager - , _envEC2 :: !(IORef (Maybe Bool)) - , _envAuth :: !Auth + { _envRegion :: !Region + , _envLogger :: !Logger + , _envRetryCheck :: !(Int -> HttpException -> Bool) + , _envOverride :: !Override + , _envManager :: !Manager + , _envEC2 :: !(IORef (Maybe Bool)) + , _envAuth :: !Auth } -- Note: The strictness annotations aobe are applied to ensure -- total field initialisation. class HasEnv a where - environment :: Lens' a Env + environment :: Lens' a Env {-# MINIMAL environment #-} -- | The current region. - envRegion :: Lens' a Region + envRegion :: Lens' a Region -- | The function used to output log messages. - envLogger :: Lens' a Logger + envLogger :: Lens' a Logger -- | The function used to determine if an 'HttpException' should be retried. - envRetryCheck :: Lens' a (Int -> HttpException -> IO Bool) - - -- | The 'RetryPolicy' used to determine backoff\/on and retry delay\/growth. - envRetryPolicy :: Lens' a (Maybe RetryPolicy) + envRetryCheck :: Lens' a (Int -> HttpException -> Bool) - -- | A HTTP response timeout override to apply. This defaults to 'Nothing', - -- and the timeout selection is outlined below. - -- - -- Timeouts are chosen by considering: - -- - -- * This 'envTimeout', if set. - -- - -- * The related 'Service' timeout for the sent request if set. (Usually 70s) - -- - -- * The 'envManager' timeout if set. - -- - -- * The default 'ClientRequest' timeout. (Approximately 30s) - -- - envTimeout :: Lens' a (Maybe Seconds) + -- | The currently applied overrides to all 'Service' configuration. + envOverride :: Lens' a Override -- | The 'Manager' used to create and manage open HTTP connections. - envManager :: Lens' a Manager + envManager :: Lens' a Manager -- | The credentials used to sign requests for authentication with AWS. - envAuth :: Lens' a Auth + envAuth :: Lens' a Auth -- | A memoised predicate for whether the underlying host is an EC2 instance. - envEC2 :: Getter a (IORef (Maybe Bool)) + envEC2 :: Getter a (IORef (Maybe Bool)) - envRegion = environment . lens _envRegion (\s a -> s { _envRegion = a }) - envLogger = environment . lens _envLogger (\s a -> s { _envLogger = a }) - envRetryCheck = environment . lens _envRetryCheck (\s a -> s { _envRetryCheck = a }) - envRetryPolicy = environment . lens _envRetryPolicy (\s a -> s { _envRetryPolicy = a }) - envTimeout = environment . lens _envTimeout (\s a -> s { _envTimeout = a }) - envManager = environment . lens _envManager (\s a -> s { _envManager = a }) - envAuth = environment . lens _envAuth (\s a -> s { _envAuth = a }) - envEC2 = environment . to _envEC2 + envRegion = environment . lens _envRegion (\s a -> s { _envRegion = a }) + envLogger = environment . lens _envLogger (\s a -> s { _envLogger = a }) + envRetryCheck = environment . lens _envRetryCheck (\s a -> s { _envRetryCheck = a }) + envOverride = environment . lens _envOverride (\s a -> s { _envOverride = a }) + envManager = environment . lens _envManager (\s a -> s { _envManager = a }) + envAuth = environment . lens _envAuth (\s a -> s { _envAuth = a }) + envEC2 = environment . to _envEC2 instance HasEnv Env where environment = id @@ -115,12 +106,49 @@ where b = buildLines [ "[Amazonka Env] {" - , " region = " <> build _envRegion - , " retry (n=0) = " <> build (join $ ($ 0) . getRetryPolicy <$> _envRetryPolicy) - , " timeout = " <> build _envTimeout + , " region = " <> build _envRegion , "}" ] +-- | An override function to apply to service configuration before use. +newtype Override = Override { applyOverride :: Service -> Service } + +instance Monoid Override where + mempty = Override id + mappend a b = Override (applyOverride b . applyOverride a) + +-- | Provide a function which will be added to the existing stack +-- of overrides applied to all service configuration. +-- +-- To override a specific service, it's suggested you use +-- either 'configure' or 'reconfigure' with a modified version of the default +-- service, such as @Network.AWS.DynamoDB.dynamoDB@. +override :: HasEnv a => (Service -> Service) -> a -> a +override f = envOverride <>~ Override f + +-- | Configure a specific service. All requests belonging to the +-- supplied service will use this configuration instead of the default. +-- +-- It's suggested you use a modified version of the default service, such +-- as @Network.AWS.DynamoDB.dynamoDB@. +-- +-- /See:/ 'reconfigure'. +configure :: HasEnv a => Service -> a -> a +configure s = override f + where + f x | on (==) _svcAbbrev s x = s + | otherwise = x + +-- | Scope an action such that all requests belonging to the supplied service +-- will use this configuration instead of the default. +-- +-- It's suggested you use a modified version of the default service, such +-- as @Network.AWS.DynamoDB.dynamoDB@. +-- +-- /See:/ 'configure'. +reconfigure :: (MonadReader r m, HasEnv r) => Service -> m a -> m a +reconfigure = local . configure + -- | Scope an action within the specific 'Region'. within :: (MonadReader r m, HasEnv r) => Region -> m a -> m a within r = local (envRegion .~ r) @@ -128,13 +156,21 @@ -- | Scope an action such that any retry logic for the 'Service' is -- ignored and any requests will at most be sent once. once :: (MonadReader r m, HasEnv r) => m a -> m a -once = local $ \e -> e - & envRetryPolicy ?~ limitRetries 0 - & envRetryCheck .~ (\_ _ -> return False) +once = local (override (serviceRetry . retryAttempts .~ 0)) -- | Scope an action such that any HTTP response will use this timeout value. +-- +-- Default timeouts are chosen by considering: +-- +-- * This 'timeout', if set. +-- +-- * The related 'Service' timeout for the sent request if set. (Usually 70s) +-- +-- * The 'envManager' timeout if set. +-- +-- * The default 'ClientRequest' timeout. (Approximately 30s) timeout :: (MonadReader r m, HasEnv r) => Seconds -> m a -> m a -timeout s = local (envTimeout ?~ s) +timeout s = local (override (serviceTimeout ?~ s)) -- | Creates a new environment with a new 'Manager' without debug logging -- and uses 'getAuth' to expand/discover the supplied 'Credentials'. @@ -154,15 +190,13 @@ -- -- Throws 'AuthError' when environment variables or IAM profiles cannot be read. newEnvWith :: (Applicative m, MonadIO m, MonadCatch m) - => Region -- ^ Initial region to operate in. - -> Credentials -- ^ Credential discovery mechanism. - -> Maybe Bool -- ^ Preload memoisation for the underlying EC2 instance check. + => Region -- ^ Initial region to operate in. + -> Credentials -- ^ Credential discovery mechanism. + -> Maybe Bool -- ^ Dictate if the instance is running on EC2. (Preload memoisation.) -> Manager -> m Env -newEnvWith r c p m = Env r logger check Nothing Nothing m - <$> liftIO (newIORef p) - <*> getAuth m c +newEnvWith r c p m = + Env r logger check mempty m <$> liftIO (newIORef p) <*> getAuth m c where logger _ _ = return () - -- FIXME: verify the usage of check. - check _ _ = return True + check _ _ = True diff --git a/src/Network/AWS/Internal/HTTP.hs b/src/Network/AWS/Internal/HTTP.hs --- a/src/Network/AWS/Internal/HTTP.hs +++ b/src/Network/AWS/Internal/HTTP.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Network.AWS.Internal.HTTP @@ -14,126 +15,94 @@ -- Portability : non-portable (GHC extensions) -- module Network.AWS.Internal.HTTP - ( perform - , retrier + ( retrier , waiter ) where +import Control.Arrow (first) import Control.Monad import Control.Monad.Catch -import Control.Monad.IO.Class +import Control.Monad.Reader import Control.Monad.Trans.Resource import Control.Retry import Data.List (intersperse) import Data.Monoid +import Data.Proxy import Data.Time import Network.AWS.Env import Network.AWS.Internal.Logger import Network.AWS.Prelude import Network.AWS.Waiter -import Network.HTTP.Conduit hiding (Request, Response) +import Network.HTTP.Conduit hiding (Proxy, Request, Response) import Prelude -perform :: (MonadCatch m, MonadResource m, AWSSigner (Sg s), AWSRequest a) - => Env - -> Service s - -> Request a +retrier :: ( MonadCatch m + , MonadResource m + , MonadReader r m + , HasEnv r + , AWSRequest a + ) + => a -> m (Either Error (Response a)) -perform e@Env{..} svc x = catches go handlers +retrier x = do + e <- view environment + rq <- configured x + retrying (policy rq) (check e rq) (perform e rq) where - go = do - t <- liftIO getCurrentTime - Signed m s <- withAuth _envAuth $ \a -> - return (signed a _envRegion t svc x) - - let rq = s { responseTimeout = timeoutFor e svc } - - logTrace _envLogger m -- trace:Signing:Meta - logDebug _envLogger rq -- debug:ClientRequest - - rs <- liftResourceT (http rq _envManager) - - logDebug _envLogger rs -- debug:ClientResponse - - Right <$> - response _envLogger svc x rs - - handlers = - [ Handler $ return . Left - , Handler $ \er -> do - logError _envLogger er - return (Left (TransportError er)) - ] + policy rq = retryStream rq <> retryService (_rqService rq) -retrier :: MonadIO m - => Env - -> Service s - -> Request a - -> m (Either Error (Response a)) - -> m (Either Error (Response a)) -retrier Env{..} Service{..} rq = - retrying (fromMaybe policy _envRetryPolicy) check - where - policy = limitRetries _retryAttempts - <> RetryPolicy (const $ listToMaybe [0 | not stream]) - <> RetryPolicy delay + check e rq n (Left r) + | Just p <- r ^? transportErr, p = msg e "http_error" n >> return True + | Just m <- r ^? serviceErr = msg e m n >> return True where - !stream = bodyStream (_rqBody rq) - - delay n - | n > 0 = Just $ truncate (grow * 1000000) - | otherwise = Nothing - where - grow = _retryBase * (fromIntegral _retryGrowth ^^ (n - 1)) - - check n = \case - Left (TransportError e) -> do - p <- liftIO (_envRetryCheck n e) - when p (msg "http_error" n) >> return p + transportErr = _TransportError . to (_envRetryCheck e n) + serviceErr = _ServiceError . to rc . _Just - Left e | Just x <- e ^? _ServiceError . to _retryCheck . _Just -> - msg x n >> return True + rc = rq ^. rqService . serviceRetry . retryCheck - _ -> return False + check _ _ _ _ = return False - msg x n = logDebug _envLogger + msg :: MonadIO m => Env -> Text -> Int -> m () + msg e m n = logDebug (_envLogger e) . mconcat . intersperse " " - $ [ "[Retry " <> build x <> "]" + $ [ "[Retry " <> build m <> "]" , "after" , build (n + 1) , "attempts." ] - Exponential{..} = _svcRetry - -waiter :: MonadIO m - => Env - -> Wait a - -> Request a - -> m (Either Error (Response a)) +waiter :: ( MonadCatch m + , MonadResource m + , MonadReader r m + , HasEnv r + , AWSRequest a + ) + => Wait a + -> a -> m (Maybe Error) -waiter Env{..} w@Wait{..} rq f = retrying policy check wait >>= exit +waiter w@Wait{..} x = do + e@Env{..} <- view environment + rq <- configured x + retrying policy (check _envLogger) (result rq <$> perform e rq) >>= exit where policy = limitRetries _waitAttempts <> constantDelay (microseconds _waitDelay) - wait = do - e <- f - return (fromMaybe AcceptRetry (accept w rq e), e) - - exit (AcceptSuccess, _) = return Nothing - exit (_, Left e) = return (Just e) - exit (_, _) = return Nothing + check e n (a, _) = msg e n a >> return (retry a) + where + retry AcceptSuccess = False + retry AcceptFailure = False + retry AcceptRetry = True - check n (a, _) = msg n a >> return (retry a) + result rq = first (fromMaybe AcceptRetry . accept w rq) . join (,) - retry AcceptSuccess = False - retry AcceptFailure = False - retry AcceptRetry = True + exit (AcceptSuccess, _) = return Nothing + exit (_, Left e) = return (Just e) + exit (_, _) = return Nothing - msg n a = logDebug _envLogger + msg l n a = logDebug l . mconcat . intersperse " " $ [ "[Await " <> build _waitName <> "]" @@ -143,7 +112,57 @@ , "attempts." ] --- | Returns the possible HTTP response timeout value in microseconds --- given the timeout configuration sources. -timeoutFor :: HasEnv a => a -> Service s -> Maybe Int -timeoutFor e s = microseconds <$> (e ^. envTimeout <|> _svcTimeout s) +-- | The 'Service' is configured + unwrapped at this point. +perform :: (MonadCatch m, MonadResource m, AWSRequest a) + => Env + -> Request a + -> m (Either Error (Response a)) +perform Env{..} x = catches go handlers + where + go = do + t <- liftIO getCurrentTime + Signed m rq <- + withAuth _envAuth $ \a -> + return $! rqSign x a _envRegion t + + logTrace _envLogger m -- trace:Signing:Meta + logDebug _envLogger rq -- debug:ClientRequest + + rs <- liftResourceT (http rq _envManager) + + logDebug _envLogger rs -- debug:ClientResponse + + Right <$> response _envLogger (_rqService x) (p x) rs + + handlers = + [ Handler $ err + , Handler $ err . TransportError + ] + where + err e = logError _envLogger e >> return (Left e) + + p :: Request a -> Proxy a + p = const Proxy + +configured :: (MonadReader r m, HasEnv r, AWSRequest a) + => a + -> m (Request a) +configured (request -> x) = do + o <- view envOverride + return $! x & rqService %~ applyOverride o + +retryStream :: Request a -> RetryPolicy +retryStream x = RetryPolicy (const $ listToMaybe [0 | not p]) + where + !p = bodyStream (_rqBody x) + +retryService :: Service -> RetryPolicy +retryService s = limitRetries _retryAttempts <> RetryPolicy delay + where + delay n + | n > 0 = Just $ truncate (grow * 1000000) + | otherwise = Nothing + where + grow = _retryBase * (fromIntegral _retryGrowth ^^ (n - 1)) + + Exponential{..} = _svcRetry s diff --git a/src/Network/AWS/Presign.hs b/src/Network/AWS/Presign.hs --- a/src/Network/AWS/Presign.hs +++ b/src/Network/AWS/Presign.hs @@ -29,7 +29,7 @@ -- number of seconds expiry has elapsed. -- -- /See:/ 'presign', 'presignWith' -presignURL :: (MonadIO m, AWSPresigner (Sg (Sv a)), AWSRequest a) +presignURL :: (MonadIO m, AWSRequest a) => Auth -> Region -> UTCTime -- ^ Signing time. @@ -41,30 +41,27 @@ -- | Presign an HTTP request that is valid from the specified time until the -- number of seconds expiry has elapsed. -- --- This requires the 'Service' signer to be an instance of 'AWSPresigner'. --- Not all signing algorithms support this. --- -- /See:/ 'presignWith' -presign :: (MonadIO m, AWSPresigner (Sg (Sv a)), AWSRequest a) +presign :: (MonadIO m, AWSRequest a) => Auth -> Region -> UTCTime -- ^ Signing time. -> Seconds -- ^ Expiry time. -> a -- ^ Request to presign. -> m ClientRequest -presign a r ts ex = presignWith id a r ts ex +presign = presignWith id --- | A variant of 'presign' that allows specifying the 'Service' definition --- used to configure the request. -presignWith :: (MonadIO m, AWSPresigner (Sg s), AWSRequest a) - => (Service (Sv a) -> Service s) -- ^ Modify the default service configuration. +-- | A variant of 'presign' that allows modifying the default 'Service' +-- definition used to configure the request. +presignWith :: (MonadIO m, AWSRequest a) + => (Service -> Service) -- ^ Modify the default service configuration. -> Auth -> Region - -> UTCTime -- ^ Signing time. - -> Seconds -- ^ Expiry time. - -> a -- ^ Request to presign. + -> UTCTime -- ^ Signing time. + -> Seconds -- ^ Expiry time. + -> a -- ^ Request to presign. -> m ClientRequest -presignWith s a r ts ex x = +presignWith f a r ts ex x = withAuth a $ \ae -> - return . view sgRequest $ - presigned ae r ts ex (s (serviceOf x)) (request x) + return $! sgRequest $ + rqPresign ex (request x & rqService %~ f) ae r ts