-- | 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.Client (responseStatus)
import Network.HTTP.Date
import Network.HTTP.Req
import Network.HTTP.Types

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

import Prelude hiding (error)

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

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 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, 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 RateLimitState
s 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 LbsResponse -> Sem r DiscordResponseType
doDiscordRequest :: IO LbsResponse -> Sem r DiscordResponseType
doDiscordRequest IO LbsResponse
r = do
  Either String LbsResponse
r'' <- IO (Either String LbsResponse) -> Sem r (Either String LbsResponse)
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO (Either String LbsResponse)
 -> Sem r (Either String LbsResponse))
-> IO (Either String LbsResponse)
-> Sem r (Either String LbsResponse)
forall a b. (a -> b) -> a -> b
$ IO (Either String LbsResponse)
-> (SomeException -> IO (Either String LbsResponse))
-> IO (Either String LbsResponse)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
Ex.catchAny (LbsResponse -> Either String LbsResponse
forall a b. b -> Either a b
Right (LbsResponse -> Either String LbsResponse)
-> IO LbsResponse -> IO (Either String LbsResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO LbsResponse
r) (Either String LbsResponse -> IO (Either String LbsResponse)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String LbsResponse -> IO (Either String LbsResponse))
-> (SomeException -> Either String LbsResponse)
-> SomeException
-> IO (Either String LbsResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String LbsResponse
forall a b. a -> Either a b
Left (String -> Either String LbsResponse)
-> (SomeException -> String)
-> SomeException
-> Either String LbsResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall e. Exception e => e -> String
Ex.displayException)
  case Either String LbsResponse
r'' of
    Right LbsResponse
r' -> do
      let status :: Status
status = Response ByteString -> Status
forall body. Response body -> Status
responseStatus (Response ByteString -> Status)
-> (LbsResponse -> Response ByteString) -> LbsResponse -> Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LbsResponse -> Response ByteString
forall response.
HttpResponse response =>
response -> Response (HttpResponseBody response)
toVanillaResponse (LbsResponse -> Status) -> LbsResponse -> Status
forall a b. (a -> b) -> a -> b
$ LbsResponse
r'
      if
          | Status -> Bool
statusIsSuccessful Status
status -> do
            let resp :: HttpResponseBody LbsResponse
resp = LbsResponse -> HttpResponseBody LbsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody LbsResponse
r'
            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
$ Builder
"Got good response from discord: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+|| Status
status Status -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ Builder
""
            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 LbsResponse -> Bool
forall r. HttpResponse r => r -> Bool
isExhausted LbsResponse
r'
                then case LbsResponse -> Maybe Int
forall r. HttpResponse r => r -> Maybe Int
parseRateLimitHeader LbsResponse
r' of
                  Just !Int
sleepTime -> ByteString -> Int -> DiscordResponseType
ExhaustedBucket ByteString
HttpResponseBody LbsResponse
resp Int
sleepTime
                  Maybe Int
Nothing -> Int -> DiscordResponseType
ServerError (Status -> Int
statusCode Status
status)
                else ByteString -> DiscordResponseType
Good ByteString
HttpResponseBody LbsResponse
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 Text
"Got 429 from discord, retrying."
            let resp :: HttpResponseBody LbsResponse
resp = LbsResponse -> HttpResponseBody LbsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody LbsResponse
r'
            case ByteString
HttpResponseBody LbsResponse
resp ByteString -> Getting (First Value) ByteString Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First Value) ByteString Value
forall t. AsValue t => Prism' t Value
_Value of
              Just 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 (Value -> Int
parseRetryAfter Value
rv) (Value -> Bool
isGlobal Value
rv)
              Maybe Value
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 -> Int
statusCode Status
status) ByteString
"429 with invalid json???"
          | Status -> Bool
statusIsClientError Status
status -> do
            let err :: HttpResponseBody LbsResponse
err = LbsResponse -> HttpResponseBody LbsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody LbsResponse
r'
            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
$ Builder
"Something went wrong: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+|| ByteString
HttpResponseBody LbsResponse
err ByteString -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ Builder
" response: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|| LbsResponse
r' LbsResponse -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ Builder
""
            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 -> Int
statusCode Status
status) ByteString
HttpResponseBody LbsResponse
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
$ Builder
"Got server error from discord: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Status -> Int
statusCode Status
status Int -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
            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 -> Int
statusCode Status
status)
    Left 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
$ Builder
"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
|+ Builder
""
      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 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 Double
end !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
* NominalDiffTime
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 :: HttpResponse r => r -> Maybe Int
parseRateLimitHeader :: r -> Maybe Int
parseRateLimitHeader r
r = Double -> UTCTime -> Int
computeDiscordTimeDiff (Double -> UTCTime -> Int)
-> Maybe Double -> Maybe (UTCTime -> Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Double
end Maybe (UTCTime -> Int) -> Maybe UTCTime -> Maybe Int
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe UTCTime
now
 where
  end :: Maybe Double
end = r -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-Ratelimit-Reset" Maybe ByteString
-> Getting (First Double) (Maybe ByteString) Double -> Maybe Double
forall s a. s -> Getting (First a) s a -> Maybe a
^? (ByteString -> Const (First Double) ByteString)
-> Maybe ByteString -> Const (First Double) (Maybe ByteString)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((ByteString -> Const (First Double) ByteString)
 -> Maybe ByteString -> Const (First Double) (Maybe ByteString))
-> ((Double -> Const (First Double) Double)
    -> ByteString -> Const (First Double) ByteString)
-> Getting (First Double) (Maybe ByteString) Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Const (First Double) Double)
-> ByteString -> Const (First Double) ByteString
forall t. AsNumber t => Prism' t Double
_Double
  now :: Maybe UTCTime
now = ByteString -> Maybe UTCTime
parseDiscordTime (ByteString -> Maybe UTCTime) -> Maybe ByteString -> Maybe UTCTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< r -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"Date"

isExhausted :: HttpResponse r => r -> Bool
isExhausted :: r -> Bool
isExhausted r
r = r -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Remaining" Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"0"

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

isGlobal :: Value -> Bool
isGlobal :: Value -> Bool
isGlobal Value
r = Value
r Value -> Getting (First Bool) Value Bool -> Maybe Bool
forall s a. s -> Getting (First a) s a -> Maybe a
^? Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"global" ((Value -> Const (First Bool) Value)
 -> Value -> Const (First Bool) Value)
-> Getting (First Bool) Value Bool
-> Getting (First Bool) Value Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Bool) Value Bool
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 =>
  -- | number of retries
  Int ->
  -- | action to perform
  Sem r (ShouldRetry a b) ->
  -- | action to run if max number of retries was reached
  Sem r () ->
  Sem r (Either a b)
retryRequest :: Int -> Sem r (ShouldRetry a b) -> Sem r () -> Sem r (Either a b)
retryRequest Int
max_retries Sem r (ShouldRetry a b)
action Sem r ()
failAction = Int -> Sem r (Either a b)
retryInner Int
0
 where
  retryInner :: Int -> Sem r (Either a b)
retryInner Int
num_retries = do
    ShouldRetry a b
res <- Sem r (ShouldRetry a b)
action
    case ShouldRetry a b
res of
      Retry 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
$ Builder
"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
|+ Builder
" 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 a
_ -> Int -> Sem r (Either a b)
retryInner (Int
num_retries Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      RFail a
r -> do
        Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"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 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 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 =>
  -- | Global lock
  Event ->
  -- | Local lock
  Lock ->
  -- | Request action
  IO LbsResponse ->
  Sem r (ShouldRetry RestError LB.ByteString)
doSingleRequest :: Event
-> Lock
-> IO LbsResponse
-> Sem r (ShouldRetry RestError ByteString)
doSingleRequest Event
gl Lock
l IO LbsResponse
r = do
  DiscordResponseType
r' <- IO LbsResponse -> Sem r DiscordResponseType
forall (r :: [(* -> *) -> * -> *]).
BotC r =>
IO LbsResponse -> Sem r DiscordResponseType
doDiscordRequest IO LbsResponse
r
  case DiscordResponseType
r' of
    Good 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 ByteString
v 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
$ Builder
"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
|+ Builder
"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
$ Int
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 Text
"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 Int
d Bool
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
$ Builder
"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
|+ Builder
" 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
$ Int
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 Int
429 Maybe Value
forall a. Maybe a
Nothing)
    Ratelimited Int
d Bool
True -> do
      Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"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
$ Int
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 Int
429 Maybe Value
forall a. Maybe a
Nothing)
    ServerError Int
c -> do
      Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"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 Text
c -> do
      Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"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 Int
c 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 LbsResponse -> Sem r (Either RestError LB.ByteString)
doRequest :: RateLimitState
-> Route -> IO LbsResponse -> Sem r (Either RestError ByteString)
doRequest RateLimitState
rlState Route
route IO LbsResponse
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
    Int
5
    (Event
-> Lock
-> IO LbsResponse
-> Sem r (ShouldRetry RestError ByteString)
forall (r :: [(* -> *) -> * -> *]).
BotC r =>
Event
-> Lock
-> IO LbsResponse
-> Sem r (ShouldRetry RestError ByteString)
doSingleRequest (RateLimitState -> Event
globalLock RateLimitState
rlState) Lock
ratelimit IO LbsResponse
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)