diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,8 +1,18 @@ # Changelog for Calamity +## 0.1.22.0 + +* Update to gateway/http endpoint v8. +* Updated the message types. +* Added `defaultIntents`, which is all but the privileged intents, also a + Data.Default instance. +* `runBotIO` and `runBotIO'` now always take an `Intents` parameter. +* Users are cached from messages, as well as member create events. +* Fix `Overwrite`s having an incorrect `type_` field. + ## 0.1.21.0 -- Fix ToJSON instance for `RawEmoji` +* Fix ToJSON instance for `RawEmoji` ## 0.1.20.1 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -110,7 +110,7 @@ token <- view packed <$> getEnv "BOT_TOKEN" Di.new $ \di -> void . P.runFinal . P.embedToFinal . DiP.runDiToIO di . runCounterAtomic . runCacheInMemory . runMetricsNoop . useConstantPrefix "!" - $ runBotIO (BotToken token) $ do + $ runBotIO (BotToken token) defaultIntents $ do addCommands $ do helpCommand command @'[User] "utest" $ \ctx u -> do 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: 5fa37b5c8ac352c7170a1e67f6f1c722b1e1e041e5f49cd19058014ae1b1caf4 +-- hash: b3783e8d7e7db062a2aa10f4642564dea368efe4f9130957aaa0259e2f96e54e name: calamity -version: 0.1.21.0 +version: 0.1.22.0 synopsis: A library for writing discord bots in haskell description: Please see the README on GitHub at category: Network, Web diff --git a/src/Calamity/Client/Client.hs b/src/Calamity/Client/Client.hs --- a/src/Calamity/Client/Client.hs +++ b/src/Calamity/Client/Client.hs @@ -102,9 +102,11 @@ runBotIO :: forall r a. (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r, Typeable (SetupEff r)) => Token + -> Intents + -- ^ The intents the bot should use -> P.Sem (SetupEff r) a -> P.Sem r (Maybe StartupError) -runBotIO token setup = runBotIO' token Nothing Nothing Nothing setup +runBotIO token intents setup = runBotIO' token intents Nothing Nothing setup resetDi :: BotC r => P.Sem r a -> P.Sem r a resetDi m = do @@ -117,15 +119,15 @@ runBotIO' :: forall r a. (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r, Typeable (SetupEff r)) => Token + -> Intents + -- ^ The intents the bot should use -> Maybe Session -- ^ The HTTP session to use, defaults to 'newAPISession' -> Maybe StatusUpdateData -- ^ The initial status to send to the gateway - -> Maybe Intents - -- ^ The intents to send to the gateway -> P.Sem (SetupEff r) a -> P.Sem r (Maybe StartupError) -runBotIO' token session status intents setup = do +runBotIO' token intents session status setup = do initialDi <- Di.fetch session' <- maybe (P.embed newAPISession) pure session client <- P.embed $ newClient token session' initialDi @@ -517,7 +519,7 @@ handleEvent' eh (InviteDelete d) = do pure $ map ($ d) (getEventHandlers @'InviteDeleteEvt eh) -handleEvent' eh evt@(MessageCreate msg) = do +handleEvent' eh evt@(MessageCreate msg _) = do updateCache evt pure $ map ($ msg) (getEventHandlers @'MessageCreateEvt eh) @@ -675,7 +677,9 @@ updateCache (GuildRoleDelete GuildRoleDeleteData { guildID, roleID }) = updateGuild guildID (#roles %~ sans roleID) -updateCache (MessageCreate msg) = setMessage msg +updateCache (MessageCreate msg user) = do + setMessage msg + forM_ user setUser updateCache (MessageUpdate msg) = updateMessage (getID msg) (update msg) diff --git a/src/Calamity/Client/ShardManager.hs b/src/Calamity/Client/ShardManager.hs --- a/src/Calamity/Client/ShardManager.hs +++ b/src/Calamity/Client/ShardManager.hs @@ -26,7 +26,7 @@ mapLeft _ (Right b) = Right b -- | Connects the bot to the gateway over n shards -shardBot :: BotC r => Maybe StatusUpdateData -> Maybe Intents -> Sem r (Either StartupError ()) +shardBot :: BotC r => Maybe StatusUpdateData -> Intents -> Sem r (Either StartupError ()) shardBot initialStatus intents = (mapLeft StartupError <$>) . P.runFail $ do numShardsVar <- P.asks numShards shardsVar <- P.asks shards @@ -50,24 +50,3 @@ P.embed . atomically $ writeTVar shardsVar shards --- | Connects the bot to the gateway over 1 shard (userbot) --- shardUserBot :: BotM () --- shardUserBot = do --- numShardsVar <- asks numShards --- shardsVar <- asks shards - --- hasShards <- liftIO $ (not . null) <$> readTVarIO shardsVar --- when hasShards $ fail "don't use shardUserBot on an already running bot." - --- token <- asks Calamity.Client.Types.token --- eventQueue <- asks eventQueue --- logEnv <- askLog - --- gateway <- aa <$> invoke GetGateway - --- let host = gateway ^. #url --- liftIO $ putMVar numShardsVar 1 - --- liftIO $ do --- shard <- newShard host 0 1 token logEnv eventQueue --- atomically $ writeTVar shardsVar [shard] diff --git a/src/Calamity/Gateway/DispatchEvents.hs b/src/Calamity/Gateway/DispatchEvents.hs --- a/src/Calamity/Gateway/DispatchEvents.hs +++ b/src/Calamity/Gateway/DispatchEvents.hs @@ -59,7 +59,7 @@ | GuildRoleDelete GuildRoleDeleteData | InviteCreate InviteCreateData | InviteDelete InviteDeleteData - | MessageCreate Message + | MessageCreate Message (Maybe User) | MessageUpdate UpdatedMessage | MessageDelete MessageDeleteData | MessageDeleteBulk MessageDeleteBulkData diff --git a/src/Calamity/Gateway/Intents.hs b/src/Calamity/Gateway/Intents.hs --- a/src/Calamity/Gateway/Intents.hs +++ b/src/Calamity/Gateway/Intents.hs @@ -4,6 +4,7 @@ -- | Discord gateway intents module Calamity.Gateway.Intents ( Intents(..) + , defaultIntents , intentGuilds , intentGuildMembers , intentGuildBans @@ -22,9 +23,10 @@ import Data.Aeson ( ToJSON ) import Data.Bits -import Data.Flags () +import Data.Flags (allBut, (.+.)) import Data.Flags.TH import Data.Word +import Data.Default.Class $(bitmaskWrapper "Intents" ''Word32 [] [ ("intentGuilds", 1 `shiftL` 0) @@ -44,3 +46,11 @@ , ("intentDirectMessageTyping", 1 `shiftL` 14)]) deriving via Word32 instance ToJSON Intents + +-- | Default intents are all but the privileged intents: members and intents +defaultIntents :: Intents +defaultIntents = allBut (intentGuildMembers .+. intentGuildPresences) + +-- | Default intents are all but the privileged intents: members and intents +instance Default Intents where + def = defaultIntents diff --git a/src/Calamity/Gateway/Shard.hs b/src/Calamity/Gateway/Shard.hs --- a/src/Calamity/Gateway/Shard.hs +++ b/src/Calamity/Gateway/Shard.hs @@ -69,7 +69,7 @@ -> Int -> Token -> Maybe StatusUpdateData - -> Maybe Intents + -> Intents -> UC.InChan CalamityEvent -> Sem r (UC.InChan ControlMessage, Async (Maybe ())) newShard gateway id count token presence intents evtIn = do @@ -163,7 +163,7 @@ let host' = fromMaybe host $ L.stripPrefix "wss://" host info $ "starting up shard "+| (shard ^. #shardID) |+" of "+| (shard ^. #shardCount) |+"" - innerLoopVal <- runWebsocket host' "/?v=6&encoding=json" innerloop + innerLoopVal <- runWebsocket host' "/?v=8&encoding=json" innerloop case innerLoopVal of Just ShardFlowShutDown -> do diff --git a/src/Calamity/Gateway/Types.hs b/src/Calamity/Gateway/Types.hs --- a/src/Calamity/Gateway/Types.hs +++ b/src/Calamity/Gateway/Types.hs @@ -44,6 +44,10 @@ import qualified Polysemy.AtomicState as P import qualified TextShow.Generic as TSG import TextShow (TextShow) +import Control.Lens.Operators ((^?)) +import Data.Aeson.Types (parseMaybe) +import Control.Lens (Ixed(ix)) +import Data.Aeson.Lens type ShardC r = (P.Members '[LogEff, P.AtomicState ShardState, P.Embed IO, P.Final IO, P.Async, MetricEff] r) @@ -109,7 +113,10 @@ parseDispatchData GUILD_ROLE_DELETE data' = GuildRoleDelete <$> parseJSON data' parseDispatchData INVITE_CREATE data' = InviteCreate <$> parseJSON data' parseDispatchData INVITE_DELETE data' = InviteDelete <$> parseJSON data' -parseDispatchData MESSAGE_CREATE data' = MessageCreate <$> 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' parseDispatchData MESSAGE_DELETE data' = MessageDelete <$> parseJSON data' parseDispatchData MESSAGE_DELETE_BULK data' = MessageDeleteBulk <$> parseJSON data' @@ -205,7 +212,7 @@ , largeThreshold :: Int , shard :: (Int, Int) , presence :: Maybe StatusUpdateData - , intents :: Maybe Intents + , intents :: Intents } deriving ( Show, Generic ) deriving ToJSON via CalamityJSON IdentifyData @@ -268,7 +275,7 @@ , shardState :: IORef ShardState , token :: Text , initialStatus :: Maybe StatusUpdateData - , intents :: Maybe Intents + , intents :: Intents } deriving ( Generic ) diff --git a/src/Calamity/HTTP/Internal/Route.hs b/src/Calamity/HTTP/Internal/Route.hs --- a/src/Calamity/HTTP/Internal/Route.hs +++ b/src/Calamity/HTTP/Internal/Route.hs @@ -125,7 +125,7 @@ hashWithSalt s (Route _ ident c g) = hashWithSalt s (ident, c, g) baseURL :: Text -baseURL = "https://discord.com/api/v7" +baseURL = "https://discord.com/api/v8" buildRoute :: forall (ids :: [(Type, RouteRequirement)]) diff --git a/src/Calamity/Types/Model/Channel/Message.hs b/src/Calamity/Types/Model/Channel/Message.hs --- a/src/Calamity/Types/Model/Channel/Message.hs +++ b/src/Calamity/Types/Model/Channel/Message.hs @@ -65,6 +65,13 @@ | ChannelIconChange | ChannelPinnedMessage | GuildMemberJoin + | UserPremiumGuildSubscription + | UserPremiumGuildSubscriptionTier1 + | UserPremiumGuildSubscriptionTier2 + | UserPremiumGuildSubscriptionTier3 + | ChannelFollowAdd + | GuildDiscoveryDisqualified + | GuildDiscoveryRequalified deriving ( Eq, Show, Enum, Generic ) deriving ( TextShow ) via TSG.FromGeneric MessageType @@ -79,5 +86,12 @@ 5 -> pure ChannelIconChange 6 -> pure ChannelPinnedMessage 7 -> pure GuildMemberJoin + 8 -> pure UserPremiumGuildSubscription + 9 -> pure UserPremiumGuildSubscriptionTier1 + 10 -> pure UserPremiumGuildSubscriptionTier2 + 11 -> pure UserPremiumGuildSubscriptionTier3 + 12 -> pure ChannelFollowAdd + 13 -> pure GuildDiscoveryDisqualified + 14 -> pure GuildDiscoveryRequalified _ -> fail $ "Invalid MessageType: " <> show n Nothing -> fail $ "Invalid MessageType: " <> show n diff --git a/src/Calamity/Types/Model/Guild/Overwrite.hs b/src/Calamity/Types/Model/Guild/Overwrite.hs --- a/src/Calamity/Types/Model/Guild/Overwrite.hs +++ b/src/Calamity/Types/Model/Guild/Overwrite.hs @@ -7,7 +7,6 @@ import Calamity.Types.Snowflake import Data.Aeson -import Data.Text.Lazy ( Text ) import GHC.Generics @@ -16,7 +15,7 @@ data Overwrite = Overwrite { id :: Snowflake Overwrite - , type_ :: Text + , type_ :: Int , allow :: Permissions , deny :: Permissions } diff --git a/src/Calamity/Types/Model/Guild/Permissions.hs b/src/Calamity/Types/Model/Guild/Permissions.hs --- a/src/Calamity/Types/Model/Guild/Permissions.hs +++ b/src/Calamity/Types/Model/Guild/Permissions.hs @@ -1,83 +1,98 @@ -{-# LANGUAGE NoDeriveAnyClass #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoDeriveAnyClass #-} -- | Guild permissions module Calamity.Types.Model.Guild.Permissions - ( Permissions(..) - , createInstantInvite - , kickMembers - , banMembers - , administrator - , manageChannels - , manageGuild - , addReactions - , viewAuditLog - , prioritySpeaker - , stream - , viewChannel - , sendMessages - , sendTtsMessages - , manageMessages - , embedLinks - , attachFiles - , readMessageHistory - , mentionEveryone - , useExternalEmojis - , viewGuildInsights - , connect - , speak - , muteMembers - , deafenMembers - , moveMembers - , useVad - , changeNickname - , manageNicknames - , manageRoles - , manageWebhooks - , manageEmojis ) where - -import Data.Aeson ( FromJSON, ToJSON ) -import Data.Flags () -import Data.Flags.TH -import Data.Word + ( Permissions (..), + createInstantInvite, + kickMembers, + banMembers, + administrator, + manageChannels, + manageGuild, + addReactions, + viewAuditLog, + prioritySpeaker, + stream, + viewChannel, + sendMessages, + sendTtsMessages, + manageMessages, + embedLinks, + attachFiles, + readMessageHistory, + mentionEveryone, + useExternalEmojis, + viewGuildInsights, + connect, + speak, + muteMembers, + deafenMembers, + moveMembers, + useVad, + changeNickname, + manageNicknames, + manageRoles, + manageWebhooks, + manageEmojis, + ) +where -import TextShow +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Aeson.Types (parseFail) +import Data.Flags () +import Data.Flags.TH +import Data.Text.Read (decimal) +import Data.Word +import TextShow -$(bitmaskWrapper "Permissions" ''Word64 [] - [ ("createInstantInvite", 0x00000001) - , ("kickMembers", 0x00000002) - , ("banMembers", 0x00000004) - , ("administrator", 0x00000008) - , ("manageChannels", 0x00000010) - , ("manageGuild", 0x00000020) - , ("addReactions", 0x00000040) - , ("viewAuditLog", 0x00000080) - , ("prioritySpeaker", 0x00000100) - , ("stream", 0x00000200) - , ("viewChannel", 0x00000400) - , ("sendMessages", 0x00000800) - , ("sendTtsMessages", 0x00001000) - , ("manageMessages", 0x00002000) - , ("embedLinks", 0x00004000) - , ("attachFiles", 0x00008000) - , ("readMessageHistory", 0x00010000) - , ("mentionEveryone", 0x00020000) - , ("useExternalEmojis", 0x00040000) - , ("viewGuildInsights", 0x00080000) - , ("connect", 0x00100000) - , ("speak", 0x00200000) - , ("muteMembers", 0x00400000) - , ("deafenMembers", 0x00800000) - , ("moveMembers", 0x01000000) - , ("useVad", 0x02000000) - , ("changeNickname", 0x04000000) - , ("manageNicknames", 0x08000000) - , ("manageRoles", 0x10000000) - , ("manageWebhooks", 0x20000000) - , ("manageEmojis", 0x4000000)]) +$( bitmaskWrapper + "Permissions" + ''Word64 + [] + [ ("createInstantInvite", 0x00000001), + ("kickMembers", 0x00000002), + ("banMembers", 0x00000004), + ("administrator", 0x00000008), + ("manageChannels", 0x00000010), + ("manageGuild", 0x00000020), + ("addReactions", 0x00000040), + ("viewAuditLog", 0x00000080), + ("prioritySpeaker", 0x00000100), + ("stream", 0x00000200), + ("viewChannel", 0x00000400), + ("sendMessages", 0x00000800), + ("sendTtsMessages", 0x00001000), + ("manageMessages", 0x00002000), + ("embedLinks", 0x00004000), + ("attachFiles", 0x00008000), + ("readMessageHistory", 0x00010000), + ("mentionEveryone", 0x00020000), + ("useExternalEmojis", 0x00040000), + ("viewGuildInsights", 0x00080000), + ("connect", 0x00100000), + ("speak", 0x00200000), + ("muteMembers", 0x00400000), + ("deafenMembers", 0x00800000), + ("moveMembers", 0x01000000), + ("useVad", 0x02000000), + ("changeNickname", 0x04000000), + ("manageNicknames", 0x08000000), + ("manageRoles", 0x10000000), + ("manageWebhooks", 0x20000000), + ("manageEmojis", 0x4000000) + ] + ) -deriving via Word64 instance ToJSON Permissions +instance ToJSON Permissions where + toJSON = toJSON . showt + toEncoding = toEncoding . showt -deriving via Word64 instance FromJSON Permissions +instance FromJSON Permissions where + parseJSON a = do + asText <- parseJSON a + case decimal asText of + Right (n, _) -> pure $ Permissions n + Left e -> parseFail e deriving via FromStringShow Permissions instance TextShow Permissions diff --git a/src/Calamity/Utils/Permissions.hs b/src/Calamity/Utils/Permissions.hs --- a/src/Calamity/Utils/Permissions.hs +++ b/src/Calamity/Utils/Permissions.hs @@ -58,6 +58,11 @@ -- | Things that 'Member's have 'Permissions' in class PermissionsIn a where -- | Calculate a 'Member'\'s 'Permissions' in something + -- + -- If permissions could not be calculated because something couldn't be found + -- in the cache, this will return an empty set of permissions. Use + -- 'permissionsIn'' if you want to handle cases where something might not exist + -- in cache. permissionsIn :: a -> Member -> Permissions -- | A 'Member'\'s 'Permissions' in a channel are their roles and overwrites @@ -71,11 +76,6 @@ -- | A variant of 'PermissionsIn' that will use the cache/http. class PermissionsIn' a where -- | Calculate the permissions of something that has a 'User' id - -- - -- If permissions could not be calculated because something couldn't be found - -- in the cache, this will return an empty set of permissions. Use - -- 'permissionsIn' if you want to handle cases where something might not exist - -- in cache. permissionsIn' :: (BotC r, HasID User u) => a -> u -> P.Sem r Permissions -- | A 'User''s 'Permissions' in a channel are their roles and overwrites