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 = (exc -> exc) -> Either exc a -> m a
forall exc (m :: * -> *) l a.
(Exception exc, MonadThrow m) =>
(l -> exc) -> Either l a -> m a
escalateAs exc -> exc
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 = (l -> m a) -> (a -> m a) -> Either l a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (exc -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (exc -> m a) -> (l -> exc) -> l -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l -> exc
f) a -> m a
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 =
  m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
Control.Exception.Lifted.catch m a
m ((SomeException -> m a) -> m a) -> (SomeException -> m a) -> m a
forall a b. (a -> b) -> a -> b
$
    \SomeException
e ->
      if SomeException -> Bool
forall e. Exception e => e -> Bool
Control.Exception.Safe.isSyncException (SomeException
e :: SomeException)
        then SomeException -> m a
h SomeException
e
        else SomeException -> m a
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 = (m a -> (SomeException -> m a) -> m a)
-> (SomeException -> m a) -> m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip m a -> (SomeException -> m a) -> m a
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 = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map a -> a
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 = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> a -> a
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 = [Double] -> m a
forall {a}. RealFrac a => [a] -> m a
loop [Double]
delaysSeconds
  where
    loop :: [a] -> m a
loop [] = m a
io
    loop (a
delay : [a]
delays) = m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (SomeException -> m a) -> m a
safeLiftedCatch m a
io ((SomeException -> m a) -> m a) -> (SomeException -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \SomeException
e -> do
      Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m, HasCallStack) =>
Severity -> LogStr -> m ()
logLocM Severity
WarningS (LogStr -> m ()) -> LogStr -> m ()
forall a b. (a -> b) -> a -> b
$ LogStr
"Retrying on exception: " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
delay a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0.000001) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
          Int -> IO ()
threadDelay
            (a -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (a -> Int) -> a -> Int
forall a b. (a -> b) -> a -> b
$ a
delay a -> a -> a
forall a. Num a => a -> a -> a
* a
1000 a -> a -> a
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 = [Double] -> m a -> m a
forall (m :: * -> *) a.
(KatipContext m, MonadBaseControl IO m) =>
[Double] -> m a -> m a
retry (Int -> [Double] -> [Double]
forall a. Int -> [a] -> [a]
take Int
10 ([Double] -> [Double]) -> [Double] -> [Double]
forall a b. (a -> b) -> a -> b
$ Double -> [Double] -> [Double]
forall a. Ord a => a -> [a] -> [a]
cap Double
60 [Double]
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 = [Double] -> m a -> m a
forall (m :: * -> *) a.
(KatipContext m, MonadBaseControl IO m) =>
[Double] -> m a -> m a
retry (Int -> [Double] -> [Double]
forall a. Int -> [a] -> [a]
take Int
4 ([Double] -> [Double]) -> [Double] -> [Double]
forall a b. (a -> b) -> a -> b
$ Double -> [Double] -> [Double]
forall a. Ord a => a -> [a] -> [a]
cap Double
60 [Double]
forall a. (Enum a, Floating a) => [a]
exponential)