calamity 0.1.30.4 → 0.1.31.0

raw patch · 10 files changed

+105/−58 lines, 10 filesdep ~polysemy-plugindep ~timedep ~typerep-mapPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: polysemy-plugin, time, typerep-map

API changes (from Hackage documentation)

Files

• Calamity/Client/Client.hs +13/−12
• Calamity/Client/Types.hs +3/−3
• Calamity/Commands/Context.hs +20/−13
• Calamity/Commands/Utils.hs +26/−19
• Calamity/Gateway/DispatchEvents.hs +2/−2
• Calamity/Gateway/Types.hs +14/−3
• Calamity/Types/Model/Channel/Component.hs +1/−1
• Calamity/Types/Model/Guild/Guild.hs +1/−1
• ChangeLog.md +21/−0
• calamity.cabal +4/−4

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

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

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

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

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

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

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

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

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

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