-- | Module containing ratelimit stuff
module Calamity.HTTP.Internal.Ratelimit
    ( newRateLimitState
    , doRequest ) where

import           Calamity.Client.Types        ( BotC )
import           Calamity.HTTP.Internal.Route
import           Calamity.HTTP.Internal.Types
import           Calamity.Internal.Utils

import           Control.Concurrent
import           Control.Concurrent.Event     ( Event )
import qualified Control.Concurrent.Event     as E
import           Control.Concurrent.STM
import           Control.Concurrent.STM.Lock  ( Lock )
import qualified Control.Concurrent.STM.Lock  as L
import           Control.Lens
import           Control.Monad

import           Data.Aeson
import           Data.Aeson.Lens
import           Data.ByteString              ( ByteString )
import qualified Data.ByteString.Lazy         as LB
import           Data.Functor
import           Data.Maybe
import qualified Data.Text.Lazy               as LT
import           Data.Time
import           Data.Time.Clock.POSIX

import           Fmt

import           Focus

import           Network.HTTP.Date
import           Network.HTTP.Types           hiding ( statusCode )
import           Network.Wreq

import qualified Polysemy                     as P
import           Polysemy                     ( Sem )
import qualified Polysemy.Async               as P

import           Prelude                      hiding ( error )

import qualified StmContainers.Map            as SC
import qualified Control.Exception.Safe as Ex

newRateLimitState :: IO RateLimitState
newRateLimitState :: IO RateLimitState
newRateLimitState = Map Route Lock -> Event -> RateLimitState
RateLimitState (Map Route Lock -> Event -> RateLimitState)
-> IO (Map Route Lock) -> IO (Event -> RateLimitState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map Route Lock)
forall key value. IO (Map key value)
SC.newIO IO (Event -> RateLimitState) -> IO Event -> IO RateLimitState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Event
E.newSet

lookupOrInsertDefaultM :: Monad m => m a -> Focus a m a
lookupOrInsertDefaultM :: m a -> Focus a m a
lookupOrInsertDefaultM aM :: m a
aM = m (a, Change a) -> (a -> m (a, Change a)) -> Focus a m a
forall (m :: * -> *) b a.
Monad m =>
m (b, Change a) -> (a -> m (b, Change a)) -> Focus a m b
casesM
  (do a
a <- m a
aM
      (a, Change a) -> m (a, Change a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, a -> Change a
forall a. a -> Change a
Set a
a))
  (\a :: a
a -> (a, Change a) -> m (a, Change a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, Change a
forall a. Change a
Leave))

getRateLimit :: RateLimitState -> Route -> STM Lock
getRateLimit :: RateLimitState -> Route -> STM Lock
getRateLimit s :: RateLimitState
s h :: Route
h = Focus Lock STM Lock -> Route -> Map Route Lock -> STM Lock
forall key value result.
(Eq key, Hashable key) =>
Focus value STM result -> key -> Map key value -> STM result
SC.focus (STM Lock -> Focus Lock STM Lock
forall (m :: * -> *) a. Monad m => m a -> Focus a m a
lookupOrInsertDefaultM STM Lock
L.new) Route
h (RateLimitState -> Map Route Lock
rateLimits RateLimitState
s)

doDiscordRequest :: BotC r => IO (Response LB.ByteString) -> Sem r DiscordResponseType
doDiscordRequest :: IO (Response ByteString) -> Sem r DiscordResponseType
doDiscordRequest r :: IO (Response ByteString)
r = do
  Either String (Response ByteString)
r'' <- IO (Either String (Response ByteString))
-> Sem r (Either String (Response ByteString))
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO (Either String (Response ByteString))
 -> Sem r (Either String (Response ByteString)))
-> IO (Either String (Response ByteString))
-> Sem r (Either String (Response ByteString))
forall a b. (a -> b) -> a -> b
$ IO (Either String (Response ByteString))
-> (SomeException -> IO (Either String (Response ByteString)))
-> IO (Either String (Response ByteString))
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
Ex.catchAny (Response ByteString -> Either String (Response ByteString)
forall a b. b -> Either a b
Right (Response ByteString -> Either String (Response ByteString))
-> IO (Response ByteString)
-> IO (Either String (Response ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Response ByteString)
r) (Either String (Response ByteString)
-> IO (Either String (Response ByteString))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (Response ByteString)
 -> IO (Either String (Response ByteString)))
-> (SomeException -> Either String (Response ByteString))
-> SomeException
-> IO (Either String (Response ByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String (Response ByteString)
forall a b. a -> Either a b
Left (String -> Either String (Response ByteString))
-> (SomeException -> String)
-> SomeException
-> Either String (Response ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall e. Exception e => e -> String
Ex.displayException)
  case Either String (Response ByteString)
r'' of
    Right r' :: Response ByteString
r' -> do
      let status :: Status
status = Response ByteString
r' Response ByteString
-> Getting Status (Response ByteString) Status -> Status
forall s a. s -> Getting a s a -> a
^. Getting Status (Response ByteString) Status
forall body. Lens' (Response body) Status
responseStatus
      if
        | Status -> Bool
statusIsSuccessful Status
status -> do
          let resp :: ByteString
resp = Response ByteString
r' Response ByteString
-> Getting ByteString (Response ByteString) ByteString
-> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString (Response ByteString) ByteString
forall body0 body1.
Lens (Response body0) (Response body1) body0 body1
responseBody
          Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "Got good response from discord: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+|| Response ByteString
r' Response ByteString
-> Getting Status (Response ByteString) Status -> Status
forall s a. s -> Getting a s a -> a
^. Getting Status (Response ByteString) Status
forall body. Lens' (Response body) Status
responseStatus Status -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ ""
          DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ if Response ByteString -> Bool
forall a. Response a -> Bool
isExhausted Response ByteString
r'
                then ByteString -> Int -> DiscordResponseType
ExhaustedBucket ByteString
resp (Int -> DiscordResponseType) -> Int -> DiscordResponseType
forall a b. (a -> b) -> a -> b
$ Response ByteString -> Int
forall a. Response a -> Int
parseRateLimitHeader Response ByteString
r'
                else ByteString -> DiscordResponseType
Good ByteString
resp
        | Status
status Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status429 -> do
          Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug "Got 429 from discord, retrying."
          case Response ByteString -> Maybe (Response Value)
forall (m :: * -> *).
MonadThrow m =>
Response ByteString -> m (Response Value)
asValue Response ByteString
r' of
            Just rv :: Response Value
rv -> DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ Int -> Bool -> DiscordResponseType
Ratelimited (Response Value -> Int
parseRetryAfter Response Value
rv) (Response Value -> Bool
isGlobal Response Value
rv)
            Nothing -> DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> DiscordResponseType
ClientError (Status
status Status -> Getting Int Status Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Status Int
Lens' Status Int
statusCode) "429 with invalid json???"
        | Status -> Bool
statusIsClientError Status
status -> do
          let err :: ByteString
err = Response ByteString
r' Response ByteString
-> Getting ByteString (Response ByteString) ByteString
-> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString (Response ByteString) ByteString
forall body0 body1.
Lens (Response body0) (Response body1) body0 body1
responseBody
          Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
error (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "Something went wrong: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+|| ByteString
err ByteString -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ " response: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|| Response ByteString
r' Response ByteString -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ ""
          DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> DiscordResponseType
ClientError (Status
status Status -> Getting Int Status Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Status Int
Lens' Status Int
statusCode) ByteString
err
        | Bool
otherwise -> do
          Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "Got server error from discord: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Status
status Status -> Getting Int Status Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Status Int
Lens' Status Int
statusCode Int -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ""
          DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ Int -> DiscordResponseType
ServerError (Status
status Status -> Getting Int Status Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Status Int
Lens' Status Int
statusCode)
    Left e :: String
e -> do
      Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
error (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "Something went wrong with the http client: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| String -> Text
LT.pack String
e Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ""
      DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> (Text -> DiscordResponseType)
-> Text
-> Sem r DiscordResponseType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DiscordResponseType
InternalResponseError (Text -> Sem r DiscordResponseType)
-> Text -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ String -> Text
LT.pack String
e


parseDiscordTime :: ByteString -> Maybe UTCTime
parseDiscordTime :: ByteString -> Maybe UTCTime
parseDiscordTime s :: ByteString
s = HTTPDate -> UTCTime
httpDateToUTC (HTTPDate -> UTCTime) -> Maybe HTTPDate -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe HTTPDate
parseHTTPDate ByteString
s

computeDiscordTimeDiff :: Double -> UTCTime -> Int
computeDiscordTimeDiff :: Double -> UTCTime -> Int
computeDiscordTimeDiff end :: Double
end now :: UTCTime
now = NominalDiffTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Int)
-> (NominalDiffTime -> NominalDiffTime) -> NominalDiffTime -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* 1000.0) (NominalDiffTime -> Int) -> NominalDiffTime -> Int
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
end' UTCTime
now
  where end' :: UTCTime
end' = Double
end Double -> (Double -> Rational) -> Rational
forall a b. a -> (a -> b) -> b
& Double -> Rational
forall a. Real a => a -> Rational
toRational Rational -> (Rational -> NominalDiffTime) -> NominalDiffTime
forall a b. a -> (a -> b) -> b
& Rational -> NominalDiffTime
forall a. Fractional a => Rational -> a
fromRational NominalDiffTime -> (NominalDiffTime -> UTCTime) -> UTCTime
forall a b. a -> (a -> b) -> b
& NominalDiffTime -> UTCTime
posixSecondsToUTCTime

-- | Parse a ratelimit header returning the number of milliseconds until it resets
parseRateLimitHeader :: Response a -> Int
parseRateLimitHeader :: Response a -> Int
parseRateLimitHeader r :: Response a
r = Double -> UTCTime -> Int
computeDiscordTimeDiff Double
end UTCTime
now
 where
  end :: Double
end = Response a
r Response a -> Getting (Endo Double) (Response a) Double -> Double
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! HeaderName -> Traversal' (Response a) ByteString
forall body. HeaderName -> Traversal' (Response body) ByteString
responseHeader "X-Ratelimit-Reset" ((ByteString -> Const (Endo Double) ByteString)
 -> Response a -> Const (Endo Double) (Response a))
-> ((Double -> Const (Endo Double) Double)
    -> ByteString -> Const (Endo Double) ByteString)
-> Getting (Endo Double) (Response a) Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Const (Endo Double) Double)
-> ByteString -> Const (Endo Double) ByteString
forall t. AsNumber t => Prism' t Double
_Double
  now :: UTCTime
now = Response a
r Response a
-> Getting (Endo ByteString) (Response a) ByteString -> ByteString
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! HeaderName -> Traversal' (Response a) ByteString
forall body. HeaderName -> Traversal' (Response body) ByteString
responseHeader "Date" ByteString -> (ByteString -> Maybe UTCTime) -> Maybe UTCTime
forall a b. a -> (a -> b) -> b
& ByteString -> Maybe UTCTime
parseDiscordTime Maybe UTCTime -> (Maybe UTCTime -> UTCTime) -> UTCTime
forall a b. a -> (a -> b) -> b
& Maybe UTCTime -> UTCTime
forall a. HasCallStack => Maybe a -> a
fromJust

isExhausted :: Response a -> Bool
isExhausted :: Response a -> Bool
isExhausted r :: Response a
r = Response a
r Response a
-> Getting (First ByteString) (Response a) ByteString
-> Maybe ByteString
forall s a. s -> Getting (First a) s a -> Maybe a
^? HeaderName -> Traversal' (Response a) ByteString
forall body. HeaderName -> Traversal' (Response body) ByteString
responseHeader "X-RateLimit-Remaining" Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just "0"

parseRetryAfter :: Response Value -> Int
parseRetryAfter :: Response Value -> Int
parseRetryAfter r :: Response Value
r =
  Response Value
r Response Value -> Getting (Endo Int) (Response Value) Int -> Int
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! (Value -> Const (Endo Int) Value)
-> Response Value -> Const (Endo Int) (Response Value)
forall body0 body1.
Lens (Response body0) (Response body1) body0 body1
responseBody ((Value -> Const (Endo Int) Value)
 -> Response Value -> Const (Endo Int) (Response Value))
-> ((Int -> Const (Endo Int) Int)
    -> Value -> Const (Endo Int) Value)
-> Getting (Endo Int) (Response Value) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key "retry_after" ((Value -> Const (Endo Int) Value)
 -> Value -> Const (Endo Int) Value)
-> ((Int -> Const (Endo Int) Int)
    -> Value -> Const (Endo Int) Value)
-> (Int -> Const (Endo Int) Int)
-> Value
-> Const (Endo Int) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const (Endo Int) Int) -> Value -> Const (Endo Int) Value
forall t a. (AsNumber t, Integral a) => Prism' t a
_Integral

isGlobal :: Response Value -> Bool
isGlobal :: Response Value -> Bool
isGlobal r :: Response Value
r = Response Value
r Response Value
-> Getting (First Bool) (Response Value) Bool -> Maybe Bool
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Value -> Const (First Bool) Value)
-> Response Value -> Const (First Bool) (Response Value)
forall body0 body1.
Lens (Response body0) (Response body1) body0 body1
responseBody ((Value -> Const (First Bool) Value)
 -> Response Value -> Const (First Bool) (Response Value))
-> ((Bool -> Const (First Bool) Bool)
    -> Value -> Const (First Bool) Value)
-> Getting (First Bool) (Response Value) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key "global" ((Value -> Const (First Bool) Value)
 -> Value -> Const (First Bool) Value)
-> ((Bool -> Const (First Bool) Bool)
    -> Value -> Const (First Bool) Value)
-> (Bool -> Const (First Bool) Bool)
-> Value
-> Const (First Bool) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Const (First Bool) Bool)
-> Value -> Const (First Bool) Value
forall t. AsPrimitive t => Prism' t Bool
_Bool Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True


-- Either (Either a a) b
data ShouldRetry a b
  = Retry a
  | RFail a
  | RGood b

retryRequest
  :: BotC r
  => Int -- ^ number of retries
  -> Sem r (ShouldRetry a b) -- ^ action to perform
  -> Sem r ()  -- ^ action to run if max number of retries was reached
  -> Sem r (Either a b)
retryRequest :: Int -> Sem r (ShouldRetry a b) -> Sem r () -> Sem r (Either a b)
retryRequest max_retries :: Int
max_retries action :: Sem r (ShouldRetry a b)
action failAction :: Sem r ()
failAction = Int -> Sem r (Either a b)
retryInner 0
 where
  retryInner :: Int -> Sem r (Either a b)
retryInner num_retries :: Int
num_retries = do
    ShouldRetry a b
res <- Sem r (ShouldRetry a b)
action
    case ShouldRetry a b
res of
      Retry r :: a
r | Int
num_retries Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
max_retries -> do
        Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "Request failed after " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Int
max_retries Int -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ " retries."
        Either a b -> Sem r (Either a b)
doFail (Either a b -> Sem r (Either a b))
-> Either a b -> Sem r (Either a b)
forall a b. (a -> b) -> a -> b
$ a -> Either a b
forall a b. a -> Either a b
Left a
r
      Retry _ -> Int -> Sem r (Either a b)
retryInner (Int -> Int
forall a. Enum a => a -> a
succ Int
num_retries)
      RFail r :: a
r -> do
        Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug "Request failed due to error response."
        Either a b -> Sem r (Either a b)
doFail (Either a b -> Sem r (Either a b))
-> Either a b -> Sem r (Either a b)
forall a b. (a -> b) -> a -> b
$ a -> Either a b
forall a b. a -> Either a b
Left a
r
      RGood r :: b
r -> Either a b -> Sem r (Either a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a b -> Sem r (Either a b))
-> Either a b -> Sem r (Either a b)
forall a b. (a -> b) -> a -> b
$ b -> Either a b
forall a b. b -> Either a b
Right b
r
    where doFail :: Either a b -> Sem r (Either a b)
doFail v :: Either a b
v = Sem r ()
failAction Sem r () -> Either a b -> Sem r (Either a b)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Either a b
v


-- Run a single request
-- NOTE: this function will only unlock the ratelimit lock if the request
-- gave a response, otherwise it will stay locked so that it can be retried again
doSingleRequest
  :: BotC r
  => Event -- ^ Global lock
  -> Lock -- ^ Local lock
  -> IO (Response LB.ByteString) -- ^ Request action
  -> Sem r (ShouldRetry RestError LB.ByteString)
doSingleRequest :: Event
-> Lock
-> IO (Response ByteString)
-> Sem r (ShouldRetry RestError ByteString)
doSingleRequest gl :: Event
gl l :: Lock
l r :: IO (Response ByteString)
r = do
  DiscordResponseType
r' <- IO (Response ByteString) -> Sem r DiscordResponseType
forall (r :: [(* -> *) -> * -> *]).
BotC r =>
IO (Response ByteString) -> Sem r DiscordResponseType
doDiscordRequest IO (Response ByteString)
r
  case DiscordResponseType
r' of
    Good v :: ByteString
v -> do
      IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> (STM () -> IO ()) -> STM () -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> Sem r ()) -> STM () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Lock -> STM ()
L.release Lock
l
      ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
 -> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ShouldRetry RestError ByteString
forall a b. b -> ShouldRetry a b
RGood ByteString
v

    ExhaustedBucket v :: ByteString
v d :: Int
d -> do
      Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "Exhausted bucket, unlocking after " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Int
d Int -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ "ms"
      Sem r (Async (Maybe ())) -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r (Async (Maybe ())) -> Sem r ())
-> (Sem r () -> Sem r (Async (Maybe ()))) -> Sem r () -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem r () -> Sem r (Async (Maybe ()))
forall (r :: [(* -> *) -> * -> *]) a.
MemberWithError Async r =>
Sem r a -> Sem r (Async (Maybe a))
P.async (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
        IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
          Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ 1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
d
          STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Lock -> STM ()
L.release Lock
l
        Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug "unlocking bucket"
      ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
 -> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ShouldRetry RestError ByteString
forall a b. b -> ShouldRetry a b
RGood ByteString
v

    Ratelimited d :: Int
d False -> do
      Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ "429 ratelimited on route, sleeping for " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Int
d Int -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ " ms"
      IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> (Int -> IO ()) -> Int -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
threadDelay (Int -> Sem r ()) -> Int -> Sem r ()
forall a b. (a -> b) -> a -> b
$ 1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
d
      ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
 -> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall a b. a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError 429 Maybe Value
forall a. Maybe a
Nothing)

    Ratelimited d :: Int
d True -> do
      Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug "429 ratelimited globally"
      IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
        Event -> IO ()
E.clear Event
gl
        Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ 1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
d
        Event -> IO ()
E.set Event
gl
      ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
 -> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall a b. a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError 429 Maybe Value
forall a. Maybe a
Nothing)

    ServerError c :: Int
c -> do
      Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug "Server failed, retrying"
      ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
 -> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall a b. a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError Int
c Maybe Value
forall a. Maybe a
Nothing)

    InternalResponseError c :: Text
c -> do
      Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug "Internal error, retrying"
      ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
 -> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall a b. a -> ShouldRetry a b
Retry (Text -> RestError
InternalClientError Text
c)

    ClientError c :: Int
c v :: ByteString
v -> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
 -> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall a b. a -> ShouldRetry a b
RFail (Int -> Maybe Value -> RestError
HTTPError Int
c (Maybe Value -> RestError) -> Maybe Value -> RestError
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
v)

doRequest :: BotC r => RateLimitState -> Route -> IO (Response LB.ByteString) -> Sem r (Either RestError LB.ByteString)
doRequest :: RateLimitState
-> Route
-> IO (Response ByteString)
-> Sem r (Either RestError ByteString)
doRequest rlState :: RateLimitState
rlState route :: Route
route action :: IO (Response ByteString)
action = do
  IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Event -> IO ()
E.wait (RateLimitState -> Event
globalLock RateLimitState
rlState)

  Lock
ratelimit <- IO Lock -> Sem r Lock
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO Lock -> Sem r Lock)
-> (STM Lock -> IO Lock) -> STM Lock -> Sem r Lock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Lock -> IO Lock
forall a. STM a -> IO a
atomically (STM Lock -> Sem r Lock) -> STM Lock -> Sem r Lock
forall a b. (a -> b) -> a -> b
$ do
    Lock
lock <- RateLimitState -> Route -> STM Lock
getRateLimit RateLimitState
rlState Route
route
    Lock -> STM ()
L.acquire Lock
lock
    Lock -> STM Lock
forall (f :: * -> *) a. Applicative f => a -> f a
pure Lock
lock

  Int
-> Sem r (ShouldRetry RestError ByteString)
-> Sem r ()
-> Sem r (Either RestError ByteString)
forall (r :: [(* -> *) -> * -> *]) a b.
BotC r =>
Int -> Sem r (ShouldRetry a b) -> Sem r () -> Sem r (Either a b)
retryRequest 5 (Event
-> Lock
-> IO (Response ByteString)
-> Sem r (ShouldRetry RestError ByteString)
forall (r :: [(* -> *) -> * -> *]).
BotC r =>
Event
-> Lock
-> IO (Response ByteString)
-> Sem r (ShouldRetry RestError ByteString)
doSingleRequest (RateLimitState -> Event
globalLock RateLimitState
rlState) Lock
ratelimit IO (Response ByteString)
action)
    (IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> (STM () -> IO ()) -> STM () -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> Sem r ()) -> STM () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Lock -> STM ()
L.release Lock
ratelimit)