-- | 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.Applicative
import Control.Concurrent
import Control.Concurrent.Event (Event)
import qualified Control.Concurrent.Event as E
import Control.Concurrent.STM
import qualified Control.Concurrent.STM.Lock as L
import Control.Lens
import Control.Monad

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

import Fmt

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

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

newRateLimitState :: IO RateLimitState
newRateLimitState :: IO RateLimitState
newRateLimitState = Map Route ByteString
-> Map ByteString Bucket -> Event -> RateLimitState
RateLimitState (Map Route ByteString
 -> Map ByteString Bucket -> Event -> RateLimitState)
-> IO (Map Route ByteString)
-> IO (Map ByteString Bucket -> Event -> RateLimitState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map Route ByteString)
forall key value. IO (Map key value)
SC.newIO IO (Map ByteString Bucket -> Event -> RateLimitState)
-> IO (Map ByteString Bucket) -> IO (Event -> RateLimitState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Map ByteString Bucket)
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

data Ratelimit
  = KnownRatelimit Bucket
  | UnknownRatelimit Route

{- performing rate limits
  1. try to fetch the lock from the ratelimiter state
  1.1. if we know the bucket then we retrieve the lock (KnownRatelimit)
  1.2. if we don't know the bucket, we just store the route (UnknownRatelimit)
  2.1. wait fot the global event (the global event is set unless we're globally ratelimited)
  2.2. wait for the local lock (locks are unlocked unless the bucket is exhausted)
  2.3. try to wait for the ratelimit to expire if it's exhausted
  3. we then perform the request, after this we'll know the bucket,
     so we update the ratelimit state with the bucket. if while performing
     the current request another request completed that made the bucket known,
     we don't try to overwrite it
  4.1. if we exceeded the local ratelimit we take the lock and release it after a delay
  4.2. if we exceeded the global ratelimit, we unset the global rl event,
       wait for it to expire, and then try again
-}

getRateLimit :: RateLimitState -> Route -> STM Ratelimit
getRateLimit :: RateLimitState -> Route -> STM Ratelimit
getRateLimit RateLimitState
s Route
h = do
  Maybe ByteString
bucketKey <- Route -> Map Route ByteString -> STM (Maybe ByteString)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup Route
h (Map Route ByteString -> STM (Maybe ByteString))
-> Map Route ByteString -> STM (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Map Route ByteString
bucketKeys RateLimitState
s
  Maybe Bucket
bucket <- Maybe (Maybe Bucket) -> Maybe Bucket
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Bucket) -> Maybe Bucket)
-> STM (Maybe (Maybe Bucket)) -> STM (Maybe Bucket)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (STM (Maybe Bucket)) -> STM (Maybe (Maybe Bucket))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ((ByteString -> Map ByteString Bucket -> STM (Maybe Bucket))
-> Map ByteString Bucket -> ByteString -> STM (Maybe Bucket)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ByteString -> Map ByteString Bucket -> STM (Maybe Bucket)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup (RateLimitState -> Map ByteString Bucket
buckets RateLimitState
s) (ByteString -> STM (Maybe Bucket))
-> Maybe ByteString -> Maybe (STM (Maybe Bucket))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
bucketKey)
  case Maybe Bucket
bucket of
    Just Bucket
bucket' ->
      Ratelimit -> STM Ratelimit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ratelimit -> STM Ratelimit) -> Ratelimit -> STM Ratelimit
forall a b. (a -> b) -> a -> b
$ Bucket -> Ratelimit
KnownRatelimit Bucket
bucket'
    Maybe Bucket
Nothing ->
      Ratelimit -> STM Ratelimit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ratelimit -> STM Ratelimit) -> Ratelimit -> STM Ratelimit
forall a b. (a -> b) -> a -> b
$ Route -> Ratelimit
UnknownRatelimit Route
h

-- | Knowing the bucket for a route, and the ratelimit info, map the route to
-- the bucket key and retrieve the bucket
updateBucket :: RateLimitState -> Route -> B.ByteString -> BucketState -> STM Bucket
updateBucket :: RateLimitState -> Route -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
s Route
h ByteString
b BucketState
bucketState = do
  Maybe ByteString
bucketKey <- Route -> Map Route ByteString -> STM (Maybe ByteString)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup Route
h (Map Route ByteString -> STM (Maybe ByteString))
-> Map Route ByteString -> STM (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Map Route ByteString
bucketKeys RateLimitState
s
  case Maybe ByteString
bucketKey of
    Just ByteString
bucketKey' -> do
      -- if we know the bucket key here, then the bucket has already been made
      Maybe Bucket
bucket <- ByteString -> Map ByteString Bucket -> STM (Maybe Bucket)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup ByteString
bucketKey' (Map ByteString Bucket -> STM (Maybe Bucket))
-> Map ByteString Bucket -> STM (Maybe Bucket)
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Map ByteString Bucket
buckets RateLimitState
s
      case Maybe Bucket
bucket of
        Just Bucket
bucket' -> do
          TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket' Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
  "state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state) (BucketState -> BucketState -> BucketState
`mergeBucket` BucketState
bucketState)
          Bucket -> STM Bucket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bucket
bucket'
        Maybe Bucket
Nothing -> [Char] -> STM Bucket
forall a. HasCallStack => [Char] -> a
Prelude.error [Char]
"Not possible"
    Maybe ByteString
Nothing -> do
      -- the bucket key wasn't known, make a new bucket and insert it
      Lock
lock <- STM Lock
L.new
      TVar BucketState
bs <- BucketState -> STM (TVar BucketState)
forall a. a -> STM (TVar a)
newTVar BucketState
bucketState
      let bucket :: Bucket
bucket = Lock -> TVar BucketState -> Bucket
Bucket Lock
lock TVar BucketState
bs
      Bucket -> ByteString -> Map ByteString Bucket -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
SC.insert Bucket
bucket ByteString
b (Map ByteString Bucket -> STM ())
-> Map ByteString Bucket -> STM ()
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Map ByteString Bucket
buckets RateLimitState
s
      ByteString -> Route -> Map Route ByteString -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
SC.insert ByteString
b Route
h (Map Route ByteString -> STM ()) -> Map Route ByteString -> STM ()
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Map Route ByteString
bucketKeys RateLimitState
s
      Bucket -> STM Bucket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bucket
bucket
  where
    mergeBucket :: BucketState -> BucketState -> BucketState
    mergeBucket :: BucketState -> BucketState -> BucketState
mergeBucket BucketState
old BucketState
new = BucketState
new { $sel:remaining:BucketState :: Maybe Int
remaining = BucketState
new BucketState
-> Getting (Maybe Int) BucketState (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^. IsLabel "remaining" (Getting (Maybe Int) BucketState (Maybe Int))
Getting (Maybe Int) BucketState (Maybe Int)
#remaining Maybe Int -> Maybe Int -> Maybe Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> BucketState
old BucketState
-> Getting (Maybe Int) BucketState (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^. IsLabel "remaining" (Getting (Maybe Int) BucketState (Maybe Int))
Getting (Maybe Int) BucketState (Maybe Int)
#remaining }

resetBucket :: Bucket -> STM ()
resetBucket :: Bucket -> STM ()
resetBucket Bucket
bucket = TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
  "state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state) (IsLabel
  "remaining"
  (ASetter BucketState BucketState (Maybe Int) (Maybe Int))
ASetter BucketState BucketState (Maybe Int) (Maybe Int)
#remaining ASetter BucketState BucketState (Maybe Int) (Maybe Int)
-> Maybe Int -> BucketState -> BucketState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Int
forall a. Maybe a
Nothing)

-- | Maybe wait for a bucket, updating its state to say we used it
useBucketOnce :: Bucket -> IO ()
useBucketOnce :: Bucket -> IO ()
useBucketOnce Bucket
bucket = do
  UTCTime
now <- IO UTCTime
getCurrentTime
  Maybe UTCTime
mWaitUntil <- STM (Maybe UTCTime) -> IO (Maybe UTCTime)
forall a. STM a -> IO a
atomically (STM (Maybe UTCTime) -> IO (Maybe UTCTime))
-> STM (Maybe UTCTime) -> IO (Maybe UTCTime)
forall a b. (a -> b) -> a -> b
$ do
    -- first wait on the lock
    Lock -> STM ()
L.wait (Lock -> STM ()) -> Lock -> STM ()
forall a b. (a -> b) -> a -> b
$ Bucket
bucket Bucket -> Getting Lock Bucket Lock -> Lock
forall s a. s -> Getting a s a -> a
^. IsLabel "lock" (Getting Lock Bucket Lock)
Getting Lock Bucket Lock
#lock

    -- now try to estimate an expiry
    BucketState
s <- TVar BucketState -> STM BucketState
forall a. TVar a -> STM a
readTVar (TVar BucketState -> STM BucketState)
-> TVar BucketState -> STM BucketState
forall a b. (a -> b) -> a -> b
$ Bucket
bucket Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
  "state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state

    let remaining :: Maybe Int
remaining = if UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> BucketState
s BucketState -> Getting UTCTime BucketState UTCTime -> UTCTime
forall s a. s -> Getting a s a -> a
^. IsLabel "resetTime" (Getting UTCTime BucketState UTCTime)
Getting UTCTime BucketState UTCTime
#resetTime
          then Maybe Int
forall a. Maybe a
Nothing
          else BucketState
s BucketState
-> Getting (Maybe Int) BucketState (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^. IsLabel "remaining" (Getting (Maybe Int) BucketState (Maybe Int))
Getting (Maybe Int) BucketState (Maybe Int)
#remaining

    case Maybe Int
remaining of
      Just Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> do
        TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (Bucket
bucket Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
  "state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state) (IsLabel
  "remaining"
  (ASetter BucketState BucketState (Maybe Int) (Maybe Int))
ASetter BucketState BucketState (Maybe Int) (Maybe Int)
#remaining ASetter BucketState BucketState (Maybe Int) (Maybe Int)
-> Int -> BucketState -> BucketState
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        Maybe UTCTime -> STM (Maybe UTCTime)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UTCTime
forall a. Maybe a
Nothing
      Just Int
_ -> do
        -- expired, lock and then reset the remaining
        Lock -> STM ()
L.acquire (Lock -> STM ()) -> Lock -> STM ()
forall a b. (a -> b) -> a -> b
$ Bucket
bucket Bucket -> Getting Lock Bucket Lock -> Lock
forall s a. s -> Getting a s a -> a
^. IsLabel "lock" (Getting Lock Bucket Lock)
Getting Lock Bucket Lock
#lock
        TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (Bucket
bucket Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
  "state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state) (IsLabel
  "remaining"
  (ASetter BucketState BucketState (Maybe Int) (Maybe Int))
ASetter BucketState BucketState (Maybe Int) (Maybe Int)
#remaining ASetter BucketState BucketState (Maybe Int) (Maybe Int)
-> Maybe Int -> BucketState -> BucketState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Int
forall a. Maybe a
Nothing)
        Maybe UTCTime -> STM (Maybe UTCTime)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe UTCTime -> STM (Maybe UTCTime))
-> (UTCTime -> Maybe UTCTime) -> UTCTime -> STM (Maybe UTCTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> STM (Maybe UTCTime)) -> UTCTime -> STM (Maybe UTCTime)
forall a b. (a -> b) -> a -> b
$ BucketState
s BucketState -> Getting UTCTime BucketState UTCTime -> UTCTime
forall s a. s -> Getting a s a -> a
^. IsLabel "resetTime" (Getting UTCTime BucketState UTCTime)
Getting UTCTime BucketState UTCTime
#resetTime
      Maybe Int
Nothing ->
        -- unknown, just assume we're good
        Maybe UTCTime -> STM (Maybe UTCTime)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UTCTime
forall a. Maybe a
Nothing

  case Maybe UTCTime
mWaitUntil of
    Just UTCTime
when -> do
      UTCTime -> IO ()
threadDelayUntil UTCTime
when
      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (Lock -> STM ()) -> Lock -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lock -> STM ()
L.release (Lock -> IO ()) -> Lock -> IO ()
forall a b. (a -> b) -> a -> b
$ Bucket
bucket Bucket -> Getting Lock Bucket Lock -> Lock
forall s a. s -> Getting a s a -> a
^. IsLabel "lock" (Getting Lock Bucket Lock)
Getting Lock Bucket Lock
#lock
    Maybe UTCTime
Nothing ->
      () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

doDiscordRequest :: BotC r => IO LbsResponse -> Sem r DiscordResponseType
doDiscordRequest :: IO LbsResponse -> Sem r DiscordResponseType
doDiscordRequest IO LbsResponse
r = do
  Either [Char] LbsResponse
r'' <- IO (Either [Char] LbsResponse) -> Sem r (Either [Char] LbsResponse)
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO (Either [Char] LbsResponse)
 -> Sem r (Either [Char] LbsResponse))
-> IO (Either [Char] LbsResponse)
-> Sem r (Either [Char] LbsResponse)
forall a b. (a -> b) -> a -> b
$ IO (Either [Char] LbsResponse)
-> (SomeException -> IO (Either [Char] LbsResponse))
-> IO (Either [Char] LbsResponse)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
Ex.catchAny (LbsResponse -> Either [Char] LbsResponse
forall a b. b -> Either a b
Right (LbsResponse -> Either [Char] LbsResponse)
-> IO LbsResponse -> IO (Either [Char] LbsResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO LbsResponse
r) (Either [Char] LbsResponse -> IO (Either [Char] LbsResponse)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] LbsResponse -> IO (Either [Char] LbsResponse))
-> (SomeException -> Either [Char] LbsResponse)
-> SomeException
-> IO (Either [Char] LbsResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Either [Char] LbsResponse
forall a b. a -> Either a b
Left ([Char] -> Either [Char] LbsResponse)
-> (SomeException -> [Char])
-> SomeException
-> Either [Char] LbsResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> [Char]
forall e. Exception e => e -> [Char]
Ex.displayException)
  case Either [Char] 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
""
            UTCTime
now <- IO UTCTime -> Sem r UTCTime
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed IO UTCTime
getCurrentTime
            if LbsResponse -> Bool
forall r. HttpResponse r => r -> Bool
isExhausted LbsResponse
r'
              then case (UTCTime -> LbsResponse -> Maybe UTCTime
forall r. HttpResponse r => UTCTime -> r -> Maybe UTCTime
parseRateLimitHeader UTCTime
now LbsResponse
r', UTCTime -> LbsResponse -> Maybe (BucketState, ByteString)
forall r.
HttpResponse r =>
UTCTime -> r -> Maybe (BucketState, ByteString)
buildBucketState UTCTime
now LbsResponse
r') of
                (Just !UTCTime
when, Just (!BucketState
bs, !ByteString
key)) ->
                  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
$ ByteString
-> UTCTime -> BucketState -> ByteString -> DiscordResponseType
ExhaustedBucket ByteString
HttpResponseBody LbsResponse
resp UTCTime
when BucketState
bs ByteString
key
                (Maybe UTCTime, Maybe (BucketState, ByteString))
_ ->
                  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)
              else case UTCTime -> LbsResponse -> Maybe (BucketState, ByteString)
forall r.
HttpResponse r =>
UTCTime -> r -> Maybe (BucketState, ByteString)
buildBucketState UTCTime
now LbsResponse
r' of
                Just (!BucketState
bs, !ByteString
key) ->
                  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
$ ByteString -> BucketState -> ByteString -> DiscordResponseType
Good ByteString
HttpResponseBody LbsResponse
resp BucketState
bs ByteString
key
                Maybe (BucketState, ByteString)
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 -> DiscordResponseType
ServerError (Status -> Int
statusCode Status
status)
          | 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."
            UTCTime
now <- IO UTCTime -> Sem r UTCTime
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed IO UTCTime
getCurrentTime
            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, UTCTime -> LbsResponse -> Maybe (BucketState, ByteString)
forall r.
HttpResponse r =>
UTCTime -> r -> Maybe (BucketState, ByteString)
buildBucketState UTCTime
now LbsResponse
r') of
              (Just !Value
rv, Maybe (BucketState, ByteString)
bs) ->
                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
$ UTCTime
-> Bool -> Maybe (BucketState, ByteString) -> DiscordResponseType
Ratelimited (UTCTime -> Value -> UTCTime
parseRetryAfter UTCTime
now Value
rv) (Value -> Bool
isGlobal Value
rv) Maybe (BucketState, ByteString)
bs
              (Maybe Value, Maybe (BucketState, ByteString))
_ ->
                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)
          | 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 [Char]
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
+| [Char] -> Text
LT.pack [Char]
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
$ [Char] -> Text
LT.pack [Char]
e

-- | Parse a ratelimit header returning when it unlocks
parseRateLimitHeader :: HttpResponse r => UTCTime -> r -> Maybe UTCTime
parseRateLimitHeader :: UTCTime -> r -> Maybe UTCTime
parseRateLimitHeader UTCTime
now r
r = Maybe UTCTime
computedEnd Maybe UTCTime -> Maybe UTCTime -> Maybe UTCTime
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe UTCTime
end
  where
    computedEnd :: Maybe UTCTime
    computedEnd :: Maybe UTCTime
computedEnd = (NominalDiffTime -> UTCTime -> UTCTime)
-> UTCTime -> NominalDiffTime -> UTCTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip NominalDiffTime -> UTCTime -> UTCTime
addUTCTime UTCTime
now (NominalDiffTime -> UTCTime)
-> Maybe NominalDiffTime -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NominalDiffTime
resetAfter

    resetAfter :: Maybe NominalDiffTime
    resetAfter :: Maybe NominalDiffTime
resetAfter = Double -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> NominalDiffTime)
-> Maybe Double -> Maybe NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-Ratelimit-Reset-After" 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

    end :: Maybe UTCTime
    end :: Maybe UTCTime
end = NominalDiffTime -> UTCTime
posixSecondsToUTCTime (NominalDiffTime -> UTCTime)
-> (Double -> NominalDiffTime) -> Double -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> UTCTime) -> Maybe Double -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      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

buildBucketState :: HttpResponse r => UTCTime -> r -> Maybe (BucketState, B.ByteString)
buildBucketState :: UTCTime -> r -> Maybe (BucketState, ByteString)
buildBucketState UTCTime
now r
r = (BucketState
bs,) (ByteString -> (BucketState, ByteString))
-> Maybe ByteString -> Maybe (BucketState, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
bucketKey
  where
    remaining :: Maybe Int
remaining = r -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Remaining" Maybe ByteString
-> Getting (First Int) (Maybe ByteString) Int -> Maybe Int
forall s a. s -> Getting (First a) s a -> Maybe a
^? (ByteString -> Const (First Int) ByteString)
-> Maybe ByteString -> Const (First Int) (Maybe ByteString)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((ByteString -> Const (First Int) ByteString)
 -> Maybe ByteString -> Const (First Int) (Maybe ByteString))
-> ((Int -> Const (First Int) Int)
    -> ByteString -> Const (First Int) ByteString)
-> Getting (First Int) (Maybe ByteString) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const (First Int) Int)
-> ByteString -> Const (First Int) ByteString
forall t a. (AsNumber t, Integral a) => Prism' t a
_Integral
    bs :: BucketState
bs = UTCTime -> Maybe Int -> BucketState
BucketState UTCTime
now Maybe Int
remaining
    bucketKey :: Maybe ByteString
bucketKey = r -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Bucket"

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"

-- | Parse the retry after field, returning when to retry
parseRetryAfter :: UTCTime -> Value -> UTCTime
parseRetryAfter :: UTCTime -> Value -> UTCTime
parseRetryAfter UTCTime
now Value
r = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
retryAfter UTCTime
now
  where
    retryAfter :: NominalDiffTime
retryAfter = Double -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> NominalDiffTime) -> Double -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ Value
r Value -> Getting (Endo Double) Value Double -> Double
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 Double) Value)
 -> Value -> Const (Endo Double) Value)
-> Getting (Endo Double) Value Double
-> Getting (Endo Double) Value Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo Double) Value Double
forall t. AsNumber t => Prism' t Double
_Double

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) ->
  Sem r (Either a b)
retryRequest :: Int -> Sem r (ShouldRetry a b) -> Sem r (Either a b)
retryRequest Int
maxRetries Sem r (ShouldRetry a b)
action = Int -> Sem r (Either a b)
retryInner Int
0
 where
  retryInner :: Int -> Sem r (Either a b)
retryInner Int
numRetries = do
    ShouldRetry a b
res <- Sem r (ShouldRetry a b)
action
    case ShouldRetry a b
res of
      Retry a
r | Int
numRetries Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxRetries -> 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
maxRetries Int -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" retries."
        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
$ a -> Either a b
forall a b. a -> Either a b
Left a
r
      Retry a
_ ->
        Int -> Sem r (Either a b)
retryInner (Int
numRetries 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)
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
$ 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

threadDelayMS :: Int -> IO ()
threadDelayMS :: Int -> IO ()
threadDelayMS Int
ms = Int -> IO ()
threadDelay (Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
ms)

threadDelayUntil :: UTCTime -> IO ()
threadDelayUntil :: UTCTime -> IO ()
threadDelayUntil UTCTime
when = do
  UTCTime
now <- IO UTCTime
getCurrentTime
  let msUntil :: Int
msUntil = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int)
-> (NominalDiffTime -> Double) -> NominalDiffTime -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000) (Double -> Double)
-> (NominalDiffTime -> Double) -> NominalDiffTime -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Real NominalDiffTime, Fractional Double) =>
NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac @_ @Double (NominalDiffTime -> Int) -> NominalDiffTime -> Int
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
when UTCTime
now
  Int -> IO ()
threadDelayMS Int
msUntil

-- Run a single request
doSingleRequest ::
  BotC r =>
  RateLimitState ->
  Route ->
  -- | Global lock
  Event ->
  -- | Request action
  IO LbsResponse ->
  Sem r (ShouldRetry RestError LB.ByteString)
doSingleRequest :: RateLimitState
-> Route
-> Event
-> IO LbsResponse
-> Sem r (ShouldRetry RestError ByteString)
doSingleRequest RateLimitState
rlstate Route
route Event
gl IO LbsResponse
r = 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)

  Ratelimit
rl <- IO Ratelimit -> Sem r Ratelimit
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO Ratelimit -> Sem r Ratelimit)
-> (STM Ratelimit -> IO Ratelimit)
-> STM Ratelimit
-> Sem r Ratelimit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Ratelimit -> IO Ratelimit
forall a. STM a -> IO a
atomically (STM Ratelimit -> Sem r Ratelimit)
-> STM Ratelimit -> Sem r Ratelimit
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Route -> STM Ratelimit
getRateLimit RateLimitState
rlstate Route
route

  case Ratelimit
rl of
    KnownRatelimit Bucket
bucket ->
      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
$ Bucket -> IO ()
useBucketOnce Bucket
bucket

    Ratelimit
_ -> () -> Sem r ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  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 BucketState
bs ByteString
bk -> do
      Sem r Bucket -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r Bucket -> Sem r ())
-> (STM Bucket -> Sem r Bucket) -> STM Bucket -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Bucket -> Sem r Bucket
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO Bucket -> Sem r Bucket)
-> (STM Bucket -> IO Bucket) -> STM Bucket -> Sem r Bucket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Bucket -> IO Bucket
forall a. STM a -> IO a
atomically (STM Bucket -> Sem r ()) -> STM Bucket -> Sem r ()
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Route -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
rlstate Route
route ByteString
bk BucketState
bs
      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 UTCTime
unlockWhen BucketState
bs ByteString
bk -> 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 at" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| UTCTime
unlockWhen UTCTime -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""

      Bucket
bucket <- IO Bucket -> Sem r Bucket
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO Bucket -> Sem r Bucket)
-> (STM Bucket -> IO Bucket) -> STM Bucket -> Sem r Bucket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Bucket -> IO Bucket
forall a. STM a -> IO a
atomically (STM Bucket -> Sem r Bucket) -> STM Bucket -> Sem r Bucket
forall a b. (a -> b) -> a -> b
$ do
        Bucket
bucket <- RateLimitState -> Route -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
rlstate Route
route ByteString
bk BucketState
bs
        Lock -> STM ()
L.acquire (Lock -> STM ()) -> Lock -> STM ()
forall a b. (a -> b) -> a -> b
$ Bucket
bucket Bucket -> Getting Lock Bucket Lock -> Lock
forall s a. s -> Getting a s a -> a
^. IsLabel "lock" (Getting Lock Bucket Lock)
Getting Lock Bucket Lock
#lock
        Bucket -> STM Bucket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bucket
bucket

      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
          UTCTime -> IO ()
threadDelayUntil UTCTime
unlockWhen
          STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Lock -> STM ()
L.release (Lock -> STM ()) -> Lock -> STM ()
forall a b. (a -> b) -> a -> b
$ Bucket
bucket Bucket -> Getting Lock Bucket Lock -> Lock
forall s a. s -> Getting a s a -> a
^. IsLabel "lock" (Getting Lock Bucket Lock)
Getting Lock Bucket Lock
#lock
            Bucket -> STM ()
resetBucket Bucket
bucket
        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 UTCTime
unlockWhen Bool
False (Just (BucketState
bs, ByteString
bk)) -> 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, retrying at " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| UTCTime
unlockWhen UTCTime -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""

      Bucket
bucket <- IO Bucket -> Sem r Bucket
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO Bucket -> Sem r Bucket)
-> (STM Bucket -> IO Bucket) -> STM Bucket -> Sem r Bucket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Bucket -> IO Bucket
forall a. STM a -> IO a
atomically (STM Bucket -> Sem r Bucket) -> STM Bucket -> Sem r Bucket
forall a b. (a -> b) -> a -> b
$ do
        Bucket
bucket <- RateLimitState -> Route -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
rlstate Route
route ByteString
bk BucketState
bs
        Lock -> STM ()
L.acquire (Lock -> STM ()) -> Lock -> STM ()
forall a b. (a -> b) -> a -> b
$ Bucket
bucket Bucket -> Getting Lock Bucket Lock -> Lock
forall s a. s -> Getting a s a -> a
^. IsLabel "lock" (Getting Lock Bucket Lock)
Getting Lock Bucket Lock
#lock
        Bucket -> STM Bucket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bucket
bucket

      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
        UTCTime -> IO ()
threadDelayUntil UTCTime
unlockWhen
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Lock -> STM ()
L.release (Lock -> STM ()) -> Lock -> STM ()
forall a b. (a -> b) -> a -> b
$ Bucket
bucket Bucket -> Getting Lock Bucket Lock -> Lock
forall s a. s -> Getting a s a -> a
^. IsLabel "lock" (Getting Lock Bucket Lock)
Getting Lock Bucket Lock
#lock
          Bucket -> STM ()
resetBucket Bucket
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
$ 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 UTCTime
unlockWhen Bool
False Maybe (BucketState, ByteString)
_ -> do
      Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"Internal error (ratelimited but no headers), retrying"
      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
$ UTCTime -> IO ()
threadDelayUntil UTCTime
unlockWhen
      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 UTCTime
unlockWhen Bool
True Maybe (BucketState, ByteString)
bs -> 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
        case Maybe (BucketState, ByteString)
bs of
          Just (BucketState
bs', ByteString
bk) ->
            IO Bucket -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bucket -> IO ())
-> (STM Bucket -> IO Bucket) -> STM Bucket -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Bucket -> IO Bucket
forall a. STM a -> IO a
atomically (STM Bucket -> IO ()) -> STM Bucket -> IO ()
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Route -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
rlstate Route
route ByteString
bk BucketState
bs'
          Maybe (BucketState, ByteString)
Nothing ->
            () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        Event -> IO ()
E.clear Event
gl
        UTCTime -> IO ()
threadDelayUntil UTCTime
unlockWhen
        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 =
  Int
-> Sem r (ShouldRetry RestError ByteString)
-> Sem r (Either RestError ByteString)
forall (r :: [(* -> *) -> * -> *]) a b.
BotC r =>
Int -> Sem r (ShouldRetry a b) -> Sem r (Either a b)
retryRequest
    Int
5
    (RateLimitState
-> Route
-> Event
-> IO LbsResponse
-> Sem r (ShouldRetry RestError ByteString)
forall (r :: [(* -> *) -> * -> *]).
BotC r =>
RateLimitState
-> Route
-> Event
-> IO LbsResponse
-> Sem r (ShouldRetry RestError ByteString)
doSingleRequest RateLimitState
rlstate Route
route (RateLimitState -> Event
globalLock RateLimitState
rlstate) IO LbsResponse
action)