{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Bot operation retrying mechanics
module MatrixBot.Bot.Retry
  ( retryOnClientError
  ) where

import Data.Function (fix)
import Data.Text (pack)
import Numeric.Natural (Natural)
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO)
import qualified Control.Exception.Safe as E
import qualified Control.Lens as L
import qualified Control.Monad.Logger as ML
import qualified Control.Monad.Reader as MR
import qualified UnliftIO.Concurrent as Async
import qualified Network.HTTP.Types.Status as Http
import qualified Servant.Client.Core as Servant
import qualified MatrixBot.Log as L
import qualified MatrixBot.SharedTypes as T


-- | Catch "Servant.ClientError" exception (which is probably some connectivity issue) and retry
--
-- It fails immediately if "Servant.ClientError" is an authorization failure.
-- Also fails immediately if it’s any other exception but "Servant.ClientError".
retryOnClientError
  ∷ (E.MonadMask m, ML.MonadLogger m, MonadIO m, MR.MonadReader r m, T.HasRetryParams r)
  ⇒ m a
  → m a
retryOnClientError :: forall (m :: * -> *) r a.
(MonadMask m, MonadLogger m, MonadIO m, MonadReader r m,
 HasRetryParams r) =>
m a -> m a
retryOnClientError m a
m = do
  Integer
retriesLimit ← (r -> Integer) -> m Integer
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
MR.asks ((r -> Integer) -> m Integer) -> (r -> Integer) -> m Integer
forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural @Integer (Natural -> Integer) -> (r -> Natural) -> r -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RetryLimit -> Natural
T.unRetryLimit (RetryLimit -> Natural) -> (r -> RetryLimit) -> r -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting RetryLimit r RetryLimit -> r -> RetryLimit
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
L.view Getting RetryLimit r RetryLimit
forall r. HasRetryParams r => Lens' r RetryLimit
Lens' r RetryLimit
T.retryLimit
  RetryDelay
retryDelay ← (r -> RetryDelay) -> m RetryDelay
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
MR.asks ((r -> RetryDelay) -> m RetryDelay)
-> (r -> RetryDelay) -> m RetryDelay
forall a b. (a -> b) -> a -> b
$ Getting RetryDelay r RetryDelay -> r -> RetryDelay
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
L.view Getting RetryDelay r RetryDelay
forall r. HasRetryParams r => Lens' r RetryDelay
Lens' r RetryDelay
T.retryDelay
  let delay :: m ()
delay = Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
Async.threadDelay (Int -> m ()) -> (RetryDelay -> Int) -> RetryDelay -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> (RetryDelay -> Integer) -> RetryDelay -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Microseconds -> Integer
T.unMicroseconds (Microseconds -> Integer)
-> (RetryDelay -> Microseconds) -> RetryDelay -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RetryDelay -> Microseconds
T.unRetryDelay (RetryDelay -> m ()) -> RetryDelay -> m ()
forall a b. (a -> b) -> a -> b
$ RetryDelay
retryDelay

  ((Integer -> m a) -> Integer -> m a
forall a b. (a -> b) -> a -> b
$ Integer
retriesLimit) ((Integer -> m a) -> m a)
-> (((Integer -> m a) -> Integer -> m a) -> Integer -> m a)
-> ((Integer -> m a) -> Integer -> m a)
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Integer -> m a) -> Integer -> m a) -> Integer -> m a
forall a. (a -> a) -> a
fix (((Integer -> m a) -> Integer -> m a) -> m a)
-> ((Integer -> m a) -> Integer -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Integer -> m a
retry (Integer -> Integer
forall a. Enum a => a -> a
pred → Integer
retryN) →
    m a
m m a -> (ClientError -> m a) -> m a
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` \(ClientError
e ∷ Servant.ClientError) → do
      Text -> m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
L.logError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Caught exception: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text) -> (ClientError -> String) -> ClientError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientError -> String
forall e. Exception e => e -> String
E.displayException) ClientError
e

      case ClientError
e of
        Servant.FailureResponse RequestF () (BaseUrl, ByteString)
_req (Response -> Status
forall a. ResponseF a -> Status
Servant.responseStatusCode → Status -> Int
Http.statusCode → Int
401) → do
          Text -> m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
L.logError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            Text
"It seems that Matrix authorization for the bot is no longer valid, "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"rethrowing exception immediately without any retries…"

          ClientError -> m ()
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
E.throwM ClientError
e

        ClientError
_ → () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
retryN Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
L.logError Text
"Retry attempts limit is hit, rethrowing exception…"
        ClientError -> m ()
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
E.throwM ClientError
e

      Text -> m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
L.logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"Retry attempt: "
        , String -> Text
pack (String -> Text) -> (Integer -> String) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show (Integer -> Text) -> Integer -> Text
forall a b. (a -> b) -> a -> b
$ Integer
retriesLimit Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
retryN
        , Text
" of maximum "
        , String -> Text
pack (String -> Text) -> (Integer -> String) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show (Integer -> Text) -> Integer -> Text
forall a b. (a -> b) -> a -> b
$ Integer
retriesLimit
        ]

      Text -> m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
L.logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Retrying after " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RetryDelay -> Text
forall s. IsString s => RetryDelay -> s
T.printRetryDelaySeconds RetryDelay
retryDelay Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"…"
      m ()
delay

      Text -> m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
L.logDebug Text
"Waiting is done, retrying now…"
      Integer -> m a
retry Integer
retryN