{-# LANGUAGE AllowAmbiguousTypes #-}

-- |
-- Module      : Amazonka.Env.Hooks
-- Copyright   : (c) 2023 Brendan Hay
-- License     : Mozilla Public License, v. 2.0.
-- Maintainer  : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability   : highly experimental
-- Portability : non-portable (GHC extensions)
--
-- Hooks carried within an 'Env', allowing ad-hoc injection of
-- different behaviour during Amazonka's request/response cycle.
-- Hooks are currently experimental, but Amazonka uses the 'Hooks' API
-- to implement its default logging, and you can add your own
-- behaviour here as well. Some examples of things hooks can do:
--
-- * Log all requests Amazonka makes to a separate log, in order to
--   audit which IAM permissions your program actually needs
--   (see 'requestHook');
--
--   @
--   {-# LANGAUGE OverloadedLabels #-}
--   import Amazonka
--   import Amazonka.Env.Hooks
--   import Data.Generics.Labels ()
--
--   main :: IO ()
--   main = do
--     env <- newEnv discover
--       \<&\> #hooks %~ 'requestHook' ('addAWSRequestHook' $ \\_env req -> req <$ logRequest req)
--     ...
--
--   logRequest :: AWSRequest a => a -> IO ()
--   logRequest = ...
--   @
--
-- * Inject a [Trace ID for AWS X-Ray](https://docs.aws.amazon.com/xray/latest/devguide/xray-concepts.html#xray-concepts-tracingheader),
--   into each request before it is signed and sent
--   (see 'configuredRequestHook'); and
--
--   @
--   {-# LANGAUGE OverloadedLabels #-}
--   import Amazonka
--   import Amazonka.Env.Hooks
--   import Data.Generics.Labels ()
--
--   main :: IO ()
--   main = do
--     env <- newEnv discover
--       \<&\> #hooks %~ 'configuredRequestHook' ('addHook' $ \\_env req -> req & #headers %~ addXRayIdHeader)
--     ...
--
--   -- The actual header would normally come from whatever calls into your program,
--   -- or you would randomly generate one yourself (hooks run in 'IO').
--   addXRayIdHeader :: ['Network.HTTP.Types.Header'] -> ['Network.HTTP.Types.Header']
--   addXRayIdHeader = ...
--   @
--
-- * Selectively silence certain expected errors, such as DynamoDB's
--   @ConditionalCheckFailedException@ ('errorHook' and 'silenceError')
--
--   @
--   {-# LANGAUGE OverloadedLabels #-}
--   import Amazonka
--   import Amazonka.Env.Hooks
--   import qualified Amazonka.DynamoDB as DynamoDB
--   import Data.Generics.Labels ()
--
--   main :: IO ()
--   main = do
--     env <- newEnv discover
--     putItemResponse <- runResourceT $
--       send
--         (env & #hooks %~ 'errorHook' ('silenceError' DynamoDB._ConditionalCheckFailedException))
--         (DynamoDB.newPutItem ...)
--     ...
--   @
--
-- Most functions with names ending in @Hook@ ('requestHook', etc.)
-- are intended for use with lenses: partially apply them to get a
-- function @'Hook' a -> 'Hook' a@ that can go on the RHS of @(%~)@
-- (the lens modify function). You then use functions like
-- 'addHookFor' to selectively extend the hooks used at any particular
-- time.
--
-- Names ending in @_@ ('Hook_', 'addHookFor_', etc.) concern hooks
-- that return @()@ instead of the hook's input type. These hooks
-- respond to some event but lack the ability to change Amazonka's
-- behaviour; either because it is unsafe to do so, or because it is
-- difficult to do anything meaningful with the updated value.
--
-- The request/response flow for a standard 'Amazonka.send' looks like
-- this:
--
-- @
--     send (req :: 'AWSRequest' a => a)
--                  |
--                  V
--         Run Hook: request
--                  |
--                  V
-- Amazonka: configure req into "Request a"
--  (Amazonka-specific HTTP request type)
--                  |
--                  V
--     Run Hook: configuredRequest
--                  |
--                  V
-- Amazonka: sign request, turn into standard
--     Network.HTTP.Client.'Network.HTTP.Client.Request'
--                  |
--                  +-<---------------------------------.
--                  V                                   |
--     Run Hook: signedRequest                          |
--                  |                                   |
--                  V                                   |
--     Run Hook: clientRequest                          |
--                  |                                   |
--                  V                                   |
--     Amazonka: send request to AWS           Run Hook: requestRetry
--                  |                                   ^
--                  V                                   |
--     Run Hook: clientResponse                         |
--                  |                                   |
--                  V                                   |
--     Run Hook: rawResponseBody                        |
--                  |                                   |
--                  V                                   |
--     Amazonka: was error? ------------------.         |
--                  |            Yes          |         |
--                  |                         V         |
--                  | No               Run Hook: error  |
--                  |                    ('NotFinal')     |
--                  |                         |         |
--                  +-<-----------------------\'         |
--                  V                                   |
--     Amazonka: should retry? -------------------------\'
--                  |            Yes
--                  | No
--                  V
--     Amazonka: was error? ------------------.
--                  |            Yes          |
--                  |                         V
--                  | No                      |
--                  |                         |
--     Run Hook: response              Run Hook: error
--                  |                     ('Final')
--                  |                         |
--                  V                         |
--     Amazonka: parse response               |
--                  |                         |
--                  +-<-----------------------\'
--                  V
--     Amazonka: return result
-- @
module Amazonka.Env.Hooks
  ( Hook,
    Hook_,
    Hooks (..),
    Finality (..),

    -- * Updating members of 'Hooks'
    requestHook,
    waitHook,
    configuredRequestHook,
    signedRequestHook,
    clientRequestHook,
    clientResponseHook,
    rawResponseBodyHook,
    requestRetryHook,
    awaitRetryHook,
    responseHook,
    errorHook,

    -- * Functions to use with the ones above
    noHook,
    noHook_,
    addHook,
    addHook_,
    addAWSRequestHook,
    addAWSRequestHook_,
    addHookFor,
    addHookFor_,
    removeHooksFor,
    removeHooksFor_,

    -- ** Specialty combinators
    silenceError,

    -- * Building 'Hooks'
    addLoggingHooks,
    noHooks,
  )
where

import {-# SOURCE #-} Amazonka.Env (Env' (..))
import Amazonka.Logger (build, logDebug, logError, logTrace)
import Amazonka.Prelude hiding (error)
import Amazonka.Types
  ( AWSRequest,
    AWSResponse,
    ClientRequest,
    ClientResponse,
    Error,
    Request,
    Signed (..),
  )
import Amazonka.Waiter (Accept, Wait (..))
import Control.Lens (Getting, has)
import qualified Control.Retry as Retry
import Data.List (intersperse)
import Data.Monoid (Any)
import Data.Typeable (Typeable, eqT, (:~:) (..))

-- | A hook that returns an updated version of its arguments.
type Hook a = forall withAuth. Env' withAuth -> a -> IO a

-- | A hook that cannot return an updated version of its argument.
type Hook_ a = forall withAuth. Env' withAuth -> a -> IO ()

-- | Indicates whether an error hook is potentially going to be
-- retried.
--
-- /See:/ 'error'
data Finality = NotFinal | Final
  deriving stock (Bounded, Enum, Eq, Ord, Show, Generic)

data Hooks = Hooks
  { -- | Called at the start of request processing, before the request
    -- is configured. This is always the first hook that runs, and
    -- argument is usually a request record type like @amazonka-s3@'s
    -- @GetObjectRequest@.
    request :: forall a. (AWSRequest a, Typeable a) => Hook a,
    -- | Called after the request has been configured into an abstract
    -- HTTP request, but before it is converted to a signed
    -- @Network.HTTP.Client.'Network.HTTP.Client.Request'@.
    --
    -- If you want to add additional headers (e.g., a
    -- [Trace ID for AWS X-Ray](https://docs.aws.amazon.com/xray/latest/devguide/xray-concepts.html#xray-concepts-tracingheader)),
    -- do it with this hook.
    configuredRequest :: forall a. (AWSRequest a, Typeable a) => Hook (Request a),
    -- | Called at the start of waiter processing, just after the
    -- request is configured.
    wait :: forall a. (AWSRequest a, Typeable a) => Hook (Wait a),
    -- | Called just after a request is signed, containing signature
    -- metadata and a
    -- @Network.HTTP.Client.'Network.HTTP.Client.Request'@.
    signedRequest :: forall a. (AWSRequest a, Typeable a) => Hook_ (Signed a),
    -- | Called on a
    -- @Network.HTTP.Client.'Network.HTTP.Client.Request'@, just
    -- before it is sent. While you can retrieve a 'ClientRequest'
    -- from the 'signedRequest' hook, this hook captures unsigned
    -- requests too.
    --
    -- Changing the contents of a signed request is highly likely to
    -- break its signature.
    clientRequest :: Hook ClientRequest,
    -- | Called on the raw
    -- @Network.HTTP.Client.'Network.HTTP.Client.Response'@, as soon
    -- as it comes back from the HTTP client. The body is replaced
    -- with @()@ to prevent its accidental consumption by hooks.
    clientResponse ::
      forall a.
      (AWSRequest a, Typeable a) =>
      Hook_ (Request a, ClientResponse ()),
    -- | Called on the raw response body, after it has been sunk from
    -- the @Network.HTTP.Client.'Network.HTTP.Client.Response'@.
    rawResponseBody :: Hook ByteStringLazy,
    -- | Called when Amazonka decides to retry a failed request. The
    -- 'Text' argument is an error code like @"http_error"@,
    -- @"request_throttled_exception"@. Check the retry check
    -- function for your particular 'Service', usually found somewhere
    -- like @Amazonka.S3.Types.defaultService@.
    requestRetry ::
      forall a.
      (AWSRequest a, Typeable a) =>
      Hook_ (Request a, Text, Retry.RetryStatus),
    -- | Called when Amazonka decides to retry a request while
    -- resolving an 'Amazonka.await' operation.
    awaitRetry ::
      forall a.
      (AWSRequest a, Typeable a) =>
      Hook_ (Request a, Wait a, Accept, Retry.RetryStatus),
    -- | Called when a response from AWS is successfully
    -- deserialised. Because the 'AWSResponse' type family is not
    -- injective, we include the original request.
    response ::
      forall a.
      (AWSRequest a, Typeable a) =>
      Hook_ (Request a, ClientResponse (AWSResponse a)),
    -- | Called whenever an AWS request returns an 'Error', even when
    -- the corresponding request is retried.
    --
    -- On the final error after all retries, this hook will be called
    -- twice: once with @NotFinal@ and once with @Final@. This
    -- behavior may change in a future version.
    error ::
      forall a.
      (AWSRequest a, Typeable a) =>
      Hook_ (Finality, Request a, Error)
  }

{-# INLINE requestHook #-}
requestHook ::
  (forall a. (AWSRequest a, Typeable a) => Hook a -> Hook a) ->
  Hooks ->
  Hooks
requestHook f hooks@Hooks {request} =
  hooks {request = f request}

{-# INLINE waitHook #-}
waitHook ::
  (forall a. (AWSRequest a, Typeable a) => Hook (Wait a) -> Hook (Wait a)) ->
  Hooks ->
  Hooks
waitHook f hooks@Hooks {wait} =
  hooks {wait = f wait}

{-# INLINE configuredRequestHook #-}
configuredRequestHook ::
  ( forall a.
    (AWSRequest a, Typeable a) =>
    Hook (Request a) ->
    Hook (Request a)
  ) ->
  Hooks ->
  Hooks
configuredRequestHook f hooks@Hooks {configuredRequest} =
  hooks {configuredRequest = f configuredRequest}

{-# INLINE signedRequestHook #-}
signedRequestHook ::
  ( forall a.
    (AWSRequest a, Typeable a) =>
    Hook_ (Signed a) ->
    Hook_ (Signed a)
  ) ->
  Hooks ->
  Hooks
signedRequestHook f hooks@Hooks {signedRequest} =
  hooks {signedRequest = f signedRequest}

{-# INLINE clientRequestHook #-}
clientRequestHook ::
  (Hook ClientRequest -> Hook ClientRequest) ->
  Hooks ->
  Hooks
clientRequestHook f hooks@Hooks {clientRequest} =
  hooks {clientRequest = f clientRequest}

{-# INLINE clientResponseHook #-}
clientResponseHook ::
  ( forall a.
    (AWSRequest a, Typeable a) =>
    Hook_ (Request a, ClientResponse ()) ->
    Hook_ (Request a, ClientResponse ())
  ) ->
  Hooks ->
  Hooks
clientResponseHook f hooks@Hooks {clientResponse} =
  hooks {clientResponse = f clientResponse}

{-# INLINE rawResponseBodyHook #-}
rawResponseBodyHook ::
  (Hook ByteStringLazy -> Hook ByteStringLazy) ->
  Hooks ->
  Hooks
rawResponseBodyHook f hooks@Hooks {rawResponseBody} =
  hooks {rawResponseBody = f rawResponseBody}

{-# INLINE requestRetryHook #-}
requestRetryHook ::
  ( forall a.
    (AWSRequest a, Typeable a) =>
    Hook_ (Request a, Text, Retry.RetryStatus) ->
    Hook_ (Request a, Text, Retry.RetryStatus)
  ) ->
  Hooks ->
  Hooks
requestRetryHook f hooks@Hooks {requestRetry} =
  hooks {requestRetry = f requestRetry}

{-# INLINE awaitRetryHook #-}
awaitRetryHook ::
  ( forall a.
    (AWSRequest a, Typeable a) =>
    Hook_ (Request a, Wait a, Accept, Retry.RetryStatus) ->
    Hook_ (Request a, Wait a, Accept, Retry.RetryStatus)
  ) ->
  Hooks ->
  Hooks
awaitRetryHook f hooks@Hooks {awaitRetry} =
  hooks {awaitRetry = f awaitRetry}

{-# INLINE responseHook #-}
responseHook ::
  ( forall a.
    (AWSRequest a, Typeable a) =>
    Hook_ (Request a, ClientResponse (AWSResponse a)) ->
    Hook_ (Request a, ClientResponse (AWSResponse a))
  ) ->
  Hooks ->
  Hooks
responseHook f hooks@Hooks {response} =
  hooks {response = f response}

{-# INLINE errorHook #-}
errorHook ::
  ( forall a.
    (AWSRequest a, Typeable a) =>
    Hook_ (Finality, Request a, Error) ->
    Hook_ (Finality, Request a, Error)
  ) ->
  Hooks ->
  Hooks
errorHook f hooks@Hooks {error} =
  hooks {error = f error}

-- | Turn a @'Hook' a@ into another @'Hook' a@ that does nothing.
--
-- -- Example: remove all request hooks:
-- @
-- requestHook noHook :: Hooks -> Hooks
-- @
noHook :: Hook a -> Hook a
noHook _ _ = pure

-- | Turn a @'Hook_' a@ into another @'Hook_' a@ that does nothing.
--
-- @
-- -- Example: Remove all response hooks:
-- responseHook noHook_ :: Hooks -> Hooks
-- @
noHook_ :: Hook_ a -> Hook_ a
noHook_ _ _ _ = pure ()

-- | Unconditionally add a @'Hook' a@ to the chain of hooks. If you
-- need to do something with specific request types, you want
-- 'addHookFor', instead.
addHook :: Typeable a => Hook a -> Hook a -> Hook a
addHook newHook oldHook env = oldHook env >=> newHook env

-- | Unconditionally add a @'Hook_' a@ to the chain of hooks. If you
-- need to do something with specific request types, you want
-- 'addHookFor_', instead.
addHook_ :: Typeable a => Hook_ a -> Hook_ a -> Hook_ a
addHook_ newHook oldHook env a = oldHook env a *> newHook env a

-- | Like 'addHook', adds an unconditional hook, but it also captures
-- the @'AWSRequest' a@ constraint. Useful for handling every AWS
-- request type in a generic way.
addAWSRequestHook :: (AWSRequest a, Typeable a) => Hook a -> Hook a -> Hook a
addAWSRequestHook = addHook

-- | 'addAWSRequestHook_' is 'addAWSRequestHook' but for 'Hook_'s.
addAWSRequestHook_ :: (AWSRequest a, Typeable a) => Hook_ a -> Hook_ a -> Hook_ a
addAWSRequestHook_ = addHook_

-- | @addHookFor \@a newHook oldHook@ When @a@ and @b@ are the same
-- type, run the given 'Hook a' after all others, otherwise only run
-- the existing hooks.
--
-- @
-- -- Example: Run @getObjectRequestHook@ on anything that is a @GetObjectRequest@:
-- requestHook (addHookFor @GetObjectRequest getObjectRequestHook) :: Hooks -> Hooks
-- @
addHookFor ::
  forall a b. (Typeable a, Typeable b) => Hook a -> Hook b -> Hook b
addHookFor newHook oldHook env =
  oldHook env >=> case eqT @a @b of
    Just Refl -> newHook env
    Nothing -> pure

-- | When @a@ and @b@ are the same type, run the given 'Hook_ a' after
-- all other hooks have run.
--
-- @
-- -- Example: Run @aSignedRequestHook@ on anything that is a @Signed GetObjectRequest@:
-- requestHook (addHookFor_ @(Signed GetObjectRequest) aSignedRequestHook) :: Hooks -> Hooks
-- @
addHookFor_ ::
  forall a b. (Typeable a, Typeable b) => Hook_ a -> Hook_ b -> Hook_ b
addHookFor_ newHook oldHook env a = do
  oldHook env a
  case eqT @a @b of
    Just Refl -> newHook env a
    Nothing -> pure ()

-- | When @a@ and @b@ are the same type, do not call any more hooks.
--
-- @
-- -- Example: Prevent any request hooks from running against a @PutObjectRequest@:
-- requestHook (removeHooksFor @PutObjectRequest) :: Hooks -> Hooks
-- @
removeHooksFor :: forall a b. (Typeable a, Typeable b) => Hook b -> Hook b
removeHooksFor oldHook env = case eqT @a @b of
  Just Refl -> pure
  Nothing -> oldHook env

-- | When @a@ and @b@ are the same type, do not call any more hooks.
--
-- @
-- -- Example: Prevent any error hooks from running against errors caused by a @PutObjectRequest@:
-- errorHook (removeHooksFor @(Finality, Request PutObjectRequest, Error)) :: Hooks -> Hooks
-- @
removeHooksFor_ :: forall a b. (Typeable a, Typeable b) => Hook_ b -> Hook_ b
removeHooksFor_ oldHook env a = case eqT @a @b of
  Just Refl -> pure ()
  Nothing -> oldHook env a

-- | Run the wrapped hook unless the given 'Fold' or 'Traversal'
-- matches the error. You will probably want to use this with the
-- error matchers defined by each service binding, allowing you to
-- selectively silence specific errors:
--
-- @
-- -- Assuming `env :: Amazonka.Env` and `putRequest :: DynamoDB.PutRequest`,
-- -- this silences a single type of error for a single call:
-- send (env & #hooks %~ errorHook (silenceError DynamoDB._ConditionalCheckFailedException))
-- @
--
-- @
-- 'silenceError' :: Getter Error e     -> 'Hook_' ('Finality', Request a, Error) -> 'Hook_' ('Finality', Request a, Error)
-- 'silenceError' :: Fold Error e       -> 'Hook_' ('Finality', Request a, Error) -> 'Hook_' ('Finality', Request a, Error)
-- 'silenceError' :: Iso' Error e       -> 'Hook_' ('Finality', Request a, Error) -> 'Hook_' ('Finality', Request a, Error)
-- 'silenceError' :: Lens' Error e      -> 'Hook_' ('Finality', Request a, Error) -> 'Hook_' ('Finality', Request a, Error)
-- 'silenceError' :: Traversal' Error e -> 'Hook_' ('Finality', Request a, Error) -> 'Hook_' ('Finality', Request a, Error)
-- @
silenceError ::
  Getting Any Error e ->
  Hook_ (Finality, Request a, Error) ->
  Hook_ (Finality, Request a, Error)
silenceError g oldHook env t@(_, _, err) =
  if has g err then pure () else oldHook env t

-- | Add default logging hooks. The default 'Env'' from
-- 'Amazonka.Env.newEnv' already has logging hooks installed, so you
-- probably only want this if you are building your own 'Hooks' from
-- scratch.
addLoggingHooks :: Hooks -> Hooks
addLoggingHooks
  hooks@Hooks
    { signedRequest,
      clientRequest,
      clientResponse,
      rawResponseBody,
      requestRetry,
      awaitRetry,
      error
    } =
    hooks
      { signedRequest = \env@Env {logger} s@Signed {signedMeta} -> do
          signedRequest env s
          logTrace logger signedMeta,
        clientRequest = \env@Env {logger} rq -> do
          rq' <- clientRequest env rq
          rq' <$ logDebug logger rq',
        clientResponse = \env@Env {logger} t@(_, rs) -> do
          clientResponse env t
          logDebug logger rs,
        rawResponseBody = \env@Env {logger} body -> do
          body' <- rawResponseBody env body
          body' <$ logTrace logger ("[Raw Response Body] {\n" <> body' <> "\n}"),
        requestRetry = \env@Env {logger} t@(_, name, retryStatus) -> do
          requestRetry env t
          logDebug logger . munwords $
            [ "[Retry " <> build name <> "]",
              "after",
              build (Retry.rsIterNumber retryStatus + 1),
              "attempt(s)."
            ],
        awaitRetry = \env@Env {logger} t@(_, Wait {name}, accept, retryStatus) -> do
          awaitRetry env t
          logDebug logger . munwords $
            [ "[Await " <> build name <> "]",
              build accept,
              "after",
              build (Retry.rsIterNumber retryStatus + 1),
              "attempts."
            ],
        error = \env@Env {logger} t@(finality, _, err) -> do
          error env t
          case finality of
            NotFinal -> logDebug logger err
            Final -> logError logger err
      }
    where
      munwords = mconcat . intersperse " "

-- | Empty 'Hooks' structure which returns everything unmodified.
noHooks :: Hooks
noHooks =
  Hooks
    { request = const pure,
      configuredRequest = const pure,
      wait = const pure,
      signedRequest = \_ _ -> pure (),
      clientRequest = const pure,
      clientResponse = \_ _ -> pure (),
      rawResponseBody = const pure,
      requestRetry = \_ _ -> pure (),
      awaitRetry = \_ _ -> pure (),
      response = \_ _ -> pure (),
      error = \_ _ -> pure ()
    }