calamity 0.1.10 → 0.1.10.1

raw patch · 29 files changed

+528/−53 lines, 29 filesdep +colourdep +data-flagsdep ~df1PVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: colour, data-flags

Dependency ranges changed: df1

API changes (from Hackage documentation)

Files

• ChangeLog.md +15/−0
• calamity.cabal +11/−3
• src/Calamity.hs +5/−1
• src/Calamity/Client/Client.hs +30/−4
• src/Calamity/Client/ShardManager.hs +3/−3
• src/Calamity/Client/Types.hs +5/−1
• src/Calamity/Commands/Parser.hs +36/−2
• src/Calamity/Gateway.hs +2/−0
• src/Calamity/Gateway/DispatchEvents.hs +28/−0
• src/Calamity/Gateway/Intents.hs +46/−0
• src/Calamity/Gateway/Shard.hs +7/−3
• src/Calamity/Gateway/Types.hs +18/−10
• src/Calamity/HTTP/Channel.hs +26/−5
• src/Calamity/HTTP/Guild.hs +5/−2
• src/Calamity/Internal/IntColour.hs +29/−0
• src/Calamity/Internal/Utils.hs +4/−0
• src/Calamity/Types/Model/Channel/Embed.hs +4/−3
• src/Calamity/Types/Model/Channel/Guild.hs +36/−0
• src/Calamity/Types/Model/Channel/Guild/Category.hs +2/−1
• src/Calamity/Types/Model/Channel/Guild/Text.hs +2/−1
• src/Calamity/Types/Model/Channel/Guild/Voice.hs +2/−1
• src/Calamity/Types/Model/Guild.hs +3/−1
• src/Calamity/Types/Model/Guild/Guild.hs +0/−2
• src/Calamity/Types/Model/Guild/Overwrite.hs +5/−5
• src/Calamity/Types/Model/Guild/Permissions.hs +83/−0
• src/Calamity/Types/Model/Guild/Role.hs +8/−5
• src/Calamity/Utils.hs +7/−0
• src/Calamity/Utils/Colour.hs +18/−0
• src/Calamity/Utils/Permissions.hs +88/−0

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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