module Calamity.HTTP.Internal.Ratelimit (
newRateLimitState,
doRequest,
) where
import Calamity.Client.Types (BotC)
import Calamity.HTTP.Internal.Route
import Calamity.HTTP.Internal.Types
import Calamity.Internal.Utils
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.Event (Event)
import qualified Control.Concurrent.Event as E
import Control.Concurrent.STM
import qualified Control.Concurrent.STM.Lock as L
import Control.Lens
import Control.Monad
import Data.Aeson
import Data.Aeson.Lens
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString as B
import Data.Maybe
import qualified Data.Text.Lazy as LT
import Data.Time
import Data.Time.Clock.POSIX
import Fmt
import Network.HTTP.Client (responseStatus)
import Network.HTTP.Req
import Network.HTTP.Types
import Polysemy (Sem)
import qualified Polysemy as P
import qualified Polysemy.Async as P
import Prelude hiding (error)
import qualified Prelude
import qualified Control.Exception.Safe as Ex
import qualified StmContainers.Map as SC
newRateLimitState :: IO RateLimitState
newRateLimitState :: IO RateLimitState
newRateLimitState = Map Route ByteString
-> Map ByteString Bucket -> Event -> RateLimitState
RateLimitState (Map Route ByteString
-> Map ByteString Bucket -> Event -> RateLimitState)
-> IO (Map Route ByteString)
-> IO (Map ByteString Bucket -> Event -> RateLimitState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map Route ByteString)
forall key value. IO (Map key value)
SC.newIO IO (Map ByteString Bucket -> Event -> RateLimitState)
-> IO (Map ByteString Bucket) -> IO (Event -> RateLimitState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Map ByteString Bucket)
forall key value. IO (Map key value)
SC.newIO IO (Event -> RateLimitState) -> IO Event -> IO RateLimitState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Event
E.newSet
data Ratelimit
= KnownRatelimit Bucket
| UnknownRatelimit Route
getRateLimit :: RateLimitState -> Route -> STM Ratelimit
getRateLimit :: RateLimitState -> Route -> STM Ratelimit
getRateLimit RateLimitState
s Route
h = do
Maybe ByteString
bucketKey <- Route -> Map Route ByteString -> STM (Maybe ByteString)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup Route
h (Map Route ByteString -> STM (Maybe ByteString))
-> Map Route ByteString -> STM (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Map Route ByteString
bucketKeys RateLimitState
s
Maybe Bucket
bucket <- Maybe (Maybe Bucket) -> Maybe Bucket
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Bucket) -> Maybe Bucket)
-> STM (Maybe (Maybe Bucket)) -> STM (Maybe Bucket)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (STM (Maybe Bucket)) -> STM (Maybe (Maybe Bucket))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ((ByteString -> Map ByteString Bucket -> STM (Maybe Bucket))
-> Map ByteString Bucket -> ByteString -> STM (Maybe Bucket)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ByteString -> Map ByteString Bucket -> STM (Maybe Bucket)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup (RateLimitState -> Map ByteString Bucket
buckets RateLimitState
s) (ByteString -> STM (Maybe Bucket))
-> Maybe ByteString -> Maybe (STM (Maybe Bucket))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
bucketKey)
case Maybe Bucket
bucket of
Just Bucket
bucket' ->
Ratelimit -> STM Ratelimit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ratelimit -> STM Ratelimit) -> Ratelimit -> STM Ratelimit
forall a b. (a -> b) -> a -> b
$ Bucket -> Ratelimit
KnownRatelimit Bucket
bucket'
Maybe Bucket
Nothing ->
Ratelimit -> STM Ratelimit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ratelimit -> STM Ratelimit) -> Ratelimit -> STM Ratelimit
forall a b. (a -> b) -> a -> b
$ Route -> Ratelimit
UnknownRatelimit Route
h
updateBucket :: RateLimitState -> Route -> B.ByteString -> BucketState -> STM Bucket
updateBucket :: RateLimitState -> Route -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
s Route
h ByteString
b BucketState
bucketState = do
Maybe ByteString
bucketKey <- Route -> Map Route ByteString -> STM (Maybe ByteString)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup Route
h (Map Route ByteString -> STM (Maybe ByteString))
-> Map Route ByteString -> STM (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Map Route ByteString
bucketKeys RateLimitState
s
case Maybe ByteString
bucketKey of
Just ByteString
bucketKey' -> do
Maybe Bucket
bucket <- ByteString -> Map ByteString Bucket -> STM (Maybe Bucket)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
SC.lookup ByteString
bucketKey' (Map ByteString Bucket -> STM (Maybe Bucket))
-> Map ByteString Bucket -> STM (Maybe Bucket)
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Map ByteString Bucket
buckets RateLimitState
s
case Maybe Bucket
bucket of
Just Bucket
bucket' -> do
TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket' Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
"state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state) (BucketState -> BucketState -> BucketState
`mergeBucket` BucketState
bucketState)
Bucket -> STM Bucket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bucket
bucket'
Maybe Bucket
Nothing -> [Char] -> STM Bucket
forall a. HasCallStack => [Char] -> a
Prelude.error [Char]
"Not possible"
Maybe ByteString
Nothing -> do
Lock
lock <- STM Lock
L.new
TVar BucketState
bs <- BucketState -> STM (TVar BucketState)
forall a. a -> STM (TVar a)
newTVar BucketState
bucketState
let bucket :: Bucket
bucket = Lock -> TVar BucketState -> Bucket
Bucket Lock
lock TVar BucketState
bs
Bucket -> ByteString -> Map ByteString Bucket -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
SC.insert Bucket
bucket ByteString
b (Map ByteString Bucket -> STM ())
-> Map ByteString Bucket -> STM ()
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Map ByteString Bucket
buckets RateLimitState
s
ByteString -> Route -> Map Route ByteString -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
SC.insert ByteString
b Route
h (Map Route ByteString -> STM ()) -> Map Route ByteString -> STM ()
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Map Route ByteString
bucketKeys RateLimitState
s
Bucket -> STM Bucket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bucket
bucket
where
mergeBucket :: BucketState -> BucketState -> BucketState
mergeBucket :: BucketState -> BucketState -> BucketState
mergeBucket BucketState
old BucketState
new = BucketState
new { $sel:remaining:BucketState :: Maybe Int
remaining = BucketState
new BucketState
-> Getting (Maybe Int) BucketState (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^. IsLabel "remaining" (Getting (Maybe Int) BucketState (Maybe Int))
Getting (Maybe Int) BucketState (Maybe Int)
#remaining Maybe Int -> Maybe Int -> Maybe Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> BucketState
old BucketState
-> Getting (Maybe Int) BucketState (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^. IsLabel "remaining" (Getting (Maybe Int) BucketState (Maybe Int))
Getting (Maybe Int) BucketState (Maybe Int)
#remaining }
resetBucket :: Bucket -> STM ()
resetBucket :: Bucket -> STM ()
resetBucket Bucket
bucket = TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Bucket
bucket Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
"state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state) (IsLabel
"remaining"
(ASetter BucketState BucketState (Maybe Int) (Maybe Int))
ASetter BucketState BucketState (Maybe Int) (Maybe Int)
#remaining ASetter BucketState BucketState (Maybe Int) (Maybe Int)
-> Maybe Int -> BucketState -> BucketState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Int
forall a. Maybe a
Nothing)
useBucketOnce :: Bucket -> IO ()
useBucketOnce :: Bucket -> IO ()
useBucketOnce Bucket
bucket = do
UTCTime
now <- IO UTCTime
getCurrentTime
Maybe UTCTime
mWaitUntil <- STM (Maybe UTCTime) -> IO (Maybe UTCTime)
forall a. STM a -> IO a
atomically (STM (Maybe UTCTime) -> IO (Maybe UTCTime))
-> STM (Maybe UTCTime) -> IO (Maybe UTCTime)
forall a b. (a -> b) -> a -> b
$ do
Lock -> STM ()
L.wait (Lock -> STM ()) -> Lock -> STM ()
forall a b. (a -> b) -> a -> b
$ Bucket
bucket Bucket -> Getting Lock Bucket Lock -> Lock
forall s a. s -> Getting a s a -> a
^. IsLabel "lock" (Getting Lock Bucket Lock)
Getting Lock Bucket Lock
#lock
BucketState
s <- TVar BucketState -> STM BucketState
forall a. TVar a -> STM a
readTVar (TVar BucketState -> STM BucketState)
-> TVar BucketState -> STM BucketState
forall a b. (a -> b) -> a -> b
$ Bucket
bucket Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
"state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state
let remaining :: Maybe Int
remaining = if UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> BucketState
s BucketState -> Getting UTCTime BucketState UTCTime -> UTCTime
forall s a. s -> Getting a s a -> a
^. IsLabel "resetTime" (Getting UTCTime BucketState UTCTime)
Getting UTCTime BucketState UTCTime
#resetTime
then Maybe Int
forall a. Maybe a
Nothing
else BucketState
s BucketState
-> Getting (Maybe Int) BucketState (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^. IsLabel "remaining" (Getting (Maybe Int) BucketState (Maybe Int))
Getting (Maybe Int) BucketState (Maybe Int)
#remaining
case Maybe Int
remaining of
Just Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> do
TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (Bucket
bucket Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
"state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state) (IsLabel
"remaining"
(ASetter BucketState BucketState (Maybe Int) (Maybe Int))
ASetter BucketState BucketState (Maybe Int) (Maybe Int)
#remaining ASetter BucketState BucketState (Maybe Int) (Maybe Int)
-> Int -> BucketState -> BucketState
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
Maybe UTCTime -> STM (Maybe UTCTime)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UTCTime
forall a. Maybe a
Nothing
Just Int
_ -> do
Lock -> STM ()
L.acquire (Lock -> STM ()) -> Lock -> STM ()
forall a b. (a -> b) -> a -> b
$ Bucket
bucket Bucket -> Getting Lock Bucket Lock -> Lock
forall s a. s -> Getting a s a -> a
^. IsLabel "lock" (Getting Lock Bucket Lock)
Getting Lock Bucket Lock
#lock
TVar BucketState -> (BucketState -> BucketState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (Bucket
bucket Bucket
-> Getting (TVar BucketState) Bucket (TVar BucketState)
-> TVar BucketState
forall s a. s -> Getting a s a -> a
^. IsLabel
"state" (Getting (TVar BucketState) Bucket (TVar BucketState))
Getting (TVar BucketState) Bucket (TVar BucketState)
#state) (IsLabel
"remaining"
(ASetter BucketState BucketState (Maybe Int) (Maybe Int))
ASetter BucketState BucketState (Maybe Int) (Maybe Int)
#remaining ASetter BucketState BucketState (Maybe Int) (Maybe Int)
-> Maybe Int -> BucketState -> BucketState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Int
forall a. Maybe a
Nothing)
Maybe UTCTime -> STM (Maybe UTCTime)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe UTCTime -> STM (Maybe UTCTime))
-> (UTCTime -> Maybe UTCTime) -> UTCTime -> STM (Maybe UTCTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> STM (Maybe UTCTime)) -> UTCTime -> STM (Maybe UTCTime)
forall a b. (a -> b) -> a -> b
$ BucketState
s BucketState -> Getting UTCTime BucketState UTCTime -> UTCTime
forall s a. s -> Getting a s a -> a
^. IsLabel "resetTime" (Getting UTCTime BucketState UTCTime)
Getting UTCTime BucketState UTCTime
#resetTime
Maybe Int
Nothing ->
Maybe UTCTime -> STM (Maybe UTCTime)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UTCTime
forall a. Maybe a
Nothing
case Maybe UTCTime
mWaitUntil of
Just UTCTime
when -> do
UTCTime -> IO ()
threadDelayUntil UTCTime
when
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (Lock -> STM ()) -> Lock -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lock -> STM ()
L.release (Lock -> IO ()) -> Lock -> IO ()
forall a b. (a -> b) -> a -> b
$ Bucket
bucket Bucket -> Getting Lock Bucket Lock -> Lock
forall s a. s -> Getting a s a -> a
^. IsLabel "lock" (Getting Lock Bucket Lock)
Getting Lock Bucket Lock
#lock
Maybe UTCTime
Nothing ->
() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
doDiscordRequest :: BotC r => IO LbsResponse -> Sem r DiscordResponseType
doDiscordRequest :: IO LbsResponse -> Sem r DiscordResponseType
doDiscordRequest IO LbsResponse
r = do
Either [Char] LbsResponse
r'' <- IO (Either [Char] LbsResponse) -> Sem r (Either [Char] LbsResponse)
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO (Either [Char] LbsResponse)
-> Sem r (Either [Char] LbsResponse))
-> IO (Either [Char] LbsResponse)
-> Sem r (Either [Char] LbsResponse)
forall a b. (a -> b) -> a -> b
$ IO (Either [Char] LbsResponse)
-> (SomeException -> IO (Either [Char] LbsResponse))
-> IO (Either [Char] LbsResponse)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
Ex.catchAny (LbsResponse -> Either [Char] LbsResponse
forall a b. b -> Either a b
Right (LbsResponse -> Either [Char] LbsResponse)
-> IO LbsResponse -> IO (Either [Char] LbsResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO LbsResponse
r) (Either [Char] LbsResponse -> IO (Either [Char] LbsResponse)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] LbsResponse -> IO (Either [Char] LbsResponse))
-> (SomeException -> Either [Char] LbsResponse)
-> SomeException
-> IO (Either [Char] LbsResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Either [Char] LbsResponse
forall a b. a -> Either a b
Left ([Char] -> Either [Char] LbsResponse)
-> (SomeException -> [Char])
-> SomeException
-> Either [Char] LbsResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> [Char]
forall e. Exception e => e -> [Char]
Ex.displayException)
case Either [Char] LbsResponse
r'' of
Right LbsResponse
r' -> do
let status :: Status
status = Response ByteString -> Status
forall body. Response body -> Status
responseStatus (Response ByteString -> Status)
-> (LbsResponse -> Response ByteString) -> LbsResponse -> Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LbsResponse -> Response ByteString
forall response.
HttpResponse response =>
response -> Response (HttpResponseBody response)
toVanillaResponse (LbsResponse -> Status) -> LbsResponse -> Status
forall a b. (a -> b) -> a -> b
$ LbsResponse
r'
if
| Status -> Bool
statusIsSuccessful Status
status -> do
let resp :: HttpResponseBody LbsResponse
resp = LbsResponse -> HttpResponseBody LbsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody LbsResponse
r'
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Builder
"Got good response from discord: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+|| Status
status Status -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ Builder
""
UTCTime
now <- IO UTCTime -> Sem r UTCTime
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed IO UTCTime
getCurrentTime
if LbsResponse -> Bool
forall r. HttpResponse r => r -> Bool
isExhausted LbsResponse
r'
then case (UTCTime -> LbsResponse -> Maybe UTCTime
forall r. HttpResponse r => UTCTime -> r -> Maybe UTCTime
parseRateLimitHeader UTCTime
now LbsResponse
r', UTCTime -> LbsResponse -> Maybe (BucketState, ByteString)
forall r.
HttpResponse r =>
UTCTime -> r -> Maybe (BucketState, ByteString)
buildBucketState UTCTime
now LbsResponse
r') of
(Just !UTCTime
when, Just (!BucketState
bs, !ByteString
key)) ->
DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ ByteString
-> UTCTime -> BucketState -> ByteString -> DiscordResponseType
ExhaustedBucket ByteString
HttpResponseBody LbsResponse
resp UTCTime
when BucketState
bs ByteString
key
(Maybe UTCTime, Maybe (BucketState, ByteString))
_ ->
DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ Int -> DiscordResponseType
ServerError (Status -> Int
statusCode Status
status)
else case UTCTime -> LbsResponse -> Maybe (BucketState, ByteString)
forall r.
HttpResponse r =>
UTCTime -> r -> Maybe (BucketState, ByteString)
buildBucketState UTCTime
now LbsResponse
r' of
Just (!BucketState
bs, !ByteString
key) ->
DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ ByteString -> BucketState -> ByteString -> DiscordResponseType
Good ByteString
HttpResponseBody LbsResponse
resp BucketState
bs ByteString
key
Maybe (BucketState, ByteString)
Nothing ->
DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ Int -> DiscordResponseType
ServerError (Status -> Int
statusCode Status
status)
| Status
status Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status429 -> do
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"Got 429 from discord, retrying."
UTCTime
now <- IO UTCTime -> Sem r UTCTime
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed IO UTCTime
getCurrentTime
let resp :: HttpResponseBody LbsResponse
resp = LbsResponse -> HttpResponseBody LbsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody LbsResponse
r'
case (ByteString
HttpResponseBody LbsResponse
resp ByteString -> Getting (First Value) ByteString Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First Value) ByteString Value
forall t. AsValue t => Prism' t Value
_Value, UTCTime -> LbsResponse -> Maybe (BucketState, ByteString)
forall r.
HttpResponse r =>
UTCTime -> r -> Maybe (BucketState, ByteString)
buildBucketState UTCTime
now LbsResponse
r') of
(Just !Value
rv, Maybe (BucketState, ByteString)
bs) ->
DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ UTCTime
-> Bool -> Maybe (BucketState, ByteString) -> DiscordResponseType
Ratelimited (UTCTime -> Value -> UTCTime
parseRetryAfter UTCTime
now Value
rv) (Value -> Bool
isGlobal Value
rv) Maybe (BucketState, ByteString)
bs
(Maybe Value, Maybe (BucketState, ByteString))
_ ->
DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ Int -> DiscordResponseType
ServerError (Status -> Int
statusCode Status
status)
| Status -> Bool
statusIsClientError Status
status -> do
let err :: HttpResponseBody LbsResponse
err = LbsResponse -> HttpResponseBody LbsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody LbsResponse
r'
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
error (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Builder
"Something went wrong: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+|| ByteString
HttpResponseBody LbsResponse
err ByteString -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ Builder
" response: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|| LbsResponse
r' LbsResponse -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ Builder
""
DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> DiscordResponseType
ClientError (Status -> Int
statusCode Status
status) ByteString
HttpResponseBody LbsResponse
err
| Bool
otherwise -> do
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Builder
"Got server error from discord: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Status -> Int
statusCode Status
status Int -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> DiscordResponseType -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ Int -> DiscordResponseType
ServerError (Status -> Int
statusCode Status
status)
Left [Char]
e -> do
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
error (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Builder
"Something went wrong with the http client: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| [Char] -> Text
LT.pack [Char]
e Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
DiscordResponseType -> Sem r DiscordResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscordResponseType -> Sem r DiscordResponseType)
-> (Text -> DiscordResponseType)
-> Text
-> Sem r DiscordResponseType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DiscordResponseType
InternalResponseError (Text -> Sem r DiscordResponseType)
-> Text -> Sem r DiscordResponseType
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
LT.pack [Char]
e
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
bs,) (ByteString -> (BucketState, ByteString))
-> Maybe ByteString -> Maybe (BucketState, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
bucketKey
where
remaining :: Maybe Int
remaining = r -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Remaining" Maybe ByteString
-> Getting (First Int) (Maybe ByteString) Int -> Maybe Int
forall s a. s -> Getting (First a) s a -> Maybe a
^? (ByteString -> Const (First Int) ByteString)
-> Maybe ByteString -> Const (First Int) (Maybe ByteString)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((ByteString -> Const (First Int) ByteString)
-> Maybe ByteString -> Const (First Int) (Maybe ByteString))
-> ((Int -> Const (First Int) Int)
-> ByteString -> Const (First Int) ByteString)
-> Getting (First Int) (Maybe ByteString) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const (First Int) Int)
-> ByteString -> Const (First Int) ByteString
forall t a. (AsNumber t, Integral a) => Prism' t a
_Integral
bs :: BucketState
bs = UTCTime -> Maybe Int -> BucketState
BucketState UTCTime
now Maybe Int
remaining
bucketKey :: Maybe ByteString
bucketKey = r -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Bucket"
isExhausted :: HttpResponse r => r -> Bool
isExhausted :: r -> Bool
isExhausted r
r = r -> ByteString -> Maybe ByteString
forall response.
HttpResponse response =>
response -> ByteString -> Maybe ByteString
responseHeader r
r ByteString
"X-RateLimit-Remaining" Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"0"
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)
threadDelayUntil :: UTCTime -> IO ()
threadDelayUntil :: UTCTime -> IO ()
threadDelayUntil UTCTime
when = do
UTCTime
now <- IO UTCTime
getCurrentTime
let msUntil :: Int
msUntil = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int)
-> (NominalDiffTime -> Double) -> NominalDiffTime -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000) (Double -> Double)
-> (NominalDiffTime -> Double) -> NominalDiffTime -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Real NominalDiffTime, Fractional Double) =>
NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac @_ @Double (NominalDiffTime -> Int) -> NominalDiffTime -> Int
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
when UTCTime
now
Int -> IO ()
threadDelayMS Int
msUntil
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 -> Route -> STM Ratelimit
getRateLimit RateLimitState
rlstate Route
route
case Ratelimit
rl of
KnownRatelimit Bucket
bucket ->
IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Bucket -> IO ()
useBucketOnce Bucket
bucket
Ratelimit
_ -> () -> Sem r ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
DiscordResponseType
r' <- IO LbsResponse -> Sem r DiscordResponseType
forall (r :: [(* -> *) -> * -> *]).
BotC r =>
IO LbsResponse -> Sem r DiscordResponseType
doDiscordRequest IO LbsResponse
r
case DiscordResponseType
r' of
Good ByteString
v BucketState
bs ByteString
bk -> do
Sem r Bucket -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r Bucket -> Sem r ())
-> (STM Bucket -> Sem r Bucket) -> STM Bucket -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Bucket -> Sem r Bucket
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO Bucket -> Sem r Bucket)
-> (STM Bucket -> IO Bucket) -> STM Bucket -> Sem r Bucket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Bucket -> IO Bucket
forall a. STM a -> IO a
atomically (STM Bucket -> Sem r ()) -> STM Bucket -> Sem r ()
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Route -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
rlstate Route
route ByteString
bk BucketState
bs
ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ShouldRetry RestError ByteString
forall a b. b -> ShouldRetry a b
RGood ByteString
v
ExhaustedBucket ByteString
v UTCTime
unlockWhen BucketState
bs ByteString
bk -> do
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Builder
"Exhausted bucket, unlocking at" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| UTCTime
unlockWhen UTCTime -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
Bucket
bucket <- IO Bucket -> Sem r Bucket
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO Bucket -> Sem r Bucket)
-> (STM Bucket -> IO Bucket) -> STM Bucket -> Sem r Bucket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Bucket -> IO Bucket
forall a. STM a -> IO a
atomically (STM Bucket -> Sem r Bucket) -> STM Bucket -> Sem r Bucket
forall a b. (a -> b) -> a -> b
$ do
Bucket
bucket <- RateLimitState -> Route -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
rlstate Route
route ByteString
bk BucketState
bs
Lock -> STM ()
L.acquire (Lock -> STM ()) -> Lock -> STM ()
forall a b. (a -> b) -> a -> b
$ Bucket
bucket Bucket -> Getting Lock Bucket Lock -> Lock
forall s a. s -> Getting a s a -> a
^. IsLabel "lock" (Getting Lock Bucket Lock)
Getting Lock Bucket Lock
#lock
Bucket -> STM Bucket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bucket
bucket
Sem r (Async (Maybe ())) -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r (Async (Maybe ())) -> Sem r ())
-> (Sem r () -> Sem r (Async (Maybe ()))) -> Sem r () -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem r () -> Sem r (Async (Maybe ()))
forall (r :: [(* -> *) -> * -> *]) a.
MemberWithError Async r =>
Sem r a -> Sem r (Async (Maybe a))
P.async (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
UTCTime -> IO ()
threadDelayUntil UTCTime
unlockWhen
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Lock -> STM ()
L.release (Lock -> STM ()) -> Lock -> STM ()
forall a b. (a -> b) -> a -> b
$ Bucket
bucket Bucket -> Getting Lock Bucket Lock -> Lock
forall s a. s -> Getting a s a -> a
^. IsLabel "lock" (Getting Lock Bucket Lock)
Getting Lock Bucket Lock
#lock
Bucket -> STM ()
resetBucket Bucket
bucket
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"unlocking bucket"
ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ShouldRetry RestError ByteString
forall a b. b -> ShouldRetry a b
RGood ByteString
v
Ratelimited UTCTime
unlockWhen Bool
False (Just (BucketState
bs, ByteString
bk)) -> do
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug (Text -> Sem r ()) -> Text -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Builder
"429 ratelimited on route, retrying at " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| UTCTime
unlockWhen UTCTime -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
Bucket
bucket <- IO Bucket -> Sem r Bucket
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO Bucket -> Sem r Bucket)
-> (STM Bucket -> IO Bucket) -> STM Bucket -> Sem r Bucket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Bucket -> IO Bucket
forall a. STM a -> IO a
atomically (STM Bucket -> Sem r Bucket) -> STM Bucket -> Sem r Bucket
forall a b. (a -> b) -> a -> b
$ do
Bucket
bucket <- RateLimitState -> Route -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
rlstate Route
route ByteString
bk BucketState
bs
Lock -> STM ()
L.acquire (Lock -> STM ()) -> Lock -> STM ()
forall a b. (a -> b) -> a -> b
$ Bucket
bucket Bucket -> Getting Lock Bucket Lock -> Lock
forall s a. s -> Getting a s a -> a
^. IsLabel "lock" (Getting Lock Bucket Lock)
Getting Lock Bucket Lock
#lock
Bucket -> STM Bucket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bucket
bucket
IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
UTCTime -> IO ()
threadDelayUntil UTCTime
unlockWhen
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Lock -> STM ()
L.release (Lock -> STM ()) -> Lock -> STM ()
forall a b. (a -> b) -> a -> b
$ Bucket
bucket Bucket -> Getting Lock Bucket Lock -> Lock
forall s a. s -> Getting a s a -> a
^. IsLabel "lock" (Getting Lock Bucket Lock)
Getting Lock Bucket Lock
#lock
Bucket -> STM ()
resetBucket Bucket
bucket
ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall a b. a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError Int
429 Maybe Value
forall a. Maybe a
Nothing)
Ratelimited UTCTime
unlockWhen Bool
False Maybe (BucketState, ByteString)
_ -> do
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"Internal error (ratelimited but no headers), retrying"
IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> IO ()
threadDelayUntil UTCTime
unlockWhen
ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall a b. a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError Int
429 Maybe Value
forall a. Maybe a
Nothing)
Ratelimited UTCTime
unlockWhen Bool
True Maybe (BucketState, ByteString)
bs -> do
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"429 ratelimited globally"
IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
case Maybe (BucketState, ByteString)
bs of
Just (BucketState
bs', ByteString
bk) ->
IO Bucket -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bucket -> IO ())
-> (STM Bucket -> IO Bucket) -> STM Bucket -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Bucket -> IO Bucket
forall a. STM a -> IO a
atomically (STM Bucket -> IO ()) -> STM Bucket -> IO ()
forall a b. (a -> b) -> a -> b
$ RateLimitState -> Route -> ByteString -> BucketState -> STM Bucket
updateBucket RateLimitState
rlstate Route
route ByteString
bk BucketState
bs'
Maybe (BucketState, ByteString)
Nothing ->
() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Event -> IO ()
E.clear Event
gl
UTCTime -> IO ()
threadDelayUntil UTCTime
unlockWhen
Event -> IO ()
E.set Event
gl
ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall a b. a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError Int
429 Maybe Value
forall a. Maybe a
Nothing)
ServerError Int
c -> do
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"Server failed, retrying"
ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall a b. a -> ShouldRetry a b
Retry (Int -> Maybe Value -> RestError
HTTPError Int
c Maybe Value
forall a. Maybe a
Nothing)
InternalResponseError Text
c -> do
Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member LogEff r =>
Text -> Sem r ()
debug Text
"Internal error, retrying"
ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall a b. a -> ShouldRetry a b
Retry (Text -> RestError
InternalClientError Text
c)
ClientError Int
c ByteString
v -> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString))
-> ShouldRetry RestError ByteString
-> Sem r (ShouldRetry RestError ByteString)
forall a b. (a -> b) -> a -> b
$ RestError -> ShouldRetry RestError ByteString
forall a b. a -> ShouldRetry a b
RFail (Int -> Maybe Value -> RestError
HTTPError Int
c (Maybe Value -> RestError) -> Maybe Value -> RestError
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
v)
doRequest :: BotC r => RateLimitState -> Route -> IO LbsResponse -> Sem r (Either RestError LB.ByteString)
doRequest :: RateLimitState
-> Route -> IO LbsResponse -> Sem r (Either RestError ByteString)
doRequest RateLimitState
rlstate Route
route IO LbsResponse
action =
Int
-> Sem r (ShouldRetry RestError ByteString)
-> Sem r (Either RestError ByteString)
forall (r :: [(* -> *) -> * -> *]) a b.
BotC r =>
Int -> Sem r (ShouldRetry a b) -> Sem r (Either a b)
retryRequest
Int
5
(RateLimitState
-> Route
-> Event
-> IO LbsResponse
-> Sem r (ShouldRetry RestError ByteString)
forall (r :: [(* -> *) -> * -> *]).
BotC r =>
RateLimitState
-> Route
-> Event
-> IO LbsResponse
-> Sem r (ShouldRetry RestError ByteString)
doSingleRequest RateLimitState
rlstate Route
route (RateLimitState -> Event
globalLock RateLimitState
rlstate) IO LbsResponse
action)