{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
Module      : Instana.SDK.Internal.Retry
Description : Handles retrying IO actions that might fail (mostly HTTP requests)
-}
module Instana.SDK.Internal.Retry
    ( acceptDataRetryPolicy
    , agentHostLookupRetryPolicy
    , announceRetryPolicy
    , retryRequest
    , retryUntil
    , retryUntilRight
    ) where

import           Control.Monad.Catch  (Handler)
import qualified Control.Retry        as Retry
import           Data.ByteString.Lazy (ByteString)
import qualified Network.HTTP.Client  as HTTP


{-| A fibonacci retry delay pattern starting with a 1 second delay going up
to 1 minute delay. This retry policy never gives up.
-}
agentHostLookupRetryPolicy :: Retry.RetryPolicyM IO
agentHostLookupRetryPolicy :: RetryPolicyM IO
agentHostLookupRetryPolicy =
  Int -> RetryPolicyM IO -> RetryPolicyM IO
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
Retry.capDelay Int
maxDelay (RetryPolicyM IO -> RetryPolicyM IO)
-> RetryPolicyM IO -> RetryPolicyM IO
forall a b. (a -> b) -> a -> b
$
    Int -> RetryPolicy
Retry.fibonacciBackoff Int
minDelay
  where
    -- 1 second
    minDelay :: Int
minDelay = 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000
    -- 60 seconds
    maxDelay :: Int
maxDelay = 60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000


{-| A constant delay pattern with a 200 ms second delay. This retry policy
gives up after 3 attempts.
-}
announceRetryPolicy :: Retry.RetryPolicyM IO
announceRetryPolicy :: RetryPolicyM IO
announceRetryPolicy =
  (Int -> RetryPolicy
Retry.constantDelay Int
delay) RetryPolicyM IO -> RetryPolicyM IO -> RetryPolicyM IO
forall a. Semigroup a => a -> a -> a
<> (Int -> RetryPolicy
Retry.limitRetries Int
retries)
  where
    delay :: Int
delay = 200 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000
    retries :: Int
retries = 3


{-| A constant delay pattern with a 10 second delay. This retry policy
gives up after 10 attempts.
-}
acceptDataRetryPolicy :: Retry.RetryPolicyM IO
acceptDataRetryPolicy :: RetryPolicyM IO
acceptDataRetryPolicy =
  (Int -> RetryPolicy
Retry.constantDelay Int
delay) RetryPolicyM IO -> RetryPolicyM IO -> RetryPolicyM IO
forall a. Semigroup a => a -> a -> a
<> (Int -> RetryPolicy
Retry.limitRetries Int
retries)
  where
    delay :: Int
delay = 10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000
    retries :: Int
retries = 10


{-| Retries a given HTTP request according to the given retry policy,
until either the request succeeds or the retry policy mandates to stop retrying.
-}
retryRequest ::
  Retry.RetryPolicyM IO
  -> (HTTP.Response ByteString -> IO a)
  -> IO (HTTP.Response ByteString)
  -> IO a
retryRequest :: RetryPolicyM IO
-> (Response ByteString -> IO a)
-> IO (Response ByteString)
-> IO a
retryRequest retryPolicy :: RetryPolicyM IO
retryPolicy decoder :: Response ByteString -> IO a
decoder request :: IO (Response ByteString)
request =
  let
    reportHttpError :: Bool -> HTTP.HttpException -> Retry.RetryStatus -> IO ()
    reportHttpError :: Bool -> HttpException -> RetryStatus -> IO ()
reportHttpError _ _ _ {- retriedOrCrashed err retryStatus -}  =
      () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       -- For a detailed error message, we could use Retry.defaultLogMsg, like
       -- this:
       -- traceM instanaLogger $
       --   Retry.defaultLogMsg retriedOrCrashed err retryStatus
       -- But we generally do not want this level of verbosity here in retry,
       -- instead, we are perfectly fine with swallowing the excetption
       -- completely.
    retryOnAnyHttpError :: HTTP.HttpException -> IO Bool
    retryOnAnyHttpError :: HttpException -> IO Bool
retryOnAnyHttpError _ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    retryOnAnyStatus :: Retry.RetryStatus -> Handler IO Bool
    retryOnAnyStatus :: RetryStatus -> Handler IO Bool
retryOnAnyStatus = (HttpException -> IO Bool)
-> (Bool -> HttpException -> RetryStatus -> IO ())
-> RetryStatus
-> Handler IO Bool
forall (m :: * -> *) e.
(Monad m, Exception e) =>
(e -> m Bool)
-> (Bool -> e -> RetryStatus -> m ())
-> RetryStatus
-> Handler m Bool
Retry.logRetries HttpException -> IO Bool
retryOnAnyHttpError Bool -> HttpException -> RetryStatus -> IO ()
reportHttpError

    executeRequestAndParseResponse :: IO a
executeRequestAndParseResponse = do
      Response ByteString
response <- IO (Response ByteString)
request
      a
decoded <- Response ByteString -> IO a
decoder Response ByteString
response
      a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
decoded

  in
    RetryPolicyM IO
-> [RetryStatus -> Handler IO Bool]
-> (RetryStatus -> IO a)
-> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> m a
Retry.recovering
       RetryPolicyM IO
retryPolicy
       [RetryStatus -> Handler IO Bool
retryOnAnyStatus]
       (IO a -> RetryStatus -> IO a
forall a b. a -> b -> a
const IO a
executeRequestAndParseResponse)


{-| Retries a given action according to the given retry policy, until it either
yields a result matching Right _ or until the retry policy mandates to stop
retrying, which ever happens first.
-}
retryUntilRight ::
  forall a.
  Show a =>
  Retry.RetryPolicyM IO
  -> IO (Either String a)
  -> IO (Either String a)
retryUntilRight :: RetryPolicyM IO -> IO (Either String a) -> IO (Either String a)
retryUntilRight retryPolicy :: RetryPolicyM IO
retryPolicy action :: IO (Either String a)
action =
  RetryPolicyM IO
-> (a -> Bool) -> IO (Either String a) -> IO (Either String a)
forall a.
Show a =>
RetryPolicyM IO
-> (a -> Bool) -> IO (Either String a) -> IO (Either String a)
retryUntil RetryPolicyM IO
retryPolicy (\_ -> Bool
True) IO (Either String a)
action


{-| Retries a given action according to the given retry policy, until either the
given retry check function returns True or the retry policy mandates to stop
retrying.
-}
retryUntil ::
  forall a.
  Show a =>
  Retry.RetryPolicyM IO
  -> (a -> Bool)
  -> IO (Either String a)
  -> IO (Either String a)
retryUntil :: RetryPolicyM IO
-> (a -> Bool) -> IO (Either String a) -> IO (Either String a)
retryUntil retryPolicy :: RetryPolicyM IO
retryPolicy retryCheck :: a -> Bool
retryCheck action :: IO (Either String a)
action = do
  let
    check :: Retry.RetryStatus -> Either String a -> IO Bool
    check :: RetryStatus -> Either String a -> IO Bool
check _ result :: Either String a
result = do
      case Either String a
result of
        Left _ ->
          Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Right value :: a
value ->
          Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ a -> Bool
retryCheck a
value
  Either String a
lastResult <- RetryPolicyM IO
-> (RetryStatus -> Either String a -> IO Bool)
-> (RetryStatus -> IO (Either String a))
-> IO (Either String a)
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
Retry.retrying
     RetryPolicyM IO
retryPolicy
     RetryStatus -> Either String a -> IO Bool
check
     (IO (Either String a) -> RetryStatus -> IO (Either String a)
forall a b. a -> b -> a
const IO (Either String a)
action)
  case Either String a
lastResult of
    Left _ ->
      Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return Either String a
lastResult
    Right lastValue :: a
lastValue ->
      if a -> Bool
retryCheck a
lastValue
      then
        Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return Either String a
lastResult
      else
        Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> IO (Either String a))
-> Either String a -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$
          String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$
            "The retried action has not yielded the expected result " String -> String -> String
forall a. [a] -> [a] -> [a]
++
            "but: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
lastValue