module Hercules.Error where

import qualified Control.Exception.Lifted
import qualified Control.Exception.Safe
import Control.Monad (when)
import Control.Monad.Catch
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Control (MonadBaseControl)
import GHC.Conc (threadDelay)
import Hercules.API.Prelude
import Katip

escalate :: (Exception exc, MonadThrow m) => Either exc a -> m a
escalate :: forall exc (m :: * -> *) a.
(Exception exc, MonadThrow m) =>
Either exc a -> m a
escalate = forall exc (m :: * -> *) l a.
(Exception exc, MonadThrow m) =>
(l -> exc) -> Either l a -> m a
escalateAs forall a. a -> a
id

escalateAs :: (Exception exc, MonadThrow m) => (l -> exc) -> Either l a -> m a
escalateAs :: forall exc (m :: * -> *) l a.
(Exception exc, MonadThrow m) =>
(l -> exc) -> Either l a -> m a
escalateAs l -> exc
f = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall b c a. (b -> c) -> (a -> b) -> a -> c
. l -> exc
f) forall (f :: * -> *) a. Applicative f => a -> f a
pure

safeLiftedCatch :: MonadBaseControl IO m => m a -> (SomeException -> m a) -> m a
safeLiftedCatch :: forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (SomeException -> m a) -> m a
safeLiftedCatch m a
m SomeException -> m a
h =
  forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
Control.Exception.Lifted.catch m a
m forall a b. (a -> b) -> a -> b
$
    \SomeException
e ->
      if forall e. Exception e => e -> Bool
Control.Exception.Safe.isSyncException (SomeException
e :: SomeException)
        then SomeException -> m a
h SomeException
e
        else forall a e. Exception e => e -> a
Control.Exception.Lifted.throw SomeException
e

safeLiftedHandle ::
  MonadBaseControl IO m =>
  (SomeException -> m a) ->
  m a ->
  m a
safeLiftedHandle :: forall (m :: * -> *) a.
MonadBaseControl IO m =>
(SomeException -> m a) -> m a -> m a
safeLiftedHandle = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (SomeException -> m a) -> m a
safeLiftedCatch

exponential :: (Enum a, Floating a) => [a]
exponential :: forall a. (Enum a, Floating a) => [a]
exponential = forall a b. (a -> b) -> [a] -> [b]
map forall a. Floating a => a -> a
exp [a
1, a
2 ..]

cap :: Ord a => a -> [a] -> [a]
cap :: forall a. Ord a => a -> [a] -> [a]
cap a
v = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Ord a => a -> a -> a
min a
v)

retry ::
  (KatipContext m, MonadBaseControl IO m) =>
  -- | Seconds
  [Double] ->
  m a ->
  m a
retry :: forall (m :: * -> *) a.
(KatipContext m, MonadBaseControl IO m) =>
[Double] -> m a -> m a
retry [Double]
delaysSeconds m a
io = forall {a}. RealFrac a => [a] -> m a
loop [Double]
delaysSeconds
  where
    loop :: [a] -> m a
loop [] = m a
io
    loop (a
delay : [a]
delays) = forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (SomeException -> m a) -> m a
safeLiftedCatch m a
io forall a b. (a -> b) -> a -> b
$ \SomeException
e -> do
      forall (m :: * -> *).
(Applicative m, KatipContext m, HasCallStack) =>
Severity -> LogStr -> m ()
logLocM Severity
WarningS forall a b. (a -> b) -> a -> b
$ LogStr
"Retrying on exception: " forall a. Semigroup a => a -> a -> a
<> forall a. StringConv a Text => a -> LogStr
logStr (forall a. Show a => a -> String
show SomeException
e)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
delay forall a. Ord a => a -> a -> Bool
>= a
0.000001) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
          Int -> IO ()
threadDelay
            (forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ a
delay forall a. Num a => a -> a -> a
* a
1000 forall a. Num a => a -> a -> a
* a
1000)
      [a] -> m a
loop [a]
delays

-- | ~5 minute exponential backoff
defaultRetry :: (KatipContext m, MonadBaseControl IO m) => m a -> m a
defaultRetry :: forall (m :: * -> *) a.
(KatipContext m, MonadBaseControl IO m) =>
m a -> m a
defaultRetry = forall (m :: * -> *) a.
(KatipContext m, MonadBaseControl IO m) =>
[Double] -> m a -> m a
retry (forall a. Int -> [a] -> [a]
take Int
10 forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> [a] -> [a]
cap Double
60 forall a. (Enum a, Floating a) => [a]
exponential)

-- | ~1 minute exponential backoff
quickRetry :: (KatipContext m, MonadBaseControl IO m) => m a -> m a
quickRetry :: forall (m :: * -> *) a.
(KatipContext m, MonadBaseControl IO m) =>
m a -> m a
quickRetry = forall (m :: * -> *) a.
(KatipContext m, MonadBaseControl IO m) =>
[Double] -> m a -> m a
retry (forall a. Int -> [a] -> [a]
take Int
4 forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> [a] -> [a]
cap Double
60 forall a. (Enum a, Floating a) => [a]
exponential)