-- |
-- Module      : Amazonka.HTTP
-- Copyright   : (c) 2013-2023 Brendan Hay
-- License     : Mozilla Public License, v. 2.0.
-- Maintainer  : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability   : provisional
-- Portability : non-portable (GHC extensions)
module Amazonka.HTTP
  ( retryRequest,
    awaitRequest,
    httpRequest,
    configureRequest,
    retryService,
    retryStream,
  )
where

import Amazonka.Core.Lens.Internal (to, (^?), _Just)
import Amazonka.Data.Body (isStreaming)
import Amazonka.Env hiding (auth)
import Amazonka.Env.Hooks (Finality (..))
import qualified Amazonka.Env.Hooks as Hooks
import Amazonka.Prelude
import Amazonka.Types
import Amazonka.Waiter
import Control.Exception as Exception
import Control.Monad.Trans.Resource (liftResourceT, transResourceT)
import qualified Control.Retry as Retry
import Data.Foldable (traverse_)
import qualified Data.Time as Time
import Data.Typeable (Typeable)
import qualified Network.HTTP.Conduit as Client.Conduit

retryRequest ::
  forall m a withAuth.
  ( MonadResource m,
    AWSRequest a,
    Typeable a,
    Typeable (AWSResponse a),
    Foldable withAuth
  ) =>
  Env' withAuth ->
  a ->
  m (Either Error (ClientResponse (AWSResponse a)))
retryRequest :: forall (m :: * -> *) a (withAuth :: * -> *).
(MonadResource m, AWSRequest a, Typeable a,
 Typeable (AWSResponse a), Foldable withAuth) =>
Env' withAuth
-> a -> m (Either Error (ClientResponse (AWSResponse a)))
retryRequest env :: Env' withAuth
env@Env {Hooks
$sel:hooks:Env :: forall (withAuth :: * -> *). Env' withAuth -> Hooks
hooks :: Hooks
hooks} a
rq = do
  a
rq' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Hooks -> forall a. (AWSRequest a, Typeable a) => Hook a
Hooks.request Hooks
hooks Env' withAuth
env a
rq
  Request a
cfgRq <- forall a (m :: * -> *) (withAuth :: * -> *).
(AWSRequest a, Typeable a, MonadIO m) =>
Env' withAuth -> a -> m (Request a)
configureRequest Env' withAuth
env a
rq'

  let attempt :: RetryStatus -> m (Either Error (ClientResponse (AWSResponse a)))
attempt RetryStatus
_ = forall (m :: * -> *) a (withAuth :: * -> *).
(MonadResource m, AWSRequest a, Typeable a, Foldable withAuth) =>
Env' withAuth
-> Request a -> m (Either Error (ClientResponse (AWSResponse a)))
httpRequest Env' withAuth
env Request a
cfgRq
      policy :: RetryPolicyM m
policy = forall a. Request a -> RetryPolicy
retryStream Request a
cfgRq forall a. Semigroup a => a -> a -> a
<> Service -> RetryPolicy
retryService (forall a. Request a -> Service
service Request a
cfgRq)
      Request
        { $sel:service:Request :: forall a. Request a -> Service
service = Service {$sel:retry:Service :: Service -> Retry
retry = Exponential {$sel:check:Exponential :: Retry -> ServiceError -> Maybe Text
check = ServiceError -> Maybe Text
serviceRetryCheck}}
        } = Request a
cfgRq

      shouldRetry :: Retry.RetryStatus -> Either Error b -> m Bool
      shouldRetry :: forall b. RetryStatus -> Either Error b -> m Bool
shouldRetry RetryStatus
s =
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
          Left Error
r
            | Just Bool
True <- Error
r forall s a. s -> Getting (First a) s a -> Maybe a
^? (Bool -> Const (First Bool) Bool)
-> Error -> Const (First Bool) Error
transportErr ->
                Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Hooks
-> forall a.
   (AWSRequest a, Typeable a) =>
   Hook_ (Request a, Text, RetryStatus)
Hooks.requestRetry Hooks
hooks Env' withAuth
env (Request a
cfgRq, Text
"http_error", RetryStatus
s)
            | Just Text
name <- Error
r forall s a. s -> Getting (First a) s a -> Maybe a
^? (Text -> Const (First Text) Text)
-> Error -> Const (First Text) Error
serviceErr ->
                Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Hooks
-> forall a.
   (AWSRequest a, Typeable a) =>
   Hook_ (Request a, Text, RetryStatus)
Hooks.requestRetry Hooks
hooks Env' withAuth
env (Request a
cfgRq, Text
name, RetryStatus
s)
          Either Error b
_other -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        where
          transportErr :: (Bool -> Const (First Bool) Bool)
-> Error -> Const (First Bool) Error
transportErr =
            forall a. AsError a => Prism' a HttpException
_TransportError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (forall (withAuth :: * -> *).
Env' withAuth -> Int -> HttpException -> Bool
retryCheck Env' withAuth
env (RetryStatus -> Int
Retry.rsIterNumber RetryStatus
s))

          serviceErr :: (Text -> Const (First Text) Text)
-> Error -> Const (First Text) Error
serviceErr =
            forall a. AsError a => Prism' a ServiceError
_ServiceError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ServiceError -> Maybe Text
serviceRetryCheck forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just

  forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
Retry.retrying RetryPolicyM m
policy forall b. RetryStatus -> Either Error b -> m Bool
shouldRetry RetryStatus -> m (Either Error (ClientResponse (AWSResponse a)))
attempt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left Error
e -> forall a b. a -> Either a b
Left Error
e forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Hooks
-> forall a.
   (AWSRequest a, Typeable a) =>
   Hook_ (Finality, Request a, Error)
Hooks.error Hooks
hooks Env' withAuth
env (Finality
Final, Request a
cfgRq, Error
e))
    Right ClientResponse (AWSResponse a)
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ClientResponse (AWSResponse a)
a

awaitRequest ::
  ( MonadResource m,
    AWSRequest a,
    Typeable a,
    Foldable withAuth
  ) =>
  Env' withAuth ->
  Wait a ->
  a ->
  m (Either Error Accept)
awaitRequest :: forall (m :: * -> *) a (withAuth :: * -> *).
(MonadResource m, AWSRequest a, Typeable a, Foldable withAuth) =>
Env' withAuth -> Wait a -> a -> m (Either Error Accept)
awaitRequest env :: Env' withAuth
env@Env {Hooks
hooks :: Hooks
$sel:hooks:Env :: forall (withAuth :: * -> *). Env' withAuth -> Hooks
hooks} Wait a
w a
rq = do
  a
rq' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Hooks -> forall a. (AWSRequest a, Typeable a) => Hook a
Hooks.request Hooks
hooks Env' withAuth
env a
rq
  Request a
cfgRq <- forall a (m :: * -> *) (withAuth :: * -> *).
(AWSRequest a, Typeable a, MonadIO m) =>
Env' withAuth -> a -> m (Request a)
configureRequest Env' withAuth
env a
rq'
  w' :: Wait a
w'@Wait {Int
[Acceptor a]
ByteString
Seconds
$sel:name:Wait :: forall a. Wait a -> ByteString
$sel:attempts:Wait :: forall a. Wait a -> Int
$sel:delay:Wait :: forall a. Wait a -> Seconds
$sel:acceptors:Wait :: forall a. Wait a -> [Acceptor a]
acceptors :: [Acceptor a]
delay :: Seconds
attempts :: Int
name :: ByteString
..} <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Hooks -> forall a. (AWSRequest a, Typeable a) => Hook (Wait a)
Hooks.wait Hooks
hooks Env' withAuth
env Wait a
w

  let handleResult :: Either Error (ClientResponse (AWSResponse a))
-> (Accept, Either Error (ClientResponse (AWSResponse a)))
handleResult Either Error (ClientResponse (AWSResponse a))
res = (forall a. a -> Maybe a -> a
fromMaybe Accept
AcceptRetry forall a b. (a -> b) -> a -> b
$ forall a. Wait a -> Acceptor a
accept Wait a
w' Request a
cfgRq Either Error (ClientResponse (AWSResponse a))
res, Either Error (ClientResponse (AWSResponse a))
res)
      attempt :: RetryStatus
-> m (Accept, Either Error (ClientResponse (AWSResponse a)))
attempt RetryStatus
_ = Either Error (ClientResponse (AWSResponse a))
-> (Accept, Either Error (ClientResponse (AWSResponse a)))
handleResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a (withAuth :: * -> *).
(MonadResource m, AWSRequest a, Typeable a, Foldable withAuth) =>
Env' withAuth
-> Request a -> m (Either Error (ClientResponse (AWSResponse a)))
httpRequest Env' withAuth
env Request a
cfgRq
      policy :: RetryPolicyM m
policy =
        Int -> RetryPolicy
Retry.limitRetries Int
attempts
          forall a. Semigroup a => a -> a -> a
<> forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
Retry.constantDelay (Seconds -> Int
toMicroseconds Seconds
delay)

      check :: RetryStatus
-> (Accept, Either Error (ClientResponse (AWSResponse a)))
-> m Bool
check RetryStatus
retryStatus (Accept
a, Either Error (ClientResponse (AWSResponse a))
_) = do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Hooks
-> forall a.
   (AWSRequest a, Typeable a) =>
   Hook_ (Request a, Wait a, Accept, RetryStatus)
Hooks.awaitRetry Hooks
hooks Env' withAuth
env (Request a
cfgRq, Wait a
w', Accept
a, RetryStatus
retryStatus)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Accept
a of
          Accept
AcceptSuccess -> Bool
False
          Accept
AcceptFailure -> Bool
False
          Accept
AcceptRetry -> Bool
True

  forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
Retry.retrying RetryPolicyM m
policy RetryStatus
-> (Accept, Either Error (ClientResponse (AWSResponse a)))
-> m Bool
check RetryStatus
-> m (Accept, Either Error (ClientResponse (AWSResponse a)))
attempt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Accept
AcceptSuccess, Either Error (ClientResponse (AWSResponse a))
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Accept
AcceptSuccess
    (Accept
_, Left Error
e) -> forall a b. a -> Either a b
Left Error
e forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Hooks
-> forall a.
   (AWSRequest a, Typeable a) =>
   Hook_ (Finality, Request a, Error)
Hooks.error Hooks
hooks Env' withAuth
env (Finality
Final, Request a
cfgRq, Error
e))
    (Accept
a, Either Error (ClientResponse (AWSResponse a))
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Accept
a

-- | Make a one-shot request to AWS, using a configured 'Request'
-- (which contains the 'Service', plus any overrides).
httpRequest ::
  ( MonadResource m,
    AWSRequest a,
    Typeable a,
    Foldable withAuth
  ) =>
  Env' withAuth ->
  Request a ->
  m (Either Error (ClientResponse (AWSResponse a)))
httpRequest :: forall (m :: * -> *) a (withAuth :: * -> *).
(MonadResource m, AWSRequest a, Typeable a, Foldable withAuth) =>
Env' withAuth
-> Request a -> m (Either Error (ClientResponse (AWSResponse a)))
httpRequest env :: Env' withAuth
env@Env {Hooks
hooks :: Hooks
$sel:hooks:Env :: forall (withAuth :: * -> *). Env' withAuth -> Hooks
hooks, Manager
$sel:manager:Env :: forall (withAuth :: * -> *). Env' withAuth -> Manager
manager :: Manager
manager, Region
$sel:region:Env :: forall (withAuth :: * -> *). Env' withAuth -> Region
region :: Region
region} Request a
cfgRq =
  forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT (forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> ResourceT m a -> ResourceT n b
transResourceT (forall a. IO a -> [Handler a] -> IO a
`Exception.catches` forall b. [Handler (Either Error b)]
handlers) ResourceT IO (Either Error (ClientResponse (AWSResponse a)))
go)
  where
    go :: ResourceT IO (Either Error (ClientResponse (AWSResponse a)))
go = do
      UTCTime
time <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
Time.getCurrentTime

      ClientRequest
clientRq :: ClientRequest <-
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hooks -> Hook ClientRequest
Hooks.clientRequest Hooks
hooks Env' withAuth
env forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< case forall (withAuth :: * -> *).
Foldable withAuth =>
Env' withAuth -> Maybe Auth
authMaybe Env' withAuth
env of
          Maybe Auth
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall a. Request a -> Region -> ClientRequest
requestUnsigned Request a
cfgRq Region
region
          Just Auth
auth -> forall (m :: * -> *) a.
MonadIO m =>
Auth -> (AuthEnv -> m a) -> m a
withAuth Auth
auth forall a b. (a -> b) -> a -> b
$ \AuthEnv
a -> do
            let s :: Signed a
s@(Signed Meta
_ ClientRequest
rq) = forall a. Algorithm a
requestSign Request a
cfgRq AuthEnv
a Region
region UTCTime
time
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Hooks -> forall a. (AWSRequest a, Typeable a) => Hook_ (Signed a)
Hooks.signedRequest Hooks
hooks Env' withAuth
env Signed a
s
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! ClientRequest
rq

      Response (ConduitM () ByteString (ResourceT IO) ())
rs <- forall (m :: * -> *) i.
MonadResource m =>
ClientRequest
-> Manager -> m (Response (ConduitM i ByteString m ()))
Client.Conduit.http ClientRequest
clientRq Manager
manager
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Hooks
-> forall a.
   (AWSRequest a, Typeable a) =>
   Hook_ (Request a, ClientResponse ())
Hooks.clientResponse Hooks
hooks Env' withAuth
env (Request a
cfgRq, forall (f :: * -> *) a. Functor f => f a -> f ()
void Response (ConduitM () ByteString (ResourceT IO) ())
rs)
      Either Error (ClientResponse (AWSResponse a))
parsedRs <-
        forall a (m :: * -> *).
(AWSRequest a, MonadResource m) =>
(ByteStringLazy -> IO ByteStringLazy)
-> Service
-> Proxy a
-> Response (ConduitM () ByteString (ResourceT IO) ())
-> m (Either Error (ClientResponse (AWSResponse a)))
response
          (Hooks -> Hook ByteStringLazy
Hooks.rawResponseBody Hooks
hooks Env' withAuth
env)
          (forall a. Request a -> Service
service Request a
cfgRq)
          (forall a. Request a -> Proxy a
proxy Request a
cfgRq)
          Response (ConduitM () ByteString (ResourceT IO) ())
rs
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hooks
-> forall a.
   (AWSRequest a, Typeable a) =>
   Hook_ (Request a, ClientResponse (AWSResponse a))
Hooks.response Hooks
hooks Env' withAuth
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Request a
cfgRq,)) Either Error (ClientResponse (AWSResponse a))
parsedRs
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Either Error (ClientResponse (AWSResponse a))
parsedRs

    handlers :: [Handler (Either Error b)]
    handlers :: forall b. [Handler (Either Error b)]
handlers =
      [ forall a e. Exception e => (e -> IO a) -> Handler a
Handler Error -> IO (Either Error b)
err,
        forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ Error -> IO (Either Error b)
err forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> Error
TransportError
      ]
      where
        err :: Error -> IO (Either Error b)
err Error
e = forall a b. a -> Either a b
Left Error
e forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Hooks
-> forall a.
   (AWSRequest a, Typeable a) =>
   Hook_ (Finality, Request a, Error)
Hooks.error Hooks
hooks Env' withAuth
env (Finality
NotFinal, Request a
cfgRq, Error
e)

    proxy :: Request a -> Proxy a
    proxy :: forall a. Request a -> Proxy a
proxy Request a
_ = forall {k} (t :: k). Proxy t
Proxy

-- Configures an AWS request `a` into its `Request a` form, applying
-- service overrides from `env` and running hooks on the configured
-- (Request a).
configureRequest ::
  (AWSRequest a, Typeable a, MonadIO m) => Env' withAuth -> a -> m (Request a)
configureRequest :: forall a (m :: * -> *) (withAuth :: * -> *).
(AWSRequest a, Typeable a, MonadIO m) =>
Env' withAuth -> a -> m (Request a)
configureRequest env :: Env' withAuth
env@Env {Service -> Service
$sel:overrides:Env :: forall (withAuth :: * -> *). Env' withAuth -> Service -> Service
overrides :: Service -> Service
overrides, Hooks
hooks :: Hooks
$sel:hooks:Env :: forall (withAuth :: * -> *). Env' withAuth -> Hooks
hooks} =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hooks -> forall a. (AWSRequest a, Typeable a) => Hook (Request a)
Hooks.configuredRequest Hooks
hooks Env' withAuth
env
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. AWSRequest a => (Service -> Service) -> a -> Request a
request Service -> Service
overrides

retryStream :: Request a -> Retry.RetryPolicy
retryStream :: forall a. Request a -> RetryPolicy
retryStream Request {RequestBody
$sel:body:Request :: forall a. Request a -> RequestBody
body :: RequestBody
body} =
  forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
Retry.RetryPolicyM forall a b. (a -> b) -> a -> b
$ \RetryStatus
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if RequestBody -> Bool
isStreaming RequestBody
body then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Int
0

retryService :: Service -> Retry.RetryPolicy
retryService :: Service -> RetryPolicy
retryService Service {$sel:retry:Service :: Service -> Retry
retry = Exponential {Double
Int
ServiceError -> Maybe Text
$sel:base:Exponential :: Retry -> Double
$sel:growth:Exponential :: Retry -> Int
$sel:attempts:Exponential :: Retry -> Int
check :: ServiceError -> Maybe Text
attempts :: Int
growth :: Int
base :: Double
$sel:check:Exponential :: Retry -> ServiceError -> Maybe Text
..}} =
  Int -> RetryPolicy
Retry.limitRetries Int
attempts forall a. Semigroup a => a -> a -> a
<> forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
Retry.RetryPolicyM (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. RetryStatus -> Maybe Int
delay)
  where
    delay :: RetryStatus -> Maybe Int
delay (RetryStatus -> Int
Retry.rsIterNumber -> Int
n)
      | Int
n forall a. Ord a => a -> a -> Bool
>= Int
0 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
truncate (Double
grow forall a. Num a => a -> a -> a
* Double
1000000)
      | Bool
otherwise = forall a. Maybe a
Nothing
      where
        grow :: Double
grow = Double
base forall a. Num a => a -> a -> a
* (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
growth forall a b. (Fractional a, Integral b) => a -> b -> a
^^ (Int
n forall a. Num a => a -> a -> a
- Int
1))