diff --git a/Calamity/Client/Client.hs b/Calamity/Client/Client.hs --- a/Calamity/Client/Client.hs +++ b/Calamity/Client/Client.hs @@ -401,7 +401,7 @@ evtCounter <- registerCounter "events_received" [("type", S.pack $ ctorName data'), ("shard", showt shardID)] void $ addCounter 1 evtCounter cacheUpdateHisto <- registerHistogram "cache_update" mempty [10, 20 .. 100] - (time, res) <- timeA $ resetDi $ handleEvent' eventHandlers data' + (time, res) <- timeA . resetDi $ handleEvent' eventHandlers data' void $ observeHistogram time cacheUpdateHisto pure res @@ -465,7 +465,7 @@ Just guild <- getGuild (getID guild) pure $ map - ($ (guild, (if isNew then GuildCreateNew else GuildCreateAvailable))) + ($ (guild, if isNew then GuildCreateNew else GuildCreateAvailable)) (getEventHandlers @'GuildCreateEvt eh) handleEvent' eh evt@(GuildUpdate guild) = do Just oldGuild <- getGuild (getID guild) @@ -479,7 +479,7 @@ updateCache evt pure $ map - ($ (oldGuild, (if unavailable then GuildDeleteUnavailable else GuildDeleteRemoved))) + ($ (oldGuild, if unavailable then GuildDeleteUnavailable else GuildDeleteRemoved)) (getEventHandlers @'GuildDeleteEvt eh) handleEvent' eh evt@(GuildBanAdd BanData{guildID, user}) = do Just guild <- getGuild guildID @@ -520,7 +520,7 @@ updateCache evt Just guild <- getGuild guildID let memberIDs = map (getID @Member) members - let members' = catMaybes $ map (\mid -> guild ^. #members . at mid) memberIDs + let members' = mapMaybe (\mid -> guild ^. #members . at mid) memberIDs pure $ map ($ (guild, members')) (getEventHandlers @'GuildMembersChunkEvt eh) handleEvent' eh evt@(GuildRoleCreate GuildRoleData{guildID, role}) = do updateCache evt @@ -543,17 +543,17 @@ pure $ map ($ d) (getEventHandlers @'InviteCreateEvt eh) handleEvent' eh (InviteDelete d) = do pure $ map ($ d) (getEventHandlers @'InviteDeleteEvt eh) -handleEvent' eh evt@(MessageCreate msg _) = do +handleEvent' eh evt@(MessageCreate msg user member) = do updateCache evt - pure $ map ($ msg) (getEventHandlers @'MessageCreateEvt eh) -handleEvent' eh evt@(MessageUpdate msg) = do + pure $ map ($ (msg, user, member)) (getEventHandlers @'MessageCreateEvt eh) +handleEvent' eh evt@(MessageUpdate msg user member) = do oldMsg <- getMessage (getID msg) updateCache evt newMsg <- getMessage (getID msg) - let rawActions = map ($ msg) (getEventHandlers @'RawMessageUpdateEvt eh) + let rawActions = map ($ (msg, user, member)) (getEventHandlers @'RawMessageUpdateEvt eh) let actions = case (oldMsg, newMsg) of (Just oldMsg', Just newMsg') -> - map ($ (oldMsg', newMsg')) (getEventHandlers @'MessageUpdateEvt eh) + map ($ (oldMsg', newMsg', user, member)) (getEventHandlers @'MessageUpdateEvt eh) _ -> [] pure $ rawActions <> actions handleEvent' eh evt@(MessageDelete MessageDeleteData{id}) = do @@ -696,10 +696,11 @@ updateGuild guildID (#roles %~ SM.insert role) updateCache (GuildRoleDelete GuildRoleDeleteData{guildID, roleID}) = updateGuild guildID (#roles %~ sans roleID) -updateCache (MessageCreate !msg !user) = do +updateCache (MessageCreate !msg !_ !_) = setMessage msg - for_ user setUser -updateCache (MessageUpdate msg) = + -- I think it's for the best not to cache things here, instead the end user + -- can just cache manually which users and members they want +updateCache (MessageUpdate msg !_ !_) = updateMessage (getID msg) (update msg) updateCache (MessageDelete MessageDeleteData{id}) = delMessage id updateCache (MessageDeleteBulk MessageDeleteBulkData{ids}) = diff --git a/Calamity/Client/Types.hs b/Calamity/Client/Types.hs --- a/Calamity/Client/Types.hs +++ b/Calamity/Client/Types.hs @@ -209,14 +209,14 @@ EHType 'GuildRoleDeleteEvt = (Guild, Role) EHType 'InviteCreateEvt = InviteCreateData EHType 'InviteDeleteEvt = InviteDeleteData - EHType 'MessageCreateEvt = Message - EHType 'MessageUpdateEvt = (Message, Message) + EHType 'MessageCreateEvt = (Message, Maybe User, Maybe Member) + EHType 'MessageUpdateEvt = (Message, Message, Maybe User, Maybe Member) 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 'RawMessageUpdateEvt = (UpdatedMessage, Maybe User, Maybe Member) EHType 'RawMessageDeleteEvt = Snowflake Message EHType 'RawMessageDeleteBulkEvt = [Snowflake Message] EHType 'RawMessageReactionAddEvt = ReactionEvtData diff --git a/Calamity/Commands/Context.hs b/Calamity/Commands/Context.hs --- a/Calamity/Commands/Context.hs +++ b/Calamity/Commands/Context.hs @@ -16,6 +16,7 @@ import Calamity.Types.Snowflake import Calamity.Types.Tellable import qualified CalamityCommands.Context as CC +import Control.Applicative import Control.Lens hiding (Context) import Control.Monad import qualified Data.Text.Lazy as L @@ -45,6 +46,9 @@ , -- | If the command was sent in a guild, this will be present guild :: Maybe Guild , -- | The member that invoked the command, if in a guild + -- + -- Note: If discord sent a member with the message, this is used; otherwise + -- we try to fetch the member from the cache. member :: Maybe Member , -- | The channel the command was invoked from channel :: Channel @@ -77,24 +81,23 @@ instance Tellable FullContext where getChannel = pure . ctxChannelID -useFullContext :: P.Member CacheEff r => P.Sem (CC.ConstructContext Message FullContext IO () ': r) a -> P.Sem r a +useFullContext :: P.Member CacheEff r => P.Sem (CC.ConstructContext (Message, User, Maybe Member) FullContext IO () ': r) a -> P.Sem r a useFullContext = P.interpret ( \case - CC.ConstructContext (pre, cmd, up) msg -> buildContext msg pre cmd up + CC.ConstructContext (pre, cmd, up) (msg, usr, mem) -> buildContext msg usr mem pre cmd up ) -buildContext :: P.Member CacheEff r => Message -> L.Text -> Command FullContext -> L.Text -> P.Sem r (Maybe FullContext) -buildContext msg prefix command unparsed = (rightToMaybe <$>) . P.runFail $ do +buildContext :: P.Member CacheEff r => Message -> User -> Maybe Member -> L.Text -> Command FullContext -> L.Text -> P.Sem r (Maybe FullContext) +buildContext msg usr mem prefix command unparsed = (rightToMaybe <$>) . P.runFail $ do guild <- join <$> getGuild `traverse` (msg ^. #guildID) - let member = guild ^? _Just . #members . ix (coerceSnowflake $ getID @User msg) + let member = mem <|> guild ^? _Just . #members . ix (coerceSnowflake $ getID @User msg) let gchan = guild ^? _Just . #channels . ix (coerceSnowflake $ getID @Channel msg) Just channel <- case gchan of Just chan -> pure . pure $ GuildChannel' chan Nothing -> DMChannel' <<$>> getDM (coerceSnowflake $ getID @Channel msg) - Just user <- getUser $ getID msg - pure $ FullContext msg guild member channel user command prefix unparsed + pure $ FullContext msg guild member channel usr command prefix unparsed -- | A lightweight context that doesn't need any cache information data LightContext = LightContext @@ -105,7 +108,11 @@ , -- | The channel the command was invoked from channelID :: Snowflake Channel , -- | The user that invoked the command - userID :: Snowflake User + user :: User + , -- | The member that triggered the command. + -- + -- Note: Only sent if discord sent the member object with the message. + member :: Maybe Member , -- | The command that was invoked command :: Command LightContext , -- | The prefix that was used to invoke the command @@ -117,7 +124,7 @@ deriving (TextShow) via TSG.FromGeneric LightContext deriving (HasID Channel) via HasIDField "channelID" LightContext deriving (HasID Message) via HasIDField "message" LightContext - deriving (HasID User) via HasIDField "userID" LightContext + deriving (HasID User) via HasIDField "user" LightContext instance CC.CommandContext IO LightContext () where ctxPrefix = (^. #prefix) @@ -127,16 +134,16 @@ instance CalamityCommandContext LightContext where ctxChannelID = (^. #channelID) ctxGuildID = (^. #guildID) - ctxUserID = (^. #userID) + ctxUserID = (^. #user . #id) ctxMessage = (^. #message) instance Tellable LightContext where getChannel = pure . ctxChannelID -useLightContext :: P.Sem (CC.ConstructContext Message LightContext IO () ': r) a -> P.Sem r a +useLightContext :: P.Sem (CC.ConstructContext (Message, User, Maybe Member) LightContext IO () ': r) a -> P.Sem r a useLightContext = P.interpret ( \case - CC.ConstructContext (pre, cmd, up) msg -> - pure . Just $ LightContext msg (msg ^. #guildID) (msg ^. #channelID) (msg ^. #author) cmd pre up + CC.ConstructContext (pre, cmd, up) (msg, usr, mem) -> + pure . Just $ LightContext msg (msg ^. #guildID) (msg ^. #channelID) usr mem cmd pre up ) diff --git a/Calamity/Commands/Utils.hs b/Calamity/Commands/Utils.hs --- a/Calamity/Commands/Utils.hs +++ b/Calamity/Commands/Utils.hs @@ -13,21 +13,23 @@ import Calamity.Client.Client import Calamity.Client.Types -import CalamityCommands.CommandUtils -import qualified CalamityCommands.Error as CC import Calamity.Commands.Dsl import Calamity.Commands.Types import Calamity.Metrics.Eff import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild.Member (Member) +import Calamity.Types.Model.User (User) +import CalamityCommands.CommandUtils +import qualified CalamityCommands.Context as CC +import qualified CalamityCommands.Error as CC +import qualified CalamityCommands.ParsePrefix as CC import qualified CalamityCommands.Utils as CC import Control.Monad import qualified Data.Text as S import qualified Data.Text.Lazy as L +import Data.Typeable import GHC.Generics (Generic) import qualified Polysemy as P -import qualified CalamityCommands.Context as CC -import qualified CalamityCommands.ParsePrefix as CC -import Data.Typeable data CmdInvokeFailReason c = NoContext @@ -42,6 +44,8 @@ data CommandNotFound = CommandNotFound { msg :: Message + , user :: User + , member :: Maybe Member , -- | The groups that were successfully parsed path :: [L.Text] } @@ -90,21 +94,24 @@ -- -- Fired when a command is successfully invoked. -- -addCommands :: (BotC r, Typeable c, CommandContext c, P.Members [CC.ParsePrefix Message, CC.ConstructContext Message c IO ()] r) +addCommands :: (BotC r, Typeable c, CommandContext c, P.Members [CC.ParsePrefix Message, CC.ConstructContext (Message, User, Maybe Member) c IO ()] r) => P.Sem (DSLState c r) a -> P.Sem r (P.Sem r (), CommandHandler c, a) addCommands m = do (handler, res) <- CC.buildCommands m - remove <- react @'MessageCreateEvt $ \msg -> do - CC.parsePrefix msg >>= \case - Just (prefix, cmd) -> do - r <- CC.handleCommands handler msg prefix cmd - case r of - Left (CC.CommandInvokeError ctx e) -> fire . customEvt $ CtxCommandError ctx e - Left (CC.NotFound path) -> fire . customEvt $ CommandNotFound msg path - Left CC.NoContext -> pure () -- ignore if context couldn't be built - Right (ctx, ()) -> do - cmdInvoke <- registerCounter "commands_invoked" [("name", S.unwords $ commandPath (CC.ctxCommand ctx))] - void $ addCounter 1 cmdInvoke - fire . customEvt $ CommandInvoked ctx - Nothing -> pure () + remove <- react @'MessageCreateEvt $ \case + (msg, Just user, member) -> do + CC.parsePrefix msg >>= \case + Just (prefix, cmd) -> do + r <- CC.handleCommands handler (msg, user, member) prefix cmd + case r of + Left (CC.CommandInvokeError ctx e) -> fire . customEvt $ CtxCommandError ctx e + Left (CC.NotFound path) -> fire . customEvt $ CommandNotFound msg user member path + Left CC.NoContext -> pure () -- ignore if context couldn't be built + Right (ctx, ()) -> do + cmdInvoke <- registerCounter "commands_invoked" [("name", S.unwords $ commandPath (CC.ctxCommand ctx))] + void $ addCounter 1 cmdInvoke + fire . customEvt $ CommandInvoked ctx + + Nothing -> pure () + _ -> pure () pure (remove, handler, res) diff --git a/Calamity/Gateway/DispatchEvents.hs b/Calamity/Gateway/DispatchEvents.hs --- a/Calamity/Gateway/DispatchEvents.hs +++ b/Calamity/Gateway/DispatchEvents.hs @@ -58,8 +58,8 @@ | GuildRoleDelete !GuildRoleDeleteData | InviteCreate !InviteCreateData | InviteDelete !InviteDeleteData - | MessageCreate !Message !(Maybe User) - | MessageUpdate !UpdatedMessage + | MessageCreate !Message !(Maybe User) !(Maybe Member) + | MessageUpdate !UpdatedMessage !(Maybe User) !(Maybe Member) | MessageDelete !MessageDeleteData | MessageDeleteBulk !MessageDeleteBulkData | MessageReactionAdd !ReactionEvtData diff --git a/Calamity/Gateway/Types.hs b/Calamity/Gateway/Types.hs --- a/Calamity/Gateway/Types.hs +++ b/Calamity/Gateway/Types.hs @@ -115,9 +115,20 @@ parseDispatchData INVITE_DELETE data' = InviteDelete <$> parseJSON data' parseDispatchData MESSAGE_CREATE data' = do message <- parseJSON data' - let user = parseMaybe parseJSON =<< (data' ^? _Object . ix "author") - pure $ MessageCreate message user -parseDispatchData MESSAGE_UPDATE data' = MessageUpdate <$> parseJSON data' + let member = parseMaybe (withObject "MessageCreate.member" $ \o -> do + userObject :: Object <- o .: "author" + memberObject :: Object <- o .: "member" + parseJSON $ Object (memberObject <> "user" .= userObject)) data' + let user = parseMaybe parseJSON =<< data' ^? _Object . ix "author" + pure $ MessageCreate message user member +parseDispatchData MESSAGE_UPDATE data' = do + message <- parseJSON data' + let member = parseMaybe (withObject "MessageCreate.member" $ \o -> do + userObject :: Object <- o .: "author" + memberObject :: Object <- o .: "member" + parseJSON $ Object (memberObject <> "user" .= userObject)) data' + let user = parseMaybe parseJSON =<< data' ^? _Object . ix "author" + pure $ MessageUpdate message user member parseDispatchData MESSAGE_DELETE data' = MessageDelete <$> parseJSON data' parseDispatchData MESSAGE_DELETE_BULK data' = MessageDeleteBulk <$> parseJSON data' parseDispatchData MESSAGE_REACTION_ADD data' = MessageReactionAdd <$> parseJSON data' diff --git a/Calamity/Types/Model/Channel/Component.hs b/Calamity/Types/Model/Channel/Component.hs --- a/Calamity/Types/Model/Channel/Component.hs +++ b/Calamity/Types/Model/Channel/Component.hs @@ -21,7 +21,7 @@ data Button = Button { style :: ButtonStyle , label :: Maybe L.Text - , emoji :: Maybe (Partial Emoji) + , emoji :: Maybe RawEmoji , customID :: Maybe L.Text , url :: Maybe L.Text , disabled :: Bool 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 @@ -12,7 +12,7 @@ import Calamity.Internal.Utils import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild.Emoji -import {-# SOURCE #-} Calamity.Types.Model.Guild.Member +import Calamity.Types.Model.Guild.Member import Calamity.Types.Model.Guild.Role import Calamity.Types.Model.Presence.Presence import Calamity.Types.Model.User diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,26 @@ # Changelog for Calamity +## 0.1.31.0 + ++ We now pass through the `.member` field of message create/update events to the + event handler. ++ The payload type of `MessageCreateEvt` has changed from `Message` to + `(Message, Maybe User, Maybe Member)`. ++ The payload type of `MessageUpdateEvt` has changed from `(Message, Message)` + to `(Message, Message, Maybe User, Maybe Member)`. ++ The payload type of `RawMessageUpdateEvt` has changed from `UpdatedMessage` to + `(UpdatedMessage, Maybe User, Maybe Member)`. ++ The provided `ConstructContext` effect handlers have changed from handling + `ConstructContext Message ...` to `ConstructContext (Message, User, Maybe + Member) ...`. ++ `FullContext` now uses the member passed with the message create event if + available. ++ `LightContext` now has a `.member` parameter, which is the member passed with + the message create event if available. The `userID` field has also been + replaced with `user :: User`. ++ `CommandNotFound` now contains the `User` and `Maybe Member` of the message + create event that triggered it. + ## 0.1.30.4 + The `status` field of `StatusUpdateData` has been changed from `Text` to diff --git a/calamity.cabal b/calamity.cabal --- a/calamity.cabal +++ b/calamity.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: calamity -version: 0.1.30.4 +version: 0.1.31.0 synopsis: A library for writing discord bots in haskell description: Please see the README on GitHub at category: Network, Web @@ -213,7 +213,7 @@ , mime-types ==0.1.* , mtl >=2.2 && <3 , polysemy >=1.5 && <2 - , polysemy-plugin ==0.3.* + , polysemy-plugin >=0.3 && <0.5 , reflection >=2.1 && <3 , req >=3.1 && <3.10 , safe-exceptions >=0.1 && <2 @@ -223,9 +223,9 @@ , stm-containers >=1.1 && <2 , text >=1.2 && <2 , text-show >=3.8 && <4 - , time >=1.8 && <1.12 + , time >=1.8 && <1.13 , tls >=1.4 && <2 - , typerep-map ==0.3.* + , typerep-map >=0.3 && <0.5 , unagi-chan ==0.4.* , unboxing-vector ==0.2.* , unordered-containers ==0.2.*