{-# 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 =
Retry.capDelay maxDelay $
Retry.fibonacciBackoff minDelay
where
-- 1 second
minDelay = 1 * 1000 * 1000
-- 60 seconds
maxDelay = 60 * 1000 * 1000
{-| A constant delay pattern with a 200 ms second delay. This retry policy
gives up after 3 attempts.
-}
announceRetryPolicy :: Retry.RetryPolicyM IO
announceRetryPolicy =
(Retry.constantDelay delay) <> (Retry.limitRetries retries)
where
delay = 200 * 1000
retries = 3
{-| A constant delay pattern with a 10 second delay. This retry policy
gives up after 10 attempts.
-}
acceptDataRetryPolicy :: Retry.RetryPolicyM IO
acceptDataRetryPolicy =
(Retry.constantDelay delay) <> (Retry.limitRetries retries)
where
delay = 10 * 1000 * 1000
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 retryPolicy decoder request =
let
reportHttpError :: Bool -> HTTP.HttpException -> Retry.RetryStatus -> IO ()
reportHttpError _ _ _ {- retriedOrCrashed err retryStatus -} =
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 _ = return True
retryOnAnyStatus :: Retry.RetryStatus -> Handler IO Bool
retryOnAnyStatus = Retry.logRetries retryOnAnyHttpError reportHttpError
executeRequestAndParseResponse = do
response <- request
decoded <- decoder response
return decoded
in
Retry.recovering
retryPolicy
[retryOnAnyStatus]
(const 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 retryPolicy action =
retryUntil retryPolicy (\_ -> True) 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 retryPolicy retryCheck action = do
let
check :: Retry.RetryStatus -> Either String a -> IO Bool
check _ result = do
case result of
Left _ ->
return True
Right value ->
return $ not $ retryCheck value
lastResult <- Retry.retrying
retryPolicy
check
(const action)
case lastResult of
Left _ ->
return lastResult
Right lastValue ->
if retryCheck lastValue
then
return lastResult
else
return $
Left $
"The retried action has not yielded the expected result " ++
"but: " ++ show lastValue