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 :: 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 :: (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 :: 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 :: (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 :: [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 :: 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) =>
[Double] ->
m a ->
m a
retry :: [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
defaultRetry :: (KatipContext m, MonadBaseControl IO m) => m a -> m a
defaultRetry :: 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)
quickRetry :: (KatipContext m, MonadBaseControl IO m) => m a -> m a
quickRetry :: 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)