-- | 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 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 LbsResponse -> Sem r DiscordResponseType
doDiscordRequest :: IO LbsResponse -> Sem r DiscordResponseType
doDiscordRequest r :: 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 r' :: 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
$ "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
||+ ""
            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
                  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 "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 rv :: 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)
              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) "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
$ "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
||+ " 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
||+ ""
            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
$ "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
|+ ""
            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 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 !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 :: HttpResponse r => r -> Maybe Int
parseRateLimitHeader :: r -> Maybe Int
parseRateLimitHeader r :: 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 "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 "Date"

isExhausted :: HttpResponse r => r -> Bool
isExhausted :: r -> Bool
isExhausted r :: r
r = r -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r "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 :: Value -> Int
parseRetryAfter :: Value -> Int
parseRetryAfter r :: 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 "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 r :: 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 "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 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
num_retries Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
      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 =>
  -- | 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 gl :: Event
gl l :: Lock
l r :: 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 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 LbsResponse -> Sem r (Either RestError LB.ByteString)
doRequest :: RateLimitState
-> Route -> IO LbsResponse -> Sem r (Either RestError ByteString)
doRequest rlState :: RateLimitState
rlState route :: Route
route action :: 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
    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)