calamity 0.7.0.1 → 0.7.1.0

raw patch · 5 files changed

+86/−68 lines, 5 filesdep ~PyFdep ~aesondep ~http-api-dataPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: PyF, aeson, http-api-data, req, typerep-map, vector

API changes (from Hackage documentation)

Files

• Calamity/HTTP/Internal/Ratelimit.hs +47/−32
• Calamity/HTTP/Internal/Route.hs +8/−8
• Calamity/Internal/Utils.hs +19/−20
• ChangeLog.md +4/−0
• calamity.cabal +8/−8

@@ -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" 

@@ -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)

@@ -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 ())

@@ -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

@@ -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 <https://github.com/simmsb/calamity#readme> 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