diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,21 @@ # Changelog for Calamity +## 0.1.10.1 + +*2020-05-31* + +* Add command parameter parsers for channel/guild/emoji +* Support allowed mentions +* Support invite events +* Support setting gateway intents +* Add `Calamity.Types.Model.Guild.Permission` and `Calamity.Utils.Permissions` + and change permissions fields from `Word64` to `Permissions` +* Add `Calamity.Utils.Colour` and change color fields from `Word64` to + `Data.Color.Color Double` + ## 0.1.10.0 + +*2020-05-27* * Renamed `Calamity.Commands.Parser.KleeneConcat` to `Calamity.Commands.Parser.KleeneStarConcat` and added 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: 386f342de92acd940a2fa9856b8efa38f04e137426a3c6100bcbeaadb5ac5e17 +-- hash: f39d1fc0a8ea4e5b188911539c4b0bfdbc8887c9a631ff56d56547749cdc3cf8 name: calamity -version: 0.1.10 +version: 0.1.10.1 synopsis: A library for writing discord bots description: Please see the README on GitHub at category: Network, Web @@ -55,6 +55,7 @@ Calamity.Commands.Utils Calamity.Gateway Calamity.Gateway.DispatchEvents + Calamity.Gateway.Intents Calamity.Gateway.Shard Calamity.Gateway.Types Calamity.HTTP @@ -75,6 +76,7 @@ Calamity.Internal.BoundedStore Calamity.Internal.ConstructorName Calamity.Internal.GenericCurry + Calamity.Internal.IntColour Calamity.Internal.LocalWriter Calamity.Internal.RunIntoIO Calamity.Internal.SnowflakeMap @@ -107,6 +109,7 @@ Calamity.Types.Model.Guild.Invite Calamity.Types.Model.Guild.Member Calamity.Types.Model.Guild.Overwrite + Calamity.Types.Model.Guild.Permissions Calamity.Types.Model.Guild.Role Calamity.Types.Model.Guild.UnavailableGuild Calamity.Types.Model.Presence @@ -122,6 +125,9 @@ Calamity.Types.Token Calamity.Types.UnixTimestamp Calamity.Types.Upgradeable + Calamity.Utils + Calamity.Utils.Colour + Calamity.Utils.Permissions other-modules: Paths_calamity hs-source-dirs: @@ -133,12 +139,14 @@ , async >=2.2 && <3 , base >=4.12 && <5 , bytestring >=0.10 && <0.11 + , colour >=2.3.5 && <2.4 , concurrent-extra >=0.7 && <0.8 , containers >=0.6 && <0.7 , data-default-class >=0.1 && <0.2 + , data-flags >=0.0.3 && <0.1 , deepseq >=1.4.4.0 && <2 , deque >=0.4 && <0.5 - , df1 >=0.3 && <0.4 + , df1 >=0.3 && <0.5 , di-polysemy >=0.1.3 && <0.2 , exceptions >=0.10 && <0.11 , fmt >=0.6 && <0.7 diff --git a/src/Calamity.hs b/src/Calamity.hs --- a/src/Calamity.hs +++ b/src/Calamity.hs @@ -1,8 +1,12 @@ module Calamity ( module Calamity.Client , module Calamity.HTTP - , module Calamity.Types ) where + , module Calamity.Types + , module Calamity.Utils + , module Calamity.Gateway.Intents ) where import Calamity.Client +import Calamity.Gateway.Intents import Calamity.HTTP import Calamity.Types +import Calamity.Utils 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 @@ -4,6 +4,7 @@ module Calamity.Client.Client ( react , runBotIO + , runBotIO' , stopBot , sendPresence , events @@ -18,6 +19,7 @@ import Calamity.Client.Types import Calamity.Gateway.DispatchEvents import Calamity.Gateway.Types +import Calamity.Gateway.Intents import Calamity.HTTP.Internal.Ratelimit import Calamity.Internal.ConstructorName import Calamity.Internal.GenericCurry @@ -89,15 +91,31 @@ ehidCounter -- | Create a bot, run your setup action, and then loop until the bot closes. -runBotIO :: forall r a. (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff] r, Typeable (SetupEff r)) => Token -> P.Sem (SetupEff r) a -> P.Sem r (Maybe StartupError) -runBotIO token setup = do +runBotIO :: forall r a. + (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff] r, Typeable (SetupEff r)) + => Token + -> P.Sem (SetupEff r) a + -> P.Sem r (Maybe StartupError) +runBotIO token setup = runBotIO' token Nothing Nothing setup + +-- | Create a bot, run your setup action, and then loop until the bot closes. +-- +-- This version allows you to specify the initial status and intents. +runBotIO' :: forall r a. + (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff] r, Typeable (SetupEff r)) + => Token + -> Maybe StatusUpdateData + -> Maybe Intents + -> P.Sem (SetupEff r) a + -> P.Sem r (Maybe StartupError) +runBotIO' token status intents setup = do client <- P.embed $ newClient token handlers <- P.embed $ newTVarIO def P.asyncToIOFinal . P.runAtomicStateTVar handlers . P.runReader client . Di.runDiToStderrIO . Di.push "calamity" $ do void $ Di.push "calamity-setup" setup - r <- shardBot + r <- shardBot status intents case r of - Left e -> pure (Just e) + Left e -> pure (Just e) Right _ -> do Di.push "calamity-loop" clientLoop Di.push "calamity-stop" finishUp @@ -475,6 +493,12 @@ updateCache evt pure $ map (\f -> f guild role) (getEventHandlers @'GuildRoleDeleteEvt eh) +handleEvent' eh (InviteCreate d) = do + pure $ map (\f -> f d) (getEventHandlers @'InviteCreateEvt eh) + +handleEvent' eh (InviteDelete d) = do + pure $ map (\f -> f d) (getEventHandlers @'InviteDeleteEvt eh) + handleEvent' eh evt@(MessageCreate msg) = do updateCache evt pure $ map ($ msg) (getEventHandlers @'MessageCreateEvt eh) @@ -640,6 +664,8 @@ updateCache (TypingStart _) = pure () updateCache (ChannelPinsUpdate _) = pure () updateCache (WebhooksUpdate _) = pure () +updateCache (InviteCreate _) = pure () +updateCache (InviteDelete _) = pure () -- we don't handle voice state currently updateCache (VoiceStateUpdate _) = pure () 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,8 +26,8 @@ mapLeft _ (Right b) = Right b -- | Connects the bot to the gateway over n shards -shardBot :: BotC r => Sem r (Either StartupError ()) -shardBot = (mapLeft StartupError <$>) . P.runFail $ do +shardBot :: BotC r => Maybe StatusUpdateData -> Maybe Intents -> Sem r (Either StartupError ()) +shardBot initialStatus intents = (mapLeft StartupError <$>) . P.runFail $ do numShardsVar <- P.asks numShards shardsVar <- P.asks shards @@ -46,7 +46,7 @@ info $ "Number of shards: " +| numShards' |+ "" shards <- for [0 .. numShards' - 1] $ \id -> - newShard host id numShards' token inc + newShard host id numShards' token initialStatus intents inc P.embed . atomically $ writeTVar shardsVar shards diff --git a/src/Calamity/Client/Types.hs b/src/Calamity/Client/Types.hs --- a/src/Calamity/Client/Types.hs +++ b/src/Calamity/Client/Types.hs @@ -16,7 +16,7 @@ , getCustomEventHandlers ) where import Calamity.Cache.Eff -import Calamity.Gateway.DispatchEvents ( CalamityEvent(..), ReadyData ) +import Calamity.Gateway.DispatchEvents ( CalamityEvent(..), InviteCreateData, InviteDeleteData, ReadyData ) import Calamity.Gateway.Types ( ControlMessage ) import Calamity.HTTP.Internal.Types import Calamity.Internal.GenericCurry @@ -135,6 +135,8 @@ | GuildRoleCreateEvt | GuildRoleUpdateEvt | GuildRoleDeleteEvt + | InviteCreateEvt + | InviteDeleteEvt | MessageCreateEvt | MessageUpdateEvt | MessageDeleteEvt @@ -169,6 +171,8 @@ EHType 'GuildRoleCreateEvt m r = Guild -> Role -> m r EHType 'GuildRoleUpdateEvt m r = Guild -> Role -> Role -> m r EHType 'GuildRoleDeleteEvt m r = Guild -> Role -> m r + EHType 'InviteCreateEvt m r = InviteCreateData -> m r + EHType 'InviteDeleteEvt m r = InviteDeleteData -> m r EHType 'MessageCreateEvt m r = Message -> m r EHType 'MessageUpdateEvt m r = Message -> Message -> m r EHType 'MessageDeleteEvt m r = Message -> m r diff --git a/src/Calamity/Commands/Parser.hs b/src/Calamity/Commands/Parser.hs --- a/src/Calamity/Commands/Parser.hs +++ b/src/Calamity/Commands/Parser.hs @@ -8,8 +8,8 @@ import Calamity.Cache.Eff import Calamity.Commands.Context -import Calamity.Types.Model.Channel ( Channel ) -import Calamity.Types.Model.Guild ( Emoji, Member, Role ) +import Calamity.Types.Model.Channel ( Channel, GuildChannel ) +import Calamity.Types.Model.Guild ( Emoji, Guild, Member, Role ) import Calamity.Types.Model.User ( User ) import Calamity.Types.Snowflake @@ -198,6 +198,9 @@ Just r' -> pure r' _ -> parseError . errFancy offs . fancy . ErrorCustom $ SpannedError e offs offe +-- | Parser for members in the guild the command was invoked in, this only looks +-- in the cache. Use @'Snowflake' 'Member'@ and use +-- 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching from http. instance Parser Member r where parse = parseMP (parserName @Member) $ mapParserMaybeM (try (ping "@") <|> snowflake) "Couldn't find a Member with this id" @@ -205,10 +208,41 @@ ctx <- P.ask pure $ ctx ^? #guild . _Just . #members . ix mid) +-- | Parser for users, this only looks in the cache. Use @'Snowflake' +-- 'User'@ and use 'Calamity.Types.Upgradeable.upgrade' if you want to allow +-- fetching from http. instance P.Member CacheEff r => Parser User r where parse = parseMP (parserName @User @r) $ mapParserMaybeM (try (ping "@") <|> snowflake) "Couldn't find a User with this id" getUser + +-- | Parser for channels in the guild the command was invoked in, this only +-- looks in the cache. Use @'Snowflake' 'Channel'@ and use +-- 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching from http. +instance Parser GuildChannel r where + parse = parseMP (parserName @GuildChannel @r) $ mapParserMaybeM (try (ping "#") <|> snowflake) + "Couldn't find a GuildChannel with this id" + (\cid -> do + ctx <- P.ask + pure $ ctx ^? #guild . _Just . #channels . ix cid) + +-- | Parser for guilds, this only looks in the cache. Use @'Snowflake' 'Guild'@ +-- and use 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching +-- from http. +instance P.Member CacheEff r => Parser Guild r where + parse = parseMP (parserName @Guild @r) $ mapParserMaybeM (try (ping "#") <|> snowflake) + "Couldn't find a Guild with this id" + getGuild + +-- | Parser for emojis in the guild the command was invoked in, this only +-- looks in the cache. Use @'Snowflake' 'Emoji'@ and use +-- 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching from http. +instance Parser Emoji r where + parse = parseMP (parserName @Emoji @r) $ mapParserMaybeM (try (ping "#") <|> snowflake) + "Couldn't find an Emoji with this id" + (\eid -> do + ctx <- P.ask + pure $ ctx ^? #guild . _Just . #emojis . ix eid) instance (Parser a r, Parser b r) => Parser (a, b) r where type ParserResult (a, b) = (ParserResult a, ParserResult b) diff --git a/src/Calamity/Gateway.hs b/src/Calamity/Gateway.hs --- a/src/Calamity/Gateway.hs +++ b/src/Calamity/Gateway.hs @@ -2,12 +2,14 @@ module Calamity.Gateway ( module Calamity.Gateway.Shard , module Calamity.Gateway.Types + , module Calamity.Gateway.Intents -- * Gateway -- $gatewayDocs ) where import Calamity.Gateway.Shard import Calamity.Gateway.Types +import Calamity.Gateway.Intents -- $gatewayDocs -- 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 @@ -57,6 +57,8 @@ | GuildRoleCreate GuildRoleData | GuildRoleUpdate GuildRoleData | GuildRoleDelete GuildRoleDeleteData + | InviteCreate InviteCreateData + | InviteDelete InviteDeleteData | MessageCreate Message | MessageUpdate UpdatedMessage | MessageDelete MessageDeleteData @@ -146,6 +148,32 @@ } deriving ( Show, Generic ) deriving FromJSON via CalamityJSON GuildRoleDeleteData + +data InviteCreateData = InviteCreateData + { channelID :: Snowflake Channel + , code :: Text + , createdAt :: UnixTimestamp + , guildID :: Maybe (Snowflake Guild) + , inviter :: Maybe (Snowflake User) + , maxAge :: Int + , maxUses :: Int + , targetUser :: Maybe (Snowflake User) + , targetUserType :: Maybe Integer + , temporary :: Bool + , uses :: Integer + } + deriving ( Show, Generic ) + deriving ( FromJSON ) via WithSpecialCases + '["inviter" `ExtractField` "id", "targetUser" `ExtractField` "id"] + InviteCreateData + +data InviteDeleteData = InviteDeleteData + { channelID :: Snowflake Channel + , guildID :: Maybe (Snowflake Guild) + , code :: Text + } + deriving ( Show, Generic ) + deriving ( FromJSON ) via CalamityJSON InviteDeleteData data MessageDeleteData = MessageDeleteData { id :: Snowflake Message diff --git a/src/Calamity/Gateway/Intents.hs b/src/Calamity/Gateway/Intents.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Gateway/Intents.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE NoDeriveAnyClass #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Discord gateway intents +module Calamity.Gateway.Intents + ( Intents(..) + , intentGuilds + , intentGuildMembers + , intentGuildBans + , intentGuildEmojis + , intentGuildIntegrations + , intentGuildWebhooks + , intentGuildInvites + , intentGuildVoiceStates + , intentGuildPresences + , intentGuildMessages + , intentGuildMessageReactions + , intentGuildMessageTyping + , intentDirectMessages + , intentDirectMessageReactions + , intentDirectMessageTyping ) where + +import Data.Aeson ( ToJSON ) +import Data.Bits +import Data.Flags () +import Data.Flags.TH +import Data.Word + +$(bitmaskWrapper "Intents" ''Word32 [] + [ ("intentGuilds", 1 `shiftL` 0) + , ("intentGuildMembers", 1 `shiftL` 1) + , ("intentGuildBans", 1 `shiftL` 2) + , ("intentGuildEmojis", 1 `shiftL` 3) + , ("intentGuildIntegrations", 1 `shiftL` 4) + , ("intentGuildWebhooks", 1 `shiftL` 5) + , ("intentGuildInvites", 1 `shiftL` 6) + , ("intentGuildVoiceStates", 1 `shiftL` 7) + , ("intentGuildPresences", 1 `shiftL` 8) + , ("intentGuildMessages", 1 `shiftL` 9) + , ("intentGuildMessageReactions", 1 `shiftL` 10) + , ("intentGuildMessageTyping", 1 `shiftL` 11) + , ("intentDirectMessages", 1 `shiftL` 12) + , ("intentDirectMessageReactions", 1 `shiftL` 13) + , ("intentDirectMessageTyping", 1 `shiftL` 14)]) + +deriving via Word32 instance ToJSON Intents 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 @@ -7,6 +7,7 @@ , newShard ) where import Calamity.Gateway.DispatchEvents +import Calamity.Gateway.Intents import Calamity.Gateway.Types import Calamity.Internal.Utils import Calamity.Metrics.Eff @@ -81,13 +82,15 @@ -> Int -> Int -> Token + -> Maybe StatusUpdateData + -> Maybe Intents -> UC.InChan CalamityEvent -> Sem r (UC.InChan ControlMessage, Async (Maybe ())) -newShard gateway id count token evtIn = do +newShard gateway id count token presence intents evtIn = do (cmdIn, stateVar) <- P.embed $ mdo (cmdIn, cmdOut) <- UC.newChan stateVar <- newIORef $ newShardState shard - let shard = Shard id count gateway evtIn cmdOut stateVar (rawToken token) + let shard = Shard id count gateway evtIn cmdOut stateVar (rawToken token) presence intents pure (cmdIn, stateVar) let runShard = P.runAtomicStateIORef stateVar shardLoop @@ -218,7 +221,8 @@ , largeThreshold = 250 , shard = (shard ^. #shardID, shard ^. #shardCount) - , presence = Nothing + , presence = shard ^. #initialStatus + , intents = shard ^. #intents }) result <- P.resourceToIOFinal $ P.bracket (P.embed $ newTBMQueueIO 1) 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 @@ -16,6 +16,7 @@ , ShardState(..) ) where import Calamity.Gateway.DispatchEvents +import Calamity.Gateway.Intents import Calamity.Internal.AesonThings import Calamity.Metrics.Eff import Calamity.Types.LogEff @@ -103,6 +104,8 @@ parseDispatchData GUILD_ROLE_CREATE data' = GuildRoleCreate <$> parseJSON data' parseDispatchData GUILD_ROLE_UPDATE data' = GuildRoleUpdate <$> parseJSON data' 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_UPDATE data' = MessageUpdate <$> parseJSON data' parseDispatchData MESSAGE_DELETE data' = MessageDelete <$> parseJSON data' @@ -174,6 +177,8 @@ | GUILD_ROLE_CREATE | GUILD_ROLE_UPDATE | GUILD_ROLE_DELETE + | INVITE_CREATE + | INVITE_DELETE | MESSAGE_CREATE | MESSAGE_UPDATE | MESSAGE_DELETE @@ -197,6 +202,7 @@ , largeThreshold :: Int , shard :: (Int, Int) , presence :: Maybe StatusUpdateData + , intents :: Maybe Intents } deriving ( Show, Generic ) deriving ToJSON via CalamityJSON IdentifyData @@ -226,8 +232,8 @@ deriving ( Show, Generic ) instance ToJSON RequestGuildMembersData where - toEncoding RequestGuildMembersData { guildID, query, limit } = pairs - ("guild_id" .= guildID <> "query" .= fromMaybe "" query <> "limit" .= fromMaybe 0 limit) + toJSON RequestGuildMembersData { guildID, query, limit } = + object ["guild_id" .= guildID, "query" .= fromMaybe "" query, "limit" .= fromMaybe 0 limit] data IdentifyProps = IdentifyProps { browser :: Text @@ -236,7 +242,7 @@ deriving ( Show, Generic ) instance ToJSON IdentifyProps where - toEncoding IdentifyProps { browser, device } = pairs ("$browser" .= browser <> "$device" .= device) + toJSON IdentifyProps { browser, device } = object ["$browser" .= browser, "$device" .= device] data ControlMessage = RestartShard @@ -250,13 +256,15 @@ deriving ( Show ) data Shard = Shard - { shardID :: Int - , shardCount :: Int - , gateway :: Text - , evtIn :: InChan CalamityEvent - , cmdOut :: OutChan ControlMessage - , shardState :: IORef ShardState - , token :: Text + { shardID :: Int + , shardCount :: Int + , gateway :: Text + , evtIn :: InChan CalamityEvent + , cmdOut :: OutChan ControlMessage + , shardState :: IORef ShardState + , token :: Text + , initialStatus :: Maybe StatusUpdateData + , intents :: Maybe Intents } deriving ( Generic ) diff --git a/src/Calamity/HTTP/Channel.hs b/src/Calamity/HTTP/Channel.hs --- a/src/Calamity/HTTP/Channel.hs +++ b/src/Calamity/HTTP/Channel.hs @@ -33,13 +33,34 @@ import TextShow data CreateMessageOptions = CreateMessageOptions - { content :: Maybe Text - , nonce :: Maybe Text - , tts :: Maybe Bool - , file :: Maybe ByteString - , embed :: Maybe Embed + { content :: Maybe Text + , nonce :: Maybe Text + , tts :: Maybe Bool + , file :: Maybe ByteString + , embed :: Maybe Embed + , allowedMentions :: Maybe AllowedMentions } deriving ( Show, Generic, Default ) + +data AllowedMentionType + = AllowedMentionRoles + | AllowedMentionUsers + | AllowedMentionEveryone + deriving ( Show, Generic ) + +instance ToJSON AllowedMentionType where + toJSON AllowedMentionRoles = String "roles" + toJSON AllowedMentionUsers = String "users" + toJSON AllowedMentionEveryone = String "everyone" + +data AllowedMentions = AllowedMentions + { parse :: [AllowedMentionType] + , roles :: [Snowflake Role] + , users :: [Snowflake User] + } + deriving ( Show, Generic, Default ) + deriving ( ToJSON ) via CalamityJSON AllowedMentions + data CreateMessageJson = CreateMessageJson { content :: Maybe Text diff --git a/src/Calamity/HTTP/Guild.hs b/src/Calamity/HTTP/Guild.hs --- a/src/Calamity/HTTP/Guild.hs +++ b/src/Calamity/HTTP/Guild.hs @@ -15,6 +15,8 @@ import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route import Calamity.Internal.AesonThings +import Calamity.Internal.IntColour () +import Calamity.Internal.Utils () import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild import Calamity.Types.Model.User @@ -25,6 +27,7 @@ import Control.Lens hiding ( (.=) ) import Data.Aeson +import Data.Colour ( Colour ) import Data.Default.Class import Data.Maybe import Data.Text ( Text ) @@ -121,8 +124,8 @@ data ModifyGuildRoleData = ModifyGuildRoleData { name :: Maybe Text - , permissions :: Maybe Integer - , color :: Maybe Integer + , permissions :: Maybe Permissions + , color :: Maybe (Colour Double) , hoist :: Maybe Bool , mentionable :: Maybe Bool } diff --git a/src/Calamity/Internal/IntColour.hs b/src/Calamity/Internal/IntColour.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Internal/IntColour.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | An orphan instnace to parse @'Data.Colour' 'Double'@ as a word64 +module Calamity.Internal.IntColour + ( colourToWord64 + , colourFromWord64 ) where + +import Data.Aeson +import Data.Bits +import Data.Colour +import Data.Colour.SRGB ( RGB(RGB), sRGB24, toSRGB24 ) +import Data.Word ( Word64 ) + +colourToWord64 :: Colour Double -> Word64 +colourToWord64 c = let RGB r g b = toSRGB24 c + i = (fromIntegral r `shiftL` 16) .|. (fromIntegral g `shiftL` 8) .|. fromIntegral b + in i + +colourFromWord64 :: Word64 -> Colour Double +colourFromWord64 i = let r = (i `shiftR` 16) .&. 0xff + g = (i `shiftR` 8) .&. 0xff + b = i .&. 0xff + in sRGB24 (fromIntegral r) (fromIntegral g) (fromIntegral b) + +instance ToJSON (Colour Double) where + toJSON = toJSON . colourToWord64 + +instance FromJSON (Colour Double) where + parseJSON v = colourFromWord64 <$> parseJSON v diff --git a/src/Calamity/Internal/Utils.hs b/src/Calamity/Internal/Utils.hs --- a/src/Calamity/Internal/Utils.hs +++ b/src/Calamity/Internal/Utils.hs @@ -35,6 +35,7 @@ import qualified Polysemy as P import TextShow +import Data.Colour (Colour) whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () whenJust = flip $ maybe (pure ()) @@ -99,6 +100,9 @@ showb = fromString . show instance (Show k, Show v) => TextShow (M.Map k v) where + showb = fromString . show + +instance (Show a, Fractional a) => TextShow (Colour a) where showb = fromString . show instance Default (M.Map k v) where diff --git a/src/Calamity/Types/Model/Channel/Embed.hs b/src/Calamity/Types/Model/Channel/Embed.hs --- a/src/Calamity/Types/Model/Channel/Embed.hs +++ b/src/Calamity/Types/Model/Channel/Embed.hs @@ -10,11 +10,13 @@ , EmbedField(..) ) where import Calamity.Internal.AesonThings +import Calamity.Internal.IntColour () import Calamity.Internal.Utils () import Control.Lens import Data.Aeson +import Data.Colour ( Colour ) import Data.Default.Class import Data.Generics.Labels () import Data.Semigroup @@ -33,7 +35,7 @@ , description :: Maybe Text , url :: Maybe Text , timestamp :: Maybe UTCTime - , color :: Maybe Word64 + , color :: Maybe (Colour Double) , footer :: Maybe EmbedFooter , image :: Maybe EmbedImage , thumbnail :: Maybe EmbedThumbnail @@ -44,8 +46,7 @@ } deriving ( Eq, Show, Generic, Default ) deriving ( TextShow ) via TSG.FromGeneric Embed - deriving ( FromJSON ) via WithSpecialCases '[IfNoneThen "fields" DefaultToEmptyArray] - Embed + deriving ( FromJSON ) via WithSpecialCases '[IfNoneThen "fields" DefaultToEmptyArray] Embed deriving ( ToJSON ) via CalamityJSON Embed instance Semigroup Embed where diff --git a/src/Calamity/Types/Model/Channel/Guild.hs b/src/Calamity/Types/Model/Channel/Guild.hs --- a/src/Calamity/Types/Model/Channel/Guild.hs +++ b/src/Calamity/Types/Model/Channel/Guild.hs @@ -5,18 +5,21 @@ , module Calamity.Types.Model.Channel.Guild.Text , module Calamity.Types.Model.Channel.Guild.Voice ) where +import Calamity.Internal.SnowflakeMap ( SnowflakeMap ) import {-# SOURCE #-} Calamity.Types.Model.Channel import Calamity.Types.Model.Channel.ChannelType import Calamity.Types.Model.Channel.Guild.Category import Calamity.Types.Model.Channel.Guild.Text import Calamity.Types.Model.Channel.Guild.Voice import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild +import Calamity.Types.Model.Guild.Overwrite import Calamity.Types.Snowflake import Control.Lens import Data.Aeson import Data.Generics.Product.Fields +import Data.Text.Lazy ( Text ) import GHC.Generics @@ -52,3 +55,36 @@ getID (GuildTextChannel a) = coerceSnowflake $ a ^. field' @"guildID" getID (GuildVoiceChannel a) = coerceSnowflake $ a ^. field' @"guildID" getID (GuildCategory a) = coerceSnowflake $ a ^. field' @"guildID" + +instance {-# OVERLAPS #-}HasField' "name" GuildChannel Text where + field' = lens get set + where + get (GuildTextChannel (TextChannel { name })) = name + get (GuildVoiceChannel (VoiceChannel { name })) = name + get (GuildCategory (Category { name })) = name + + set (GuildTextChannel t) v = GuildTextChannel (t { name = v }) + set (GuildVoiceChannel t) v = GuildVoiceChannel (t { name = v }) + set (GuildCategory t) v = GuildCategory (t { name = v }) + +instance {-# OVERLAPS #-}HasField' "permissionOverwrites" GuildChannel (SnowflakeMap Overwrite) where + field' = lens get set + where + get (GuildTextChannel (TextChannel { permissionOverwrites })) = permissionOverwrites + get (GuildVoiceChannel (VoiceChannel { permissionOverwrites })) = permissionOverwrites + get (GuildCategory (Category { permissionOverwrites })) = permissionOverwrites + + set (GuildTextChannel t) v = GuildTextChannel (t { permissionOverwrites = v }) + set (GuildVoiceChannel t) v = GuildVoiceChannel (t { permissionOverwrites = v }) + set (GuildCategory t) v = GuildCategory (t { permissionOverwrites = v }) + +instance {-# OVERLAPS #-}HasField' "position" GuildChannel Int where + field' = lens get set + where + get (GuildTextChannel (TextChannel { position })) = position + get (GuildVoiceChannel (VoiceChannel { position })) = position + get (GuildCategory (Category { position })) = position + + set (GuildTextChannel t) v = GuildTextChannel (t { position = v }) + set (GuildVoiceChannel t) v = GuildVoiceChannel (t { position = v }) + set (GuildCategory t) v = GuildCategory (t { position = v }) diff --git a/src/Calamity/Types/Model/Channel/Guild/Category.hs b/src/Calamity/Types/Model/Channel/Guild/Category.hs --- a/src/Calamity/Types/Model/Channel/Guild/Category.hs +++ b/src/Calamity/Types/Model/Channel/Guild/Category.hs @@ -2,6 +2,7 @@ ( Category(..) ) where import Calamity.Internal.AesonThings +import Calamity.Internal.SnowflakeMap ( SnowflakeMap ) import Calamity.Internal.Utils () import {-# SOURCE #-} Calamity.Types.Model.Channel import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild @@ -18,7 +19,7 @@ data Category = Category { id :: Snowflake Category - , permissionOverwrites :: [Overwrite] + , permissionOverwrites :: SnowflakeMap Overwrite , name :: Text , nsfw :: Bool , position :: Int diff --git a/src/Calamity/Types/Model/Channel/Guild/Text.hs b/src/Calamity/Types/Model/Channel/Guild/Text.hs --- a/src/Calamity/Types/Model/Channel/Guild/Text.hs +++ b/src/Calamity/Types/Model/Channel/Guild/Text.hs @@ -3,6 +3,7 @@ ( TextChannel(..) ) where import Calamity.Internal.AesonThings +import Calamity.Internal.SnowflakeMap ( SnowflakeMap ) import Calamity.Internal.Utils () import {-# SOURCE #-} Calamity.Types.Model.Channel import {-# SOURCE #-} Calamity.Types.Model.Channel.Guild.Category @@ -24,7 +25,7 @@ { id :: Snowflake TextChannel , guildID :: Snowflake Guild , position :: Int - , permissionOverwrites :: [Overwrite] + , permissionOverwrites :: SnowflakeMap Overwrite , name :: Text , topic :: Maybe Text , nsfw :: Bool diff --git a/src/Calamity/Types/Model/Channel/Guild/Voice.hs b/src/Calamity/Types/Model/Channel/Guild/Voice.hs --- a/src/Calamity/Types/Model/Channel/Guild/Voice.hs +++ b/src/Calamity/Types/Model/Channel/Guild/Voice.hs @@ -3,6 +3,7 @@ ( VoiceChannel(..) ) where import Calamity.Internal.AesonThings +import Calamity.Internal.SnowflakeMap ( SnowflakeMap ) import Calamity.Internal.Utils () import {-# SOURCE #-} Calamity.Types.Model.Channel import {-# SOURCE #-} Calamity.Types.Model.Channel.Guild.Category @@ -22,7 +23,7 @@ { id :: Snowflake VoiceChannel , guildID :: Snowflake Guild , position :: Int - , permissionOverwrites :: [Overwrite] + , permissionOverwrites :: SnowflakeMap Overwrite , name :: Text , bitrate :: Int , userLimit :: Int diff --git a/src/Calamity/Types/Model/Guild.hs b/src/Calamity/Types/Model/Guild.hs --- a/src/Calamity/Types/Model/Guild.hs +++ b/src/Calamity/Types/Model/Guild.hs @@ -8,7 +8,8 @@ , module Calamity.Types.Model.Guild.Overwrite , module Calamity.Types.Model.Guild.Invite , module Calamity.Types.Model.Guild.Role - , module Calamity.Types.Model.Guild.UnavailableGuild ) where + , module Calamity.Types.Model.Guild.UnavailableGuild + , module Calamity.Types.Model.Guild.Permissions ) where import Calamity.Types.Model.Guild.AuditLog import Calamity.Types.Model.Guild.Ban @@ -19,3 +20,4 @@ import Calamity.Types.Model.Guild.Overwrite import Calamity.Types.Model.Guild.Role import Calamity.Types.Model.Guild.UnavailableGuild +import Calamity.Types.Model.Guild.Permissions diff --git a/src/Calamity/Types/Model/Guild/Guild.hs b/src/Calamity/Types/Model/Guild/Guild.hs --- a/src/Calamity/Types/Model/Guild/Guild.hs +++ b/src/Calamity/Types/Model/Guild/Guild.hs @@ -74,8 +74,6 @@ parseJSON = withObject "Guild" $ \v -> do id <- v .: "id" - -- TODO: clean this up - members' <- do members' <- v .: "members" SM.fromList <$> traverse (\m -> parseJSON $ Object (m <> "guild_id" .= id)) members' 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 @@ -3,22 +3,22 @@ ( Overwrite(..) ) where import Calamity.Internal.AesonThings +import Calamity.Types.Model.Guild.Permissions import Calamity.Types.Snowflake import Data.Aeson -import Data.Text.Lazy ( Text ) -import Data.Word +import Data.Text.Lazy ( Text ) import GHC.Generics import TextShow -import qualified TextShow.Generic as TSG +import qualified TextShow.Generic as TSG data Overwrite = Overwrite { id :: Snowflake Overwrite , type_ :: Text - , allow :: Word64 - , deny :: Word64 + , allow :: Permissions + , deny :: Permissions } deriving ( Eq, Show, Generic ) deriving ( TextShow ) via TSG.FromGeneric Overwrite diff --git a/src/Calamity/Types/Model/Guild/Permissions.hs b/src/Calamity/Types/Model/Guild/Permissions.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Guild/Permissions.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE NoDeriveAnyClass #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | 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 + +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)]) + +deriving via Word64 instance ToJSON Permissions + +deriving via Word64 instance FromJSON Permissions + +deriving via FromStringShow Permissions instance TextShow Permissions diff --git a/src/Calamity/Types/Model/Guild/Role.hs b/src/Calamity/Types/Model/Guild/Role.hs --- a/src/Calamity/Types/Model/Guild/Role.hs +++ b/src/Calamity/Types/Model/Guild/Role.hs @@ -3,24 +3,27 @@ ( Role(..) ) where import Calamity.Internal.AesonThings +import Calamity.Internal.IntColour () +import Calamity.Internal.Utils () +import Calamity.Types.Model.Guild.Permissions import Calamity.Types.Snowflake import Data.Aeson -import Data.Text.Lazy ( Text ) -import Data.Word +import Data.Colour +import Data.Text.Lazy ( Text ) import GHC.Generics import TextShow -import qualified TextShow.Generic as TSG +import qualified TextShow.Generic as TSG data Role = Role { id :: Snowflake Role , name :: Text - , color :: Word64 + , color :: Colour Double , hoist :: Bool , position :: Int - , permissions :: Word64 + , permissions :: Permissions , managed :: Bool , mentionable :: Bool } diff --git a/src/Calamity/Utils.hs b/src/Calamity/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Utils.hs @@ -0,0 +1,7 @@ +-- | Useful things +module Calamity.Utils + ( module Calamity.Utils.Permissions + , module Calamity.Utils.Colour ) where + +import Calamity.Utils.Colour +import Calamity.Utils.Permissions diff --git a/src/Calamity/Utils/Colour.hs b/src/Calamity/Utils/Colour.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Utils/Colour.hs @@ -0,0 +1,18 @@ +-- | Discord colour utilities +module Calamity.Utils.Colour + ( colourToWord64 + , colourFromWord64 + -- * Useful colours + , blurple + , greyple ) where + +import Calamity.Internal.IntColour + +import Data.Colour +import Data.Colour.SRGB ( sRGB24 ) + +blurple :: (Ord a, Floating a) => Colour a +blurple = sRGB24 0x72 0x89 0xda + +greyple :: (Ord a, Floating a) => Colour a +greyple = sRGB24 0x99 0xaa 0xb5 diff --git a/src/Calamity/Utils/Permissions.hs b/src/Calamity/Utils/Permissions.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Utils/Permissions.hs @@ -0,0 +1,88 @@ +-- | Permission utilities +module Calamity.Utils.Permissions + ( PermissionsIn(..) + , PermissionsIn'(..) + , basePermissions + , applyOverwrites ) where + +import Calamity.Client.Types +import Calamity.Types.Model.Channel.Guild +import Calamity.Types.Model.Guild.Guild +import Calamity.Types.Model.Guild.Member +import Calamity.Types.Model.Guild.Overwrite +import Calamity.Types.Model.Guild.Permissions +import Calamity.Types.Snowflake +import Calamity.Types.Upgradeable + +import Control.Lens + +import Data.Flags +import qualified Data.Vector.Unboxed as V + +import qualified Polysemy as P + +basePermissions :: Guild -> Member -> Permissions +basePermissions g m + | (g ^. #ownerID == getID m) = allFlags + | otherwise = let everyoneRole = g ^. #roles . at (coerceSnowflake $ getID @Guild g) + permsEveryone = maybe noFlags (^. #permissions) everyoneRole + rolePerms = g ^.. #roles . foldMap ix (V.toList $ m ^. #roles) . #permissions + perms = foldl andFlags noFlags (permsEveryone:rolePerms) + in if perms .<=. administrator + then allFlags + else perms + +applyOverwrites :: GuildChannel -> Member -> Permissions -> Permissions +applyOverwrites c m p + | p .<=. administrator = allFlags + | otherwise = + let everyoneOverwrite = c ^. #permissionOverwrites . at (coerceSnowflake $ getID @Guild c) + everyoneAllow = maybe noFlags (^. #allow) everyoneOverwrite + everyoneDeny = maybe noFlags (^. #deny) everyoneOverwrite + p' = p .-. everyoneDeny .+. everyoneAllow + roleOverwrites = c ^.. #permissionOverwrites . foldMap ix + (map (coerceSnowflake @_ @Overwrite) . V.toList $ m ^. #roles) + roleAllow = foldl andFlags noFlags (roleOverwrites ^.. traverse . #allow) + roleDeny = foldl andFlags noFlags (roleOverwrites ^.. traverse . #deny) + p'' = p' .-. roleDeny .+. roleAllow + memberOverwrite = c ^. #permissionOverwrites . at (coerceSnowflake @_ @Overwrite $ getID @Member m) + memberAllow = maybe noFlags (^. #allow) memberOverwrite + memberDeny = maybe noFlags (^. #deny) memberOverwrite + p''' = p'' .-. memberDeny .+. memberAllow + in p''' + +class PermissionsIn a where + permissionsIn :: a -> Member -> Permissions + +instance PermissionsIn (Guild, GuildChannel) where + permissionsIn (g, c) m = applyOverwrites c m $ basePermissions g m + +instance PermissionsIn Guild where + permissionsIn g m = basePermissions g m + +class PermissionsIn' a where + permissionsIn' :: BotC r => a -> Member -> P.Sem r Permissions + +instance PermissionsIn' GuildChannel where + permissionsIn' c m = do + g <- upgrade (getID @Guild c) + case g of + Just g' -> pure $ permissionsIn (g', c) m + Nothing -> pure noFlags + +instance PermissionsIn' Guild where + permissionsIn' g m = pure $ permissionsIn g m + +instance PermissionsIn' (Snowflake GuildChannel) where + permissionsIn' cid m = do + c <- upgrade cid + case c of + Just c' -> permissionsIn' c' m + Nothing -> pure noFlags + +instance PermissionsIn' (Snowflake Guild) where + permissionsIn' gid m = do + g <- upgrade gid + case g of + Just g' -> permissionsIn' g' m + Nothing -> pure noFlags