{-# LANGUAGE TemplateHaskell #-}
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 qualified Control.Concurrent.Event as E
import Control.Concurrent.STM
import qualified Control.Exception.Safe as Ex
import Control.Monad
import qualified Data.Aeson as Aeson
import Data.Aeson.Optics
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import Data.Maybe
import qualified Data.Text 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 qualified Polysemy as P
import PyF
import qualified StmContainers.Map as SC
import Prelude hiding (error)
import qualified Prelude
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 forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
(b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> forall (key :: OpticKind) (value :: OpticKind). IO (Map key value)
SC.newIO forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
(b :: OpticKind).
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall (key :: OpticKind) (value :: OpticKind). IO (Map key value)
SC.newIO 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 <- forall (key :: OpticKind) (value :: OpticKind).
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup RouteKey
h forall (a :: OpticKind) b. (a -> b) -> a -> b
$ RateLimitState -> Map RouteKey ByteString
bucketKeys RateLimitState
s
Maybe Bucket
bucket <- forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
Monad m =>
m (m a) -> m a
join forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
(b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> forall (t :: OpticKind -> OpticKind) (f :: OpticKind -> OpticKind)
(a :: OpticKind).
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (forall (a :: OpticKind) (b :: OpticKind) (c :: OpticKind).
(a -> b -> c) -> b -> a -> c
flip 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) forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
(b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> Maybe ByteString
bucketKey)
case Maybe Bucket
bucket of
Just Bucket
bucket' ->
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Bucket -> Ratelimit
KnownRatelimit Bucket
bucket'
Maybe Bucket
Nothing ->
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure 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 forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "ongoing" a => a
#ongoing
,
$sel:remaining:BucketState :: Int
remaining =
if forall (a :: OpticKind). Maybe a -> Bool
isJust (BucketState
old forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "resetTime" a => a
#resetTime) Bool -> Bool -> Bool
&& BucketState
old forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "resetKey" a => a
#resetKey forall (a :: OpticKind). Eq a => a -> a -> Bool
/= BucketState
new forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "resetKey" a => a
#resetKey
then forall (a :: OpticKind). Ord a => a -> a -> a
min (BucketState
old forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "remaining" a => a
#remaining) (BucketState
new forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "remaining" a => a
#remaining)
else BucketState
new forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "remaining" a => a
#remaining
,
$sel:resetTime:BucketState :: Maybe UTCTime
resetTime =
if BucketState
old forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "resetKey" a => a
#resetKey forall (a :: OpticKind). Eq a => a -> a -> Bool
/= BucketState
new forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "resetKey" a => a
#resetKey
then BucketState
new forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "resetTime" a => a
#resetTime
else BucketState
old forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "resetTime" a => a
#resetTime
}
updateKnownBucket :: Bucket -> BucketState -> STM ()
updateKnownBucket :: Bucket -> BucketState -> STM ()
updateKnownBucket Bucket
bucket BucketState
bucketState = forall (a :: OpticKind). TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "state" a => a
#state) (BucketState -> BucketState -> BucketState
`mergeBucketStates` BucketState
bucketState)
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 <- forall (key :: OpticKind) (value :: OpticKind).
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup RouteKey
h forall (a :: OpticKind) b. (a -> b) -> a -> b
$ RateLimitState -> Map RouteKey ByteString
bucketKeys RateLimitState
s
case Maybe ByteString
bucketKey of
Just ByteString
bucketKey' -> do
Maybe Bucket
bucket <- forall (key :: OpticKind) (value :: OpticKind).
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup ByteString
bucketKey' forall (a :: OpticKind) b. (a -> b) -> a -> b
$ RateLimitState -> Map ByteString Bucket
buckets RateLimitState
s
case Maybe Bucket
bucket of
Just Bucket
bucket' -> do
forall (a :: OpticKind). TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket' forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "state" a => a
#state) (BucketState -> BucketState -> BucketState
`mergeBucketStates` BucketState
bucketState)
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure Bucket
bucket'
Maybe Bucket
Nothing -> forall a. HasCallStack => [Char] -> a
Prelude.error [Char]
"Not possible"
Maybe ByteString
Nothing -> do
Bucket
bs <- do
Maybe Bucket
bucket <- forall (key :: OpticKind) (value :: OpticKind).
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup ByteString
b forall (a :: OpticKind) b. (a -> b) -> a -> b
$ RateLimitState -> Map ByteString Bucket
buckets RateLimitState
s
case Maybe Bucket
bucket of
Just Bucket
bs -> forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure Bucket
bs
Maybe Bucket
Nothing -> do
Bucket
bs <- TVar BucketState -> Bucket
Bucket forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
(b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> forall (a :: OpticKind). a -> STM (TVar a)
newTVar BucketState
bucketState
forall (key :: OpticKind) (value :: OpticKind).
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
SC.insert Bucket
bs ByteString
b forall (a :: OpticKind) b. (a -> b) -> a -> b
$ RateLimitState -> Map ByteString Bucket
buckets RateLimitState
s
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure Bucket
bs
forall (key :: OpticKind) (value :: OpticKind).
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
SC.insert ByteString
b RouteKey
h forall (a :: OpticKind) b. (a -> b) -> a -> b
$ RateLimitState -> Map RouteKey ByteString
bucketKeys RateLimitState
s
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure Bucket
bs
resetBucket :: Bucket -> STM ()
resetBucket :: Bucket -> STM ()
resetBucket Bucket
bucket =
forall (a :: OpticKind). TVar a -> (a -> a) -> STM ()
modifyTVar'
(Bucket
bucket forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "state" a => a
#state)
( \BucketState
bs ->
BucketState
bs forall (a :: OpticKind) (b :: OpticKind). a -> (a -> b) -> b
& forall (a :: OpticKind). IsLabel "remaining" a => a
#remaining 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 forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "limit" a => a
#limit
forall (a :: OpticKind) (b :: OpticKind). a -> (a -> b) -> b
& forall (a :: OpticKind). IsLabel "resetTime" a => a
#resetTime 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
.~ forall (a :: OpticKind). 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 forall (a :: OpticKind). Ord a => a -> a -> Bool
> Int
0 = Bool
False
canResetBucketNow UTCTime
now BucketState
bs = case BucketState
bs forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "resetTime" a => a
#resetTime of
Just UTCTime
rt -> UTCTime
now forall (a :: OpticKind). Ord a => a -> a -> Bool
> UTCTime
rt
Maybe UTCTime
Nothing -> Bool
False
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 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]
forall (a :: OpticKind).
(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
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 <- forall (a :: OpticKind). STM a -> IO a
atomically forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
BucketState
s <- forall (a :: OpticKind). TVar a -> STM a
readTVar forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Bucket
bucket forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "state" a => a
#state
forall (f :: OpticKind -> OpticKind).
Applicative f =>
Bool -> f () -> f ()
when
(BucketState -> Bool
shouldWaitForUnlock BucketState
s)
forall (a :: OpticKind). STM a
retry
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 <- forall (a :: OpticKind). TVar a -> STM a
readTVar forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Bucket
bucket forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "state" a => a
#state
if BucketState
s forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "remaining" a => a
#remaining forall (a :: OpticKind). Num a => a -> a -> a
- BucketState
s forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "ongoing" a => a
#ongoing forall (a :: OpticKind). Ord a => a -> a -> Bool
> Int
0
then do
forall (a :: OpticKind). TVar a -> (a -> a) -> STM ()
modifyTVar'
(Bucket
bucket forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "state" a => a
#state)
( (forall (a :: OpticKind). IsLabel "remaining" a => a
#remaining 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
%~ forall (a :: OpticKind). Enum a => a -> a
pred)
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. (forall (a :: OpticKind). IsLabel "ongoing" a => a
#ongoing 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
%~ forall (a :: OpticKind). Enum a => a -> a
succ)
)
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure WaitDelay
GoNow
else do
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (Maybe UTCTime -> WaitDelay
intoWaitDelay forall (a :: OpticKind) b. (a -> b) -> a -> b
$ BucketState
s forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "resetTime" a => a
#resetTime)
case WaitDelay
mWaitDelay of
WaitUntil UTCTime
waitUntil -> do
if UTCTime
waitUntil forall (a :: OpticKind). Ord a => a -> a -> Bool
< UTCTime
now
then Int -> IO ()
threadDelayMS Int
20
else
UTCTime -> IO ()
threadDelayUntil UTCTime
waitUntil
if Int
tries forall (a :: OpticKind). Ord a => a -> a -> Bool
< Int
50
then Int -> IO ()
go (Int
tries forall (a :: OpticKind). Num a => a -> a -> a
+ Int
1)
else forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure ()
WaitDelay
WaitRetrySoon -> do
Int -> IO ()
threadDelayMS Int
20
if Int
tries forall (a :: OpticKind). Ord a => a -> a -> Bool
< Int
50
then Int -> IO ()
go (Int
tries forall (a :: OpticKind). Num a => a -> a -> a
+ Int
1)
else forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure ()
WaitDelay
GoNow -> do
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'' <- forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
(a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed forall (a :: OpticKind) b. (a -> b) -> a -> b
$ forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
Ex.catchAny (forall (a :: OpticKind) (b :: OpticKind). b -> Either a b
Right forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
(b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> IO LbsResponse
r) (forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. forall (a :: OpticKind) (b :: OpticKind). a -> Either a b
Left forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. forall (e :: OpticKind). Exception e => e -> [Char]
Ex.displayException)
case Either [Char] LbsResponse
r'' of
Right LbsResponse
r' -> do
let status :: Status
status = forall (body :: OpticKind). Response body -> Status
responseStatus forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. forall (response :: OpticKind).
HttpResponse response =>
response -> Response (HttpResponseBody response)
toVanillaResponse forall (a :: OpticKind) b. (a -> b) -> a -> b
$ LbsResponse
r'
if
| Status -> Bool
statusIsSuccessful Status
status -> do
let resp :: HttpResponseBody LbsResponse
resp = forall (response :: OpticKind).
HttpResponse response =>
response -> HttpResponseBody response
responseBody LbsResponse
r'
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Text
"Got good response from discord: " forall (a :: OpticKind). Semigroup a => a -> a -> a
<> ([Char] -> Text
T.pack forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. forall (a :: OpticKind). Show a => a -> [Char]
show forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Status
status)
UTCTime
now <- 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 = forall (r :: OpticKind).
HttpResponse r =>
UTCTime -> r -> Maybe (BucketState, ByteString)
buildBucketState UTCTime
now LbsResponse
r'
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (a :: OpticKind) b. (a -> b) -> a -> b
$ ByteString
-> Maybe (BucketState, ByteString) -> DiscordResponseType
Good HttpResponseBody LbsResponse
resp Maybe (BucketState, ByteString)
rlHeaders
| Status
status forall (a :: OpticKind). Eq a => a -> a -> Bool
== Status
status429 -> do
UTCTime
now <- 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 = forall (response :: OpticKind).
HttpResponse response =>
response -> HttpResponseBody response
responseBody LbsResponse
r'
case (HttpResponseBody LbsResponse
resp forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? forall (t :: OpticKind). AsValue t => Prism' t Value
_Value, forall (r :: OpticKind).
HttpResponse r =>
UTCTime -> r -> Maybe (BucketState, ByteString)
buildBucketState UTCTime
now LbsResponse
r') of
(Just !Value
rv, Maybe (BucketState, ByteString)
bs) ->
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure 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))
_ ->
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure 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 = forall (response :: OpticKind).
HttpResponse response =>
response -> HttpResponseBody response
responseBody LbsResponse
r'
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
error forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall (a :: OpticKind) b. (a -> b) -> a -> b
$ ([Char]
"Something went wrong: " forall (a :: OpticKind). Semigroup a => a -> a -> a
<> forall (a :: OpticKind). Show a => a -> [Char]
show HttpResponseBody LbsResponse
err forall (a :: OpticKind). Semigroup a => a -> a -> a
<> [Char]
", response: " forall (a :: OpticKind). Semigroup a => a -> a -> a
<> forall (a :: OpticKind). Show a => a -> [Char]
show LbsResponse
r')
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Int -> ByteString -> DiscordResponseType
ClientError (Status -> Int
statusCode Status
status) HttpResponseBody LbsResponse
err
| Bool
otherwise -> do
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall (a :: OpticKind) b. (a -> b) -> a -> b
$ [Char]
"Got server error from discord: " forall (a :: OpticKind). Semigroup a => a -> a -> a
<> (forall (a :: OpticKind). Show a => a -> [Char]
show forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. Status -> Int
statusCode forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Status
status)
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Int -> DiscordResponseType
ServerError (Status -> Int
statusCode Status
status)
Left [Char]
e -> do
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
error forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall (a :: OpticKind) b. (a -> b) -> a -> b
$ [Char]
"Something went wrong with the http client: " forall (a :: OpticKind). Semigroup a => a -> a -> a
<> [Char]
e
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. Text -> DiscordResponseType
InternalResponseError forall (a :: OpticKind) b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
e
parseRateLimitHeader :: HttpResponse r => UTCTime -> r -> Maybe UTCTime
UTCTime
now r
r = Maybe UTCTime
computedEnd 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 = forall (a :: OpticKind) (b :: OpticKind) (c :: OpticKind).
(a -> b -> c) -> b -> a -> c
flip NominalDiffTime -> UTCTime -> UTCTime
addUTCTime UTCTime
now 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 = forall (a :: OpticKind) (b :: OpticKind).
(Real a, Fractional b) =>
a -> b
realToFrac forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
(b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> forall (response :: OpticKind).
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-Ratelimit-Reset-After" forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? forall (a :: OpticKind) (b :: OpticKind).
Prism (Maybe a) (Maybe b) a b
_Just 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
% forall (t :: OpticKind). AsNumber t => Prism' t Double
_Double
end :: Maybe UTCTime
end :: Maybe UTCTime
end =
NominalDiffTime -> UTCTime
posixSecondsToUTCTime 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
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
(b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> forall (response :: OpticKind).
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-Ratelimit-Reset" forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? forall (a :: OpticKind) (b :: OpticKind).
Prism (Maybe a) (Maybe b) a b
_Just 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
% 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 = (,) forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
(b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> Maybe BucketState
bs 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 = forall (response :: OpticKind).
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Remaining" forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? forall (a :: OpticKind) (b :: OpticKind).
Prism (Maybe a) (Maybe b) a b
_Just 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
% forall (t :: OpticKind) (a :: OpticKind).
(AsNumber t, Integral a) =>
Prism' t a
_Integral
limit :: Maybe Int
limit = forall (response :: OpticKind).
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Limit" forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? forall (a :: OpticKind) (b :: OpticKind).
Prism (Maybe a) (Maybe b) a b
_Just 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
% forall (t :: OpticKind) (a :: OpticKind).
(AsNumber t, Integral a) =>
Prism' t a
_Integral
resetKey :: Maybe Int
resetKey = forall (a :: OpticKind) (b :: OpticKind).
(RealFrac a, Integral b) =>
a -> b
ceiling forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
(b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> forall (response :: OpticKind).
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Reset" forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? forall (a :: OpticKind) (b :: OpticKind).
Prism (Maybe a) (Maybe b) a b
_Just 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
% forall (t :: OpticKind). AsNumber t => Prism' t Double
_Double
resetTime :: Maybe UTCTime
resetTime = 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 forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
(b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> Maybe Int
resetKey forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
(b :: OpticKind).
Applicative f =>
f (a -> b) -> f a -> f b
<*> Maybe Int
remaining forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
(b :: OpticKind).
Applicative f =>
f (a -> b) -> f a -> f b
<*> Maybe Int
limit forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
(b :: OpticKind).
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure Int
0
bucketKey :: Maybe ByteString
bucketKey = forall (response :: OpticKind).
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Bucket"
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 = forall (a :: OpticKind) (b :: OpticKind).
(Real a, Fractional b) =>
a -> b
realToFrac forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Value
r forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
(HasCallStack, Is k An_AffineFold) =>
s -> Optic' k is s a -> a
^?! forall (t :: OpticKind).
AsValue t =>
Key -> AffineTraversal' t Value
key Key
"retry_after" 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
% forall (t :: OpticKind). AsNumber t => Prism' t Double
_Double
isGlobal :: Aeson.Value -> Bool
isGlobal :: Value -> Bool
isGlobal Value
r = Value
r forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? forall (t :: OpticKind).
AsValue t =>
Key -> AffineTraversal' t Value
key Key
"global" 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
% forall (t :: OpticKind). AsValue t => Prism' t Bool
_Bool forall (a :: OpticKind). Eq a => a -> a -> Bool
== forall (a :: OpticKind). a -> Maybe a
Just Bool
True
data ShouldRetry a b
= Retry a
| RFail a
| RGood b
retryRequest ::
P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r =>
Int ->
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 forall (a :: OpticKind). Ord a => a -> a -> Bool
> Int
maxRetries -> do
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall (a :: OpticKind) b. (a -> b) -> a -> b
$ [Char]
"Request failed after " forall (a :: OpticKind). Semigroup a => a -> a -> a
<> forall (a :: OpticKind). Show a => a -> [Char]
show Int
maxRetries forall (a :: OpticKind). Semigroup a => a -> a -> a
<> [Char]
" retries"
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (a :: OpticKind) b. (a -> b) -> 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 forall (a :: OpticKind). Num a => a -> a -> a
+ Int
1)
RFail a
r -> do
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug Text
"Request failed due to error response"
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (a :: OpticKind) b. (a -> b) -> a -> b
$ forall (a :: OpticKind) (b :: OpticKind). a -> Either a b
Left a
r
RGood b
r ->
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (a :: OpticKind) b. (a -> b) -> 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 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
UTCTime
now <- IO UTCTime
getCurrentTime
let msUntil :: Int
msUntil = forall (a :: OpticKind) (b :: OpticKind).
(RealFrac a, Integral b) =>
a -> b
ceiling forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. (forall (a :: OpticKind). Num a => a -> a -> a
* Double
1000) 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 forall (a :: OpticKind) b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
when' UTCTime
now
Int -> IO ()
threadDelayMS Int
msUntil
doSingleRequest ::
P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r =>
RateLimitState ->
Route ->
Event ->
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
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
(a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Event -> IO ()
E.wait (RateLimitState -> Event
globalLock RateLimitState
rlstate)
Ratelimit
rl <- forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
(a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. forall (a :: OpticKind). STM a -> IO a
atomically 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 ->
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
(a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Bucket -> IO ()
useBucketOnce Bucket
bucket
Ratelimit
_ -> forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug Text
"unknown ratelimit"
DiscordResponseType
r' <- 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
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Functor f =>
f a -> f ()
void forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
(a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. forall (a :: OpticKind). STM a -> IO a
atomically forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
case Ratelimit
rl of
KnownRatelimit Bucket
bucket ->
forall (a :: OpticKind). TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "state" a => a
#state) (forall (a :: OpticKind). IsLabel "ongoing" a => a
#ongoing 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
%~ forall (a :: OpticKind). Enum a => a -> a
pred)
Ratelimit
_ -> 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)) ->
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Functor f =>
f a -> f ()
void 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) -> forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure ()
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (a :: OpticKind) b. (a -> b) -> a -> b
$ forall (a :: OpticKind) (b :: OpticKind). b -> ShouldRetry a b
RGood ByteString
v
Ratelimited UTCTime
unlockWhen Bool
False (Just (BucketState
bs, ByteString
bk)) -> do
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall (a :: OpticKind) b. (a -> b) -> a -> b
$ [Char]
"429 ratelimited on route, retrying at " forall (a :: OpticKind). Semigroup a => a -> a -> a
<> forall (a :: OpticKind). Show a => a -> [Char]
show UTCTime
unlockWhen
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
(a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. forall (a :: OpticKind). STM a -> IO a
atomically forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
case Ratelimit
rl of
KnownRatelimit Bucket
bucket -> do
forall (a :: OpticKind). TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "state" a => a
#state) (forall (a :: OpticKind). IsLabel "ongoing" a => a
#ongoing 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
%~ forall (a :: OpticKind). Enum a => a -> a
pred)
Bucket -> BucketState -> STM ()
updateKnownBucket Bucket
bucket BucketState
bs
Ratelimit
_ -> forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Functor f =>
f a -> f ()
void 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
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
(a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
UTCTime -> IO ()
threadDelayUntil UTCTime
unlockWhen
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (a :: OpticKind) b. (a -> b) -> a -> b
$ forall (a :: OpticKind) (b :: OpticKind). a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError Int
429 forall (a :: OpticKind). Maybe a
Nothing)
Ratelimited UTCTime
unlockWhen Bool
False Maybe (BucketState, ByteString)
_ -> do
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 ->
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Functor f =>
f a -> f ()
void forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
(a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. forall (a :: OpticKind). STM a -> IO a
atomically forall (a :: OpticKind) b. (a -> b) -> a -> b
$ forall (a :: OpticKind). TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "state" a => a
#state) (forall (a :: OpticKind). IsLabel "ongoing" a => a
#ongoing 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
%~ forall (a :: OpticKind). Enum a => a -> a
pred)
Ratelimit
_ -> forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure ()
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
(a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed forall (a :: OpticKind) b. (a -> b) -> a -> b
$ UTCTime -> IO ()
threadDelayUntil UTCTime
unlockWhen
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (a :: OpticKind) b. (a -> b) -> a -> b
$ forall (a :: OpticKind) (b :: OpticKind). a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError Int
429 forall (a :: OpticKind). Maybe a
Nothing)
Ratelimited UTCTime
unlockWhen Bool
True Maybe (BucketState, ByteString)
bs -> do
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug Text
"429 ratelimited globally"
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
(a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
forall (a :: OpticKind). STM a -> IO a
atomically forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
case Ratelimit
rl of
KnownRatelimit Bucket
bucket ->
forall (a :: OpticKind). TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
(a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "state" a => a
#state) (forall (a :: OpticKind). IsLabel "ongoing" a => a
#ongoing 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
%~ forall (a :: OpticKind). Enum a => a -> a
pred)
Ratelimit
_ -> forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure ()
case Maybe (BucketState, ByteString)
bs of
Just (BucketState
bs', ByteString
bk) ->
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Functor f =>
f a -> f ()
void 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 ->
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
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (a :: OpticKind) b. (a -> b) -> a -> b
$ forall (a :: OpticKind) (b :: OpticKind). a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError Int
429 forall (a :: OpticKind). Maybe a
Nothing)
ServerError Int
c -> do
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug Text
"Server failed, retrying"
case Ratelimit
rl of
KnownRatelimit Bucket
bucket ->
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
(a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Bucket -> IO ()
useBucketOnce Bucket
bucket
Ratelimit
_ -> forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug Text
"unknown ratelimit"
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (a :: OpticKind) b. (a -> b) -> a -> b
$ forall (a :: OpticKind) (b :: OpticKind). a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError Int
c forall (a :: OpticKind). Maybe a
Nothing)
InternalResponseError Text
c -> do
forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug Text
"Internal error, retrying"
case Ratelimit
rl of
KnownRatelimit Bucket
bucket ->
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
(a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Bucket -> IO ()
useBucketOnce Bucket
bucket
Ratelimit
_ -> forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug Text
"unknown ratelimit"
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (a :: OpticKind) b. (a -> b) -> a -> b
$ 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 ->
forall (m :: OpticKind -> OpticKind) (r :: EffectRow)
(a :: OpticKind).
Member (Embed m) r =>
m a -> Sem r a
P.embed forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Bucket -> IO ()
useBucketOnce Bucket
bucket
Ratelimit
_ -> forall (r :: EffectRow). Member LogEff r => Text -> Sem r ()
debug Text
"unknown ratelimit"
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (a :: OpticKind) b. (a -> b) -> a -> b
$ forall (a :: OpticKind) (b :: OpticKind). a -> ShouldRetry a b
RFail (Int -> Maybe Value -> RestError
HTTPError Int
c forall (a :: OpticKind) b. (a -> b) -> a -> b
$ 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 =
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
(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)