{-# LANGUAGE TemplateHaskell #-}

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

import Calamity.HTTP.Internal.Route
import Calamity.HTTP.Internal.Types
import Calamity.Internal.Utils
import Calamity.Types.LogEff
import Calamity.Types.TokenEff
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.Event (Event)
import Control.Concurrent.Event qualified as E
import Control.Concurrent.STM
import Control.Exception.Safe qualified as Ex
import Control.Monad
import Data.Aeson qualified as Aeson
import Data.Aeson.Optics
import Data.ByteString qualified as B
import Data.ByteString.Lazy qualified as LB
import Data.Maybe
import Data.Text qualified as T
import Data.Time
import Data.Time.Clock.POSIX
import Network.HTTP.Client (responseStatus)
import Network.HTTP.Req
import Network.HTTP.Types
import Optics
import Optics.Operators.Unsafe ((^?!))
import Polysemy (Sem, makeSem)
import Polysemy qualified as P
import StmContainers.Map qualified as SC
import Prelude hiding (error)
import Prelude qualified

data RatelimitEff m a where
  GetRatelimitState :: RatelimitEff m RateLimitState

makeSem ''RatelimitEff

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 :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> IO (Map RouteKey ByteString)
forall (key :: OpticKind) (value :: OpticKind). IO (Map key value)
SC.newIO IO (Map ByteString Bucket -> Event -> RateLimitState)
-> IO (Map ByteString Bucket) -> IO (Event -> RateLimitState)
forall (a :: OpticKind) (b :: OpticKind).
IO (a -> b) -> IO a -> IO b
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Applicative f =>
f (a -> b) -> f a -> f b
<*> IO (Map ByteString Bucket)
forall (key :: OpticKind) (value :: OpticKind). IO (Map key value)
SC.newIO IO (Event -> RateLimitState) -> IO Event -> IO RateLimitState
forall (a :: OpticKind) (b :: OpticKind).
IO (a -> b) -> IO a -> IO b
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
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 :: OpticKind) (value :: OpticKind).
(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 :: OpticKind) b. (a -> b) -> a -> b
$ RateLimitState -> Map RouteKey ByteString
bucketKeys RateLimitState
s
  Maybe Bucket
bucket <- Maybe (Maybe Bucket) -> Maybe Bucket
forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
Monad m =>
m (m a) -> m a
join (Maybe (Maybe Bucket) -> Maybe Bucket)
-> STM (Maybe (Maybe Bucket)) -> STM (Maybe Bucket)
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> (ByteString -> STM (Maybe Bucket))
-> Maybe ByteString -> STM (Maybe (Maybe Bucket))
forall (t :: OpticKind -> OpticKind) (f :: OpticKind -> OpticKind)
       (a :: OpticKind) (b :: OpticKind).
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (ByteString -> Map ByteString Bucket -> STM (Maybe Bucket)
forall (key :: OpticKind) (value :: OpticKind).
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
`SC.lookup` RateLimitState -> Map ByteString Bucket
buckets RateLimitState
s) Maybe ByteString
bucketKey
  case Maybe Bucket
bucket of
    Just Bucket
bucket' ->
      Ratelimit -> STM Ratelimit
forall (a :: OpticKind). a -> STM a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (Ratelimit -> STM Ratelimit) -> Ratelimit -> STM Ratelimit
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Bucket -> Ratelimit
KnownRatelimit Bucket
bucket'
    Maybe Bucket
Nothing ->
      Ratelimit -> STM Ratelimit
forall (a :: OpticKind). a -> STM a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (Ratelimit -> STM Ratelimit) -> Ratelimit -> STM Ratelimit
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ RouteKey -> Ratelimit
UnknownRatelimit RouteKey
h

mergeBucketStates :: BucketState -> BucketState -> BucketState
mergeBucketStates :: BucketState -> BucketState -> BucketState
mergeBucketStates BucketState
old BucketState
new =
  BucketState
new
    { $sel:ongoing:BucketState :: Int
ongoing = BucketState
old BucketState
-> Optic A_Lens NoIx BucketState BucketState Int Int -> Int
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx BucketState BucketState Int 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 :: OpticKind). Maybe a -> Bool
isJust (BucketState
old BucketState
-> Optic' A_Lens NoIx BucketState (Maybe UTCTime) -> Maybe UTCTime
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx BucketState (Maybe UTCTime)
#resetTime) Bool -> Bool -> Bool
&& BucketState
old BucketState
-> Optic A_Lens NoIx BucketState BucketState Int Int -> Int
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx BucketState BucketState Int Int
#resetKey Int -> Int -> Bool
forall (a :: OpticKind). Eq a => a -> a -> Bool
/= BucketState
new BucketState
-> Optic A_Lens NoIx BucketState BucketState Int Int -> Int
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx BucketState BucketState Int Int
#resetKey
          then Int -> Int -> Int
forall (a :: OpticKind). Ord a => a -> a -> a
min (BucketState
old BucketState
-> Optic A_Lens NoIx BucketState BucketState Int Int -> Int
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx BucketState BucketState Int Int
#remaining) (BucketState
new BucketState
-> Optic A_Lens NoIx BucketState BucketState Int Int -> Int
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx BucketState BucketState Int Int
#remaining)
          else BucketState
new BucketState
-> Optic A_Lens NoIx BucketState BucketState Int Int -> Int
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx BucketState BucketState Int Int
#remaining
    , -- only take the new resetTime if it actually changed
      $sel:resetTime:BucketState :: Maybe UTCTime
resetTime =
        if BucketState
old BucketState
-> Optic A_Lens NoIx BucketState BucketState Int Int -> Int
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx BucketState BucketState Int Int
#resetKey Int -> Int -> Bool
forall (a :: OpticKind). Eq a => a -> a -> Bool
/= BucketState
new BucketState
-> Optic A_Lens NoIx BucketState BucketState Int Int -> Int
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx BucketState BucketState Int Int
#resetKey
          then BucketState
new BucketState
-> Optic' A_Lens NoIx BucketState (Maybe UTCTime) -> Maybe UTCTime
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx BucketState (Maybe UTCTime)
#resetTime
          else BucketState
old BucketState
-> Optic' A_Lens NoIx BucketState (Maybe UTCTime) -> Maybe UTCTime
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx BucketState (Maybe UTCTime)
#resetTime
    }

updateKnownBucket :: Bucket -> BucketState -> STM ()
updateKnownBucket :: Bucket -> BucketState -> STM ()
updateKnownBucket Bucket
bucket BucketState
bucketState = TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall (a :: OpticKind). TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket Bucket
-> Optic' An_Iso NoIx Bucket (TVar BucketState) -> TVar BucketState
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx Bucket (TVar BucketState)
#state) (BucketState -> BucketState -> BucketState
`mergeBucketStates` BucketState
bucketState)

{- | 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 :: OpticKind) (value :: OpticKind).
(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 :: OpticKind) 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 :: OpticKind) (value :: OpticKind).
(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 :: OpticKind) 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 :: OpticKind). TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket' Bucket
-> Optic' An_Iso NoIx Bucket (TVar BucketState) -> TVar BucketState
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx Bucket (TVar BucketState)
#state) (BucketState -> BucketState -> BucketState
`mergeBucketStates` BucketState
bucketState)
          Bucket -> STM Bucket
forall (a :: OpticKind). a -> STM a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
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
      -- we didn't know the key to this bucket, but we might know the bucket
      -- if we truly don't know the bucket, then make a new one
      Bucket
bs <- do
        Maybe Bucket
bucket <- ByteString -> Map ByteString Bucket -> STM (Maybe Bucket)
forall (key :: OpticKind) (value :: OpticKind).
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup ByteString
b (Map ByteString Bucket -> STM (Maybe Bucket))
-> Map ByteString Bucket -> STM (Maybe Bucket)
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ RateLimitState -> Map ByteString Bucket
buckets RateLimitState
s
        case Maybe Bucket
bucket of
          Just Bucket
bs -> Bucket -> STM Bucket
forall (a :: OpticKind). a -> STM a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure Bucket
bs
          Maybe Bucket
Nothing -> do
            Bucket
bs <- TVar BucketState -> Bucket
Bucket (TVar BucketState -> Bucket)
-> STM (TVar BucketState) -> STM Bucket
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> BucketState -> STM (TVar BucketState)
forall (a :: OpticKind). a -> STM (TVar a)
newTVar BucketState
bucketState
            Bucket -> ByteString -> Map ByteString Bucket -> STM ()
forall (key :: OpticKind) (value :: OpticKind).
(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 :: OpticKind) b. (a -> b) -> a -> b
$ RateLimitState -> Map ByteString Bucket
buckets RateLimitState
s
            Bucket -> STM Bucket
forall (a :: OpticKind). a -> STM a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure Bucket
bs

      ByteString -> RouteKey -> Map RouteKey ByteString -> STM ()
forall (key :: OpticKind) (value :: OpticKind).
(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 :: OpticKind) b. (a -> b) -> a -> b
$ RateLimitState -> Map RouteKey ByteString
bucketKeys RateLimitState
s
      Bucket -> STM Bucket
forall (a :: OpticKind). a -> STM a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure Bucket
bs

resetBucket :: Bucket -> STM ()
resetBucket :: Bucket -> STM ()
resetBucket Bucket
bucket =
  TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall (a :: OpticKind). TVar a -> (a -> a) -> STM ()
modifyTVar'
    (Bucket
bucket Bucket
-> Optic' An_Iso NoIx Bucket (TVar BucketState) -> TVar BucketState
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx Bucket (TVar BucketState)
#state)
    ( \BucketState
bs ->
        BucketState
bs
          BucketState -> (BucketState -> BucketState) -> BucketState
forall (a :: OpticKind) (b :: OpticKind). a -> (a -> b) -> b
& Optic A_Lens NoIx BucketState BucketState Int Int
#remaining Optic A_Lens NoIx BucketState BucketState Int Int
-> Int -> BucketState -> BucketState
forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (t :: OpticKind) (a :: OpticKind) (b :: OpticKind).
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ BucketState
bs BucketState
-> Optic A_Lens NoIx BucketState BucketState Int Int -> Int
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx BucketState BucketState Int Int
#limit
          BucketState -> (BucketState -> BucketState) -> BucketState
forall (a :: OpticKind) (b :: OpticKind). a -> (a -> b) -> b
& Optic' A_Lens NoIx BucketState (Maybe UTCTime)
#resetTime Optic' A_Lens NoIx BucketState (Maybe UTCTime)
-> Maybe UTCTime -> BucketState -> BucketState
forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (t :: OpticKind) (a :: OpticKind) (b :: OpticKind).
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Maybe UTCTime
forall (a :: OpticKind). Maybe a
Nothing
    )

canResetBucketNow :: UTCTime -> BucketState -> Bool
canResetBucketNow :: UTCTime -> BucketState -> Bool
canResetBucketNow UTCTime
_ BucketState {Int
$sel:ongoing:BucketState :: BucketState -> Int
ongoing :: Int
ongoing} | Int
ongoing Int -> Int -> Bool
forall (a :: OpticKind). 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
-> Optic' A_Lens NoIx BucketState (Maybe UTCTime) -> Maybe UTCTime
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx BucketState (Maybe UTCTime)
#resetTime of
  Just UTCTime
rt -> UTCTime
now UTCTime -> UTCTime -> Bool
forall (a :: OpticKind). 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
$sel:ongoing:BucketState :: BucketState -> Int
ongoing :: Int
ongoing} = Int
ongoing Int -> Int -> Bool
forall (a :: OpticKind). 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 :: OpticKind).
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WaitDelay -> ShowS
showsPrec :: Int -> WaitDelay -> ShowS
$cshow :: WaitDelay -> [Char]
show :: WaitDelay -> [Char]
$cshowList :: [WaitDelay] -> ShowS
showList :: [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 :: OpticKind). STM a -> IO a
atomically (STM WaitDelay -> IO WaitDelay) -> STM WaitDelay -> IO WaitDelay
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
        BucketState
s <- TVar BucketState -> STM BucketState
forall (a :: OpticKind). TVar a -> STM a
readTVar (TVar BucketState -> STM BucketState)
-> TVar BucketState -> STM BucketState
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Bucket
bucket Bucket
-> Optic' An_Iso NoIx Bucket (TVar BucketState) -> TVar BucketState
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx 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 :: OpticKind -> OpticKind).
Applicative f =>
Bool -> f () -> f ()
when
          (BucketState -> Bool
shouldWaitForUnlock BucketState
s)
          STM ()
forall (a :: OpticKind). 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 :: OpticKind -> OpticKind).
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 :: OpticKind). TVar a -> STM a
readTVar (TVar BucketState -> STM BucketState)
-> TVar BucketState -> STM BucketState
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Bucket
bucket Bucket
-> Optic' An_Iso NoIx Bucket (TVar BucketState) -> TVar BucketState
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx Bucket (TVar BucketState)
#state

        if BucketState
s BucketState
-> Optic A_Lens NoIx BucketState BucketState Int Int -> Int
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx BucketState BucketState Int Int
#remaining Int -> Int -> Int
forall (a :: OpticKind). Num a => a -> a -> a
- BucketState
s BucketState
-> Optic A_Lens NoIx BucketState BucketState Int Int -> Int
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx BucketState BucketState Int Int
#ongoing Int -> Int -> Bool
forall (a :: OpticKind). Ord a => a -> a -> Bool
> Int
0
          then do
            -- there are tokens remaining for us to use
            TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall (a :: OpticKind). TVar a -> (a -> a) -> STM ()
modifyTVar'
              (Bucket
bucket Bucket
-> Optic' An_Iso NoIx Bucket (TVar BucketState) -> TVar BucketState
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx Bucket (TVar BucketState)
#state)
              ( (Optic A_Lens NoIx BucketState BucketState Int Int
#remaining Optic A_Lens NoIx BucketState BucketState Int Int
-> (Int -> Int) -> BucketState -> BucketState
forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (t :: OpticKind) (a :: OpticKind) (b :: OpticKind).
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ Int -> Int
forall (a :: OpticKind). Enum a => a -> a
pred)
                  (BucketState -> BucketState)
-> (BucketState -> BucketState) -> BucketState -> BucketState
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. (Optic A_Lens NoIx BucketState BucketState Int Int
#ongoing Optic A_Lens NoIx BucketState BucketState Int Int
-> (Int -> Int) -> BucketState -> BucketState
forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (t :: OpticKind) (a :: OpticKind) (b :: OpticKind).
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ Int -> Int
forall (a :: OpticKind). Enum a => a -> a
succ)
              )
            WaitDelay -> STM WaitDelay
forall (a :: OpticKind). a -> STM a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
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 (a :: OpticKind). a -> STM a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (Maybe UTCTime -> WaitDelay
intoWaitDelay (Maybe UTCTime -> WaitDelay) -> Maybe UTCTime -> WaitDelay
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ BucketState
s BucketState
-> Optic' A_Lens NoIx BucketState (Maybe UTCTime) -> Maybe UTCTime
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx BucketState (Maybe UTCTime)
#resetTime)

      case WaitDelay
mWaitDelay of
        WaitUntil UTCTime
waitUntil -> do
          if UTCTime
waitUntil UTCTime -> UTCTime -> Bool
forall (a :: OpticKind). 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
          Bool -> IO () -> IO ()
forall (f :: OpticKind -> OpticKind).
Applicative f =>
Bool -> f () -> f ()
when (Int
tries Int -> Int -> Bool
forall (a :: OpticKind). Ord a => a -> a -> Bool
< Int
50) (IO () -> IO ()) -> IO () -> IO ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Int -> IO ()
go (Int
tries Int -> Int -> Int
forall (a :: OpticKind). Num a => a -> a -> a
+ Int
1) -- print "bailing after number of retries"
        WaitDelay
WaitRetrySoon -> do
          Int -> IO ()
threadDelayMS Int
20
          Bool -> IO () -> IO ()
forall (f :: OpticKind -> OpticKind).
Applicative f =>
Bool -> f () -> f ()
when (Int
tries Int -> Int -> Bool
forall (a :: OpticKind). Ord a => a -> a -> Bool
< Int
50) (IO () -> IO ()) -> IO () -> IO ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Int -> IO ()
go (Int
tries Int -> Int -> Int
forall (a :: OpticKind). Num a => a -> a -> a
+ Int
1) -- print "bailing after number of retries"
        WaitDelay
GoNow -> do
          -- print "ok going forward with request"
          () -> IO ()
forall (a :: OpticKind). a -> IO a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure ()

doDiscordRequest :: P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r => IO LbsResponse -> Sem r DiscordResponseType
doDiscordRequest :: forall (r :: EffectRow).
Members '[RatelimitEff, TokenEff, LogEff, Embed IO] r =>
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 :: OpticKind -> OpticKind) (r :: EffectRow)
       (a :: OpticKind).
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 :: OpticKind) b. (a -> b) -> a -> b
$ IO (Either [Char] LbsResponse)
-> (SomeException -> IO (Either [Char] LbsResponse))
-> IO (Either [Char] LbsResponse)
forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
Ex.catchAny (LbsResponse -> Either [Char] LbsResponse
forall (a :: OpticKind) (b :: OpticKind). b -> Either a b
Right (LbsResponse -> Either [Char] LbsResponse)
-> IO LbsResponse -> IO (Either [Char] LbsResponse)
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> IO LbsResponse
r) (Either [Char] LbsResponse -> IO (Either [Char] LbsResponse)
forall (a :: OpticKind). a -> IO a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (Either [Char] LbsResponse -> IO (Either [Char] LbsResponse))
-> (SomeException -> Either [Char] LbsResponse)
-> SomeException
-> IO (Either [Char] LbsResponse)
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. [Char] -> Either [Char] LbsResponse
forall (a :: OpticKind) (b :: OpticKind). a -> Either a b
Left ([Char] -> Either [Char] LbsResponse)
-> (SomeException -> [Char])
-> SomeException
-> Either [Char] LbsResponse
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. SomeException -> [Char]
forall (e :: OpticKind). 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 :: OpticKind). Response body -> Status
responseStatus (Response ByteString -> Status)
-> (LbsResponse -> Response ByteString) -> LbsResponse -> Status
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. LbsResponse -> Response ByteString
LbsResponse -> Response (HttpResponseBody LbsResponse)
forall (response :: OpticKind).
HttpResponse response =>
response -> Response (HttpResponseBody response)
toVanillaResponse (LbsResponse -> Status) -> LbsResponse -> Status
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ LbsResponse
r'
      if
          | Status -> Bool
statusIsSuccessful Status
status -> do
              let resp :: HttpResponseBody LbsResponse
resp = LbsResponse -> HttpResponseBody LbsResponse
forall (response :: OpticKind).
HttpResponse response =>
response -> HttpResponseBody response
responseBody LbsResponse
r'
              Text -> Sem r ()
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug (Text -> Sem r ()) -> Text -> Sem r ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Text
"Got good response from discord: " Text -> Text -> Text
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> ([Char] -> Text
T.pack ([Char] -> Text) -> (Status -> [Char]) -> Status -> Text
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. Status -> [Char]
forall (a :: OpticKind). Show a => a -> [Char]
show (Status -> Text) -> Status -> Text
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Status
status)
              UTCTime
now <- IO UTCTime -> Sem r UTCTime
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
       (a :: OpticKind).
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 :: OpticKind).
HttpResponse r =>
UTCTime -> r -> Maybe (BucketState, ByteString)
buildBucketState UTCTime
now LbsResponse
r'
              DiscordResponseType -> Sem r DiscordResponseType
forall (a :: OpticKind). a -> Sem r a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall (a :: OpticKind) 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 :: OpticKind). Eq a => a -> a -> Bool
== Status
status429 -> do
              UTCTime
now <- IO UTCTime -> Sem r UTCTime
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
       (a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed IO UTCTime
getCurrentTime
              let resp :: HttpResponseBody LbsResponse
resp = LbsResponse -> HttpResponseBody LbsResponse
forall (response :: OpticKind).
HttpResponse response =>
response -> HttpResponseBody response
responseBody LbsResponse
r'
              case (ByteString
HttpResponseBody LbsResponse
resp ByteString -> Optic' A_Prism NoIx ByteString Value -> Maybe Value
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? Optic' A_Prism NoIx ByteString Value
forall (t :: OpticKind). AsValue t => Prism' t Value
_Value, UTCTime -> LbsResponse -> Maybe (BucketState, ByteString)
forall (r :: OpticKind).
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 (a :: OpticKind). a -> Sem r a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall (a :: OpticKind) 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 (a :: OpticKind). a -> Sem r a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall (a :: OpticKind) 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 :: OpticKind).
HttpResponse response =>
response -> HttpResponseBody response
responseBody LbsResponse
r'
              Text -> Sem r ()
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
error (Text -> Sem r ()) -> ([Char] -> Text) -> [Char] -> Sem r ()
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Sem r ()) -> [Char] -> Sem r ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ [Char]
"Something went wrong: " [Char] -> ShowS
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall (a :: OpticKind). Show a => a -> [Char]
show ByteString
HttpResponseBody LbsResponse
err [Char] -> ShowS
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> [Char]
", response: " [Char] -> ShowS
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> LbsResponse -> [Char]
forall (a :: OpticKind). Show a => a -> [Char]
show LbsResponse
r'
              DiscordResponseType -> Sem r DiscordResponseType
forall (a :: OpticKind). a -> Sem r a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall (a :: OpticKind) 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 :: EffectRow). Member LogEff r => Text -> Sem r ()
debug (Text -> Sem r ()) -> ([Char] -> Text) -> [Char] -> Sem r ()
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Sem r ()) -> [Char] -> Sem r ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ [Char]
"Got server error from discord: " [Char] -> ShowS
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> (Int -> [Char]
forall (a :: OpticKind). Show a => a -> [Char]
show (Int -> [Char]) -> (Status -> Int) -> Status -> [Char]
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. Status -> Int
statusCode (Status -> [Char]) -> Status -> [Char]
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Status
status)
              DiscordResponseType -> Sem r DiscordResponseType
forall (a :: OpticKind). a -> Sem r a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Int -> DiscordResponseType
ServerError (Status -> Int
statusCode Status
status)
    Left [Char]
e -> do
      Text -> Sem r ()
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
error (Text -> Sem r ()) -> ([Char] -> Text) -> [Char] -> Sem r ()
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Sem r ()) -> [Char] -> Sem r ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ [Char]
"Something went wrong with the http client: " [Char] -> ShowS
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> [Char]
e
      DiscordResponseType -> Sem r DiscordResponseType
forall (a :: OpticKind). a -> Sem r a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> (Text -> DiscordResponseType)
-> Text
-> Sem r DiscordResponseType
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. Text -> DiscordResponseType
InternalResponseError (Text -> Sem r DiscordResponseType)
-> Text -> Sem r DiscordResponseType
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
e

-- | Parse a ratelimit header returning when it unlocks
parseRateLimitHeader :: HttpResponse r => UTCTime -> r -> Maybe UTCTime
parseRateLimitHeader :: forall (r :: OpticKind).
HttpResponse r =>
UTCTime -> r -> Maybe UTCTime
parseRateLimitHeader UTCTime
now r
r = Maybe UTCTime
computedEnd Maybe UTCTime -> Maybe UTCTime -> Maybe UTCTime
forall (a :: OpticKind). Maybe a -> Maybe a -> Maybe a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
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 :: OpticKind) (b :: OpticKind) (c :: OpticKind).
(a -> b -> c) -> b -> a -> c
flip NominalDiffTime -> UTCTime -> UTCTime
addUTCTime UTCTime
now (NominalDiffTime -> UTCTime)
-> Maybe NominalDiffTime -> Maybe UTCTime
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> Maybe NominalDiffTime
resetAfter

    resetAfter :: Maybe NominalDiffTime
    resetAfter :: Maybe NominalDiffTime
resetAfter = Double -> NominalDiffTime
forall (a :: OpticKind) (b :: OpticKind).
(Real a, Fractional b) =>
a -> b
realToFrac (Double -> NominalDiffTime)
-> Maybe Double -> Maybe NominalDiffTime
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> r -> ByteString -> Maybe ByteString
forall (response :: OpticKind).
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-Ratelimit-Reset-After" Maybe ByteString
-> Optic' A_Prism NoIx (Maybe ByteString) Double -> Maybe Double
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? Prism (Maybe ByteString) (Maybe ByteString) ByteString ByteString
forall (a :: OpticKind) (b :: OpticKind).
Prism (Maybe a) (Maybe b) a b
_Just Prism (Maybe ByteString) (Maybe ByteString) ByteString ByteString
-> Optic A_Prism NoIx ByteString ByteString Double Double
-> Optic' A_Prism NoIx (Maybe ByteString) Double
forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Prism NoIx ByteString ByteString Double Double
forall (t :: OpticKind). AsNumber t => Prism' t Double
_Double

    end :: Maybe UTCTime
    end :: Maybe UTCTime
end =
      NominalDiffTime -> UTCTime
posixSecondsToUTCTime
        (NominalDiffTime -> UTCTime)
-> (Double -> NominalDiffTime) -> Double -> UTCTime
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. Double -> NominalDiffTime
forall (a :: OpticKind) (b :: OpticKind).
(Real a, Fractional b) =>
a -> b
realToFrac
        (Double -> UTCTime) -> Maybe Double -> Maybe UTCTime
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> r -> ByteString -> Maybe ByteString
forall (response :: OpticKind).
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-Ratelimit-Reset"
        Maybe ByteString
-> Optic' A_Prism NoIx (Maybe ByteString) Double -> Maybe Double
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? Prism (Maybe ByteString) (Maybe ByteString) ByteString ByteString
forall (a :: OpticKind) (b :: OpticKind).
Prism (Maybe a) (Maybe b) a b
_Just
        Prism (Maybe ByteString) (Maybe ByteString) ByteString ByteString
-> Optic A_Prism NoIx ByteString ByteString Double Double
-> Optic' A_Prism NoIx (Maybe ByteString) Double
forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Prism NoIx ByteString ByteString Double Double
forall (t :: OpticKind). AsNumber t => Prism' t Double
_Double

buildBucketState :: HttpResponse r => UTCTime -> r -> Maybe (BucketState, B.ByteString)
buildBucketState :: forall (r :: OpticKind).
HttpResponse r =>
UTCTime -> r -> Maybe (BucketState, ByteString)
buildBucketState UTCTime
now r
r = (,) (BucketState -> ByteString -> (BucketState, ByteString))
-> Maybe BucketState
-> Maybe (ByteString -> (BucketState, ByteString))
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> Maybe BucketState
bs Maybe (ByteString -> (BucketState, ByteString))
-> Maybe ByteString -> Maybe (BucketState, ByteString)
forall (a :: OpticKind) (b :: OpticKind).
Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Applicative f =>
f (a -> b) -> f a -> f b
<*> Maybe ByteString
bucketKey
  where
    remaining :: Maybe Int
remaining = r -> ByteString -> Maybe ByteString
forall (response :: OpticKind).
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Remaining" Maybe ByteString
-> Optic' A_Prism NoIx (Maybe ByteString) Int -> Maybe Int
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? Prism (Maybe ByteString) (Maybe ByteString) ByteString ByteString
forall (a :: OpticKind) (b :: OpticKind).
Prism (Maybe a) (Maybe b) a b
_Just Prism (Maybe ByteString) (Maybe ByteString) ByteString ByteString
-> Optic A_Prism NoIx ByteString ByteString Int Int
-> Optic' A_Prism NoIx (Maybe ByteString) Int
forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Prism NoIx ByteString ByteString Int Int
forall (t :: OpticKind) (a :: OpticKind).
(AsNumber t, Integral a) =>
Prism' t a
_Integral
    limit :: Maybe Int
limit = r -> ByteString -> Maybe ByteString
forall (response :: OpticKind).
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Limit" Maybe ByteString
-> Optic' A_Prism NoIx (Maybe ByteString) Int -> Maybe Int
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? Prism (Maybe ByteString) (Maybe ByteString) ByteString ByteString
forall (a :: OpticKind) (b :: OpticKind).
Prism (Maybe a) (Maybe b) a b
_Just Prism (Maybe ByteString) (Maybe ByteString) ByteString ByteString
-> Optic A_Prism NoIx ByteString ByteString Int Int
-> Optic' A_Prism NoIx (Maybe ByteString) Int
forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Prism NoIx ByteString ByteString Int Int
forall (t :: OpticKind) (a :: OpticKind).
(AsNumber t, Integral a) =>
Prism' t a
_Integral
    resetKey :: Maybe Int
resetKey = Double -> Int
forall (b :: OpticKind). Integral b => Double -> b
forall (a :: OpticKind) (b :: OpticKind).
(RealFrac a, Integral b) =>
a -> b
ceiling (Double -> Int) -> Maybe Double -> Maybe Int
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> r -> ByteString -> Maybe ByteString
forall (response :: OpticKind).
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Reset" Maybe ByteString
-> Optic' A_Prism NoIx (Maybe ByteString) Double -> Maybe Double
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? Prism (Maybe ByteString) (Maybe ByteString) ByteString ByteString
forall (a :: OpticKind) (b :: OpticKind).
Prism (Maybe a) (Maybe b) a b
_Just Prism (Maybe ByteString) (Maybe ByteString) ByteString ByteString
-> Optic A_Prism NoIx ByteString ByteString Double Double
-> Optic' A_Prism NoIx (Maybe ByteString) Double
forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Prism NoIx ByteString ByteString Double Double
forall (t :: OpticKind). AsNumber t => Prism' t Double
_Double
    resetTime :: Maybe UTCTime
resetTime = UTCTime -> r -> Maybe UTCTime
forall (r :: OpticKind).
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 :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> Maybe Int
resetKey Maybe (Int -> Int -> Int -> BucketState)
-> Maybe Int -> Maybe (Int -> Int -> BucketState)
forall (a :: OpticKind) (b :: OpticKind).
Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Applicative f =>
f (a -> b) -> f a -> f b
<*> Maybe Int
remaining Maybe (Int -> Int -> BucketState)
-> Maybe Int -> Maybe (Int -> BucketState)
forall (a :: OpticKind) (b :: OpticKind).
Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Applicative f =>
f (a -> b) -> f a -> f b
<*> Maybe Int
limit Maybe (Int -> BucketState) -> Maybe Int -> Maybe BucketState
forall (a :: OpticKind) (b :: OpticKind).
Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Applicative f =>
f (a -> b) -> f a -> f b
<*> Int -> Maybe Int
forall (a :: OpticKind). a -> Maybe a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure Int
0
    bucketKey :: Maybe ByteString
bucketKey = r -> ByteString -> Maybe ByteString
forall (response :: OpticKind).
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Bucket"

-- | Parse the retry after field, returning when to retry
parseRetryAfter :: UTCTime -> Aeson.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 :: OpticKind) (b :: OpticKind).
(Real a, Fractional b) =>
a -> b
realToFrac (Double -> NominalDiffTime) -> Double -> NominalDiffTime
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Value
r Value -> Optic' An_AffineTraversal NoIx Value Double -> Double
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
(HasCallStack, Is k An_AffineFold) =>
s -> Optic' k is s a -> a
^?! Key -> AffineTraversal' Value Value
forall (t :: OpticKind).
AsValue t =>
Key -> AffineTraversal' t Value
key Key
"retry_after" AffineTraversal' Value Value
-> Optic A_Prism NoIx Value Value Double Double
-> Optic' An_AffineTraversal NoIx Value Double
forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Prism NoIx Value Value Double Double
forall (t :: OpticKind). AsNumber t => Prism' t Double
_Double

isGlobal :: Aeson.Value -> Bool
isGlobal :: Value -> Bool
isGlobal Value
r = Value
r Value -> Optic' An_AffineTraversal NoIx Value Bool -> Maybe Bool
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? Key -> AffineTraversal' Value Value
forall (t :: OpticKind).
AsValue t =>
Key -> AffineTraversal' t Value
key Key
"global" AffineTraversal' Value Value
-> Optic A_Prism NoIx Value Value Bool Bool
-> Optic' An_AffineTraversal NoIx Value Bool
forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Prism NoIx Value Value Bool Bool
forall (t :: OpticKind). AsValue t => Prism' t Bool
_Bool Maybe Bool -> Maybe Bool -> Bool
forall (a :: OpticKind). Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall (a :: OpticKind). a -> Maybe a
Just Bool
True

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

retryRequest ::
  P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r =>
  -- | number of retries
  Int ->
  -- | action to perform
  Sem r (ShouldRetry a b) ->
  Sem r (Either a b)
retryRequest :: forall (r :: EffectRow) (a :: OpticKind) (b :: OpticKind).
Members '[RatelimitEff, TokenEff, LogEff, Embed IO] r =>
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 :: OpticKind). Ord a => a -> a -> Bool
> Int
maxRetries -> do
          Text -> Sem r ()
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug (Text -> Sem r ()) -> ([Char] -> Text) -> [Char] -> Sem r ()
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Sem r ()) -> [Char] -> Sem r ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ [Char]
"Request failed after " [Char] -> ShowS
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> Int -> [Char]
forall (a :: OpticKind). Show a => a -> [Char]
show Int
maxRetries [Char] -> ShowS
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> [Char]
" retries"
          Either a b -> Sem r (Either a b)
forall (a :: OpticKind). a -> Sem r a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (Either a b -> Sem r (Either a b))
-> Either a b -> Sem r (Either a b)
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ a -> Either a b
forall (a :: OpticKind) (b :: OpticKind). a -> Either a b
Left a
r
        Retry a
_ ->
          Int -> Sem r (Either a b)
retryInner (Int
numRetries Int -> Int -> Int
forall (a :: OpticKind). Num a => a -> a -> a
+ Int
1)
        RFail a
r -> do
          Text -> Sem r ()
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug Text
"Request failed due to error response"
          Either a b -> Sem r (Either a b)
forall (a :: OpticKind). a -> Sem r a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (Either a b -> Sem r (Either a b))
-> Either a b -> Sem r (Either a b)
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ a -> Either a b
forall (a :: OpticKind) (b :: OpticKind). a -> Either a b
Left a
r
        RGood b
r ->
          Either a b -> Sem r (Either a b)
forall (a :: OpticKind). a -> Sem r a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (Either a b -> Sem r (Either a b))
-> Either a b -> Sem r (Either a b)
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ b -> Either a b
forall (a :: OpticKind) (b :: OpticKind). 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 :: OpticKind). 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 (b :: OpticKind). Integral b => Double -> b
forall (a :: OpticKind) (b :: OpticKind).
(RealFrac a, Integral b) =>
a -> b
ceiling (Double -> Int)
-> (NominalDiffTime -> Double) -> NominalDiffTime -> Int
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall (a :: OpticKind). Num a => a -> a -> a
* Double
1000) (Double -> Double)
-> (NominalDiffTime -> Double) -> NominalDiffTime -> Double
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. forall (a :: OpticKind) (b :: OpticKind).
(Real a, Fractional b) =>
a -> b
realToFrac @_ @Double (NominalDiffTime -> Int) -> NominalDiffTime -> Int
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
when' UTCTime
now
  Int -> IO ()
threadDelayMS Int
msUntil

-- Run a single request
doSingleRequest ::
  P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r =>
  RateLimitState ->
  Route ->
  -- | Global lock
  Event ->
  -- | Request action
  IO LbsResponse ->
  Sem r (ShouldRetry RestError LB.ByteString)
doSingleRequest :: forall (r :: EffectRow).
Members '[RatelimitEff, TokenEff, LogEff, Embed IO] r =>
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 :: OpticKind -> OpticKind) (r :: EffectRow)
       (a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Event -> IO ()
E.wait (RateLimitState -> Event
globalLock RateLimitState
rlstate)

  Ratelimit
rl <- IO Ratelimit -> Sem r Ratelimit
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
       (a :: OpticKind).
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 :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. STM Ratelimit -> IO Ratelimit
forall (a :: OpticKind). STM a -> IO a
atomically (STM Ratelimit -> Sem r Ratelimit)
-> STM Ratelimit -> Sem r Ratelimit
forall (a :: OpticKind) 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 :: OpticKind -> OpticKind) (r :: EffectRow)
       (a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Bucket -> IO ()
useBucketOnce Bucket
bucket
    Ratelimit
_ -> Text -> Sem r ()
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug Text
"unknown ratelimit"

  DiscordResponseType
r' <- IO LbsResponse -> Sem r DiscordResponseType
forall (r :: EffectRow).
Members '[RatelimitEff, TokenEff, LogEff, Embed IO] 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 :: OpticKind -> OpticKind) (a :: OpticKind).
Functor f =>
f a -> f ()
void (Sem r () -> Sem r ())
-> (STM () -> Sem r ()) -> STM () -> Sem r ()
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. IO () -> Sem r ()
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
       (a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> (STM () -> IO ()) -> STM () -> Sem r ()
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall (a :: OpticKind). STM a -> IO a
atomically (STM () -> Sem r ()) -> STM () -> Sem r ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
        case Ratelimit
rl of
          KnownRatelimit Bucket
bucket ->
            TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall (a :: OpticKind). TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket Bucket
-> Optic' An_Iso NoIx Bucket (TVar BucketState) -> TVar BucketState
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx Bucket (TVar BucketState)
#state) (Optic A_Lens NoIx BucketState BucketState Int Int
#ongoing Optic A_Lens NoIx BucketState BucketState Int Int
-> (Int -> Int) -> BucketState -> BucketState
forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (t :: OpticKind) (a :: OpticKind) (b :: OpticKind).
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ Int -> Int
forall (a :: OpticKind). Enum a => a -> a
pred)
          Ratelimit
_ -> () -> STM ()
forall (a :: OpticKind). a -> STM a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure ()
        case (Ratelimit
rl, Maybe (BucketState, ByteString)
rlHeaders) of
          (KnownRatelimit Bucket
bucket, Just (BucketState
bs, ByteString
_bk)) ->
            Bucket -> BucketState -> STM ()
updateKnownBucket Bucket
bucket BucketState
bs
          (Ratelimit
_, Just (BucketState
bs, ByteString
bk)) ->
            STM Bucket -> STM ()
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Functor f =>
f a -> f ()
void (STM Bucket -> STM ()) -> STM Bucket -> STM ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ RateLimitState
-> RouteKey -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
rlstate (Route -> RouteKey
routeKey Route
route) ByteString
bk BucketState
bs
          (Ratelimit
_, Maybe (BucketState, ByteString)
Nothing) -> () -> STM ()
forall (a :: OpticKind). a -> STM a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure ()
      ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (a :: OpticKind). a -> Sem r a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (ShouldRetry RestError ByteString
 -> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ ByteString -> ShouldRetry RestError ByteString
forall (a :: OpticKind) (b :: OpticKind). b -> ShouldRetry a b
RGood ByteString
v
    Ratelimited UTCTime
unlockWhen Bool
False (Just (BucketState
bs, ByteString
bk)) -> do
      Text -> Sem r ()
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug (Text -> Sem r ()) -> ([Char] -> Text) -> [Char] -> Sem r ()
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Sem r ()) -> [Char] -> Sem r ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ [Char]
"429 ratelimited on route, retrying at " [Char] -> ShowS
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> UTCTime -> [Char]
forall (a :: OpticKind). Show a => a -> [Char]
show UTCTime
unlockWhen

      IO () -> Sem r ()
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
       (a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> (STM () -> IO ()) -> STM () -> Sem r ()
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall (a :: OpticKind). STM a -> IO a
atomically (STM () -> Sem r ()) -> STM () -> Sem r ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
        case Ratelimit
rl of
          KnownRatelimit Bucket
bucket -> do
            TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall (a :: OpticKind). TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket Bucket
-> Optic' An_Iso NoIx Bucket (TVar BucketState) -> TVar BucketState
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx Bucket (TVar BucketState)
#state) (Optic A_Lens NoIx BucketState BucketState Int Int
#ongoing Optic A_Lens NoIx BucketState BucketState Int Int
-> (Int -> Int) -> BucketState -> BucketState
forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (t :: OpticKind) (a :: OpticKind) (b :: OpticKind).
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ Int -> Int
forall (a :: OpticKind). Enum a => a -> a
pred)
            Bucket -> BucketState -> STM ()
updateKnownBucket Bucket
bucket BucketState
bs
          Ratelimit
_ -> STM Bucket -> STM ()
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Functor f =>
f a -> f ()
void (STM Bucket -> STM ()) -> STM Bucket -> STM ()
forall (a :: OpticKind) 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 :: OpticKind -> OpticKind) (r :: EffectRow)
       (a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
        UTCTime -> IO ()
threadDelayUntil UTCTime
unlockWhen

      ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (a :: OpticKind). a -> Sem r a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (ShouldRetry RestError ByteString
 -> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall (a :: OpticKind) (b :: OpticKind). a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError Int
429 Maybe Value
forall (a :: OpticKind). Maybe a
Nothing)
    Ratelimited UTCTime
unlockWhen Bool
False Maybe (BucketState, ByteString)
_ -> do
      Text -> Sem r ()
forall (r :: EffectRow). 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 :: OpticKind -> OpticKind) (a :: OpticKind).
Functor f =>
f a -> f ()
void (Sem r () -> Sem r ())
-> (STM () -> Sem r ()) -> STM () -> Sem r ()
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. IO () -> Sem r ()
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
       (a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> (STM () -> IO ()) -> STM () -> Sem r ()
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall (a :: OpticKind). STM a -> IO a
atomically (STM () -> Sem r ()) -> STM () -> Sem r ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall (a :: OpticKind). TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket Bucket
-> Optic' An_Iso NoIx Bucket (TVar BucketState) -> TVar BucketState
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx Bucket (TVar BucketState)
#state) (Optic A_Lens NoIx BucketState BucketState Int Int
#ongoing Optic A_Lens NoIx BucketState BucketState Int Int
-> (Int -> Int) -> BucketState -> BucketState
forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (t :: OpticKind) (a :: OpticKind) (b :: OpticKind).
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ Int -> Int
forall (a :: OpticKind). Enum a => a -> a
pred)
        Ratelimit
_ -> () -> Sem r ()
forall (a :: OpticKind). a -> Sem r a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure ()

      IO () -> Sem r ()
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
       (a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ UTCTime -> IO ()
threadDelayUntil UTCTime
unlockWhen
      ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (a :: OpticKind). a -> Sem r a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (ShouldRetry RestError ByteString
 -> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall (a :: OpticKind) (b :: OpticKind). a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError Int
429 Maybe Value
forall (a :: OpticKind). Maybe a
Nothing)
    Ratelimited UTCTime
unlockWhen Bool
True Maybe (BucketState, ByteString)
bs -> do
      Text -> Sem r ()
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug Text
"429 ratelimited globally"

      IO () -> Sem r ()
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
       (a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
        STM () -> IO ()
forall (a :: OpticKind). STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
          case Ratelimit
rl of
            KnownRatelimit Bucket
bucket ->
              TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall (a :: OpticKind). TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket Bucket
-> Optic' An_Iso NoIx Bucket (TVar BucketState) -> TVar BucketState
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx Bucket (TVar BucketState)
#state) (Optic A_Lens NoIx BucketState BucketState Int Int
#ongoing Optic A_Lens NoIx BucketState BucketState Int Int
-> (Int -> Int) -> BucketState -> BucketState
forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (t :: OpticKind) (a :: OpticKind) (b :: OpticKind).
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ Int -> Int
forall (a :: OpticKind). Enum a => a -> a
pred)
            Ratelimit
_ -> () -> STM ()
forall (a :: OpticKind). a -> STM a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure ()
          case Maybe (BucketState, ByteString)
bs of
            Just (BucketState
bs', ByteString
bk) ->
              STM Bucket -> STM ()
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Functor f =>
f a -> f ()
void (STM Bucket -> STM ()) -> STM Bucket -> STM ()
forall (a :: OpticKind) 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 (a :: OpticKind). a -> STM a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
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 (a :: OpticKind). a -> Sem r a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (ShouldRetry RestError ByteString
 -> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall (a :: OpticKind) (b :: OpticKind). a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError Int
429 Maybe Value
forall (a :: OpticKind). Maybe a
Nothing)
    ServerError Int
c -> do
      Text -> Sem r ()
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug Text
"Server failed, retrying"
      case Ratelimit
rl of
        KnownRatelimit Bucket
bucket ->
          IO () -> Sem r ()
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
       (a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Bucket -> IO ()
useBucketOnce Bucket
bucket
        Ratelimit
_ -> Text -> Sem r ()
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug Text
"unknown ratelimit"
      ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (a :: OpticKind). a -> Sem r a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (ShouldRetry RestError ByteString
 -> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall (a :: OpticKind) (b :: OpticKind). a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError Int
c Maybe Value
forall (a :: OpticKind). Maybe a
Nothing)
    InternalResponseError Text
c -> do
      Text -> Sem r ()
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug Text
"Internal error, retrying"
      case Ratelimit
rl of
        KnownRatelimit Bucket
bucket ->
          IO () -> Sem r ()
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
       (a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Bucket -> IO ()
useBucketOnce Bucket
bucket
        Ratelimit
_ -> Text -> Sem r ()
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug Text
"unknown ratelimit"
      ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (a :: OpticKind). a -> Sem r a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (ShouldRetry RestError ByteString
 -> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall (a :: OpticKind) (b :: OpticKind). 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 :: OpticKind -> OpticKind) (r :: EffectRow)
       (a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Bucket -> IO ()
useBucketOnce Bucket
bucket
        Ratelimit
_ -> Text -> Sem r ()
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug Text
"unknown ratelimit"
      ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (a :: OpticKind). a -> Sem r a
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (ShouldRetry RestError ByteString
 -> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall (a :: OpticKind) (b :: OpticKind). a -> ShouldRetry a b
RFail (Int -> Maybe Value -> RestError
HTTPError Int
c (Maybe Value -> RestError) -> Maybe Value -> RestError
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ ByteString -> Maybe Value
forall (a :: OpticKind). FromJSON a => ByteString -> Maybe a
Aeson.decode ByteString
v)

doRequest :: P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r => RateLimitState -> Route -> IO LbsResponse -> Sem r (Either RestError LB.ByteString)
doRequest :: forall (r :: EffectRow).
Members '[RatelimitEff, TokenEff, LogEff, Embed IO] r =>
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 :: EffectRow) (a :: OpticKind) (b :: OpticKind).
Members '[RatelimitEff, TokenEff, LogEff, Embed IO] 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 :: EffectRow).
Members '[RatelimitEff, TokenEff, LogEff, Embed IO] r =>
RateLimitState
-> Route
-> Event
-> IO LbsResponse
-> Sem r (ShouldRetry RestError ByteString)
doSingleRequest RateLimitState
rlstate Route
route (RateLimitState -> Event
globalLock RateLimitState
rlstate) IO LbsResponse
action)