calamity 0.1.26.1 → 0.1.27.0

raw patch · 13 files changed

+470/−382 lines, 13 filesdep +http-api-dataPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: http-api-data

API changes (from Hackage documentation)

Files

• Calamity/Client/Client.hs +44/−12
• Calamity/Client/Types.hs +250/−213
• Calamity/Gateway/DispatchEvents.hs +118/−99
• Calamity/HTTP/AuditLog.hs +4/−6
• Calamity/HTTP/Channel.hs +10/−10
• Calamity/HTTP/Guild.hs +2/−2
• Calamity/HTTP/Internal/Request.hs +2/−1
• Calamity/HTTP/User.hs +2/−4
• Calamity/HTTP/Webhook.hs +2/−3
• Calamity/Types/Model/Channel/Reaction.hs +13/−24
• Calamity/Types/Model/Guild/Guild.hs +7/−6
• ChangeLog.md +13/−0
• calamity.cabal +3/−2

@@ -550,20 +550,36 @@ handleEvent' eh evt@(MessageReactionAdd reaction) = do   updateCache evt   msg <- getMessage (getID reaction)+  user <- getUser (getID reaction)+  chan <- case reaction ^. #guildID of+    Just _ -> do+      chan <- getGuildChannel (coerceSnowflake $ getID @Channel reaction)+      pure (GuildChannel' <$> chan)+    Nothing -> do+      chan <- getDM (coerceSnowflake $ getID @Channel reaction)+      pure (DMChannel' <$> chan)   let rawActions = map ($ reaction) (getEventHandlers @'RawMessageReactionAddEvt eh)-  let actions = case msg of-        Just msg' ->-          map ($ (msg', reaction)) (getEventHandlers @'MessageReactionAddEvt eh)+  let actions = case (msg, user, chan) of+        (Just msg', Just user', Just chan') ->+          map ($ (msg', user', chan', reaction ^. #emoji)) (getEventHandlers @'MessageReactionAddEvt eh)         _ -> []   pure $ rawActions <> actions  handleEvent' eh evt@(MessageReactionRemove reaction) = do   msg <- getMessage (getID reaction)   updateCache evt+  user <- getUser (getID reaction)+  chan <- case reaction ^. #guildID of+    Just _ -> do+      chan <- getGuildChannel (coerceSnowflake $ getID @Channel reaction)+      pure (GuildChannel' <$> chan)+    Nothing -> do+      chan <- getDM (coerceSnowflake $ getID @Channel reaction)+      pure (DMChannel' <$> chan)   let rawActions = map ($ reaction) (getEventHandlers @'RawMessageReactionRemoveEvt eh)-  let actions = case msg of-        Just msg' ->-          map ($ (msg', reaction)) (getEventHandlers @'MessageReactionRemoveEvt eh)+  let actions = case (msg, user, chan) of+        (Just msg', Just user', Just chan') ->+          map ($ (msg', user', chan', reaction ^. #emoji)) (getEventHandlers @'MessageReactionRemoveEvt eh)         _ -> []   pure $ rawActions <> actions @@ -607,7 +623,7 @@   pure $ map ($ (oldUser, newUser)) (getEventHandlers @'UserUpdateEvt eh)  handleEvent' eh evt@(VoiceStateUpdate newVoiceState@V.VoiceState{guildID=Just guildID}) = do-  oldVoiceState <- join . fmap (find ((==V.sessionID newVoiceState) . V.sessionID) . voiceStates) <$> getGuild guildID+  oldVoiceState <- ((find ((== V.sessionID newVoiceState) . V.sessionID) . voiceStates) =<<) <$> getGuild guildID   updateCache evt   pure $ map ($ (oldVoiceState, newVoiceState)) (getEventHandlers @'VoiceStateUpdateEvt eh) @@ -690,11 +706,27 @@ updateCache (MessageDeleteBulk MessageDeleteBulkData { ids }) =   for_ ids delMessage -updateCache (MessageReactionAdd reaction) =-  updateMessage (getID reaction) (#reactions %~ cons reaction)--updateCache (MessageReactionRemove reaction) =-  updateMessage (getID reaction) (#reactions %~ filter (\r -> r ^. #emoji /= reaction ^. #emoji))+updateCache (MessageReactionAdd reaction) = do+  isMe <- (\u -> Just (getID @User reaction) == (getID @User <$> u)) <$> getBotUser+  updateMessage+    (getID reaction)+    ( \m ->+        case m ^. #reactions & filter ((== (reaction ^. #emoji)) . (^. #emoji)) of+          [] -> m & #reactions <>~ [Reaction 1 isMe (reaction ^. #emoji)]+          _ ->+            m & #reactions . traverse . filtered ((== (reaction ^. #emoji)) . (^. #emoji))+              %~ (#count +~ 1) . (#me ||~ isMe)+    )+updateCache (MessageReactionRemove reaction) = do+  isMe <- (\u -> Just (getID @User reaction) == (getID @User <$> u)) <$> getBotUser+  updateMessage+    (getID reaction)+    ( \m ->+        m+          & #reactions . traverse . filtered ((== (reaction ^. #emoji)) . (^. #emoji))+            %~ (#count -~ 1) . (#me &&~ not isMe)+          & #reactions %~ filter (\r -> r ^. #count /= 0)+    )  updateCache (MessageReactionRemoveAll MessageReactionRemoveAllData { messageID }) =   updateMessage messageID (#reactions .~ mempty)

@@ -1,93 +1,105 @@ -- | Types for the client-module Calamity.Client.Types-    ( Client(..)-    , StartupError(..)-    , EventType(..)-    , GuildCreateStatus(..)-    , GuildDeleteStatus(..)-    , EHType-    , BotC-    , SetupEff-    , ReactConstraints-    , EventHandlers(..)-    , InsertEventHandler(..)-    , RemoveEventHandler(..)-    , getEventHandlers-    , getCustomEventHandlers ) where+module Calamity.Client.Types (+  Client (..),+  StartupError (..),+  EventType (..),+  GuildCreateStatus (..),+  GuildDeleteStatus (..),+  EHType,+  BotC,+  SetupEff,+  ReactConstraints,+  EventHandlers (..),+  InsertEventHandler (..),+  RemoveEventHandler (..),+  getEventHandlers,+  getCustomEventHandlers,+) where -import           Calamity.Cache.Eff-import           Calamity.Gateway.DispatchEvents ( CalamityEvent(..), InviteCreateData, InviteDeleteData, ReadyData )-import           Calamity.Gateway.Types          ( ControlMessage )-import           Calamity.HTTP.Internal.Types-import           Calamity.Metrics.Eff-import           Calamity.Types.LogEff-import           Calamity.Types.Model.Channel-import           Calamity.Types.Model.Channel.UpdatedMessage-import           Calamity.Types.Model.Guild-import           Calamity.Types.Model.User-import           Calamity.Types.Model.Voice-import           Calamity.Types.Token-import           Calamity.Types.UnixTimestamp-import           Calamity.Types.Snowflake+import Calamity.Cache.Eff+import Calamity.Gateway.DispatchEvents (CalamityEvent (..), InviteCreateData, InviteDeleteData, ReactionEvtData, ReadyData)+import Calamity.Gateway.Types (ControlMessage)+import Calamity.HTTP.Internal.Types+import Calamity.Metrics.Eff+import Calamity.Types.LogEff+import Calamity.Types.Model.Channel+import Calamity.Types.Model.Channel.UpdatedMessage+import Calamity.Types.Model.Guild+import Calamity.Types.Model.User+import Calamity.Types.Model.Voice+import Calamity.Types.Snowflake+import Calamity.Types.Token+import Calamity.Types.UnixTimestamp -import           Control.Concurrent.Async-import           Control.Concurrent.Chan.Unagi-import           Control.Concurrent.MVar-import           Control.Concurrent.STM.TVar+import Control.Concurrent.Async+import Control.Concurrent.Chan.Unagi+import Control.Concurrent.MVar+import Control.Concurrent.STM.TVar -import           Data.Default.Class-import           Data.Dynamic-import qualified Data.HashMap.Lazy               as LH-import           Data.IORef-import           Data.Maybe-import           Data.Time-import qualified Data.TypeRepMap                 as TM-import           Data.TypeRepMap                 ( TypeRepMap, WrapTypeable(..) )-import           Data.Typeable-import           Data.Void+import Data.Default.Class+import Data.Dynamic+import qualified Data.HashMap.Lazy as LH+import Data.IORef+import Data.Maybe+import Data.Time+import Data.TypeRepMap (TypeRepMap, WrapTypeable (..))+import qualified Data.TypeRepMap as TM+import Data.Typeable+import Data.Void -import           GHC.Exts                        ( fromList )-import           GHC.Generics+import GHC.Exts (fromList)+import GHC.Generics -import qualified Polysemy                        as P-import qualified Polysemy.Async                  as P-import qualified Polysemy.AtomicState            as P-import qualified Polysemy.Reader                 as P+import qualified Polysemy as P+import qualified Polysemy.Async as P+import qualified Polysemy.AtomicState as P+import qualified Polysemy.Reader as P -import qualified TextShow.Generic                as TSG-import TextShow import qualified Df1 as Df1 import qualified Di.Core as DC+import TextShow+import qualified TextShow.Generic as TSG  data Client = Client-  { shards              :: TVar [(InChan ControlMessage, Async (Maybe ()))]-  , numShards           :: MVar Int-  , token               :: Token-  , rlState             :: RateLimitState-  , eventsIn            :: InChan CalamityEvent-  , eventsOut           :: OutChan CalamityEvent-  , ehidCounter         :: IORef Integer-  , initialDi           :: Maybe (DC.Di Df1.Level Df1.Path Df1.Message)+  { shards :: TVar [(InChan ControlMessage, Async (Maybe ()))]+  , numShards :: MVar Int+  , token :: Token+  , rlState :: RateLimitState+  , eventsIn :: InChan CalamityEvent+  , eventsOut :: OutChan CalamityEvent+  , ehidCounter :: IORef Integer+  , initialDi :: Maybe (DC.Di Df1.Level Df1.Path Df1.Message)   }-  deriving ( Generic )+  deriving (Generic)  type BotC r =-  ( P.Members '[LogEff, MetricEff, CacheEff, P.Reader Client,-  P.AtomicState EventHandlers, P.Embed IO, P.Final IO, P.Async] r-  , Typeable r)+  ( P.Members+      '[ LogEff+       , MetricEff+       , CacheEff+       , P.Reader Client+       , P.AtomicState EventHandlers+       , P.Embed IO+       , P.Final IO+       , P.Async+       ]+      r+  , Typeable r+  )  -- | A concrete effect stack used inside the bot type SetupEff r = (P.Reader Client ': P.AtomicState EventHandlers ': P.Async ': r) --- | Some constraints that 'Calamity.Client.Client.react' needs to work. Don't--- worry about these since they are satisfied for any type @s@ can be+{- | Some constraints that 'Calamity.Client.Client.react' needs to work. Don't+ worry about these since they are satisfied for any type @s@ can be+-} type ReactConstraints s =   ( InsertEventHandler s   , RemoveEventHandler s   )  newtype StartupError = StartupError String-  deriving ( Show )+  deriving (Show)  -- | A Data Kind used to fire custom events data EventType@@ -113,104 +125,109 @@   | InviteCreateEvt   | InviteDeleteEvt   | MessageCreateEvt-  | MessageUpdateEvt-  -- ^ Fired when a cached message is updated, use 'RawMessageUpdateEvt' to see-  -- updates of uncached messages-  | RawMessageUpdateEvt-  -- ^ Fired when a message is updated-  | MessageDeleteEvt-  -- ^ Fired when a cached message is deleted, use 'RawMessageDeleteEvt' to see-  -- deletes of uncached messages.-  ---  -- Does not include messages deleted through bulk deletes, use-  -- 'MessageDeleteBulkEvt' for those-  | RawMessageDeleteEvt-  -- ^ Fired when a message is deleted.-  ---  -- Does not include messages deleted through bulk deletes, use-  -- 'RawMessageDeleteBulkEvt' for those-  | MessageDeleteBulkEvt-  -- ^ Fired when messages are bulk deleted. Only includes cached messages, use-  -- 'RawMessageDeleteBulkEvt' to see deletes of uncached messages.-  | RawMessageDeleteBulkEvt-  -- ^ Fired when messages are bulk deleted.-  | MessageReactionAddEvt-  -- ^ Fired when a reaction is added to a cached message, use-  -- 'RawMessageReactionAddEvt' to see reactions on uncached messages.-  | RawMessageReactionAddEvt-  -- ^ Fired when a reaction is added to a message.-  | MessageReactionRemoveEvt-  -- ^ Fired when a reaction is removed from a cached message, use-  -- 'RawMessageReactionRemoveEvt' to see reactions on uncached messages.-  | RawMessageReactionRemoveEvt-  -- ^ Fired when a reaction is removed from a message.-  | MessageReactionRemoveAllEvt-  -- ^ Fired when all reactions are removed from a cached message, use-  -- 'RawMessageReactionRemoveEvt' to see reactions on uncached messages.-  ---  -- The message passed will contain the removed events.-  | RawMessageReactionRemoveAllEvt-  -- ^ Fired when all reactions are removed from a message.+  | -- | Fired when a cached message is updated, use 'RawMessageUpdateEvt' to see+    -- updates of uncached messages+    MessageUpdateEvt+  | -- | Fired when a message is updated+    RawMessageUpdateEvt+  | -- | Fired when a cached message is deleted, use 'RawMessageDeleteEvt' to see+    -- deletes of uncached messages.+    --+    -- Does not include messages deleted through bulk deletes, use+    -- 'MessageDeleteBulkEvt' for those+    MessageDeleteEvt+  | -- | Fired when a message is deleted.+    --+    -- Does not include messages deleted through bulk deletes, use+    -- 'RawMessageDeleteBulkEvt' for those+    RawMessageDeleteEvt+  | -- | Fired when messages are bulk deleted. Only includes cached messages, use+    -- 'RawMessageDeleteBulkEvt' to see deletes of uncached messages.+    MessageDeleteBulkEvt+  | -- | Fired when messages are bulk deleted.+    RawMessageDeleteBulkEvt+  | -- | Fired when a reaction is added to a cached message, use+    -- 'RawMessageReactionAddEvt' to see reactions on uncached messages.+    MessageReactionAddEvt+  | -- | Fired when a reaction is added to a message.+    RawMessageReactionAddEvt+  | -- | Fired when a reaction is removed from a cached message, use+    -- 'RawMessageReactionRemoveEvt' to see reactions on uncached messages.+    MessageReactionRemoveEvt+  | -- | Fired when a reaction is removed from a message.+    RawMessageReactionRemoveEvt+  | -- | Fired when all reactions are removed from a cached message, use+    -- 'RawMessageReactionRemoveEvt' to see reactions on uncached messages.+    --+    -- The message passed will contain the removed events.+    MessageReactionRemoveAllEvt+  | -- | Fired when all reactions are removed from a message.+    RawMessageReactionRemoveAllEvt   | TypingStartEvt   | UserUpdateEvt-  | VoiceStateUpdateEvt-  -- ^ Sent when someone joins/leaves/moves voice channels-  | forall s a. CustomEvt s a-  -- ^ A custom event, @s@ is the name and @a@ is the data sent to the handler+  | -- | Sent when someone joins/leaves/moves voice channels+    VoiceStateUpdateEvt+  | -- | A custom event, @s@ is the name and @a@ is the data sent to the handler+    forall s a. CustomEvt s a  data GuildCreateStatus-  = GuildCreateNew -- ^ The guild was just joined-  | GuildCreateAvailable -- ^ The guild is becoming available-  deriving ( Generic, Show )-  deriving ( TextShow ) via TSG.FromGeneric GuildCreateStatus+  = -- | The guild was just joined+    GuildCreateNew+  | -- | The guild is becoming available+    GuildCreateAvailable+  deriving (Generic, Show)+  deriving (TextShow) via TSG.FromGeneric GuildCreateStatus  data GuildDeleteStatus-  = GuildDeleteUnavailable -- ^ The guild became unavailable-  | GuildDeleteRemoved -- ^ The bot was removed from the guild-  deriving ( Generic, Show )-  deriving ( TextShow ) via TSG.FromGeneric GuildDeleteStatus+  = -- | The guild became unavailable+    GuildDeleteUnavailable+  | -- | The bot was removed from the guild+    GuildDeleteRemoved+  deriving (Generic, Show)+  deriving (TextShow) via TSG.FromGeneric GuildDeleteStatus --- | A type family to decide what the parameters for an event handler should be--- determined by the type of event it is handling.+{- | A type family to decide what the parameters for an event handler should be+ determined by the type of event it is handling.+-} type family EHType (d :: EventType) where-  EHType 'ReadyEvt                    = ReadyData-  EHType 'ChannelCreateEvt            = Channel-  EHType 'ChannelUpdateEvt            = (Channel, Channel)-  EHType 'ChannelDeleteEvt            = Channel-  EHType 'ChannelpinsUpdateEvt        = (Channel, Maybe UTCTime)-  EHType 'GuildCreateEvt              = (Guild, GuildCreateStatus)-  EHType 'GuildUpdateEvt              = (Guild, Guild)-  EHType 'GuildDeleteEvt              = (Guild, GuildDeleteStatus)-  EHType 'GuildBanAddEvt              = (Guild, User)-  EHType 'GuildBanRemoveEvt           = (Guild, User)-  EHType 'GuildEmojisUpdateEvt        = (Guild, [Emoji])-  EHType 'GuildIntegrationsUpdateEvt  = Guild-  EHType 'GuildMemberAddEvt           = Member-  EHType 'GuildMemberRemoveEvt        = Member-  EHType 'GuildMemberUpdateEvt        = (Member, Member)-  EHType 'GuildMembersChunkEvt        = (Guild, [Member])-  EHType 'GuildRoleCreateEvt          = (Guild, Role)-  EHType 'GuildRoleUpdateEvt          = (Guild, Role, Role)-  EHType 'GuildRoleDeleteEvt          = (Guild, Role)-  EHType 'InviteCreateEvt             = InviteCreateData-  EHType 'InviteDeleteEvt             = InviteDeleteData-  EHType 'MessageCreateEvt            = Message-  EHType 'MessageUpdateEvt            = (Message, Message)-  EHType 'MessageDeleteEvt            = Message-  EHType 'MessageDeleteBulkEvt        = [Message]-  EHType 'MessageReactionAddEvt       = (Message, Reaction)-  EHType 'MessageReactionRemoveEvt    = (Message, Reaction)+  EHType 'ReadyEvt = ReadyData+  EHType 'ChannelCreateEvt = Channel+  EHType 'ChannelUpdateEvt = (Channel, Channel)+  EHType 'ChannelDeleteEvt = Channel+  EHType 'ChannelpinsUpdateEvt = (Channel, Maybe UTCTime)+  EHType 'GuildCreateEvt = (Guild, GuildCreateStatus)+  EHType 'GuildUpdateEvt = (Guild, Guild)+  EHType 'GuildDeleteEvt = (Guild, GuildDeleteStatus)+  EHType 'GuildBanAddEvt = (Guild, User)+  EHType 'GuildBanRemoveEvt = (Guild, User)+  EHType 'GuildEmojisUpdateEvt = (Guild, [Emoji])+  EHType 'GuildIntegrationsUpdateEvt = Guild+  EHType 'GuildMemberAddEvt = Member+  EHType 'GuildMemberRemoveEvt = Member+  EHType 'GuildMemberUpdateEvt = (Member, Member)+  EHType 'GuildMembersChunkEvt = (Guild, [Member])+  EHType 'GuildRoleCreateEvt = (Guild, Role)+  EHType 'GuildRoleUpdateEvt = (Guild, Role, Role)+  EHType 'GuildRoleDeleteEvt = (Guild, Role)+  EHType 'InviteCreateEvt = InviteCreateData+  EHType 'InviteDeleteEvt = InviteDeleteData+  EHType 'MessageCreateEvt = Message+  EHType 'MessageUpdateEvt = (Message, Message)+  EHType 'MessageDeleteEvt = Message+  EHType 'MessageDeleteBulkEvt = [Message]+  EHType 'MessageReactionAddEvt = (Message, User, Channel, RawEmoji)+  EHType 'MessageReactionRemoveEvt = (Message, User, Channel, RawEmoji)   EHType 'MessageReactionRemoveAllEvt = Message-  EHType 'RawMessageUpdateEvt            = UpdatedMessage-  EHType 'RawMessageDeleteEvt            = Snowflake Message-  EHType 'RawMessageDeleteBulkEvt        = [Snowflake Message]-  EHType 'RawMessageReactionAddEvt       = Reaction-  EHType 'RawMessageReactionRemoveEvt    = Reaction+  EHType 'RawMessageUpdateEvt = UpdatedMessage+  EHType 'RawMessageDeleteEvt = Snowflake Message+  EHType 'RawMessageDeleteBulkEvt = [Snowflake Message]+  EHType 'RawMessageReactionAddEvt = ReactionEvtData+  EHType 'RawMessageReactionRemoveEvt = ReactionEvtData   EHType 'RawMessageReactionRemoveAllEvt = Snowflake Message-  EHType 'TypingStartEvt              = (Channel, Snowflake User, UnixTimestamp)-  EHType 'UserUpdateEvt               = (User, User)-  EHType 'VoiceStateUpdateEvt         = (Maybe VoiceState, VoiceState)-  EHType ('CustomEvt s a)             = a+  EHType 'TypingStartEvt = (Channel, Snowflake User, UnixTimestamp)+  EHType 'UserUpdateEvt = (User, User)+  EHType 'VoiceStateUpdateEvt = (Maybe VoiceState, VoiceState)+  EHType ( 'CustomEvt s a) = a  type StoredEHType t = EHType t -> IO () @@ -218,12 +235,12 @@  data EventHandlerWithID a = EventHandlerWithID   { ehID :: Integer-  , eh   :: a+  , eh :: a   }  type family EHStorageType (t :: EventType) where-  EHStorageType ('CustomEvt s a) = LH.HashMap TypeRep (LH.HashMap TypeRep [EventHandlerWithID (StoredEHType ('CustomEvt s a))])-  EHStorageType t                = [EventHandlerWithID (StoredEHType t)]+  EHStorageType ( 'CustomEvt s a) = LH.HashMap TypeRep (LH.HashMap TypeRep [EventHandlerWithID (StoredEHType ( 'CustomEvt s a))])+  EHStorageType t = [EventHandlerWithID (StoredEHType t)]  newtype EventHandler (t :: EventType) = EH   { unwrapEventHandler :: (Semigroup (EHStorageType t), Monoid (EHStorageType t)) => EHStorageType t@@ -236,36 +253,39 @@   mempty = EH mempty  instance Default EventHandlers where-  def = EventHandlers $ fromList [ WrapTypeable $ EH @'ReadyEvt []-                                 , WrapTypeable $ EH @'ChannelCreateEvt []-                                 , WrapTypeable $ EH @'ChannelUpdateEvt []-                                 , WrapTypeable $ EH @'ChannelDeleteEvt []-                                 , WrapTypeable $ EH @'ChannelpinsUpdateEvt []-                                 , WrapTypeable $ EH @'GuildCreateEvt []-                                 , WrapTypeable $ EH @'GuildUpdateEvt []-                                 , WrapTypeable $ EH @'GuildDeleteEvt []-                                 , WrapTypeable $ EH @'GuildBanAddEvt []-                                 , WrapTypeable $ EH @'GuildBanRemoveEvt []-                                 , WrapTypeable $ EH @'GuildEmojisUpdateEvt []-                                 , WrapTypeable $ EH @'GuildIntegrationsUpdateEvt []-                                 , WrapTypeable $ EH @'GuildMemberAddEvt []-                                 , WrapTypeable $ EH @'GuildMemberRemoveEvt []-                                 , WrapTypeable $ EH @'GuildMemberUpdateEvt []-                                 , WrapTypeable $ EH @'GuildMembersChunkEvt []-                                 , WrapTypeable $ EH @'GuildRoleCreateEvt []-                                 , WrapTypeable $ EH @'GuildRoleUpdateEvt []-                                 , WrapTypeable $ EH @'GuildRoleDeleteEvt []-                                 , WrapTypeable $ EH @'MessageCreateEvt []-                                 , WrapTypeable $ EH @'MessageUpdateEvt []-                                 , WrapTypeable $ EH @'MessageDeleteEvt []-                                 , WrapTypeable $ EH @'MessageDeleteBulkEvt []-                                 , WrapTypeable $ EH @'MessageReactionAddEvt []-                                 , WrapTypeable $ EH @'MessageReactionRemoveEvt []-                                 , WrapTypeable $ EH @'MessageReactionRemoveAllEvt []-                                 , WrapTypeable $ EH @'TypingStartEvt []-                                 , WrapTypeable $ EH @'UserUpdateEvt []-                                 , WrapTypeable $ EH @('CustomEvt Void Dynamic) LH.empty-                                 ]+  def =+    EventHandlers $+      fromList+        [ WrapTypeable $ EH @ 'ReadyEvt []+        , WrapTypeable $ EH @ 'ChannelCreateEvt []+        , WrapTypeable $ EH @ 'ChannelUpdateEvt []+        , WrapTypeable $ EH @ 'ChannelDeleteEvt []+        , WrapTypeable $ EH @ 'ChannelpinsUpdateEvt []+        , WrapTypeable $ EH @ 'GuildCreateEvt []+        , WrapTypeable $ EH @ 'GuildUpdateEvt []+        , WrapTypeable $ EH @ 'GuildDeleteEvt []+        , WrapTypeable $ EH @ 'GuildBanAddEvt []+        , WrapTypeable $ EH @ 'GuildBanRemoveEvt []+        , WrapTypeable $ EH @ 'GuildEmojisUpdateEvt []+        , WrapTypeable $ EH @ 'GuildIntegrationsUpdateEvt []+        , WrapTypeable $ EH @ 'GuildMemberAddEvt []+        , WrapTypeable $ EH @ 'GuildMemberRemoveEvt []+        , WrapTypeable $ EH @ 'GuildMemberUpdateEvt []+        , WrapTypeable $ EH @ 'GuildMembersChunkEvt []+        , WrapTypeable $ EH @ 'GuildRoleCreateEvt []+        , WrapTypeable $ EH @ 'GuildRoleUpdateEvt []+        , WrapTypeable $ EH @ 'GuildRoleDeleteEvt []+        , WrapTypeable $ EH @ 'MessageCreateEvt []+        , WrapTypeable $ EH @ 'MessageUpdateEvt []+        , WrapTypeable $ EH @ 'MessageDeleteEvt []+        , WrapTypeable $ EH @ 'MessageDeleteBulkEvt []+        , WrapTypeable $ EH @ 'MessageReactionAddEvt []+        , WrapTypeable $ EH @ 'MessageReactionRemoveEvt []+        , WrapTypeable $ EH @ 'MessageReactionRemoveAllEvt []+        , WrapTypeable $ EH @ 'TypingStartEvt []+        , WrapTypeable $ EH @ 'UserUpdateEvt []+        , WrapTypeable $ EH @( 'CustomEvt Void Dynamic) LH.empty+        ]  instance Semigroup EventHandlers where   (EventHandlers a) <> (EventHandlers b) = EventHandlers $ TM.unionWith (<>) a b@@ -276,18 +296,17 @@ -- not sure what to think of this  type family EHInstanceSelector (d :: EventType) :: Bool where-  EHInstanceSelector ('CustomEvt _ _) = 'True-  EHInstanceSelector _                = 'False-+  EHInstanceSelector ( 'CustomEvt _ _) = 'True+  EHInstanceSelector _ = 'False  fromDynamicJust :: forall a. Typeable a => Dynamic -> a fromDynamicJust d = case fromDynamic d of   Just x -> x   Nothing -> error $ "Extracting dynamic failed, wanted: " <> (show . typeRep $ Proxy @a) <> ", got: " <> (show $ dynTypeRep d) ---- | A helper typeclass that is used to decide how to register regular--- events, and custom events which require storing in a map at runtime.+{- | A helper typeclass that is used to decide how to register regular+ events, and custom events which require storing in a map at runtime.+-} class InsertEventHandler a where   makeEventHandlers :: Proxy a -> Integer -> StoredEHType a -> EventHandlers @@ -300,15 +319,18 @@ intoDynFn :: forall a. Typeable a => (a -> IO ()) -> (Dynamic -> IO ()) intoDynFn fn = \d -> fn $ fromDynamicJust d -instance (Typeable a, Typeable s, Typeable (StoredEHType ('CustomEvt s a)), (EHType ('CustomEvt s a) -> IO ()) ~ (a -> IO ()))-  => InsertEventHandler' 'True ('CustomEvt s a) where-  makeEventHandlers' _ _ id' handler = EventHandlers . TM.one $ EH @('CustomEvt Void Dynamic)-    (LH.singleton (typeRep $ Proxy @s) (LH.singleton (typeRep $ Proxy @a) [EventHandlerWithID id' (intoDynFn handler)]))+instance+  (Typeable a, Typeable s, Typeable (StoredEHType ( 'CustomEvt s a)), (EHType ( 'CustomEvt s a) -> IO ()) ~ (a -> IO ())) =>+  InsertEventHandler' 'True ( 'CustomEvt s a)+  where+  makeEventHandlers' _ _ id' handler =+    EventHandlers . TM.one $+      EH @( 'CustomEvt Void Dynamic)+        (LH.singleton (typeRep $ Proxy @s) (LH.singleton (typeRep $ Proxy @a) [EventHandlerWithID id' (intoDynFn handler)]))  instance (Typeable s, EHStorageType s ~ [EventHandlerWithID (StoredEHType s)], Typeable (StoredEHType s)) => InsertEventHandler' 'False s where   makeEventHandlers' _ _ id' handler = EventHandlers . TM.one $ EH @s [EventHandlerWithID id' handler] - class GetEventHandlers a where   getEventHandlers :: EventHandlers -> [StoredEHType a] @@ -318,14 +340,13 @@ class GetEventHandlers' (flag :: Bool) a where   getEventHandlers' :: Proxy a -> Proxy flag -> EventHandlers -> [StoredEHType a] -instance GetEventHandlers' 'True ('CustomEvt s a) where+instance GetEventHandlers' 'True ( 'CustomEvt s a) where   getEventHandlers' _ _ _ = error "use getCustomEventHandlers instead"  instance (Typeable s, Typeable (StoredEHType s), EHStorageType s ~ [EventHandlerWithID (StoredEHType s)]) => GetEventHandlers' 'False s where   getEventHandlers' _ _ (EventHandlers handlers) =     let theseHandlers = unwrapEventHandler @s $ fromMaybe mempty (TM.lookup handlers :: Maybe (EventHandler s))-    in map eh theseHandlers-+     in map eh theseHandlers  class RemoveEventHandler a where   removeEventHandler :: Proxy a -> Integer -> EventHandlers -> EventHandlers@@ -336,19 +357,35 @@ class RemoveEventHandler' (flag :: Bool) a where   removeEventHandler' :: Proxy flag -> Proxy a -> Integer -> EventHandlers -> EventHandlers -instance (Typeable s, Typeable a) => RemoveEventHandler' 'True ('CustomEvt s a) where-  removeEventHandler' _ _ id' (EventHandlers handlers) = EventHandlers $ TM.adjust @('CustomEvt Void Dynamic)-    (\(EH ehs) -> EH (LH.update (Just . LH.update (Just . filter ((/= id') . ehID)) (typeRep $ Proxy @a))-                      (typeRep $ Proxy @s) ehs)) handlers--instance (Typeable s, Typeable (StoredEHType s), EHStorageType s ~ [EventHandlerWithID (StoredEHType s)])-  => RemoveEventHandler' 'False s where-  removeEventHandler' _ _ id' (EventHandlers handlers) = EventHandlers $ TM.adjust @s-    (\(EH ehs) -> EH $ filter ((/= id') . ehID) ehs) handlers+instance (Typeable s, Typeable a) => RemoveEventHandler' 'True ( 'CustomEvt s a) where+  removeEventHandler' _ _ id' (EventHandlers handlers) =+    EventHandlers $+      TM.adjust @( 'CustomEvt Void Dynamic)+        ( \(EH ehs) ->+            EH+              ( LH.update+                  (Just . LH.update (Just . filter ((/= id') . ehID)) (typeRep $ Proxy @a))+                  (typeRep $ Proxy @s)+                  ehs+              )+        )+        handlers +instance+  (Typeable s, Typeable (StoredEHType s), EHStorageType s ~ [EventHandlerWithID (StoredEHType s)]) =>+  RemoveEventHandler' 'False s+  where+  removeEventHandler' _ _ id' (EventHandlers handlers) =+    EventHandlers $+      TM.adjust @s+        (\(EH ehs) -> EH $ filter ((/= id') . ehID) ehs)+        handlers  getCustomEventHandlers :: TypeRep -> TypeRep -> EventHandlers -> [Dynamic -> IO ()] getCustomEventHandlers s a (EventHandlers handlers) =-    let handlerMap = unwrapEventHandler @('CustomEvt Void Dynamic) $ fromMaybe mempty-          (TM.lookup handlers :: Maybe (EventHandler ('CustomEvt Void Dynamic)))-    in map eh . concat $ LH.lookup s handlerMap >>= LH.lookup a+  let handlerMap =+        unwrapEventHandler @( 'CustomEvt Void Dynamic) $+          fromMaybe+            mempty+            (TM.lookup handlers :: Maybe (EventHandler ( 'CustomEvt Void Dynamic)))+   in map eh . concat $ LH.lookup s handlerMap >>= LH.lookup a

@@ -1,41 +1,45 @@ -- | module containing all dispatch events module Calamity.Gateway.DispatchEvents where -import           Calamity.Internal.AesonThings-import           Calamity.Internal.ConstructorName-import           Calamity.Internal.Utils                     ()-import           Calamity.Types.Model.Channel-import           Calamity.Types.Model.Channel.UpdatedMessage-import           Calamity.Types.Model.Guild.Ban-import           Calamity.Types.Model.Guild.Emoji-import           Calamity.Types.Model.Guild.Guild-import           Calamity.Types.Model.Guild.Member-import           Calamity.Types.Model.Guild.Role-import           Calamity.Types.Model.Guild.UnavailableGuild-import           Calamity.Types.Model.Presence.Presence-import           Calamity.Types.Model.User-import           Calamity.Types.Model.Voice-import           Calamity.Types.Snowflake-import           Calamity.Types.UnixTimestamp+import Calamity.Internal.AesonThings+import Calamity.Internal.ConstructorName+import Calamity.Internal.Utils ()+import Calamity.Types.Model.Channel+import Calamity.Types.Model.Channel.UpdatedMessage+import Calamity.Types.Model.Guild.Ban+import Calamity.Types.Model.Guild.Emoji+import Calamity.Types.Model.Guild.Guild+import Calamity.Types.Model.Guild.Member+import Calamity.Types.Model.Guild.Role+import Calamity.Types.Model.Guild.UnavailableGuild+import Calamity.Types.Model.Presence.Presence+import Calamity.Types.Model.User+import Calamity.Types.Model.Voice+import Calamity.Types.Snowflake+import Calamity.Types.UnixTimestamp -import           Data.Aeson-import           Data.Dynamic-import           Data.Text.Lazy                              ( Text )-import           Data.Time-import           Data.Typeable-import           Data.Vector.Unboxing                        ( Vector )+import Data.Aeson+import Data.Dynamic+import Data.Text.Lazy (Text)+import Data.Time+import Data.Typeable+import Data.Vector.Unboxing (Vector) -import           GHC.Generics+import GHC.Generics  data CalamityEvent   = Dispatch-    Int -- ^ The shard that pushed this event-    DispatchData -- ^ The attached data+      Int+      -- ^ The shard that pushed this event+      DispatchData+      -- ^ The attached data   | Custom-    TypeRep -- ^ The name of the custom event-    Dynamic -- ^ The data sent to the custom event+      TypeRep+      -- ^ The name of the custom event+      Dynamic+      -- ^ The data sent to the custom event   | ShutDown-  deriving ( Show, Generic )+  deriving (Show, Generic)  data DispatchData   = Ready !ReadyData@@ -64,8 +68,8 @@   | MessageUpdate !UpdatedMessage   | MessageDelete !MessageDeleteData   | MessageDeleteBulk !MessageDeleteBulkData-  | MessageReactionAdd !Reaction-  | MessageReactionRemove !Reaction+  | MessageReactionAdd !ReactionEvtData+  | MessageReactionRemove !ReactionEvtData   | MessageReactionRemoveAll !MessageReactionRemoveAllData   | PresenceUpdate !PresenceUpdateData   | TypingStart !TypingStartData@@ -73,58 +77,58 @@   | VoiceStateUpdate !VoiceState   | VoiceServerUpdate !VoiceServerUpdateData   | WebhooksUpdate !WebhooksUpdateData-  deriving ( Show, Generic, CtorName )+  deriving (Show, Generic, CtorName)  data ReadyData = ReadyData-  { v         :: Integer-  , user      :: User-  , guilds    :: [UnavailableGuild]+  { v :: Integer+  , user :: User+  , guilds :: [UnavailableGuild]   , sessionID :: Text   }-  deriving ( Show, Generic )-  deriving FromJSON via CalamityJSON ReadyData+  deriving (Show, Generic)+  deriving (FromJSON) via CalamityJSON ReadyData  data ChannelPinsUpdateData = ChannelPinsUpdateData-  { channelID        :: Snowflake Channel+  { channelID :: Snowflake Channel   , lastPinTimestamp :: Maybe UTCTime   }-  deriving ( Show, Generic )-  deriving FromJSON via CalamityJSON ChannelPinsUpdateData+  deriving (Show, Generic)+  deriving (FromJSON) via CalamityJSON ChannelPinsUpdateData  data GuildEmojisUpdateData = GuildEmojisUpdateData   { guildID :: Snowflake Guild-  , emojis  :: [Emoji]+  , emojis :: [Emoji]   }-  deriving ( Show, Generic )-  deriving FromJSON via CalamityJSON GuildEmojisUpdateData+  deriving (Show, Generic)+  deriving (FromJSON) via CalamityJSON GuildEmojisUpdateData  newtype GuildIntegrationsUpdateData = GuildIntegrationsUpdateData   { guildID :: Snowflake Guild   }-  deriving newtype ( Show, Generic )-  deriving FromJSON via CalamityJSON GuildIntegrationsUpdateData+  deriving newtype (Show, Generic)+  deriving (FromJSON) via CalamityJSON GuildIntegrationsUpdateData  data GuildMemberRemoveData = GuildMemberRemoveData   { guildID :: Snowflake Guild-  , user    :: User+  , user :: User   }-  deriving ( Show, Generic )-  deriving FromJSON via CalamityJSON GuildMemberRemoveData+  deriving (Show, Generic)+  deriving (FromJSON) via CalamityJSON GuildMemberRemoveData  data GuildMemberUpdateData = GuildMemberUpdateData-  { guildID  :: Snowflake Guild-  , roles    :: Vector (Snowflake Role)-  , user     :: User-  , nick     :: Maybe Text+  { guildID :: Snowflake Guild+  , roles :: Vector (Snowflake Role)+  , user :: User+  , nick :: Maybe Text   }-  deriving ( Show, Generic )-  deriving FromJSON via CalamityJSON GuildMemberUpdateData+  deriving (Show, Generic)+  deriving (FromJSON) via CalamityJSON GuildMemberUpdateData  data GuildMembersChunkData = GuildMembersChunkData   { guildID :: Snowflake Guild   , members :: [Member]   }-  deriving ( Show, Generic )+  deriving (Show, Generic)  instance FromJSON GuildMembersChunkData where   parseJSON = withObject "GuildMembersChunkData" $ \v -> do@@ -138,73 +142,75 @@  data GuildRoleData = GuildRoleData   { guildID :: Snowflake Guild-  , role    :: Role+  , role :: Role   }-  deriving ( Show, Generic )-  deriving FromJSON via CalamityJSON GuildRoleData+  deriving (Show, Generic)+  deriving (FromJSON) via CalamityJSON GuildRoleData  data GuildRoleDeleteData = GuildRoleDeleteData   { guildID :: Snowflake Guild-  , roleID  :: Snowflake Role+  , roleID :: Snowflake Role   }-  deriving ( Show, Generic )-  deriving FromJSON via CalamityJSON GuildRoleDeleteData+  deriving (Show, Generic)+  deriving (FromJSON) via CalamityJSON GuildRoleDeleteData  data InviteCreateData = InviteCreateData-  { channelID      :: Snowflake Channel-  , code           :: Text-  , createdAt      :: UTCTime-  , guildID        :: Maybe (Snowflake Guild)-  , inviter        :: Maybe (Snowflake User)-  , maxAge         :: Int-  , maxUses        :: Int-  , targetUser     :: Maybe (Snowflake User)+  { channelID :: Snowflake Channel+  , code :: Text+  , createdAt :: UTCTime+  , guildID :: Maybe (Snowflake Guild)+  , inviter :: Maybe (Snowflake User)+  , maxAge :: Int+  , maxUses :: Int+  , targetUser :: Maybe (Snowflake User)   , targetUserType :: Maybe Integer-  , temporary      :: Bool-  , uses           :: Integer+  , temporary :: Bool+  , uses :: Integer   }-  deriving ( Show, Generic )-  deriving ( FromJSON ) via WithSpecialCases-      '["inviter" `ExtractFieldFrom` "id", "targetUser" `ExtractFieldFrom` "id"]-      InviteCreateData+  deriving (Show, Generic)+  deriving+    (FromJSON)+    via WithSpecialCases+          '["inviter" `ExtractFieldFrom` "id", "targetUser" `ExtractFieldFrom` "id"]+          InviteCreateData  data InviteDeleteData = InviteDeleteData   { channelID :: Snowflake Channel-  , guildID   :: Maybe (Snowflake Guild)-  , code      :: Text+  , guildID :: Maybe (Snowflake Guild)+  , code :: Text   }-  deriving ( Show, Generic )-  deriving ( FromJSON ) via CalamityJSON InviteDeleteData+  deriving (Show, Generic)+  deriving (FromJSON) via CalamityJSON InviteDeleteData  data MessageDeleteData = MessageDeleteData-  { id        :: Snowflake Message+  { id :: Snowflake Message   , channelID :: Snowflake Channel-  , guildID   :: Snowflake Guild+  , guildID :: Snowflake Guild   }-  deriving ( Show, Generic )-  deriving FromJSON via CalamityJSON MessageDeleteData+  deriving (Show, Generic)+  deriving (FromJSON) via CalamityJSON MessageDeleteData  data MessageDeleteBulkData = MessageDeleteBulkData-  { guildID   :: Snowflake Guild+  { guildID :: Snowflake Guild   , channelID :: Snowflake Channel-  , ids       :: [Snowflake Message]+  , ids :: [Snowflake Message]   }-  deriving ( Show, Generic )-  deriving FromJSON via CalamityJSON MessageDeleteBulkData+  deriving (Show, Generic)+  deriving (FromJSON) via CalamityJSON MessageDeleteBulkData  data MessageReactionRemoveAllData = MessageReactionRemoveAllData   { channelID :: Snowflake Channel   , messageID :: Snowflake Message-  , guildID   :: Maybe (Snowflake Guild)+  , guildID :: Maybe (Snowflake Guild)   }-  deriving ( Show, Generic )-  deriving FromJSON via CalamityJSON MessageReactionRemoveAllData+  deriving (Show, Generic)+  deriving (FromJSON) via CalamityJSON MessageReactionRemoveAllData  data PresenceUpdateData = PresenceUpdateData-  { userID   :: Snowflake User+  { userID :: Snowflake User   , presence :: Presence   }-  deriving ( Show, Generic )+  deriving (Show, Generic)  instance FromJSON PresenceUpdateData where   parseJSON = withObject "PresenceUpdate" $ \v -> do@@ -214,17 +220,30 @@  data TypingStartData = TypingStartData   { channelID :: Snowflake Channel-  , guildID   :: Maybe (Snowflake Guild)-  , userID    :: Snowflake User+  , guildID :: Maybe (Snowflake Guild)+  , userID :: Snowflake User   , timestamp :: UnixTimestamp   }-  deriving ( Show, Generic )-  deriving FromJSON via CalamityJSON TypingStartData+  deriving (Show, Generic)+  deriving (FromJSON) via CalamityJSON TypingStartData  newtype VoiceServerUpdateData = VoiceServerUpdateData Value-  deriving newtype ( Show, Generic )-  deriving newtype ( ToJSON, FromJSON )+  deriving newtype (Show, Generic)+  deriving newtype (ToJSON, FromJSON)  newtype WebhooksUpdateData = WebhooksUpdateData Value-  deriving newtype ( Show, Generic )-  deriving newtype ( ToJSON, FromJSON )+  deriving newtype (Show, Generic)+  deriving newtype (ToJSON, FromJSON)++data ReactionEvtData = ReactionEvtData+  { userID :: Snowflake User+  , channelID :: Snowflake Channel+  , messageID :: Snowflake Message+  , guildID :: Maybe (Snowflake Guild)+  , emoji :: RawEmoji+  }+  deriving (Eq, Show, Generic)+  deriving (ToJSON, FromJSON) via CalamityJSON ReactionEvtData+  deriving (HasID User) via HasIDField "userID" ReactionEvtData+  deriving (HasID Channel) via HasIDField "channelID" ReactionEvtData+  deriving (HasID Message) via HasIDField "messageID" ReactionEvtData

@@ -17,8 +17,6 @@  import GHC.Generics -import TextShow (showt)- data GetAuditLogOptions = GetAuditLogOptions   { userID :: Maybe (Snowflake User)   , actionType :: Maybe AuditLogAction@@ -40,8 +38,8 @@    action (GetAuditLog _ GetAuditLogOptions{userID, actionType, before, limit}) =     getWithP-      ( "user_id" =:? (showt <$> userID)-          <> "action_type" =:? (showt . fromEnum <$> actionType)-          <> "before" =:? (showt <$> before)-          <> "limit" =:? (showt <$> limit)+      ( "user_id" =:? (fromSnowflake <$> userID)+          <> "action_type" =:? (fromEnum <$> actionType)+          <> "before" =:? (fromSnowflake <$> before)+          <> "limit" =:? limit       )

@@ -301,22 +301,22 @@   action (GetChannel _) = getWith   action (ModifyChannel _ p) = putWith' (ReqBodyJson p)   action (DeleteChannel _) = deleteWith-  action (GetChannelMessages _ (Just (ChannelMessagesAround (showt . fromSnowflake -> a))) l) =-    getWithP ("around" =: a <> "limit" =:? (showt . (^. #limit) <$> l))-  action (GetChannelMessages _ (Just (ChannelMessagesBefore (showt . fromSnowflake -> a))) l) =-    getWithP ("before" =: a <> "limit" =:? (showt . (^. #limit) <$> l))-  action (GetChannelMessages _ (Just (ChannelMessagesAfter (showt . fromSnowflake -> a))) l) =-    getWithP ("after" =: a <> "limit" =:? (showt . (^. #limit) <$> l))-  action (GetChannelMessages _ Nothing l) = getWithP ("limit" =:? (showt . (^. #limit) <$> l))+  action (GetChannelMessages _ (Just (ChannelMessagesAround (fromSnowflake -> a))) l) =+    getWithP ("around" =: a <> "limit" =:? (l ^? _Just . #limit))+  action (GetChannelMessages _ (Just (ChannelMessagesBefore (fromSnowflake -> a))) l) =+    getWithP ("before" =: a <> "limit" =:? (l ^? _Just . #limit))+  action (GetChannelMessages _ (Just (ChannelMessagesAfter (fromSnowflake -> a))) l) =+    getWithP ("after" =: a <> "limit" =:? (l ^? _Just . #limit))+  action (GetChannelMessages _ Nothing l) = getWithP ("limit" =:? (l ^? _Just . #limit))   action (GetMessage _ _) = getWith   action CreateReaction{} = putEmpty   action DeleteOwnReaction{} = deleteWith   action DeleteUserReaction{} = deleteWith   action (GetReactions _ _ _ GetReactionsOptions{before, after, limit}) =     getWithP-      ( "before" =:? (showt <$> before)-          <> "after" =:? (showt <$> after)-          <> "limit" =:? (showt <$> limit)+      ( "before" =:? (fromSnowflake <$> before)+          <> "after" =:? (fromSnowflake <$> after)+          <> "limit" =:? limit       )   action (DeleteAllReactions _ _) = deleteWith   action (EditMessage _ _ o) = patchWith' (ReqBodyJson o)

@@ -328,7 +328,7 @@   action (GetGuildMember _ _) = getWith   action (ListGuildMembers _ ListMembersOptions{limit, after}) =     getWithP-      ("limit" =:? (showt <$> limit) <> "after" =:? (showt <$> after))+      ("limit" =:? limit <> "after" =:? (fromSnowflake <$> after))   action (AddGuildMember _ _ o) = putWith' (ReqBodyJson o)   action (ModifyGuildMember _ _ o) = patchWith' (ReqBodyJson o)   action (ModifyCurrentUserNick _ nick) = patchWith' (ReqBodyJson $ object ["nick" .= nick])@@ -339,7 +339,7 @@   action (GetGuildBan _ _) = getWith   action (CreateGuildBan _ _ CreateGuildBanData{deleteMessageDays, reason}) =     putEmptyP-      ("delete-message-days" =:? (showt <$> deleteMessageDays) <> "reason" =:? (showt <$> reason))+      ("delete-message-days" =:? deleteMessageDays <> "reason" =:? reason)   action (RemoveGuildBan _ _) = deleteWith   action (GetGuildRoles _) = getWith   action (CreateGuildRole _ o) = postWith' (ReqBodyJson o)

@@ -35,6 +35,7 @@ import DiPolysemy hiding (debug, error, info)  import Network.HTTP.Req+import Web.HttpApiData  import Polysemy (Sem) import qualified Polysemy as P@@ -140,6 +141,6 @@ deleteWith :: Url 'Https -> Option 'Https -> Req LbsResponse deleteWith u = req DELETE u NoReqBody lbsResponse -(=:?) :: T.Text -> Maybe T.Text -> Option 'Https+(=:?) :: ToHttpApiData a => T.Text -> Maybe a -> Option 'Https n =:? (Just x) = n =: x n =:? Nothing = mempty

@@ -23,8 +23,6 @@  import Network.HTTP.Req -import TextShow- data ModifyUserData = ModifyUserData   { username :: Maybe Text   , -- | The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data@@ -80,8 +78,8 @@   action (ModifyCurrentUser o) = patchWith' $ ReqBodyJson o   action (GetCurrentUserGuilds GetCurrentUserGuildsOptions{before, after, limit}) =     getWithP-      ( "before" =:? (showt <$> before) <> "after" =:? (showt <$> after)-          <> "limit" =:? (showt <$> limit)+      ( "before" =:? (fromSnowflake <$> before) <> "after" =:? (fromSnowflake <$> after)+          <> "limit" =:? limit       )   action (LeaveGuild _) = deleteWith   action (CreateDM (getID @User -> uid)) = postWith' $ ReqBodyJson (object ["recipient_id" .= uid])

@@ -26,7 +26,6 @@ import Network.HTTP.Req  import Network.HTTP.Client.MultipartFormData-import TextShow  data CreateWebhookData = CreateWebhookData   { username :: Maybe Text@@ -130,7 +129,7 @@   action (ExecuteWebhook _ _ o@ExecuteWebhookOptions{file = Nothing}) =     postWithP'       (ReqBodyJson . upcast @ExecuteWebhookJson $ o)-      ("wait" =:? (showt <$> o ^. #wait))+      ("wait" =:? (o ^. #wait))   action (ExecuteWebhook _ _ wh@ExecuteWebhookOptions{file = Just f}) = \u o -> do     body <- reqBodyMultipart [partLBS @IO "file" f, partLBS "payload_json" (encode . upcast @ExecuteWebhookJson $ wh)]-    postWithP' body ("wait" =:? (showt <$> wh ^. #wait)) u o+    postWithP' body ("wait" =:? (wh ^. #wait)) u o

@@ -1,32 +1,21 @@ -- | Message reactions-module Calamity.Types.Model.Channel.Reaction-    ( Reaction(..) ) where+module Calamity.Types.Model.Channel.Reaction (Reaction (..)) where -import           Calamity.Internal.AesonThings-import {-# SOURCE #-} Calamity.Types.Model.Channel-import {-# SOURCE #-} Calamity.Types.Model.Channel.Message-import           Calamity.Types.Model.Guild.Emoji-import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild-import           Calamity.Types.Model.User-import           Calamity.Types.Snowflake+import Calamity.Internal.AesonThings+import Calamity.Types.Model.Guild.Emoji -import           Data.Aeson+import Data.Aeson -import           GHC.Generics+import GHC.Generics -import           TextShow-import qualified TextShow.Generic                     as TSG+import TextShow+import qualified TextShow.Generic as TSG  data Reaction = Reaction-  { userID    :: Snowflake User-  , channelID :: Snowflake Channel-  , messageID :: Snowflake Message-  , guildID   :: Maybe (Snowflake Guild)-  , emoji     :: RawEmoji+  { count :: Integer+  , me :: Bool+  , emoji :: RawEmoji   }-  deriving ( Eq, Show, Generic )-  deriving ( TextShow ) via TSG.FromGeneric Reaction-  deriving ( ToJSON, FromJSON ) via CalamityJSON Reaction-  deriving ( HasID User ) via HasIDField "userID" Reaction-  deriving ( HasID Channel ) via HasIDField "channelID" Reaction-  deriving ( HasID Message ) via HasIDField "messageID" Reaction+  deriving (Eq, Show, Generic)+  deriving (TextShow) via TSG.FromGeneric Reaction+  deriving (ToJSON, FromJSON) via CalamityJSON Reaction

@@ -20,6 +20,8 @@ import Control.DeepSeq import Control.Lens ((^.)) import Data.Aeson+import Data.Aeson.Types+import Data.Maybe import Data.Generics.Product.Fields import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as LH@@ -72,23 +74,22 @@   parseJSON = withObject "Guild" $ \v -> do     id <- v .: "id" +    -- sadly we have now way of logging members/channels/presences' that failed to parser here     members' <- do       members' <- v .: "members"-      SM.fromList <$> traverse (\m -> parseJSON $ Object (m <> "guild_id" .= id)) members'+      pure . SM.fromList . mapMaybe (parseMaybe @Object @Member (\m -> parseJSON $ Object (m <> "guild_id" .= id))) $ members'      channels' <- do       channels' <- v .: "channels"-      SM.fromList <$> traverse (\m -> parseJSON $ Object (m <> "guild_id" .= id)) channels'+      pure . SM.fromList . mapMaybe (parseMaybe @Object @GuildChannel (\m -> parseJSON $ Object (m <> "guild_id" .= id))) $ channels'      presences' <- do       presences' <- v .: "presences"-      LH.fromList-        <$> traverse+      pure . LH.fromList . mapMaybe (parseMaybe @Object @(Snowflake User, Presence)           ( \m -> do               p <- parseJSON $ Object (m <> "guild_id" .= id)               pure (getID $ p ^. field @"user", p)-          )-          presences'+          )) $ presences'      Guild id       <$> v .: "name"

@@ -1,5 +1,18 @@ # Changelog for Calamity +## 0.1.27.0+++ Change the structure of `Reaction` to be `(count, me, emoji)`++ The previous structure of `Reaction` is now known as `ReactionEvtData`++ The type of `MessageReactionAddEvt` and `MessageReactionRemoveEvt` events has+  been changed from `(Message, Reaction)` to `(Message, User, Channel,+  RawEmoji)`++ The type of `RawMessageReactionAddEvt` and `RawMessageReactionRemoveEvt`+  events has been changed from `Reaction` to `ReactionEvtData`++ More fixes to HTTP++ When parsing guilds, channels/members/ and presences that cannot be parsed are+  (silently) ignored instead of causing parsing of the guild to fail.+ ## 0.1.26.1  + Quick fix of GetChannelMessages

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: fd4324b88c3e1af82980462b807e21231e704910a8187311dbb902ed02735a29+-- hash: 40f996e3e284d2ed02f53b7bd8da0fa83fe1e3c156c0d0f71a46cc4afab91437  name:           calamity-version:        0.1.26.1+version:        0.1.27.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@@ -156,6 +156,7 @@     , focus >=1.0 && <2     , generic-lens >=2.0 && <3     , hashable >=1.2 && <2+    , http-api-data >=0.4.3 && <0.5     , http-client >=0.5 && <0.8     , http-date >=0.0.8 && <0.1     , http-types >=0.12 && <0.13