-- | 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 Control.Lens
import Control.Monad

import Data.Aeson
import Data.Aeson.Lens
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
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 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 RouteKey ByteString
-> Map ByteString Bucket -> Event -> RateLimitState
RateLimitState (Map RouteKey ByteString
 -> Map ByteString Bucket -> Event -> RateLimitState)
-> IO (Map RouteKey ByteString)
-> IO (Map ByteString Bucket -> Event -> RateLimitState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map RouteKey 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 RouteKey

getRateLimit :: RateLimitState -> RouteKey -> STM Ratelimit
getRateLimit :: RateLimitState -> RouteKey -> STM Ratelimit
getRateLimit RateLimitState
s RouteKey
h = do
  Maybe ByteString
bucketKey <- RouteKey -> Map RouteKey ByteString -> STM (Maybe ByteString)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup RouteKey
h (Map RouteKey ByteString -> STM (Maybe ByteString))
-> Map RouteKey ByteString -> STM (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Map RouteKey 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
$ RouteKey -> Ratelimit
UnknownRatelimit RouteKey
h

{- | Knowing the bucket for a route, and the ratelimit info, map the route to
 the bucket key and retrieve the bucket
-}
updateBucket :: RateLimitState -> RouteKey -> B.ByteString -> BucketState -> STM Bucket
updateBucket :: RateLimitState
-> RouteKey -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
s RouteKey
h ByteString
b BucketState
bucketState = do
  Maybe ByteString
bucketKey <- RouteKey -> Map RouteKey ByteString -> STM (Maybe ByteString)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup RouteKey
h (Map RouteKey ByteString -> STM (Maybe ByteString))
-> Map RouteKey ByteString -> STM (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Map RouteKey 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
      -- if the given bucket key is different than the known bucket key then oops
      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
`mergeStates` 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
      Bucket
bs <- TVar BucketState -> Bucket
Bucket (TVar BucketState -> Bucket)
-> STM (TVar BucketState) -> STM Bucket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BucketState -> STM (TVar BucketState)
forall a. a -> STM (TVar a)
newTVar BucketState
bucketState
      Bucket -> ByteString -> Map ByteString Bucket -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
SC.insert Bucket
bs 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 -> RouteKey -> Map RouteKey ByteString -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
SC.insert ByteString
b RouteKey
h (Map RouteKey ByteString -> STM ())
-> Map RouteKey ByteString -> STM ()
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Map RouteKey ByteString
bucketKeys RateLimitState
s
      Bucket -> STM Bucket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bucket
bs
 where
  mergeStates :: BucketState -> BucketState -> BucketState
  mergeStates :: BucketState -> BucketState -> BucketState
mergeStates BucketState
old BucketState
new =
    BucketState
new
      { $sel:ongoing:BucketState :: Int
ongoing = BucketState
old BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "ongoing" (Getting Int BucketState Int)
Getting Int BucketState Int
#ongoing
      , -- we only ignore the previous 'remaining' if we've not reset yet and the
        -- reset time has changed
        $sel:remaining:BucketState :: Int
remaining =
          if (Maybe UTCTime -> Bool
forall a. Maybe a -> Bool
isJust (Maybe UTCTime -> Bool) -> Maybe UTCTime -> Bool
forall a b. (a -> b) -> a -> b
$ BucketState
old BucketState
-> Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
-> Maybe UTCTime
forall s a. s -> Getting a s a -> a
^. IsLabel
  "resetTime" (Getting (Maybe UTCTime) BucketState (Maybe UTCTime))
Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
#resetTime) Bool -> Bool -> Bool
&& (BucketState
old BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "resetKey" (Getting Int BucketState Int)
Getting Int BucketState Int
#resetKey Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= BucketState
new BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "resetKey" (Getting Int BucketState Int)
Getting Int BucketState Int
#resetKey)
            then Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (BucketState
old BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "remaining" (Getting Int BucketState Int)
Getting Int BucketState Int
#remaining) (BucketState
new BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "remaining" (Getting Int BucketState Int)
Getting Int BucketState Int
#remaining)
            else BucketState
new BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "remaining" (Getting Int BucketState Int)
Getting Int BucketState Int
#remaining
      , -- only take the new resetTime if it actually changed
        $sel:resetTime:BucketState :: Maybe UTCTime
resetTime =
          if BucketState
old BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "resetKey" (Getting Int BucketState Int)
Getting Int BucketState Int
#resetKey Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= BucketState
new BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "resetKey" (Getting Int BucketState Int)
Getting Int BucketState Int
#resetKey
            then BucketState
new BucketState
-> Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
-> Maybe UTCTime
forall s a. s -> Getting a s a -> a
^. IsLabel
  "resetTime" (Getting (Maybe UTCTime) BucketState (Maybe UTCTime))
Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
#resetTime
            else BucketState
old BucketState
-> Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
-> Maybe UTCTime
forall s a. s -> Getting a s a -> a
^. IsLabel
  "resetTime" (Getting (Maybe UTCTime) BucketState (Maybe UTCTime))
Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
#resetTime
      }

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)
    ( \BucketState
bs ->
        BucketState
bs BucketState -> (BucketState -> BucketState) -> BucketState
forall a b. a -> (a -> b) -> b
& IsLabel "remaining" (ASetter BucketState BucketState Int Int)
ASetter BucketState BucketState Int Int
#remaining ASetter BucketState BucketState Int Int
-> Int -> BucketState -> BucketState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ BucketState
bs BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "limit" (Getting Int BucketState Int)
Getting Int BucketState Int
#limit
          BucketState -> (BucketState -> BucketState) -> BucketState
forall a b. a -> (a -> b) -> b
& IsLabel
  "resetTime"
  (ASetter BucketState BucketState (Maybe UTCTime) (Maybe UTCTime))
ASetter BucketState BucketState (Maybe UTCTime) (Maybe UTCTime)
#resetTime ASetter BucketState BucketState (Maybe UTCTime) (Maybe UTCTime)
-> Maybe UTCTime -> BucketState -> BucketState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe UTCTime
forall a. Maybe a
Nothing
    )

canResetBucketNow :: UTCTime -> BucketState -> Bool
canResetBucketNow :: UTCTime -> BucketState -> Bool
canResetBucketNow UTCTime
_ BucketState{Int
ongoing :: Int
$sel:ongoing:BucketState :: BucketState -> Int
ongoing} | Int
ongoing Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Bool
False
-- don't allow resetting the bucket if there's ongoing requests, we'll wait
-- until another request finishes and updates the counter
canResetBucketNow UTCTime
now BucketState
bs = case BucketState
bs BucketState
-> Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
-> Maybe UTCTime
forall s a. s -> Getting a s a -> a
^. IsLabel
  "resetTime" (Getting (Maybe UTCTime) BucketState (Maybe UTCTime))
Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
#resetTime of
  Just UTCTime
rt -> UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
rt
  Maybe UTCTime
Nothing -> Bool
False

-- canResetBucket :: BucketState -> Bool
-- canResetBucket bs = isNothing $ bs ^. #startedWaitingTime

shouldWaitForUnlock :: BucketState -> Bool
shouldWaitForUnlock :: BucketState -> Bool
shouldWaitForUnlock BucketState{$sel:remaining:BucketState :: BucketState -> Int
remaining = Int
0, Int
ongoing :: Int
$sel:ongoing:BucketState :: BucketState -> Int
ongoing} = Int
ongoing Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
shouldWaitForUnlock BucketState
_ = Bool
False

data WaitDelay
  = WaitUntil UTCTime
  | WaitRetrySoon
  | GoNow
  deriving (Int -> WaitDelay -> ShowS
[WaitDelay] -> ShowS
WaitDelay -> [Char]
(Int -> WaitDelay -> ShowS)
-> (WaitDelay -> [Char])
-> ([WaitDelay] -> ShowS)
-> Show WaitDelay
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [WaitDelay] -> ShowS
$cshowList :: [WaitDelay] -> ShowS
show :: WaitDelay -> [Char]
$cshow :: WaitDelay -> [Char]
showsPrec :: Int -> WaitDelay -> ShowS
$cshowsPrec :: Int -> WaitDelay -> ShowS
Show)

intoWaitDelay :: Maybe UTCTime -> WaitDelay
intoWaitDelay :: Maybe UTCTime -> WaitDelay
intoWaitDelay (Just UTCTime
t) = UTCTime -> WaitDelay
WaitUntil UTCTime
t
intoWaitDelay Maybe UTCTime
Nothing = WaitDelay
WaitRetrySoon

-- | Maybe wait for a bucket, updating its state to say we used it
useBucketOnce :: Bucket -> IO ()
useBucketOnce :: Bucket -> IO ()
useBucketOnce Bucket
bucket = Int -> IO ()
go Int
0
 where
  go :: Int -> IO ()
  go :: Int -> IO ()
go Int
tries = do
    UTCTime
now <- IO UTCTime
getCurrentTime
    WaitDelay
mWaitDelay <- STM WaitDelay -> IO WaitDelay
forall a. STM a -> IO a
atomically (STM WaitDelay -> IO WaitDelay) -> STM WaitDelay -> IO WaitDelay
forall a b. (a -> b) -> a -> b
$ do
      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

      -- -- [0]
      -- -- if there are ongoing requests, wait for them to finish and deliver
      -- -- truth on the current ratelimit state
      Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
        (BucketState -> Bool
shouldWaitForUnlock BucketState
s)
        STM ()
forall a. STM a
retry

      -- if there are no ongoing requests, and the bucket reset time has lapsed,
      -- we can just reset the bucket.
      --
      -- if we've already reset the bucket then there should be an ongoing
      -- request so we'll just end up waiting for that to finish
      Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
        (UTCTime -> BucketState -> Bool
canResetBucketNow UTCTime
now BucketState
s)
        (Bucket -> STM ()
resetBucket Bucket
bucket)

      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

      if BucketState
s BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "remaining" (Getting Int BucketState Int)
Getting Int BucketState Int
#remaining Int -> Int -> Int
forall a. Num a => a -> a -> a
- BucketState
s BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "ongoing" (Getting Int BucketState Int)
Getting Int BucketState Int
#ongoing Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
        then do
          -- there are tokens remaining for us to use
          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 Int Int)
ASetter BucketState BucketState Int Int
#remaining ASetter BucketState BucketState Int Int
-> Int -> BucketState -> BucketState
forall a s t. Num a => ASetter s t a a -> a -> s -> t
-~ Int
1)
                (BucketState -> BucketState)
-> (BucketState -> BucketState) -> BucketState -> BucketState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IsLabel "ongoing" (ASetter BucketState BucketState Int Int)
ASetter BucketState BucketState Int Int
#ongoing ASetter BucketState BucketState Int Int
-> Int -> BucketState -> BucketState
forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Int
1)
            )
          WaitDelay -> STM WaitDelay
forall (f :: * -> *) a. Applicative f => a -> f a
pure WaitDelay
GoNow
        else do
          -- the bucket has expired, there are no ongoing requests because of
          -- [0] wait and then retry after we can unlock the bucket
          WaitDelay -> STM WaitDelay
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe UTCTime -> WaitDelay
intoWaitDelay (Maybe UTCTime -> WaitDelay) -> Maybe UTCTime -> WaitDelay
forall a b. (a -> b) -> a -> b
$ BucketState
s BucketState
-> Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
-> Maybe UTCTime
forall s a. s -> Getting a s a -> a
^. IsLabel
  "resetTime" (Getting (Maybe UTCTime) BucketState (Maybe UTCTime))
Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
#resetTime)

    -- putStrLn (show now <> ": Using bucket, waiting until: " <> show mWaitDelay <> ", uses: " <> show s <> ", " <> inf)

    case WaitDelay
mWaitDelay of
      WaitUntil UTCTime
waitUntil -> do
        if UTCTime
waitUntil UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
now
          then Int -> IO ()
threadDelayMS Int
20
          else -- if the reset is in the past, we're fucked
            UTCTime -> IO ()
threadDelayUntil UTCTime
waitUntil
        -- if we needed to sleep, go again so that multiple concurrent requests
        -- don't exceed the bucket, to ensure we don't sit in a loop if a
        -- request dies on us, bail out after 50 loops
        if Int
tries Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
50
          then Int -> IO ()
go (Int
tries Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          else () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- print "bailing after number of retries"
      WaitDelay
WaitRetrySoon -> do
        Int -> IO ()
threadDelayMS Int
20
        if Int
tries Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
50
          then Int -> IO ()
go (Int
tries Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          else () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- print "bailing after number of retries"
      WaitDelay
GoNow -> do
        -- print "ok going forward with request"
        () -> 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
            let rlHeaders :: Maybe (BucketState, ByteString)
rlHeaders = UTCTime -> LbsResponse -> Maybe (BucketState, ByteString)
forall r.
HttpResponse r =>
UTCTime -> r -> Maybe (BucketState, ByteString)
buildBucketState UTCTime
now LbsResponse
r'
            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
-> Maybe (BucketState, ByteString) -> DiscordResponseType
Good ByteString
HttpResponseBody LbsResponse
resp Maybe (BucketState, ByteString)
rlHeaders
          | Status
status Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status429 -> do
            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 -> ByteString -> (BucketState, ByteString))
-> Maybe BucketState
-> Maybe (ByteString -> (BucketState, ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe BucketState
bs Maybe (ByteString -> (BucketState, ByteString))
-> Maybe ByteString -> Maybe (BucketState, ByteString)
forall (f :: * -> *) a b. Applicative f => 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
  limit :: Maybe Int
limit = r -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Limit" 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
  resetKey :: Maybe Int
resetKey = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Int) -> Maybe Double -> Maybe Int
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
  resetTime :: Maybe UTCTime
resetTime = UTCTime -> r -> Maybe UTCTime
forall r. HttpResponse r => UTCTime -> r -> Maybe UTCTime
parseRateLimitHeader UTCTime
now r
r
  bs :: Maybe BucketState
bs = Maybe UTCTime -> Int -> Int -> Int -> Int -> BucketState
BucketState Maybe UTCTime
resetTime (Int -> Int -> Int -> Int -> BucketState)
-> Maybe Int -> Maybe (Int -> Int -> Int -> BucketState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
resetKey Maybe (Int -> Int -> Int -> BucketState)
-> Maybe Int -> Maybe (Int -> Int -> BucketState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int
remaining Maybe (Int -> Int -> BucketState)
-> Maybe Int -> Maybe (Int -> BucketState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int
limit Maybe (Int -> BucketState) -> Maybe Int -> Maybe BucketState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Maybe Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
  bucketKey :: Maybe ByteString
bucketKey = r -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Bucket"

-- | 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)

tenMS :: NominalDiffTime
tenMS :: NominalDiffTime
tenMS = NominalDiffTime
0.01

threadDelayUntil :: UTCTime -> IO ()
threadDelayUntil :: UTCTime -> IO ()
threadDelayUntil UTCTime
when = do
  let when' :: UTCTime
when' = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
tenMS UTCTime
when -- lol
  UTCTime
now <- IO UTCTime
getCurrentTime
  let msUntil :: Int
msUntil = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (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 -> RouteKey -> STM Ratelimit
getRateLimit RateLimitState
rlstate (Route -> RouteKey
routeKey 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
_ -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"unknown ratelimit"

  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 Maybe (BucketState, ByteString)
rlHeaders -> do
      Sem r () -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r () -> Sem r ())
-> (STM () -> Sem r ()) -> STM () -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
$ do
        case Ratelimit
rl of
          KnownRatelimit 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 "ongoing" (ASetter BucketState BucketState Int Int)
ASetter BucketState BucketState Int Int
#ongoing ASetter BucketState BucketState Int Int
-> Int -> BucketState -> BucketState
forall a s t. Num a => ASetter s t a a -> a -> s -> t
-~ Int
1)
          Ratelimit
_ -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        case Maybe (BucketState, ByteString)
rlHeaders of
          Just (BucketState
bs, ByteString
bk) ->
            STM Bucket -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM Bucket -> STM ()) -> STM Bucket -> STM ()
forall a b. (a -> b) -> a -> b
$ RateLimitState
-> RouteKey -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
rlstate (Route -> RouteKey
routeKey Route
route) ByteString
bk BucketState
bs
          Maybe (BucketState, ByteString)
Nothing -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      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
""

      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
$ do
        case Ratelimit
rl of
          KnownRatelimit 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 "ongoing" (ASetter BucketState BucketState Int Int)
ASetter BucketState BucketState Int Int
#ongoing ASetter BucketState BucketState Int Int
-> Int -> BucketState -> BucketState
forall a s t. Num a => ASetter s t a a -> a -> s -> t
-~ Int
1)
          Ratelimit
_ -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        STM Bucket -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM Bucket -> STM ()) -> STM Bucket -> STM ()
forall a b. (a -> b) -> a -> b
$ RateLimitState
-> RouteKey -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
rlstate (Route -> RouteKey
routeKey Route
route) ByteString
bk BucketState
bs

      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

      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"
      case Ratelimit
rl of
        KnownRatelimit Bucket
bucket ->
          Sem r () -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r () -> Sem r ())
-> (STM () -> Sem r ()) -> STM () -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
$ 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 "ongoing" (ASetter BucketState BucketState Int Int)
ASetter BucketState BucketState Int Int
#ongoing ASetter BucketState BucketState Int Int
-> Int -> BucketState -> BucketState
forall a s t. Num a => ASetter s t a a -> a -> s -> t
-~ Int
1)
        Ratelimit
_ -> () -> Sem r ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      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
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          case Ratelimit
rl of
            KnownRatelimit 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 "ongoing" (ASetter BucketState BucketState Int Int)
ASetter BucketState BucketState Int Int
#ongoing ASetter BucketState BucketState Int Int
-> Int -> BucketState -> BucketState
forall a s t. Num a => ASetter s t a a -> a -> s -> t
-~ Int
1)
            Ratelimit
_ -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          case Maybe (BucketState, ByteString)
bs of
            Just (BucketState
bs', ByteString
bk) ->
              STM Bucket -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM Bucket -> STM ()) -> STM Bucket -> STM ()
forall a b. (a -> b) -> a -> b
$ RateLimitState
-> RouteKey -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
rlstate (Route -> RouteKey
routeKey Route
route) ByteString
bk BucketState
bs'
            Maybe (BucketState, ByteString)
Nothing ->
              () -> STM ()
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"
      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
_ -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"unknown ratelimit"
      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"
      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
_ -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"unknown ratelimit"
      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 -> do
      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
_ -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"unknown ratelimit"
      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)