calamity 0.1.28.3 → 0.1.28.4

raw patch · 7 files changed

+103/−58 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Calamity/HTTP/Channel.hs +8/−4
• Calamity/HTTP/Internal/Ratelimit.hs +10/−13
• Calamity/HTTP/Internal/Route.hs +71/−32
• Calamity/HTTP/Internal/Types.hs +3/−5
• Calamity/HTTP/Invite.hs +4/−2
• ChangeLog.md +5/−0
• calamity.cabal +2/−2

@@ -235,21 +235,25 @@       & giveID mid       & buildRoute   route (CreateReaction (getID -> cid) (getID @Message -> mid) emoji) =-    baseRoute cid // S "messages" // ID @Message // S "reactions" // S (renderEmoji emoji) // S "@me"+    baseRoute cid // S "messages" // ID @Message // S "reactions" // PS @"emoji" // S "@me"       & giveID mid+      & giveParam @"emoji" (renderEmoji emoji)       & buildRoute   route (DeleteOwnReaction (getID -> cid) (getID @Message -> mid) emoji) =-    baseRoute cid // S "messages" // ID @Message // S "reactions" // S (renderEmoji emoji) // S "@me"+    baseRoute cid // S "messages" // ID @Message // S "reactions" // PS @"emoji" // S "@me"       & giveID mid+      & giveParam @"emoji" (renderEmoji emoji)       & buildRoute   route (DeleteUserReaction (getID -> cid) (getID @Message -> mid) emoji (getID @User -> uid)) =-    baseRoute cid // S "messages" // ID @Message // S "reactions" // S (renderEmoji emoji) // ID @User+    baseRoute cid // S "messages" // ID @Message // S "reactions" // PS @"emoji" // ID @User       & giveID mid       & giveID uid+      & giveParam @"emoji" (renderEmoji emoji)       & buildRoute   route (GetReactions (getID -> cid) (getID @Message -> mid) emoji _) =-    baseRoute cid // S "messages" // ID @Message // S "reactions" // S (renderEmoji emoji)+    baseRoute cid // S "messages" // ID @Message // S "reactions" // PS @"emoji"       & giveID mid+      & giveParam @"emoji" (renderEmoji emoji)       & buildRoute   route (DeleteAllReactions (getID -> cid) (getID @Message -> mid)) =     baseRoute cid // S "messages" // ID @Message // S "reactions"

@@ -14,7 +14,6 @@ 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 @@ -47,9 +46,9 @@  data Ratelimit   = KnownRatelimit Bucket-  | UnknownRatelimit Route+  | UnknownRatelimit RouteKey -getRateLimit :: RateLimitState -> Route -> STM Ratelimit+getRateLimit :: RateLimitState -> RouteKey -> STM Ratelimit getRateLimit s h = do   bucketKey <- SC.lookup h $ bucketKeys s   bucket <- join <$> sequenceA (flip SC.lookup (buckets s) <$> bucketKey)@@ -62,7 +61,7 @@ {- | Knowing the bucket for a route, and the ratelimit info, map the route to  the bucket key and retrieve the bucket -}-updateBucket :: RateLimitState -> Route -> B.ByteString -> BucketState -> STM Bucket+updateBucket :: RateLimitState -> RouteKey -> B.ByteString -> BucketState -> STM Bucket updateBucket s h b bucketState = do   bucketKey <- SC.lookup h $ bucketKeys s   case bucketKey of@@ -77,12 +76,10 @@         Nothing -> Prelude.error "Not possible"     Nothing -> do       -- the bucket key wasn't known, make a new bucket and insert it-      lock <- L.new-      bs <- newTVar bucketState-      let bucket = Bucket lock bs-      SC.insert bucket b $ buckets s+      bs <- Bucket <$> newTVar bucketState+      SC.insert bs b $ buckets s       SC.insert b h $ bucketKeys s-      pure bucket+      pure bs  where   mergeStates :: BucketState -> BucketState -> BucketState   mergeStates old new =@@ -321,7 +318,7 @@ doSingleRequest rlstate route gl r = do   P.embed $ E.wait (globalLock rlstate) -  rl <- P.embed . atomically $ getRateLimit rlstate route+  rl <- P.embed . atomically $ getRateLimit rlstate (routeKey route)    case rl of     KnownRatelimit bucket ->@@ -339,7 +336,7 @@           _ -> pure ()         case rlHeaders of           Just (bs, bk) ->-            void $ updateBucket rlstate route bk bs+            void $ updateBucket rlstate (routeKey route) bk bs           Nothing -> pure ()       pure $ RGood v     Ratelimited unlockWhen False (Just (bs, bk)) -> do@@ -350,7 +347,7 @@           KnownRatelimit bucket ->             modifyTVar' (bucket ^. #state) (#ongoing -~ 1)           _ -> pure ()-        void $ updateBucket rlstate route bk bs+        void $ updateBucket rlstate (routeKey route) bk bs        P.embed $ do         threadDelayUntil unlockWhen@@ -376,7 +373,7 @@             _ -> pure ()           case bs of             Just (bs', bk) ->-              void $ updateBucket rlstate route bk bs'+              void $ updateBucket rlstate (routeKey route) bk bs'             Nothing ->               pure () 

@@ -5,11 +5,15 @@ module Calamity.HTTP.Internal.Route     ( mkRouteBuilder     , giveID+    , giveParam     , buildRoute+    , routeKey+    , RouteKey     , RouteBuilder     , RouteRequirement     , Route(path)     , S(..)+    , PS(..)     , ID(..)     , RouteFragmentable(..) ) where @@ -31,14 +35,24 @@ import           GHC.Generics                 hiding ( S )  import           TextShow+import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)  data RouteFragment   = S' Text+    -- ^ Static string fragment+  | PS' String+    -- ^ Parameterised string fragment   | ID' TypeRep+    -- ^ ID fragment   deriving ( Generic, Show, Eq ) +-- | A static string fragment of a route newtype S = S Text +-- | A parameterised string fragment of a route+data PS (s :: Symbol) = PS++-- | An id fragment of a route data ID a = ID  instance Hashable RouteFragment@@ -49,23 +63,37 @@   | Satisfied   deriving ( Generic, Show, Eq ) -data RouteBuilder (idState :: [(Type, RouteRequirement)]) = UnsafeMkRouteBuilder+data RequirementType+  = IDRequirement Type+  | PSRequirement Symbol++data RouteBuilder (reqstate :: [(RequirementType, RouteRequirement)]) = UnsafeMkRouteBuilder   { route :: [RouteFragment]   , ids   :: [(TypeRep, Word64)]+  , params :: [(String, Text)]   }  mkRouteBuilder :: RouteBuilder '[]-mkRouteBuilder = UnsafeMkRouteBuilder [] []+mkRouteBuilder = UnsafeMkRouteBuilder [] [] []  giveID-  :: forall k ids-   . Typeable k-  => Snowflake k-  -> RouteBuilder ids-  -> RouteBuilder ('(k, 'Satisfied) ': ids)-giveID (Snowflake id) (UnsafeMkRouteBuilder route ids) =-  UnsafeMkRouteBuilder route ((typeRep (Proxy @k), id) : ids)+  :: forall t reqs+   . Typeable t+  => Snowflake t+  -> RouteBuilder reqs+  -> RouteBuilder ('( 'IDRequirement t, 'Satisfied) ': reqs)+giveID (Snowflake id) (UnsafeMkRouteBuilder route ids params) =+  UnsafeMkRouteBuilder route ((typeRep $ Proxy @t, id) : ids) params +giveParam+  :: forall (s :: Symbol) reqs+   . KnownSymbol s+  => Text+  -> RouteBuilder reqs+  -> RouteBuilder ('( 'PSRequirement s, 'Satisfied) ': reqs)+giveParam value (UnsafeMkRouteBuilder route ids params) =+  UnsafeMkRouteBuilder route ids ((symbolVal $ Proxy @s, value) : params)+ type family (&&) (a :: Bool) (b :: Bool) :: Bool where   'True && 'True = 'True   _     && _     = 'False@@ -80,17 +108,17 @@   IsElem k (k : _)  = 'True   IsElem k (_ : xs) = IsElem k xs -type family EnsureFulfilled (ids :: [(k, RouteRequirement)]) :: Constraint where-  EnsureFulfilled ids = EnsureFulfilledInner ids '[] 'True+type family EnsureFulfilled (reqs :: [(RequirementType, RouteRequirement)]) :: Constraint where+  EnsureFulfilled reqs = EnsureFulfilledInner reqs '[] 'True -type family EnsureFulfilledInner (ids :: [(k, RouteRequirement)]) (seen :: [k]) (ok :: Bool) :: Constraint where+type family EnsureFulfilledInner (reqs :: [(RequirementType, RouteRequirement)]) (seen :: [RequirementType]) (ok :: Bool) :: Constraint where   EnsureFulfilledInner '[]                      _    'True = ()   EnsureFulfilledInner ('(k, 'NotNeeded) ': xs) seen ok    = EnsureFulfilledInner xs (k ': seen) ok   EnsureFulfilledInner ('(k, 'Satisfied) ': xs) seen ok    = EnsureFulfilledInner xs (k ': seen) ok   EnsureFulfilledInner ('(k, 'Required)  ': xs) seen ok    = EnsureFulfilledInner xs (k ': seen) (IsElem k seen && ok) -type family AddRequired k (ids :: [(Type, RouteRequirement)]) :: [(Type, RouteRequirement)] where-  AddRequired k ids = '(k, AddRequiredInner (Lookup k ids)) ': ids+type family AddRequired k (reqs :: [(RequirementType, RouteRequirement)]) :: [(RequirementType, RouteRequirement)] where+  AddRequired k reqs = '(k, AddRequiredInner (Lookup k reqs)) ': reqs  type family AddRequiredInner (k :: Maybe RouteRequirement) :: RouteRequirement where   AddRequiredInner ('Just 'Required)  = 'Required@@ -98,23 +126,30 @@   AddRequiredInner ('Just 'NotNeeded) = 'Required   AddRequiredInner 'Nothing           = 'Required -class Typeable a => RouteFragmentable a ids where-  type ConsRes a ids+class Typeable a => RouteFragmentable a reqs where+  type ConsRes a reqs -  (//) :: RouteBuilder ids -> a -> ConsRes a ids+  (//) :: RouteBuilder reqs -> a -> ConsRes a reqs -instance RouteFragmentable S ids where-  type ConsRes S ids = RouteBuilder ids+instance RouteFragmentable S reqs where+  type ConsRes S reqs = RouteBuilder reqs -  (UnsafeMkRouteBuilder r ids) // (S t) =-    UnsafeMkRouteBuilder (r <> [S' t]) ids+  (UnsafeMkRouteBuilder r ids params) // (S t) =+    UnsafeMkRouteBuilder (r <> [S' t]) ids params -instance Typeable a => RouteFragmentable (ID (a :: Type)) (ids :: [(Type, RouteRequirement)]) where-  type ConsRes (ID a) ids = RouteBuilder (AddRequired a ids)+instance Typeable a => RouteFragmentable (ID (a :: Type)) (reqs :: [(RequirementType, RouteRequirement)]) where+  type ConsRes (ID a) reqs = RouteBuilder (AddRequired ('IDRequirement a) reqs) -  (UnsafeMkRouteBuilder r ids) // ID =-    UnsafeMkRouteBuilder (r <> [ID' (typeRep (Proxy @a))]) ids+  (UnsafeMkRouteBuilder r ids params) // ID =+    UnsafeMkRouteBuilder (r <> [ID' $ typeRep $ Proxy @a]) ids params +instance KnownSymbol s => RouteFragmentable (PS s) (reqs :: [(RequirementType, RouteRequirement)]) where+  type ConsRes (PS s) reqs = RouteBuilder (AddRequired ('PSRequirement s) reqs)++  (UnsafeMkRouteBuilder r ids params) // PS =+    UnsafeMkRouteBuilder (r <> [PS' $ symbolVal $ Proxy @s]) ids params++ infixl 5 //  data Route = Route@@ -122,27 +157,31 @@   , key       :: Text   , channelID :: Maybe (Snowflake Channel)   , guildID   :: Maybe (Snowflake Guild)-  } deriving (Generic, Show, Eq)+  } deriving (Generic, Show) -instance Hashable Route where-  hashWithSalt s (Route _ ident c g) = hashWithSalt s (ident, c, g)+type RouteKey = (Text, Maybe (Snowflake Channel), Maybe (Snowflake Guild)) +routeKey :: Route -> RouteKey+routeKey Route {key, channelID, guildID} = (key, channelID, guildID)+ baseURL :: Url 'Https baseURL = https "discord.com" /: "api" /: "v8"  buildRoute-  :: forall (ids :: [(Type, RouteRequirement)])-   . EnsureFulfilled ids-  => RouteBuilder ids+  :: forall (reqs :: [(RequirementType, RouteRequirement)])+   . EnsureFulfilled reqs+  => RouteBuilder reqs   -> Route-buildRoute (UnsafeMkRouteBuilder route ids) = Route+buildRoute (UnsafeMkRouteBuilder route ids params) = Route   (foldl' (/:) baseURL $ map goR route)   (T.concat (map goIdent 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) = showt . fromJust $ lookup t ids    goIdent (S'  t) = t+  goIdent (PS' s) = T.pack s   goIdent (ID' t) = showt t

@@ -12,7 +12,6 @@ import           Calamity.Internal.AesonThings  import           Control.Concurrent.Event      ( Event )-import           Control.Concurrent.STM.Lock   ( Lock ) import           Control.Concurrent.STM.TVar   ( TVar )  import Data.Time@@ -49,14 +48,13 @@   }   deriving ( Generic, Show ) -data Bucket = Bucket-  { lock :: Lock-  , state :: TVar BucketState+newtype Bucket = Bucket+  { state :: TVar BucketState   }   deriving ( Generic )  data RateLimitState = RateLimitState-  { bucketKeys :: SC.Map Route B.ByteString+  { bucketKeys :: SC.Map RouteKey B.ByteString   , buckets    :: SC.Map B.ByteString Bucket   , globalLock :: Event   }

@@ -22,10 +22,12 @@   type Result (InviteRequest a) = a    route (GetInvite c) =-    baseRoute // S c+    baseRoute // PS @"invite"+      & giveParam @"invite" c       & buildRoute   route (DeleteInvite c) =-    baseRoute // S c+    baseRoute // PS @"invite"+      & giveParam @"invite" c       & buildRoute    action (GetInvite _) = getWithP ("with_counts" =: True)

@@ -1,5 +1,10 @@ # Changelog for Calamity +## 0.1.28.4+++ Rework the route handling so that the bucket keys for emoji routes work+  properly+ ## 0.1.28.3  + Fix HTTP responses from discord that don't have ratelimit info being treated

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 3ef864682cfb94fce9b938cf2c9b2cf32ac1170e904fb5fd492abf28259a6c81+-- hash: ab4efef98213c2235c6f8062573bbfac890f01cc09133f83530d5e4388dbcccd  name:           calamity-version:        0.1.28.3+version:        0.1.28.4 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