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 = escalateAs id
escalateAs :: (Exception exc, MonadThrow m) => (l -> exc) -> Either l a -> m a
escalateAs f = either (throwM . f) pure
safeLiftedCatch :: MonadBaseControl IO m => m a -> (SomeException -> m a) -> m a
safeLiftedCatch m h =
Control.Exception.Lifted.catch m $
\e ->
if Control.Exception.Safe.isSyncException (e :: SomeException)
then h e
else Control.Exception.Lifted.throw e
safeLiftedHandle ::
MonadBaseControl IO m =>
(SomeException -> m a) ->
m a ->
m a
safeLiftedHandle = flip safeLiftedCatch
exponential :: (Enum a, Floating a) => [a]
exponential = map exp [1, 2 ..]
cap :: Ord a => a -> [a] -> [a]
cap v = map (min v)
retry ::
(KatipContext m, MonadBaseControl IO m) =>
-- | Seconds
[Double] ->
m a ->
m a
retry delaysSeconds io = loop delaysSeconds
where
loop [] = io
loop (delay : delays) = safeLiftedCatch io $ \e -> do
logLocM WarningS $ "Retrying on exception: " <> logStr (show e)
when (delay >= 0.000001) $
liftIO $
threadDelay
(floor $ delay * 1000 * 1000)
loop delays
-- | ~5 minute exponential backoff
defaultRetry :: (KatipContext m, MonadBaseControl IO m) => m a -> m a
defaultRetry = retry (take 10 $ cap 60 exponential)
-- | ~1 minute exponential backoff
quickRetry :: (KatipContext m, MonadBaseControl IO m) => m a -> m a
quickRetry = retry (take 4 $ cap 60 exponential)