module Calamity.HTTP.Internal.Ratelimit (
newRateLimitState,
doRequest,
) where
import Calamity.Client.Types (BotC)
import Calamity.HTTP.Internal.Route
import Calamity.HTTP.Internal.Types
import Calamity.Internal.Utils
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.Event (Event)
import qualified Control.Concurrent.Event as E
import Control.Concurrent.STM
import Control.Lens
import Control.Monad
import Data.Aeson
import Data.Aeson.Lens
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import Data.Maybe
import qualified Data.Text.Lazy as LT
import Data.Time
import Data.Time.Clock.POSIX
import Fmt
import Network.HTTP.Client (responseStatus)
import Network.HTTP.Req
import Network.HTTP.Types
import Polysemy (Sem)
import qualified Polysemy as P
import Prelude hiding (error)
import qualified Prelude
import qualified Control.Exception.Safe as Ex
import qualified StmContainers.Map as SC
newRateLimitState :: IO RateLimitState
newRateLimitState :: IO RateLimitState
newRateLimitState = Map RouteKey ByteString
-> Map ByteString Bucket -> Event -> RateLimitState
RateLimitState (Map RouteKey ByteString
-> Map ByteString Bucket -> Event -> RateLimitState)
-> IO (Map RouteKey ByteString)
-> IO (Map ByteString Bucket -> Event -> RateLimitState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map RouteKey ByteString)
forall key value. IO (Map key value)
SC.newIO IO (Map ByteString Bucket -> Event -> RateLimitState)
-> IO (Map ByteString Bucket) -> IO (Event -> RateLimitState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Map ByteString Bucket)
forall key value. IO (Map key value)
SC.newIO IO (Event -> RateLimitState) -> IO Event -> IO RateLimitState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Event
E.newSet
data Ratelimit
= KnownRatelimit Bucket
| UnknownRatelimit RouteKey
getRateLimit :: RateLimitState -> RouteKey -> STM Ratelimit
getRateLimit :: RateLimitState -> RouteKey -> STM Ratelimit
getRateLimit RateLimitState
s RouteKey
h = do
Maybe ByteString
bucketKey <- RouteKey -> Map RouteKey ByteString -> STM (Maybe ByteString)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup RouteKey
h (Map RouteKey ByteString -> STM (Maybe ByteString))
-> Map RouteKey ByteString -> STM (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Map RouteKey ByteString
bucketKeys RateLimitState
s
Maybe Bucket
bucket <- Maybe (Maybe Bucket) -> Maybe Bucket
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Bucket) -> Maybe Bucket)
-> STM (Maybe (Maybe Bucket)) -> STM (Maybe Bucket)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (STM (Maybe Bucket)) -> STM (Maybe (Maybe Bucket))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ((ByteString -> Map ByteString Bucket -> STM (Maybe Bucket))
-> Map ByteString Bucket -> ByteString -> STM (Maybe Bucket)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ByteString -> Map ByteString Bucket -> STM (Maybe Bucket)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup (RateLimitState -> Map ByteString Bucket
buckets RateLimitState
s) (ByteString -> STM (Maybe Bucket))
-> Maybe ByteString -> Maybe (STM (Maybe Bucket))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
bucketKey)
case Maybe Bucket
bucket of
Just Bucket
bucket' ->
Ratelimit -> STM Ratelimit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ratelimit -> STM Ratelimit) -> Ratelimit -> STM Ratelimit
forall a b. (a -> b) -> a -> b
$ Bucket -> Ratelimit
KnownRatelimit Bucket
bucket'
Maybe Bucket
Nothing ->
Ratelimit -> STM Ratelimit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ratelimit -> STM Ratelimit) -> Ratelimit -> STM Ratelimit
forall a b. (a -> b) -> a -> b
$ RouteKey -> Ratelimit
UnknownRatelimit RouteKey
h
updateBucket :: RateLimitState -> RouteKey -> B.ByteString -> BucketState -> STM Bucket
updateBucket :: RateLimitState
-> RouteKey -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
s RouteKey
h ByteString
b BucketState
bucketState = do
Maybe ByteString
bucketKey <- RouteKey -> Map RouteKey ByteString -> STM (Maybe ByteString)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup RouteKey
h (Map RouteKey ByteString -> STM (Maybe ByteString))
-> Map RouteKey ByteString -> STM (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Map RouteKey ByteString
bucketKeys RateLimitState
s
case Maybe ByteString
bucketKey of
Just ByteString
bucketKey' -> do
Maybe Bucket
bucket <- ByteString -> Map ByteString Bucket -> STM (Maybe Bucket)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup ByteString
bucketKey' (Map ByteString Bucket -> STM (Maybe Bucket))
-> Map ByteString Bucket -> STM (Maybe Bucket)
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Map ByteString Bucket
buckets RateLimitState
s
case Maybe Bucket
bucket of
Just Bucket
bucket' -> do
TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket' Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
"state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state) (BucketState -> BucketState -> BucketState
`mergeStates` BucketState
bucketState)
Bucket -> STM Bucket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bucket
bucket'
Maybe Bucket
Nothing -> [Char] -> STM Bucket
forall a. HasCallStack => [Char] -> a
Prelude.error [Char]
"Not possible"
Maybe ByteString
Nothing -> do
Bucket
bs <- TVar BucketState -> Bucket
Bucket (TVar BucketState -> Bucket)
-> STM (TVar BucketState) -> STM Bucket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BucketState -> STM (TVar BucketState)
forall a. a -> STM (TVar a)
newTVar BucketState
bucketState
Bucket -> ByteString -> Map ByteString Bucket -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
SC.insert Bucket
bs ByteString
b (Map ByteString Bucket -> STM ())
-> Map ByteString Bucket -> STM ()
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Map ByteString Bucket
buckets RateLimitState
s
ByteString -> RouteKey -> Map RouteKey ByteString -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
SC.insert ByteString
b RouteKey
h (Map RouteKey ByteString -> STM ())
-> Map RouteKey ByteString -> STM ()
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Map RouteKey ByteString
bucketKeys RateLimitState
s
Bucket -> STM Bucket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bucket
bs
where
mergeStates :: BucketState -> BucketState -> BucketState
mergeStates :: BucketState -> BucketState -> BucketState
mergeStates BucketState
old BucketState
new =
BucketState
new
{ $sel:ongoing:BucketState :: Int
ongoing = BucketState
old BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "ongoing" (Getting Int BucketState Int)
Getting Int BucketState Int
#ongoing
,
$sel:remaining:BucketState :: Int
remaining =
if (Maybe UTCTime -> Bool
forall a. Maybe a -> Bool
isJust (Maybe UTCTime -> Bool) -> Maybe UTCTime -> Bool
forall a b. (a -> b) -> a -> b
$ BucketState
old BucketState
-> Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
-> Maybe UTCTime
forall s a. s -> Getting a s a -> a
^. IsLabel
"resetTime" (Getting (Maybe UTCTime) BucketState (Maybe UTCTime))
Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
#resetTime) Bool -> Bool -> Bool
&& (BucketState
old BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "resetKey" (Getting Int BucketState Int)
Getting Int BucketState Int
#resetKey Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= BucketState
new BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "resetKey" (Getting Int BucketState Int)
Getting Int BucketState Int
#resetKey)
then Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (BucketState
old BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "remaining" (Getting Int BucketState Int)
Getting Int BucketState Int
#remaining) (BucketState
new BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "remaining" (Getting Int BucketState Int)
Getting Int BucketState Int
#remaining)
else BucketState
new BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "remaining" (Getting Int BucketState Int)
Getting Int BucketState Int
#remaining
,
$sel:resetTime:BucketState :: Maybe UTCTime
resetTime =
if BucketState
old BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "resetKey" (Getting Int BucketState Int)
Getting Int BucketState Int
#resetKey Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= BucketState
new BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "resetKey" (Getting Int BucketState Int)
Getting Int BucketState Int
#resetKey
then BucketState
new BucketState
-> Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
-> Maybe UTCTime
forall s a. s -> Getting a s a -> a
^. IsLabel
"resetTime" (Getting (Maybe UTCTime) BucketState (Maybe UTCTime))
Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
#resetTime
else BucketState
old BucketState
-> Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
-> Maybe UTCTime
forall s a. s -> Getting a s a -> a
^. IsLabel
"resetTime" (Getting (Maybe UTCTime) BucketState (Maybe UTCTime))
Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
#resetTime
}
resetBucket :: Bucket -> STM ()
resetBucket :: Bucket -> STM ()
resetBucket Bucket
bucket =
TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar'
(Bucket
bucket Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
"state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state)
( \BucketState
bs ->
BucketState
bs BucketState -> (BucketState -> BucketState) -> BucketState
forall a b. a -> (a -> b) -> b
& IsLabel "remaining" (ASetter BucketState BucketState Int Int)
ASetter BucketState BucketState Int Int
#remaining ASetter BucketState BucketState Int Int
-> Int -> BucketState -> BucketState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ BucketState
bs BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "limit" (Getting Int BucketState Int)
Getting Int BucketState Int
#limit
BucketState -> (BucketState -> BucketState) -> BucketState
forall a b. a -> (a -> b) -> b
& IsLabel
"resetTime"
(ASetter BucketState BucketState (Maybe UTCTime) (Maybe UTCTime))
ASetter BucketState BucketState (Maybe UTCTime) (Maybe UTCTime)
#resetTime ASetter BucketState BucketState (Maybe UTCTime) (Maybe UTCTime)
-> Maybe UTCTime -> BucketState -> BucketState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe UTCTime
forall a. Maybe a
Nothing
)
canResetBucketNow :: UTCTime -> BucketState -> Bool
canResetBucketNow :: UTCTime -> BucketState -> Bool
canResetBucketNow UTCTime
_ BucketState{Int
ongoing :: Int
$sel:ongoing:BucketState :: BucketState -> Int
ongoing} | Int
ongoing Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Bool
False
canResetBucketNow UTCTime
now BucketState
bs = case BucketState
bs BucketState
-> Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
-> Maybe UTCTime
forall s a. s -> Getting a s a -> a
^. IsLabel
"resetTime" (Getting (Maybe UTCTime) BucketState (Maybe UTCTime))
Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
#resetTime of
Just UTCTime
rt -> UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
rt
Maybe UTCTime
Nothing -> Bool
False
shouldWaitForUnlock :: BucketState -> Bool
shouldWaitForUnlock :: BucketState -> Bool
shouldWaitForUnlock BucketState{$sel:remaining:BucketState :: BucketState -> Int
remaining = Int
0, Int
ongoing :: Int
$sel:ongoing:BucketState :: BucketState -> Int
ongoing} = Int
ongoing Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
shouldWaitForUnlock BucketState
_ = Bool
False
data WaitDelay
= WaitUntil UTCTime
| WaitRetrySoon
| GoNow
deriving (Int -> WaitDelay -> ShowS
[WaitDelay] -> ShowS
WaitDelay -> [Char]
(Int -> WaitDelay -> ShowS)
-> (WaitDelay -> [Char])
-> ([WaitDelay] -> ShowS)
-> Show WaitDelay
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [WaitDelay] -> ShowS
$cshowList :: [WaitDelay] -> ShowS
show :: WaitDelay -> [Char]
$cshow :: WaitDelay -> [Char]
showsPrec :: Int -> WaitDelay -> ShowS
$cshowsPrec :: Int -> WaitDelay -> ShowS
Show)
intoWaitDelay :: Maybe UTCTime -> WaitDelay
intoWaitDelay :: Maybe UTCTime -> WaitDelay
intoWaitDelay (Just UTCTime
t) = UTCTime -> WaitDelay
WaitUntil UTCTime
t
intoWaitDelay Maybe UTCTime
Nothing = WaitDelay
WaitRetrySoon
useBucketOnce :: Bucket -> IO ()
useBucketOnce :: Bucket -> IO ()
useBucketOnce Bucket
bucket = Int -> IO ()
go Int
0
where
go :: Int -> IO ()
go :: Int -> IO ()
go Int
tries = do
UTCTime
now <- IO UTCTime
getCurrentTime
WaitDelay
mWaitDelay <- STM WaitDelay -> IO WaitDelay
forall a. STM a -> IO a
atomically (STM WaitDelay -> IO WaitDelay) -> STM WaitDelay -> IO WaitDelay
forall a b. (a -> b) -> a -> b
$ do
BucketState
s <- TVar BucketState -> STM BucketState
forall a. TVar a -> STM a
readTVar (TVar BucketState -> STM BucketState)
-> TVar BucketState -> STM BucketState
forall a b. (a -> b) -> a -> b
$ Bucket
bucket Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
"state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
(BucketState -> Bool
shouldWaitForUnlock BucketState
s)
STM ()
forall a. STM a
retry
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
(UTCTime -> BucketState -> Bool
canResetBucketNow UTCTime
now BucketState
s)
(Bucket -> STM ()
resetBucket Bucket
bucket)
BucketState
s <- TVar BucketState -> STM BucketState
forall a. TVar a -> STM a
readTVar (TVar BucketState -> STM BucketState)
-> TVar BucketState -> STM BucketState
forall a b. (a -> b) -> a -> b
$ Bucket
bucket Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
"state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state
if BucketState
s BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "remaining" (Getting Int BucketState Int)
Getting Int BucketState Int
#remaining Int -> Int -> Int
forall a. Num a => a -> a -> a
- BucketState
s BucketState -> Getting Int BucketState Int -> Int
forall s a. s -> Getting a s a -> a
^. IsLabel "ongoing" (Getting Int BucketState Int)
Getting Int BucketState Int
#ongoing Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
then do
TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar'
(Bucket
bucket Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
"state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state)
( (IsLabel "remaining" (ASetter BucketState BucketState Int Int)
ASetter BucketState BucketState Int Int
#remaining ASetter BucketState BucketState Int Int
-> Int -> BucketState -> BucketState
forall a s t. Num a => ASetter s t a a -> a -> s -> t
-~ Int
1)
(BucketState -> BucketState)
-> (BucketState -> BucketState) -> BucketState -> BucketState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IsLabel "ongoing" (ASetter BucketState BucketState Int Int)
ASetter BucketState BucketState Int Int
#ongoing ASetter BucketState BucketState Int Int
-> Int -> BucketState -> BucketState
forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Int
1)
)
WaitDelay -> STM WaitDelay
forall (f :: * -> *) a. Applicative f => a -> f a
pure WaitDelay
GoNow
else do
WaitDelay -> STM WaitDelay
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe UTCTime -> WaitDelay
intoWaitDelay (Maybe UTCTime -> WaitDelay) -> Maybe UTCTime -> WaitDelay
forall a b. (a -> b) -> a -> b
$ BucketState
s BucketState
-> Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
-> Maybe UTCTime
forall s a. s -> Getting a s a -> a
^. IsLabel
"resetTime" (Getting (Maybe UTCTime) BucketState (Maybe UTCTime))
Getting (Maybe UTCTime) BucketState (Maybe UTCTime)
#resetTime)
case WaitDelay
mWaitDelay of
WaitUntil UTCTime
waitUntil -> do
if UTCTime
waitUntil UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
now
then Int -> IO ()
threadDelayMS Int
20
else
UTCTime -> IO ()
threadDelayUntil UTCTime
waitUntil
if Int
tries Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
50
then Int -> IO ()
go (Int
tries Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
else () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
WaitDelay
WaitRetrySoon -> do
Int -> IO ()
threadDelayMS Int
20
if Int
tries Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
50
then Int -> IO ()
go (Int
tries Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
else () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
WaitDelay
GoNow -> do
() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
doDiscordRequest :: BotC r => IO LbsResponse -> Sem r DiscordResponseType
doDiscordRequest :: IO LbsResponse -> Sem r DiscordResponseType
doDiscordRequest IO LbsResponse
r = do
Either [Char] LbsResponse
r'' <- IO (Either [Char] LbsResponse) -> Sem r (Either [Char] LbsResponse)
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO (Either [Char] LbsResponse)
-> Sem r (Either [Char] LbsResponse))
-> IO (Either [Char] LbsResponse)
-> Sem r (Either [Char] LbsResponse)
forall a b. (a -> b) -> a -> b
$ IO (Either [Char] LbsResponse)
-> (SomeException -> IO (Either [Char] LbsResponse))
-> IO (Either [Char] LbsResponse)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
Ex.catchAny (LbsResponse -> Either [Char] LbsResponse
forall a b. b -> Either a b
Right (LbsResponse -> Either [Char] LbsResponse)
-> IO LbsResponse -> IO (Either [Char] LbsResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO LbsResponse
r) (Either [Char] LbsResponse -> IO (Either [Char] LbsResponse)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] LbsResponse -> IO (Either [Char] LbsResponse))
-> (SomeException -> Either [Char] LbsResponse)
-> SomeException
-> IO (Either [Char] LbsResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Either [Char] LbsResponse
forall a b. a -> Either a b
Left ([Char] -> Either [Char] LbsResponse)
-> (SomeException -> [Char])
-> SomeException
-> Either [Char] LbsResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> [Char]
forall e. Exception e => e -> [Char]
Ex.displayException)
case Either [Char] LbsResponse
r'' of
Right LbsResponse
r' -> do
let status :: Status
status = Response ByteString -> Status
forall body. Response body -> Status
responseStatus (Response ByteString -> Status)
-> (LbsResponse -> Response ByteString) -> LbsResponse -> Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LbsResponse -> Response ByteString
forall response.
HttpResponse response =>
response -> Response (HttpResponseBody response)
toVanillaResponse (LbsResponse -> Status) -> LbsResponse -> Status
forall a b. (a -> b) -> a -> b
$ LbsResponse
r'
if
| Status -> Bool
statusIsSuccessful Status
status -> do
let resp :: HttpResponseBody LbsResponse
resp = LbsResponse -> HttpResponseBody LbsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody LbsResponse
r'
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Builder
"Got good response from discord: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+|| Status
status Status -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ Builder
""
UTCTime
now <- IO UTCTime -> Sem r UTCTime
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed IO UTCTime
getCurrentTime
let rlHeaders :: Maybe (BucketState, ByteString)
rlHeaders = UTCTime -> LbsResponse -> Maybe (BucketState, ByteString)
forall r.
HttpResponse r =>
UTCTime -> r -> Maybe (BucketState, ByteString)
buildBucketState UTCTime
now LbsResponse
r'
DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ ByteString
-> Maybe (BucketState, ByteString) -> DiscordResponseType
Good ByteString
HttpResponseBody LbsResponse
resp Maybe (BucketState, ByteString)
rlHeaders
| Status
status Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status429 -> do
UTCTime
now <- IO UTCTime -> Sem r UTCTime
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed IO UTCTime
getCurrentTime
let resp :: HttpResponseBody LbsResponse
resp = LbsResponse -> HttpResponseBody LbsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody LbsResponse
r'
case (ByteString
HttpResponseBody LbsResponse
resp ByteString -> Getting (First Value) ByteString Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First Value) ByteString Value
forall t. AsValue t => Prism' t Value
_Value, UTCTime -> LbsResponse -> Maybe (BucketState, ByteString)
forall r.
HttpResponse r =>
UTCTime -> r -> Maybe (BucketState, ByteString)
buildBucketState UTCTime
now LbsResponse
r') of
(Just !Value
rv, Maybe (BucketState, ByteString)
bs) ->
DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ UTCTime
-> Bool -> Maybe (BucketState, ByteString) -> DiscordResponseType
Ratelimited (UTCTime -> Value -> UTCTime
parseRetryAfter UTCTime
now Value
rv) (Value -> Bool
isGlobal Value
rv) Maybe (BucketState, ByteString)
bs
(Maybe Value, Maybe (BucketState, ByteString))
_ ->
DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ Int -> DiscordResponseType
ServerError (Status -> Int
statusCode Status
status)
| Status -> Bool
statusIsClientError Status
status -> do
let err :: HttpResponseBody LbsResponse
err = LbsResponse -> HttpResponseBody LbsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody LbsResponse
r'
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
error (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Builder
"Something went wrong: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+|| ByteString
HttpResponseBody LbsResponse
err ByteString -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ Builder
" response: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|| LbsResponse
r' LbsResponse -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ Builder
""
DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> DiscordResponseType
ClientError (Status -> Int
statusCode Status
status) ByteString
HttpResponseBody LbsResponse
err
| Bool
otherwise -> do
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Builder
"Got server error from discord: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Status -> Int
statusCode Status
status Int -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ Int -> DiscordResponseType
ServerError (Status -> Int
statusCode Status
status)
Left [Char]
e -> do
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
error (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Builder
"Something went wrong with the http client: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| [Char] -> Text
LT.pack [Char]
e Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> (Text -> DiscordResponseType)
-> Text
-> Sem r DiscordResponseType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DiscordResponseType
InternalResponseError (Text -> Sem r DiscordResponseType)
-> Text -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
LT.pack [Char]
e
parseRateLimitHeader :: HttpResponse r => UTCTime -> r -> Maybe UTCTime
UTCTime
now r
r = Maybe UTCTime
computedEnd Maybe UTCTime -> Maybe UTCTime -> Maybe UTCTime
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe UTCTime
end
where
computedEnd :: Maybe UTCTime
computedEnd :: Maybe UTCTime
computedEnd = (NominalDiffTime -> UTCTime -> UTCTime)
-> UTCTime -> NominalDiffTime -> UTCTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip NominalDiffTime -> UTCTime -> UTCTime
addUTCTime UTCTime
now (NominalDiffTime -> UTCTime)
-> Maybe NominalDiffTime -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NominalDiffTime
resetAfter
resetAfter :: Maybe NominalDiffTime
resetAfter :: Maybe NominalDiffTime
resetAfter = Double -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> NominalDiffTime)
-> Maybe Double -> Maybe NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-Ratelimit-Reset-After" Maybe ByteString
-> Getting (First Double) (Maybe ByteString) Double -> Maybe Double
forall s a. s -> Getting (First a) s a -> Maybe a
^? (ByteString -> Const (First Double) ByteString)
-> Maybe ByteString -> Const (First Double) (Maybe ByteString)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((ByteString -> Const (First Double) ByteString)
-> Maybe ByteString -> Const (First Double) (Maybe ByteString))
-> ((Double -> Const (First Double) Double)
-> ByteString -> Const (First Double) ByteString)
-> Getting (First Double) (Maybe ByteString) Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Const (First Double) Double)
-> ByteString -> Const (First Double) ByteString
forall t. AsNumber t => Prism' t Double
_Double
end :: Maybe UTCTime
end :: Maybe UTCTime
end =
NominalDiffTime -> UTCTime
posixSecondsToUTCTime (NominalDiffTime -> UTCTime)
-> (Double -> NominalDiffTime) -> Double -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac
(Double -> UTCTime) -> Maybe Double -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-Ratelimit-Reset" Maybe ByteString
-> Getting (First Double) (Maybe ByteString) Double -> Maybe Double
forall s a. s -> Getting (First a) s a -> Maybe a
^? (ByteString -> Const (First Double) ByteString)
-> Maybe ByteString -> Const (First Double) (Maybe ByteString)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((ByteString -> Const (First Double) ByteString)
-> Maybe ByteString -> Const (First Double) (Maybe ByteString))
-> ((Double -> Const (First Double) Double)
-> ByteString -> Const (First Double) ByteString)
-> Getting (First Double) (Maybe ByteString) Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Const (First Double) Double)
-> ByteString -> Const (First Double) ByteString
forall t. AsNumber t => Prism' t Double
_Double
buildBucketState :: HttpResponse r => UTCTime -> r -> Maybe (BucketState, B.ByteString)
buildBucketState :: UTCTime -> r -> Maybe (BucketState, ByteString)
buildBucketState UTCTime
now r
r = (,) (BucketState -> ByteString -> (BucketState, ByteString))
-> Maybe BucketState
-> Maybe (ByteString -> (BucketState, ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe BucketState
bs Maybe (ByteString -> (BucketState, ByteString))
-> Maybe ByteString -> Maybe (BucketState, ByteString)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe ByteString
bucketKey
where
remaining :: Maybe Int
remaining = r -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Remaining" Maybe ByteString
-> Getting (First Int) (Maybe ByteString) Int -> Maybe Int
forall s a. s -> Getting (First a) s a -> Maybe a
^? (ByteString -> Const (First Int) ByteString)
-> Maybe ByteString -> Const (First Int) (Maybe ByteString)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((ByteString -> Const (First Int) ByteString)
-> Maybe ByteString -> Const (First Int) (Maybe ByteString))
-> ((Int -> Const (First Int) Int)
-> ByteString -> Const (First Int) ByteString)
-> Getting (First Int) (Maybe ByteString) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const (First Int) Int)
-> ByteString -> Const (First Int) ByteString
forall t a. (AsNumber t, Integral a) => Prism' t a
_Integral
limit :: Maybe Int
limit = r -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Limit" Maybe ByteString
-> Getting (First Int) (Maybe ByteString) Int -> Maybe Int
forall s a. s -> Getting (First a) s a -> Maybe a
^? (ByteString -> Const (First Int) ByteString)
-> Maybe ByteString -> Const (First Int) (Maybe ByteString)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((ByteString -> Const (First Int) ByteString)
-> Maybe ByteString -> Const (First Int) (Maybe ByteString))
-> ((Int -> Const (First Int) Int)
-> ByteString -> Const (First Int) ByteString)
-> Getting (First Int) (Maybe ByteString) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const (First Int) Int)
-> ByteString -> Const (First Int) ByteString
forall t a. (AsNumber t, Integral a) => Prism' t a
_Integral
resetKey :: Maybe Int
resetKey = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Int) -> Maybe Double -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Reset" Maybe ByteString
-> Getting (First Double) (Maybe ByteString) Double -> Maybe Double
forall s a. s -> Getting (First a) s a -> Maybe a
^? (ByteString -> Const (First Double) ByteString)
-> Maybe ByteString -> Const (First Double) (Maybe ByteString)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((ByteString -> Const (First Double) ByteString)
-> Maybe ByteString -> Const (First Double) (Maybe ByteString))
-> ((Double -> Const (First Double) Double)
-> ByteString -> Const (First Double) ByteString)
-> Getting (First Double) (Maybe ByteString) Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Const (First Double) Double)
-> ByteString -> Const (First Double) ByteString
forall t. AsNumber t => Prism' t Double
_Double
resetTime :: Maybe UTCTime
resetTime = UTCTime -> r -> Maybe UTCTime
forall r. HttpResponse r => UTCTime -> r -> Maybe UTCTime
parseRateLimitHeader UTCTime
now r
r
bs :: Maybe BucketState
bs = Maybe UTCTime -> Int -> Int -> Int -> Int -> BucketState
BucketState Maybe UTCTime
resetTime (Int -> Int -> Int -> Int -> BucketState)
-> Maybe Int -> Maybe (Int -> Int -> Int -> BucketState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
resetKey Maybe (Int -> Int -> Int -> BucketState)
-> Maybe Int -> Maybe (Int -> Int -> BucketState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int
remaining Maybe (Int -> Int -> BucketState)
-> Maybe Int -> Maybe (Int -> BucketState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int
limit Maybe (Int -> BucketState) -> Maybe Int -> Maybe BucketState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Maybe Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
bucketKey :: Maybe ByteString
bucketKey = r -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Bucket"
parseRetryAfter :: UTCTime -> Value -> UTCTime
parseRetryAfter :: UTCTime -> Value -> UTCTime
parseRetryAfter UTCTime
now Value
r = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
retryAfter UTCTime
now
where
retryAfter :: NominalDiffTime
retryAfter = Double -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> NominalDiffTime) -> Double -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ Value
r Value -> Getting (Endo Double) Value Double -> Double
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"retry_after" ((Value -> Const (Endo Double) Value)
-> Value -> Const (Endo Double) Value)
-> Getting (Endo Double) Value Double
-> Getting (Endo Double) Value Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo Double) Value Double
forall t. AsNumber t => Prism' t Double
_Double
isGlobal :: Value -> Bool
isGlobal :: Value -> Bool
isGlobal Value
r = Value
r Value -> Getting (First Bool) Value Bool -> Maybe Bool
forall s a. s -> Getting (First a) s a -> Maybe a
^? Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"global" ((Value -> Const (First Bool) Value)
-> Value -> Const (First Bool) Value)
-> Getting (First Bool) Value Bool
-> Getting (First Bool) Value Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Bool) Value Bool
forall t. AsPrimitive t => Prism' t Bool
_Bool Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
data ShouldRetry a b
= Retry a
| RFail a
| RGood b
retryRequest ::
BotC r =>
Int ->
Sem r (ShouldRetry a b) ->
Sem r (Either a b)
retryRequest :: Int -> Sem r (ShouldRetry a b) -> Sem r (Either a b)
retryRequest Int
maxRetries Sem r (ShouldRetry a b)
action = Int -> Sem r (Either a b)
retryInner Int
0
where
retryInner :: Int -> Sem r (Either a b)
retryInner Int
numRetries = do
ShouldRetry a b
res <- Sem r (ShouldRetry a b)
action
case ShouldRetry a b
res of
Retry a
r | Int
numRetries Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxRetries -> do
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Builder
"Request failed after " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Int
maxRetries Int -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" retries."
Either a b -> Sem r (Either a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a b -> Sem r (Either a b))
-> Either a b -> Sem r (Either a b)
forall a b. (a -> b) -> a -> b
$ a -> Either a b
forall a b. a -> Either a b
Left a
r
Retry a
_ ->
Int -> Sem r (Either a b)
retryInner (Int
numRetries Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
RFail a
r -> do
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"Request failed due to error response."
Either a b -> Sem r (Either a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a b -> Sem r (Either a b))
-> Either a b -> Sem r (Either a b)
forall a b. (a -> b) -> a -> b
$ a -> Either a b
forall a b. a -> Either a b
Left a
r
RGood b
r ->
Either a b -> Sem r (Either a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a b -> Sem r (Either a b))
-> Either a b -> Sem r (Either a b)
forall a b. (a -> b) -> a -> b
$ b -> Either a b
forall a b. b -> Either a b
Right b
r
threadDelayMS :: Int -> IO ()
threadDelayMS :: Int -> IO ()
threadDelayMS Int
ms = Int -> IO ()
threadDelay (Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
ms)
tenMS :: NominalDiffTime
tenMS :: NominalDiffTime
tenMS = NominalDiffTime
0.01
threadDelayUntil :: UTCTime -> IO ()
threadDelayUntil :: UTCTime -> IO ()
threadDelayUntil UTCTime
when = do
let when' :: UTCTime
when' = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
tenMS UTCTime
when
UTCTime
now <- IO UTCTime
getCurrentTime
let msUntil :: Int
msUntil = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Int)
-> (NominalDiffTime -> Double) -> NominalDiffTime -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000) (Double -> Double)
-> (NominalDiffTime -> Double) -> NominalDiffTime -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Real NominalDiffTime, Fractional Double) =>
NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac @_ @Double (NominalDiffTime -> Int) -> NominalDiffTime -> Int
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
when' UTCTime
now
Int -> IO ()
threadDelayMS Int
msUntil
doSingleRequest ::
BotC r =>
RateLimitState ->
Route ->
Event ->
IO LbsResponse ->
Sem r (ShouldRetry RestError LB.ByteString)
doSingleRequest :: RateLimitState
-> Route
-> Event
-> IO LbsResponse
-> Sem r (ShouldRetry RestError ByteString)
doSingleRequest RateLimitState
rlstate Route
route Event
gl IO LbsResponse
r = do
IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Event -> IO ()
E.wait (RateLimitState -> Event
globalLock RateLimitState
rlstate)
Ratelimit
rl <- IO Ratelimit -> Sem r Ratelimit
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO Ratelimit -> Sem r Ratelimit)
-> (STM Ratelimit -> IO Ratelimit)
-> STM Ratelimit
-> Sem r Ratelimit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Ratelimit -> IO Ratelimit
forall a. STM a -> IO a
atomically (STM Ratelimit -> Sem r Ratelimit)
-> STM Ratelimit -> Sem r Ratelimit
forall a b. (a -> b) -> a -> b
$ RateLimitState -> RouteKey -> STM Ratelimit
getRateLimit RateLimitState
rlstate (Route -> RouteKey
routeKey Route
route)
case Ratelimit
rl of
KnownRatelimit Bucket
bucket ->
IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Bucket -> IO ()
useBucketOnce Bucket
bucket
Ratelimit
_ -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"unknown ratelimit"
DiscordResponseType
r' <- IO LbsResponse -> Sem r DiscordResponseType
forall (r :: [(* -> *) -> * -> *]).
BotC r =>
IO LbsResponse -> Sem r DiscordResponseType
doDiscordRequest IO LbsResponse
r
case DiscordResponseType
r' of
Good ByteString
v Maybe (BucketState, ByteString)
rlHeaders -> do
Sem r () -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r () -> Sem r ())
-> (STM () -> Sem r ()) -> STM () -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> (STM () -> IO ()) -> STM () -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> Sem r ()) -> STM () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
case Ratelimit
rl of
KnownRatelimit Bucket
bucket ->
TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
"state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state) (IsLabel "ongoing" (ASetter BucketState BucketState Int Int)
ASetter BucketState BucketState Int Int
#ongoing ASetter BucketState BucketState Int Int
-> Int -> BucketState -> BucketState
forall a s t. Num a => ASetter s t a a -> a -> s -> t
-~ Int
1)
Ratelimit
_ -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
case Maybe (BucketState, ByteString)
rlHeaders of
Just (BucketState
bs, ByteString
bk) ->
STM Bucket -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM Bucket -> STM ()) -> STM Bucket -> STM ()
forall a b. (a -> b) -> a -> b
$ RateLimitState
-> RouteKey -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
rlstate (Route -> RouteKey
routeKey Route
route) ByteString
bk BucketState
bs
Maybe (BucketState, ByteString)
Nothing -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ShouldRetry RestError ByteString
forall a b. b -> ShouldRetry a b
RGood ByteString
v
Ratelimited UTCTime
unlockWhen Bool
False (Just (BucketState
bs, ByteString
bk)) -> do
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Builder
"429 ratelimited on route, retrying at " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| UTCTime
unlockWhen UTCTime -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> (STM () -> IO ()) -> STM () -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> Sem r ()) -> STM () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
case Ratelimit
rl of
KnownRatelimit Bucket
bucket ->
TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
"state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state) (IsLabel "ongoing" (ASetter BucketState BucketState Int Int)
ASetter BucketState BucketState Int Int
#ongoing ASetter BucketState BucketState Int Int
-> Int -> BucketState -> BucketState
forall a s t. Num a => ASetter s t a a -> a -> s -> t
-~ Int
1)
Ratelimit
_ -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
STM Bucket -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM Bucket -> STM ()) -> STM Bucket -> STM ()
forall a b. (a -> b) -> a -> b
$ RateLimitState
-> RouteKey -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
rlstate (Route -> RouteKey
routeKey Route
route) ByteString
bk BucketState
bs
IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
UTCTime -> IO ()
threadDelayUntil UTCTime
unlockWhen
ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall a b. a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError Int
429 Maybe Value
forall a. Maybe a
Nothing)
Ratelimited UTCTime
unlockWhen Bool
False Maybe (BucketState, ByteString)
_ -> do
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"Internal error (ratelimited but no headers), retrying"
case Ratelimit
rl of
KnownRatelimit Bucket
bucket ->
Sem r () -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r () -> Sem r ())
-> (STM () -> Sem r ()) -> STM () -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> (STM () -> IO ()) -> STM () -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> Sem r ()) -> STM () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
"state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state) (IsLabel "ongoing" (ASetter BucketState BucketState Int Int)
ASetter BucketState BucketState Int Int
#ongoing ASetter BucketState BucketState Int Int
-> Int -> BucketState -> BucketState
forall a s t. Num a => ASetter s t a a -> a -> s -> t
-~ Int
1)
Ratelimit
_ -> () -> Sem r ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> IO ()
threadDelayUntil UTCTime
unlockWhen
ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall a b. a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError Int
429 Maybe Value
forall a. Maybe a
Nothing)
Ratelimited UTCTime
unlockWhen Bool
True Maybe (BucketState, ByteString)
bs -> do
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"429 ratelimited globally"
IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
case Ratelimit
rl of
KnownRatelimit Bucket
bucket ->
TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
"state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state) (IsLabel "ongoing" (ASetter BucketState BucketState Int Int)
ASetter BucketState BucketState Int Int
#ongoing ASetter BucketState BucketState Int Int
-> Int -> BucketState -> BucketState
forall a s t. Num a => ASetter s t a a -> a -> s -> t
-~ Int
1)
Ratelimit
_ -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
case Maybe (BucketState, ByteString)
bs of
Just (BucketState
bs', ByteString
bk) ->
STM Bucket -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM Bucket -> STM ()) -> STM Bucket -> STM ()
forall a b. (a -> b) -> a -> b
$ RateLimitState
-> RouteKey -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
rlstate (Route -> RouteKey
routeKey Route
route) ByteString
bk BucketState
bs'
Maybe (BucketState, ByteString)
Nothing ->
() -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Event -> IO ()
E.clear Event
gl
UTCTime -> IO ()
threadDelayUntil UTCTime
unlockWhen
Event -> IO ()
E.set Event
gl
ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall a b. a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError Int
429 Maybe Value
forall a. Maybe a
Nothing)
ServerError Int
c -> do
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"Server failed, retrying"
case Ratelimit
rl of
KnownRatelimit Bucket
bucket ->
IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Bucket -> IO ()
useBucketOnce Bucket
bucket
Ratelimit
_ -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"unknown ratelimit"
ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall a b. a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError Int
c Maybe Value
forall a. Maybe a
Nothing)
InternalResponseError Text
c -> do
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"Internal error, retrying"
case Ratelimit
rl of
KnownRatelimit Bucket
bucket ->
IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Bucket -> IO ()
useBucketOnce Bucket
bucket
Ratelimit
_ -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"unknown ratelimit"
ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall a b. a -> ShouldRetry a b
Retry (Text -> RestError
InternalClientError Text
c)
ClientError Int
c ByteString
v -> do
case Ratelimit
rl of
KnownRatelimit Bucket
bucket ->
IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Bucket -> IO ()
useBucketOnce Bucket
bucket
Ratelimit
_ -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"unknown ratelimit"
ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall a b. a -> ShouldRetry a b
RFail (Int -> Maybe Value -> RestError
HTTPError Int
c (Maybe Value -> RestError) -> Maybe Value -> RestError
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
v)
doRequest :: BotC r => RateLimitState -> Route -> IO LbsResponse -> Sem r (Either RestError LB.ByteString)
doRequest :: RateLimitState
-> Route -> IO LbsResponse -> Sem r (Either RestError ByteString)
doRequest RateLimitState
rlstate Route
route IO LbsResponse
action =
Int
-> Sem r (ShouldRetry RestError ByteString)
-> Sem r (Either RestError ByteString)
forall (r :: [(* -> *) -> * -> *]) a b.
BotC r =>
Int -> Sem r (ShouldRetry a b) -> Sem r (Either a b)
retryRequest
Int
5
(RateLimitState
-> Route
-> Event
-> IO LbsResponse
-> Sem r (ShouldRetry RestError ByteString)
forall (r :: [(* -> *) -> * -> *]).
BotC r =>
RateLimitState
-> Route
-> Event
-> IO LbsResponse
-> Sem r (ShouldRetry RestError ByteString)
doSingleRequest RateLimitState
rlstate Route
route (RateLimitState -> Event
globalLock RateLimitState
rlstate) IO LbsResponse
action)