diff --git a/Calamity/Client/Client.hs b/Calamity/Client/Client.hs --- a/Calamity/Client/Client.hs +++ b/Calamity/Client/Client.hs @@ -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) diff --git a/Calamity/Client/Types.hs b/Calamity/Client/Types.hs --- a/Calamity/Client/Types.hs +++ b/Calamity/Client/Types.hs @@ -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 diff --git a/Calamity/Gateway/DispatchEvents.hs b/Calamity/Gateway/DispatchEvents.hs --- a/Calamity/Gateway/DispatchEvents.hs +++ b/Calamity/Gateway/DispatchEvents.hs @@ -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 diff --git a/Calamity/HTTP/AuditLog.hs b/Calamity/HTTP/AuditLog.hs --- a/Calamity/HTTP/AuditLog.hs +++ b/Calamity/HTTP/AuditLog.hs @@ -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 ) diff --git a/Calamity/HTTP/Channel.hs b/Calamity/HTTP/Channel.hs --- a/Calamity/HTTP/Channel.hs +++ b/Calamity/HTTP/Channel.hs @@ -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) diff --git a/Calamity/HTTP/Guild.hs b/Calamity/HTTP/Guild.hs --- a/Calamity/HTTP/Guild.hs +++ b/Calamity/HTTP/Guild.hs @@ -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) diff --git a/Calamity/HTTP/Internal/Request.hs b/Calamity/HTTP/Internal/Request.hs --- a/Calamity/HTTP/Internal/Request.hs +++ b/Calamity/HTTP/Internal/Request.hs @@ -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 diff --git a/Calamity/HTTP/User.hs b/Calamity/HTTP/User.hs --- a/Calamity/HTTP/User.hs +++ b/Calamity/HTTP/User.hs @@ -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]) diff --git a/Calamity/HTTP/Webhook.hs b/Calamity/HTTP/Webhook.hs --- a/Calamity/HTTP/Webhook.hs +++ b/Calamity/HTTP/Webhook.hs @@ -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 diff --git a/Calamity/Types/Model/Channel/Reaction.hs b/Calamity/Types/Model/Channel/Reaction.hs --- a/Calamity/Types/Model/Channel/Reaction.hs +++ b/Calamity/Types/Model/Channel/Reaction.hs @@ -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 diff --git a/Calamity/Types/Model/Guild/Guild.hs b/Calamity/Types/Model/Guild/Guild.hs --- a/Calamity/Types/Model/Guild/Guild.hs +++ b/Calamity/Types/Model/Guild/Guild.hs @@ -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" diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/calamity.cabal b/calamity.cabal --- a/calamity.cabal +++ b/calamity.cabal @@ -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 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