diff --git a/Calamity/HTTP/Internal/Ratelimit.hs b/Calamity/HTTP/Internal/Ratelimit.hs --- a/Calamity/HTTP/Internal/Ratelimit.hs +++ b/Calamity/HTTP/Internal/Ratelimit.hs @@ -62,6 +62,27 @@ Nothing -> pure $ UnknownRatelimit h +mergeBucketStates :: BucketState -> BucketState -> BucketState +mergeBucketStates old new = + new + { ongoing = old ^. #ongoing + , -- we only ignore the previous 'remaining' if we've not reset yet and the + -- reset time has changed + remaining = + if isJust (old ^. #resetTime) && old ^. #resetKey /= new ^. #resetKey + then min (old ^. #remaining) (new ^. #remaining) + else new ^. #remaining + , -- only take the new resetTime if it actually changed + resetTime = + if old ^. #resetKey /= new ^. #resetKey + then new ^. #resetTime + else old ^. #resetTime + } + + +updateKnownBucket :: Bucket -> BucketState -> STM () +updateKnownBucket bucket bucketState = modifyTVar' (bucket ^. #state) (`mergeBucketStates` bucketState) + {- | Knowing the bucket for a route, and the ratelimit info, map the route to the bucket key and retrieve the bucket -} @@ -75,32 +96,23 @@ bucket <- SC.lookup bucketKey' $ buckets s case bucket of Just bucket' -> do - modifyTVar' (bucket' ^. #state) (`mergeStates` bucketState) + modifyTVar' (bucket' ^. #state) (`mergeBucketStates` bucketState) pure bucket' Nothing -> Prelude.error "Not possible" Nothing -> do - -- the bucket key wasn't known, make a new bucket and insert it - bs <- Bucket <$> newTVar bucketState - SC.insert bs b $ buckets s + -- we didn't know the key to this bucket, but we might know the bucket + -- if we truly don't know the bucket, then make a new one + bs <- do + bucket <- SC.lookup b $ buckets s + case bucket of + Just bs -> pure bs + Nothing -> do + bs <- Bucket <$> newTVar bucketState + SC.insert bs b $ buckets s + pure bs + SC.insert b h $ bucketKeys s pure bs - where - mergeStates :: BucketState -> BucketState -> BucketState - mergeStates old new = - new - { ongoing = old ^. #ongoing - , -- we only ignore the previous 'remaining' if we've not reset yet and the - -- reset time has changed - remaining = - if isJust (old ^. #resetTime) && old ^. #resetKey /= new ^. #resetKey - then min (old ^. #remaining) (new ^. #remaining) - else new ^. #remaining - , -- only take the new resetTime if it actually changed - resetTime = - if old ^. #resetKey /= new ^. #resetKey - then new ^. #resetTime - else old ^. #resetTime - } resetBucket :: Bucket -> STM () resetBucket bucket = @@ -178,8 +190,6 @@ -- [0] wait and then retry after we can unlock the bucket pure (intoWaitDelay $ s ^. #resetTime) - -- putStrLn (show now <> ": Using bucket, waiting until: " <> show mWaitDelay <> ", uses: " <> show s <> ", " <> inf) - case mWaitDelay of WaitUntil waitUntil -> do if waitUntil < now @@ -336,36 +346,41 @@ void . P.embed . atomically $ do case rl of KnownRatelimit bucket -> - modifyTVar' (bucket ^. #state) (#ongoing %~ succ) + modifyTVar' (bucket ^. #state) (#ongoing %~ pred) _ -> pure () - case rlHeaders of - Just (bs, bk) -> + case (rl, rlHeaders) of + (KnownRatelimit bucket, Just (bs, _bk)) -> + updateKnownBucket bucket bs + (_, Just (bs, bk)) -> void $ updateBucket rlstate (routeKey route) bk bs - Nothing -> pure () + (_, Nothing) -> pure () pure $ RGood v + Ratelimited unlockWhen False (Just (bs, bk)) -> do debug . T.pack $ "429 ratelimited on route, retrying at " <> show unlockWhen P.embed . atomically $ do case rl of - KnownRatelimit bucket -> - modifyTVar' (bucket ^. #state) (#ongoing %~ succ) - _ -> pure () - void $ updateBucket rlstate (routeKey route) bk bs + KnownRatelimit bucket -> do + modifyTVar' (bucket ^. #state) (#ongoing %~ pred) + updateKnownBucket bucket bs + _ -> void $ updateBucket rlstate (routeKey route) bk bs P.embed $ do threadDelayUntil unlockWhen pure $ Retry (HTTPError 429 Nothing) + Ratelimited unlockWhen False _ -> do debug "Internal error (ratelimited but no headers), retrying" case rl of KnownRatelimit bucket -> - void . P.embed . atomically $ modifyTVar' (bucket ^. #state) (#ongoing %~ succ) + void . P.embed . atomically $ modifyTVar' (bucket ^. #state) (#ongoing %~ pred) _ -> pure () P.embed $ threadDelayUntil unlockWhen pure $ Retry (HTTPError 429 Nothing) + Ratelimited unlockWhen True bs -> do debug "429 ratelimited globally" diff --git a/Calamity/HTTP/Internal/Route.hs b/Calamity/HTTP/Internal/Route.hs --- a/Calamity/HTTP/Internal/Route.hs +++ b/Calamity/HTTP/Internal/Route.hs @@ -174,17 +174,17 @@ Route buildRoute (UnsafeMkRouteBuilder route ids params) = Route - (foldl' (/:) baseURL $ map goR route) - (T.concat (map goIdent route)) + (foldl' (/:) baseURL $ map goRoute route) + (T.concat (map goKey route)) (Snowflake <$> lookup (typeRep (Proxy @Channel)) ids) (Snowflake <$> lookup (typeRep (Proxy @Guild)) ids) where - goR (S' t) = t - goR (PS' t) = fromJust $ lookup t params - goR (ID' t) = TextShow.showt . fromJust $ lookup t ids + goRoute (S' t) = t + goRoute (PS' t) = fromJust $ lookup t params + goRoute (ID' t) = TextShow.showt . fromJust $ lookup t ids - goIdent (S' t) = t - goIdent (PS' s) = T.pack s - goIdent (ID' t) = TextShow.showt t + goKey (S' t) = t + goKey (PS' t) = T.pack t + goKey (ID' t) = TextShow.showt t $(makeFieldLabelsNoPrefix ''Route) diff --git a/Calamity/Internal/Utils.hs b/Calamity/Internal/Utils.hs --- a/Calamity/Internal/Utils.hs +++ b/Calamity/Internal/Utils.hs @@ -26,37 +26,38 @@ CalamityToJSON' (..), ) where --- import Calamity.Internal.RunIntoIO +import Calamity.Internal.RunIntoIO import Calamity.Types.LogEff import Control.Applicative -import Control.Monad (when) +import qualified Data.Aeson as Aeson import Data.Aeson.Encoding (null_) import Data.Default.Class import qualified Data.Map as M +import Data.Maybe (catMaybes) import Data.Semigroup (Last (..)) import Data.Text import qualified Data.Vector.Unboxing as VU import qualified DiPolysemy as Di import qualified Polysemy as P import TextShow -import qualified Data.Aeson as Aeson -import Data.Maybe (catMaybes) {- | Like whileM, but stateful effects are not preserved to mitigate memory leaks This means Polysemy.Error won't work to break the loop, etc. Instead, Error/Alternative will just result in the loop quitting. -} -whileMFinalIO :: P.Sem r Bool -> P.Sem r () +whileMFinalIO :: P.Member (P.Final IO) r => P.Sem r Bool -> P.Sem r () whileMFinalIO action = do - go action + action' <- runSemToIO action + P.embedFinal $ go action' where - go action = do - r <- action - when r $ go_b action - {-# INLINE go #-} - go_b = go - {-# NOINLINE go_b #-} + go action' = do + r <- action' + case r of + Just True -> + go action' + _ -> + pure () {- | Like untilJust, but stateful effects are not preserved to mitigate memory leaks @@ -65,18 +66,16 @@ -} untilJustFinalIO :: P.Member (P.Final IO) r => P.Sem r (Maybe a) -> P.Sem r a untilJustFinalIO action = do - go action + action' <- runSemToIO action + P.embedFinal $ go action' where - go action = do - r <- action + go action' = do + r <- action' case r of - Just a -> + Just (Just a) -> pure a _ -> - go_b action - {-# INLINE go #-} - go_b = go - {-# NOINLINE go_b #-} + go action' whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () whenJust = flip $ maybe (pure ()) diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for Calamity +## 0.7.1.0 + ++ Fix ratelimits being effectively broken (succ -> pred) + ## 0.7.0.1 + Fix accidental semver breakage diff --git a/calamity.cabal b/calamity.cabal --- a/calamity.cabal +++ b/calamity.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: calamity -version: 0.7.0.1 +version: 0.7.1.0 synopsis: A library for writing discord bots in haskell description: Please see the README on GitHub at category: Network, Web @@ -18,7 +18,7 @@ license-file: LICENSE build-type: Simple tested-with: - GHC == 8.10.7, GHC == 9.2.4 + GHC == 8.10.7, GHC == 9.2.5 extra-source-files: README.md ChangeLog.md @@ -186,8 +186,8 @@ QuasiQuotes ghc-options: -fplugin=Polysemy.Plugin -funbox-strict-fields -Wall -fno-warn-name-shadowing build-depends: - PyF ==0.10.* - , aeson ==2.0.* + PyF ==0.11.* + , aeson >=2.0 && <2.2 , async >=2.2 && <3 , base >=4.13 && <5 , bytestring >=0.10 && <0.12 @@ -206,7 +206,7 @@ , exceptions ==0.10.* , focus >=1.0 && <2 , hashable >=1.2 && <2 - , http-api-data >=0.4.3 && <0.5 + , http-api-data >=0.4.3 && <0.6 , http-client >=0.5 && <0.8 , http-date >=0.0.8 && <0.1 , http-types ==0.12.* @@ -216,7 +216,7 @@ , polysemy >=1.5 && <2 , polysemy-plugin >=0.3 && <0.5 , reflection >=2.1 && <3 - , req >=3.9.2 && <3.11 + , req >=3.9.2 && <3.14 , safe-exceptions >=0.1 && <2 , scientific ==0.3.* , stm >=2.5 && <3 @@ -226,11 +226,11 @@ , text-show >=3.8 && <4 , time >=1.8 && <1.13 , tls >=1.4 && <2 - , typerep-map >=0.3 && <0.6 + , typerep-map >=0.5 && <0.7 , unagi-chan ==0.4.* , unboxing-vector ==0.2.* , unordered-containers ==0.2.* - , vector ==0.12.* + , vector >=0.12 && <0.14 , websockets >=0.12 && <0.13 , x509-system >=1.6.6 && <1.7 , random >=1.2 && <1.3