summaryrefslogtreecommitdiff
path: root/deps/discord-haskell/src/Discord/Internal
diff options
context:
space:
mode:
authorLLLL Colonq <llll@colonq>2024-01-11 20:42:57 -0500
committerLLLL Colonq <llll@colonq>2024-01-11 20:42:57 -0500
commitae18b594c97782cc201ffa365f12064831b1ec93 (patch)
tree5570a7f8ab15a113f332839b900c2c47444e7314 /deps/discord-haskell/src/Discord/Internal
parent0be357bb60a2bc4523056aba34add78b715211f5 (diff)
Handle stickers, properly handle exceptions in threads
Diffstat (limited to 'deps/discord-haskell/src/Discord/Internal')
-rw-r--r--deps/discord-haskell/src/Discord/Internal/Gateway.hs5
-rw-r--r--deps/discord-haskell/src/Discord/Internal/Gateway/Cache.hs62
-rw-r--r--deps/discord-haskell/src/Discord/Internal/Rest/ApplicationInfo.hs38
-rw-r--r--deps/discord-haskell/src/Discord/Internal/Rest/Channel.hs44
-rw-r--r--deps/discord-haskell/src/Discord/Internal/Rest/Emoji.hs11
-rw-r--r--deps/discord-haskell/src/Discord/Internal/Rest/Guild.hs33
-rw-r--r--deps/discord-haskell/src/Discord/Internal/Rest/User.hs3
-rw-r--r--deps/discord-haskell/src/Discord/Internal/Rest/Webhook.hs3
-rw-r--r--deps/discord-haskell/src/Discord/Internal/Types.hs3
-rw-r--r--deps/discord-haskell/src/Discord/Internal/Types/ApplicationInfo.hs23
-rw-r--r--deps/discord-haskell/src/Discord/Internal/Types/Channel.hs45
-rw-r--r--deps/discord-haskell/src/Discord/Internal/Types/Emoji.hs2
-rw-r--r--deps/discord-haskell/src/Discord/Internal/Types/Events.hs26
-rw-r--r--deps/discord-haskell/src/Discord/Internal/Types/Gateway.hs11
-rw-r--r--deps/discord-haskell/src/Discord/Internal/Types/Guild.hs51
-rw-r--r--deps/discord-haskell/src/Discord/Internal/Types/Interactions.hs1
-rw-r--r--deps/discord-haskell/src/Discord/Internal/Types/Prelude.hs42
-rw-r--r--deps/discord-haskell/src/Discord/Internal/Types/RolePermissions.hs9
18 files changed, 280 insertions, 132 deletions
diff --git a/deps/discord-haskell/src/Discord/Internal/Gateway.hs b/deps/discord-haskell/src/Discord/Internal/Gateway.hs
index f07be39..a31c4de 100644
--- a/deps/discord-haskell/src/Discord/Internal/Gateway.hs
+++ b/deps/discord-haskell/src/Discord/Internal/Gateway.hs
@@ -7,6 +7,7 @@ module Discord.Internal.Gateway
, CacheHandle(..)
, GatewayException(..)
, Cache(..)
+ , initializeCache
, startCacheThread
, startGatewayThread
, module Discord.Internal.Types
@@ -21,13 +22,13 @@ import Data.Time (getCurrentTime)
import Discord.Internal.Types (Auth, EventInternalParse, GatewayIntent)
import Discord.Internal.Gateway.EventLoop (connectionLoop, GatewayHandle(..), GatewayException(..))
-import Discord.Internal.Gateway.Cache (cacheLoop, Cache(..), CacheHandle(..))
+import Discord.Internal.Gateway.Cache (cacheLoop, Cache(..), CacheHandle(..), initializeCache)
-- | Starts a thread for the cache
startCacheThread :: Bool -> Chan T.Text -> IO (CacheHandle, ThreadId)
startCacheThread isEnabled log = do
events <- newChan :: IO (Chan (Either GatewayException EventInternalParse))
- cache <- newEmptyMVar :: IO (MVar (Either (Cache, GatewayException) Cache))
+ cache <- newEmptyMVar :: IO (MVar Cache)
let cacheHandle = CacheHandle events cache
tid <- forkIO $ cacheLoop isEnabled cacheHandle log
pure (cacheHandle, tid)
diff --git a/deps/discord-haskell/src/Discord/Internal/Gateway/Cache.hs b/deps/discord-haskell/src/Discord/Internal/Gateway/Cache.hs
index a4f228a..9ae3257 100644
--- a/deps/discord-haskell/src/Discord/Internal/Gateway/Cache.hs
+++ b/deps/discord-haskell/src/Discord/Internal/Gateway/Cache.hs
@@ -5,7 +5,7 @@
module Discord.Internal.Gateway.Cache where
import Prelude hiding (log)
-import Control.Monad (forever, join)
+import Control.Monad (forever, join, when)
import Control.Concurrent.MVar
import Control.Concurrent.Chan
import Data.Foldable (foldl')
@@ -15,50 +15,38 @@ import qualified Data.Text as T
import Discord.Internal.Types
import Discord.Internal.Gateway.EventLoop
+-- | Cached data from gateway. Set RunDiscordOpts.discordEnableCache=true to enable all the fields
data Cache = Cache
- { cacheCurrentUser :: !User
- , cacheDMChannels :: !(M.Map ChannelId Channel)
- , cacheGuilds :: !(M.Map GuildId (Maybe (Guild, Maybe GuildCreateData)))
- , cacheChannels :: !(M.Map ChannelId Channel)
- , cacheApplication :: !PartialApplication
+ { cacheCurrentUser :: !User -- ^ Filled before onStart handler
+ , cacheDMChannels :: !(M.Map ChannelId Channel) -- ^ Filled over time
+ , cacheGuilds :: !(M.Map GuildId (Maybe (Guild, Maybe GuildCreateData))) -- ^ Filled over time
+ , cacheChannels :: !(M.Map ChannelId Channel) -- ^ Filled over time
+ , cacheApplication :: !FullApplication -- ^ Filled before onStart handler
} deriving (Show)
+-- | Internal handle for cacheLoop to manage the cache
data CacheHandle = CacheHandle
- { cacheHandleEvents :: Chan (Either GatewayException EventInternalParse)
- , cacheHandleCache :: MVar (Either (Cache, GatewayException) Cache)
+ { cacheHandleEvents :: Chan (Either GatewayException EventInternalParse) -- ^ Read gateway events
+ , cacheHandleCache :: MVar Cache -- ^ Current cache.
}
-cacheLoop :: Bool -> CacheHandle -> Chan T.Text -> IO ()
-cacheLoop isEnabled cacheHandle log = do
- ready <- readChan eventChan
- case ready of
- Right (InternalReady _ user _ _ _ _ pApp) -> do
- putMVar cache (Right (Cache user M.empty M.empty M.empty pApp))
- loop
- Right r ->
- writeChan log ("cache - stopping cache - expected Ready event, but got " <> T.pack (show r))
- Left e ->
- writeChan log ("cache - stopping cache - gateway exception " <> T.pack (show e))
- where
- cache = cacheHandleCache cacheHandle
- eventChan = cacheHandleEvents cacheHandle
+-- | Internally used to setup the first cache
+initializeCache :: User -> FullApplication -> CacheHandle -> IO ()
+initializeCache user app cacheHandle = putMVar (cacheHandleCache cacheHandle) (Cache user M.empty M.empty M.empty app)
- loop :: IO ()
- loop = forever $ do
- eventOrExcept <- readChan eventChan
- if not isEnabled
- then return ()
- else do
- minfo <- takeMVar cache
- case minfo of
- Left nope -> putMVar cache (Left nope)
- Right info -> case eventOrExcept of
- Left e -> putMVar cache (Left (info, e))
- Right event -> putMVar cache $! Right $! adjustCache info event
+-- | IO loop to update cache on each gateway event
+cacheLoop :: Bool -> CacheHandle -> Chan T.Text -> IO ()
+cacheLoop isEnabled cacheHandle _log = when isEnabled $ forever $ do
+ eventOrExcept <- readChan (cacheHandleEvents cacheHandle)
+ case eventOrExcept of
+ Left _ -> pure ()
+ Right event -> modifyMVar_ (cacheHandleCache cacheHandle) $! pure . adjustCache event
-adjustCache :: Cache -> EventInternalParse -> Cache
-adjustCache minfo event = case event of
- InternalReady _ _ gus _ _ _ pa -> minfo { cacheApplication = pa, cacheGuilds = M.union (cacheGuilds minfo) (M.fromList $ (\gu -> (idOnceAvailable gu, Nothing)) <$> gus) }
+-- | Apply gateway event to cache
+adjustCache :: EventInternalParse -> Cache -> Cache
+adjustCache event minfo = case event of
+ -- note: ready only sends a partial app. we could update the info stored in the full app
+ InternalReady _ _ gus _ _ _ _partialApp -> minfo { cacheGuilds = M.union (cacheGuilds minfo) (M.fromList $ (\gu -> (idOnceAvailable gu, Nothing)) <$> gus) }
InternalGuildCreate guild guildData ->
let newChans = guildCreateChannels guildData
diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/ApplicationInfo.hs b/deps/discord-haskell/src/Discord/Internal/Rest/ApplicationInfo.hs
new file mode 100644
index 0000000..f0ad7f2
--- /dev/null
+++ b/deps/discord-haskell/src/Discord/Internal/Rest/ApplicationInfo.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Provides actions for Channel API interactions
+module Discord.Internal.Rest.ApplicationInfo
+ ( FullApplicationRequest(..)
+ ) where
+
+import Network.HTTP.Req ((/:))
+import qualified Network.HTTP.Req as R
+
+import Discord.Internal.Rest.Prelude
+import Discord.Internal.Types
+
+instance Request (FullApplicationRequest a) where
+ majorRoute = applicationMajorRoute
+ jsonRequest = applicationJsonRequest
+
+
+-- | Data constructor for requests. See <https://discord.com/developers/docs/resources/ API>
+data FullApplicationRequest a where
+ -- | Get the full application for the current user
+ GetCurrentApplication :: FullApplicationRequest FullApplication
+
+applicationMajorRoute :: FullApplicationRequest a -> String
+applicationMajorRoute c = case c of
+ (GetCurrentApplication) -> "application "
+
+applications :: R.Url 'R.Https
+applications = baseUrl /: "applications"
+
+applicationJsonRequest :: FullApplicationRequest r -> JsonRequest
+applicationJsonRequest c = case c of
+ (GetCurrentApplication) -> Get (applications /: "@me") mempty
diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Channel.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Channel.hs
index 1024d9d..82b402c 100644
--- a/deps/discord-haskell/src/Discord/Internal/Rest/Channel.hs
+++ b/deps/discord-haskell/src/Discord/Internal/Rest/Channel.hs
@@ -22,7 +22,7 @@ module Discord.Internal.Rest.Channel
import Data.Aeson
import Data.Default (Default, def)
-import Data.Emoji (unicodeByName)
+import Text.Emoji (emojiFromAlias)
import qualified Data.Text as T
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
@@ -159,16 +159,14 @@ instance Default MessageDetailedOpts where
}
-- | Data constructor for `GetReactions` requests
-data ReactionTiming = BeforeReaction MessageId
- | AfterReaction MessageId
- | LatestReaction
+data ReactionTiming = AfterUser UserId
+ | FirstUsers
deriving (Show, Read, Eq, Ord)
reactionTimingToQuery :: ReactionTiming -> R.Option 'R.Https
reactionTimingToQuery t = case t of
- (BeforeReaction snow) -> "before" R.=: show snow
- (AfterReaction snow) -> "after" R.=: show snow
- LatestReaction -> mempty
+ (AfterUser snow) -> "after" R.=: show snow
+ FirstUsers -> mempty
-- | Data constructor for `GetChannelMessages` requests.
--
@@ -310,6 +308,12 @@ instance ToJSON StartThreadOpts where
, "rate_limit_per_user" .=? startThreadRateLimit
]
+instance Default StartThreadOpts where
+ def = StartThreadOpts { startThreadName = "New Thread"
+ , startThreadAutoArchive = Nothing
+ , startThreadRateLimit = Nothing
+ }
+
-- | Options for `StartThreadNoMessage` request
data StartThreadNoMessageOpts = StartThreadNoMessageOpts
{ -- | Base options for the thread
@@ -401,11 +405,25 @@ channelMajorRoute c = case c of
cleanupEmoji :: T.Text -> T.Text
cleanupEmoji emoji =
let noAngles = T.replace "<" "" (T.replace ">" "" emoji)
- byName = T.pack <$> unicodeByName (T.unpack (T.replace ":" "" emoji))
- in case (byName, T.stripPrefix ":" noAngles) of
- (Just e, _) -> e
- (_, Just a) -> "custom:" <> a
- (_, Nothing) -> noAngles
+ noColons = T.replace ":" "" emoji
+ toneModifier s = case s of
+ "tone1" -> Just "\x1f3fb"
+ "tone2" -> Just "\x1f3fc"
+ "tone3" -> Just "\x1f3fd"
+ "tone4" -> Just "\x1f3fe"
+ "tone5" -> Just "\x1f3ff"
+ _ -> Nothing
+ byName = case emojiFromAlias noColons of
+ Just e -> Just e
+ Nothing ->
+ let (prefix, tone) = T.breakOnEnd "_" noColons
+ in case ((fst <$> T.unsnoc prefix) >>= emojiFromAlias, toneModifier tone) of
+ (Just p, Just t) -> Just (p <> t)
+ _ -> Nothing
+ in case (byName, T.stripPrefix ":" noAngles) of
+ (Just e, _) -> e
+ (_, Just a) -> "custom:" <> a
+ (_, Nothing) -> noAngles
channels :: R.Url 'R.Https
channels = baseUrl /: "channels"
@@ -566,7 +584,7 @@ channelJsonRequest c = case c of
mempty
(StartThreadNoMessage chan sto) ->
- Post (channels /~ chan /: "messages" /: "threads")
+ Post (channels /~ chan /: "threads")
(pure $ R.ReqBodyJson $ toJSON sto)
mempty
diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Emoji.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Emoji.hs
index 2a52171..e849123 100644
--- a/deps/discord-haskell/src/Discord/Internal/Rest/Emoji.hs
+++ b/deps/discord-haskell/src/Discord/Internal/Rest/Emoji.hs
@@ -20,7 +20,6 @@ import Data.Aeson
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as B64
import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
import Discord.Internal.Rest.Prelude
import Discord.Internal.Types
import Network.HTTP.Req ((/:), (/~))
@@ -65,7 +64,7 @@ instance ToJSON ModifyGuildEmojiOpts where
parseEmojiImage :: B.ByteString -> Either T.Text (Base64Image Emoji)
parseEmojiImage bs
| B.length bs > 256000 = Left "Cannot create emoji - File is larger than 256kb"
- | Just mime <- getMimeType bs = Right (Base64Image mime (TE.decodeUtf8 (B64.encode bs)))
+ | Just mime <- getMimeType bs = Right (Base64Image mime (B64.encode bs))
| otherwise = Left "Unsupported image format provided"
emojiMajorRoute :: EmojiRequest a -> String
@@ -112,13 +111,13 @@ emojiJsonRequest c = case c of
parseStickerImage :: B.ByteString -> Either T.Text (Base64Image Sticker)
parseStickerImage bs
| B.length bs > 512000
- = Left "Cannot create sticker - File is larger than 512kb"
+ = Left "Cannot create sticker - File is larger than 512kb"
| Just "image/png" <- getMimeType bs
- = Right (Base64Image "image/png" (TE.decodeUtf8 (B64.encode bs)))
+ = Right (Base64Image "image/png" (B64.encode bs))
| not (B.null bs) && B.head bs == 0x7b -- '{'
- = Right (Base64Image "application/json" (TE.decodeUtf8 (B64.encode bs)))
+ = Right (Base64Image "application/json" (B64.encode bs))
| otherwise
- = Left "Unsupported image format provided"
+ = Left "Unsupported image format provided"
-- | Options for `CreateGuildSticker`
data CreateGuildStickerOpts = CreateGuildStickerOpts
diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Guild.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Guild.hs
index a0cb3aa..99c3e77 100644
--- a/deps/discord-haskell/src/Discord/Internal/Rest/Guild.hs
+++ b/deps/discord-haskell/src/Discord/Internal/Rest/Guild.hs
@@ -15,6 +15,7 @@ module Discord.Internal.Rest.Guild
, ModifyGuildRoleOpts(..)
, CreateGuildIntegrationOpts(..)
, ModifyGuildIntegrationOpts(..)
+ , ListActiveThreads (..)
) where
@@ -53,6 +54,8 @@ data GuildRequest a where
-- 'MANAGE_CHANNELS' permission. Returns a list of all of the guild's 'Channel'
-- objects on success. Fires multiple Channel Update 'Event's.
ModifyGuildChannelPositions :: GuildId -> [(ChannelId,Int)] -> GuildRequest [Channel]
+ -- | Returns a list of active threads in a guild
+ ListActiveGuildThreads :: GuildId -> GuildRequest ListActiveThreads
-- | Returns a guild 'Member' object for the specified user
GetGuildMember :: GuildId -> UserId -> GuildRequest GuildMember
-- | Returns a list of guild 'Member' objects that are members of the guild.
@@ -61,14 +64,13 @@ data GuildRequest a where
-- for the user with the guilds.join scope. Returns the guild 'Member' as the body.
-- Fires a Guild Member Add 'Event'. Requires the bot to have the
-- CREATE_INSTANT_INVITE permission.
- AddGuildMember :: GuildId -> UserId -> AddGuildMemberOpts
- -> GuildRequest ()
+ AddGuildMember :: GuildId -> UserId -> AddGuildMemberOpts -> GuildRequest ()
-- | Modify attributes of a guild 'Member'. Fires a Guild Member Update 'Event'.
ModifyGuildMember :: GuildId -> UserId -> ModifyGuildMemberOpts -> GuildRequest GuildMember
-- | Modify the nickname of the current user
ModifyCurrentUserNick :: GuildId -> T.Text -> GuildRequest ()
-- | Add a member to a guild role. Requires 'MANAGE_ROLES' permission.
- AddGuildMemberRole :: GuildId -> UserId -> RoleId -> GuildRequest ()
+ AddGuildMemberRole :: GuildId -> UserId -> RoleId -> GuildRequest ()
-- | Remove a member from a guild role. Requires 'MANAGE_ROLES' permission.
RemoveGuildMemberRole :: GuildId -> UserId -> RoleId -> GuildRequest ()
-- | Remove a member from a guild. Requires 'KICK_MEMBER' permission. Fires a
@@ -132,11 +134,11 @@ data GuildRequest a where
-- | Sync an 'Integration'. Requires the 'MANAGE_GUILD' permission.
SyncGuildIntegration :: GuildId -> IntegrationId -> GuildRequest ()
-- | Returns the 'GuildWidget' object. Requires the 'MANAGE_GUILD' permission.
- GetGuildWidget :: GuildId -> GuildRequest GuildWidget
+ GetGuildWidget :: GuildId -> GuildRequest GuildWidget
-- | Modify a 'GuildWidget' object for the guild. All attributes may be passed in with
-- JSON and modified. Requires the 'MANAGE_GUILD' permission. Returns the updated
-- 'GuildWidget' object.
- ModifyGuildWidget :: GuildId -> GuildWidget -> GuildRequest GuildWidget
+ ModifyGuildWidget :: GuildId -> GuildWidget -> GuildRequest GuildWidget
-- | Vanity URL
GetGuildVanityURL :: GuildId -> GuildRequest T.Text
@@ -301,6 +303,23 @@ data GuildMembersTiming = GuildMembersTiming
, guildMembersTimingAfter :: Maybe UserId
} deriving (Show, Read, Eq, Ord)
+-- | result for `ListGuildActiveThreads`
+data ListActiveThreads = ListActiveThreads
+ { listActiveThreadsThreads :: [Channel]
+ , listActiveThreadsMembers :: [ThreadMember]
+ } deriving (Show, Read, Eq, Ord)
+
+instance ToJSON ListActiveThreads where
+ toJSON ListActiveThreads{..} = object
+ [ ("threads", toJSON listActiveThreadsThreads)
+ , ("members", toJSON listActiveThreadsMembers)
+ ]
+
+instance FromJSON ListActiveThreads where
+ parseJSON = withObject "ListActiveThreads" $ \o ->
+ ListActiveThreads <$> o .: "threads"
+ <*> o .: "members"
+
guildMembersTimingToQuery :: GuildMembersTiming -> R.Option 'R.Https
guildMembersTimingToQuery (GuildMembersTiming mLimit mAfter) =
let limit = case mLimit of
@@ -319,6 +338,7 @@ guildMajorRoute c = case c of
(GetGuildChannels g) -> "guild_chan " <> show g
(CreateGuildChannel g _ _ _) -> "guild_chan " <> show g
(ModifyGuildChannelPositions g _) -> "guild_chan " <> show g
+ (ListActiveGuildThreads g) -> "guild_chan " <> show g
(GetGuildMember g _) -> "guild_memb " <> show g
(ListGuildMembers g _) -> "guild_membs " <> show g
(AddGuildMember g _ _) -> "guild_membs " <> show g
@@ -376,6 +396,9 @@ guildJsonRequest c = case c of
,("position", toJSON b)]) newlocs
in Patch (guilds /~ guild /: "channels") (pure (R.ReqBodyJson patch)) mempty
+ (ListActiveGuildThreads guild) ->
+ Get (guilds /~ guild /: "threads" /: "active") mempty
+
(GetGuildMember guild member) ->
Get (guilds /~ guild /: "members" /~ member) mempty
diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/User.hs b/deps/discord-haskell/src/Discord/Internal/Rest/User.hs
index 28c0505..2ab9c24 100644
--- a/deps/discord-haskell/src/Discord/Internal/Rest/User.hs
+++ b/deps/discord-haskell/src/Discord/Internal/Rest/User.hs
@@ -15,7 +15,6 @@ import Data.Aeson
import Network.HTTP.Req ((/:), (/~))
import qualified Network.HTTP.Req as R
import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as B64
@@ -58,7 +57,7 @@ data UserRequest a where
-- This function accepts all file types accepted by 'getMimeType'.
parseAvatarImage :: B.ByteString -> Either T.Text (Base64Image User)
parseAvatarImage bs
- | Just mime <- getMimeType bs = Right (Base64Image mime (TE.decodeUtf8 (B64.encode bs)))
+ | Just mime <- getMimeType bs = Right (Base64Image mime (B64.encode bs))
| otherwise = Left "Unsupported image format provided"
userMajorRoute :: UserRequest a -> String
diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Webhook.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Webhook.hs
index 7b4a545..be39b09 100644
--- a/deps/discord-haskell/src/Discord/Internal/Rest/Webhook.hs
+++ b/deps/discord-haskell/src/Discord/Internal/Rest/Webhook.hs
@@ -13,6 +13,7 @@ module Discord.Internal.Rest.Webhook
) where
import Data.Aeson
+import qualified Data.Aeson.Key as Key
import qualified Data.Text as T
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
@@ -124,7 +125,7 @@ data WebhookContent = WebhookContentText T.Text
| WebhookContentEmbeds [CreateEmbed]
deriving (Show, Read, Eq, Ord)
-webhookContentJson :: WebhookContent -> [(AesonKey, Value)]
+webhookContentJson :: WebhookContent -> [(Key.Key, Value)]
webhookContentJson c = case c of
WebhookContentText t -> [("content", toJSON t)]
WebhookContentFile _ _ -> []
diff --git a/deps/discord-haskell/src/Discord/Internal/Types.hs b/deps/discord-haskell/src/Discord/Internal/Types.hs
index 0dac11c..e115f9a 100644
--- a/deps/discord-haskell/src/Discord/Internal/Types.hs
+++ b/deps/discord-haskell/src/Discord/Internal/Types.hs
@@ -1,6 +1,7 @@
-- | Re-export ALL the internal type modules. Hiding is in Discord.Types
module Discord.Internal.Types
( module Discord.Internal.Types.Prelude,
+ module Discord.Internal.Types.ApplicationInfo,
module Discord.Internal.Types.Channel,
module Discord.Internal.Types.Color,
module Discord.Internal.Types.Events,
@@ -19,6 +20,7 @@ where
import Data.Aeson (Object, ToJSON (toJSON))
import Data.Time.Clock (UTCTime (..))
+import Discord.Internal.Types.ApplicationInfo
import Discord.Internal.Types.Channel
import Discord.Internal.Types.Color
import Discord.Internal.Types.Components
@@ -41,6 +43,7 @@ userFacingEvent event = case event of
InternalChannelDelete a -> ChannelDelete a
InternalThreadCreate a -> ThreadCreate a
InternalThreadUpdate a -> ThreadUpdate a
+ InternalThreadMemberUpdate a -> ThreadMemberUpdate a
InternalThreadDelete a -> ThreadDelete a
InternalThreadListSync a -> ThreadListSync a
InternalThreadMembersUpdate a -> ThreadMembersUpdate a
diff --git a/deps/discord-haskell/src/Discord/Internal/Types/ApplicationInfo.hs b/deps/discord-haskell/src/Discord/Internal/Types/ApplicationInfo.hs
new file mode 100644
index 0000000..708f1c7
--- /dev/null
+++ b/deps/discord-haskell/src/Discord/Internal/Types/ApplicationInfo.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | Data structures pertaining to Discord User
+module Discord.Internal.Types.ApplicationInfo where
+
+import Data.Aeson
+import qualified Data.Text as T
+import Discord.Internal.Types.Prelude
+
+-- | Structure containing partial information about an Application
+data FullApplication = FullApplication
+ { fullApplicationID :: ApplicationId
+ , fullApplicationName :: T.Text
+ , fullApplicationFlags :: Int
+ } deriving (Show, Eq, Read)
+
+instance FromJSON FullApplication where
+ parseJSON = withObject "FullApplication" $ \o ->
+ FullApplication <$> o .: "id"
+ <*> o .: "name"
+ <*> o .: "flags"
+
diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Channel.hs b/deps/discord-haskell/src/Discord/Internal/Types/Channel.hs
index 9f4671a..a577f64 100644
--- a/deps/discord-haskell/src/Discord/Internal/Types/Channel.hs
+++ b/deps/discord-haskell/src/Discord/Internal/Types/Channel.hs
@@ -9,6 +9,7 @@ module Discord.Internal.Types.Channel (
, Overwrite (..)
, ThreadMetadata (..)
, ThreadMember (..)
+ , ThreadMemberUpdateFields (..)
, ThreadListSyncFields (..)
, ThreadMembersUpdateFields (..)
, Message (..)
@@ -23,7 +24,7 @@ module Discord.Internal.Types.Channel (
, MessageFlag (..)
, MessageFlags (..)
, MessageInteraction (..)
-
+
, ChannelTypeOption (..)
) where
@@ -170,7 +171,7 @@ instance FromJSON Channel where
case type' of
0 ->
ChannelText <$> o .: "id"
- <*> o .:? "guild_id" .!= 0
+ <*> o .: "guild_id"
<*> o .: "name"
<*> o .: "position"
<*> o .: "permission_overwrites"
@@ -185,7 +186,7 @@ instance FromJSON Channel where
<*> o .:? "last_message_id"
2 ->
ChannelVoice <$> o .: "id"
- <*> o .:? "guild_id" .!= 0
+ <*> o .: "guild_id"
<*> o .: "name"
<*> o .: "position"
<*> o .: "permission_overwrites"
@@ -199,13 +200,13 @@ instance FromJSON Channel where
<*> o .:? "last_message_id"
4 ->
ChannelGuildCategory <$> o .: "id"
- <*> o .:? "guild_id" .!= 0
+ <*> o .: "guild_id"
<*> o .: "name"
<*> o .: "position"
<*> o .: "permission_overwrites"
5 ->
ChannelNews <$> o .: "id"
- <*> o .:? "guild_id" .!= 0
+ <*> o .: "guild_id"
<*> o .: "name"
<*> o .: "position"
<*> o .: "permission_overwrites"
@@ -215,14 +216,14 @@ instance FromJSON Channel where
<*> o .:? "parent_id"
6 ->
ChannelStorePage <$> o .: "id"
- <*> o .:? "guild_id" .!= 0
+ <*> o .: "guild_id"
<*> o .: "name"
<*> o .: "position"
<*> o .:? "nsfw" .!= False
<*> o .: "permission_overwrites"
<*> o .:? "parent_id"
10 -> ChannelNewsThread <$> o.: "id"
- <*> o .:? "guild_id" .!= 0
+ <*> o .: "guild_id"
<*> o .:? "name"
<*> o .:? "rate_limit_per_user"
<*> o .:? "last_message_id"
@@ -230,7 +231,7 @@ instance FromJSON Channel where
<*> o .:? "thread_metadata"
<*> o .:? "member"
11 -> ChannelPublicThread <$> o.: "id"
- <*> o .:? "guild_id" .!= 0
+ <*> o .: "guild_id"
<*> o .:? "name"
<*> o .:? "rate_limit_per_user"
<*> o .:? "last_message_id"
@@ -238,7 +239,7 @@ instance FromJSON Channel where
<*> o .:? "thread_metadata"
<*> o .:? "member"
12 -> ChannelPrivateThread <$> o.: "id"
- <*> o .:? "guild_id" .!= 0
+ <*> o .: "guild_id"
<*> o .:? "name"
<*> o .:? "rate_limit_per_user"
<*> o .:? "last_message_id"
@@ -247,7 +248,7 @@ instance FromJSON Channel where
<*> o .:? "member"
13 ->
ChannelStage <$> o .: "id"
- <*> o .:? "guild_id" .!= 0
+ <*> o .: "guild_id"
<*> o .: "id"
<*> o .:? "topic" .!= ""
_ -> ChannelUnknownType <$> o .: "id"
@@ -453,6 +454,30 @@ instance ToJSON ThreadMember where
, "flags" .== threadMemberFlags
]
+data ThreadMemberUpdateFields = ThreadMemberUpdateFields
+ { threadMemberUpdateFieldsThreadId :: Maybe ChannelId -- ^ id of the thread
+ , threadMemberUpdateFieldsUserId :: Maybe UserId -- ^ id of the user
+ , threadMemberUpdateFieldsJoinTime :: UTCTime -- ^ time the current user last joined the thread
+ , threadMemberUpdateFieldsFlags :: Integer -- ^ user-thread settings
+ , threadMemberUpdateFieldsGuildId :: GuildId -- ^ id of the guild
+ } deriving (Show, Read, Eq, Ord)
+
+instance FromJSON ThreadMemberUpdateFields where
+ parseJSON = withObject "ThreadMemberUpdateFields" $ \o ->
+ ThreadMemberUpdateFields <$> o .:? "id"
+ <*> o .:? "user_id"
+ <*> o .: "join_timestamp"
+ <*> o .: "flags"
+ <*> o .: "guild_id"
+
+instance ToJSON ThreadMemberUpdateFields where
+ toJSON ThreadMemberUpdateFields{..} = objectFromMaybes
+ [ "id" .=? threadMemberUpdateFieldsThreadId
+ , "user_id" .=? threadMemberUpdateFieldsUserId
+ , "join_timestamp" .== threadMemberUpdateFieldsJoinTime
+ , "flags" .== threadMemberUpdateFieldsFlags
+ , "guild_id" .== threadMemberUpdateFieldsGuildId
+ ]
data ThreadListSyncFields = ThreadListSyncFields
{ threadListSyncFieldsGuildId :: GuildId
diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Emoji.hs b/deps/discord-haskell/src/Discord/Internal/Types/Emoji.hs
index 9023d4a..4e0408c 100644
--- a/deps/discord-haskell/src/Discord/Internal/Types/Emoji.hs
+++ b/deps/discord-haskell/src/Discord/Internal/Types/Emoji.hs
@@ -152,6 +152,7 @@ data StickerFormatType
= StickerFormatTypePNG
| StickerFormatTypeAPNG
| StickerFormatTypeLOTTIE
+ | StickerFormatTypeGIF
deriving (Show, Read, Eq, Ord, Data)
instance InternalDiscordEnum StickerFormatType where
@@ -159,6 +160,7 @@ instance InternalDiscordEnum StickerFormatType where
fromDiscordType StickerFormatTypePNG = 1
fromDiscordType StickerFormatTypeAPNG = 2
fromDiscordType StickerFormatTypeLOTTIE = 3
+ fromDiscordType StickerFormatTypeGIF = 4
instance ToJSON StickerFormatType where
toJSON = toJSON . fromDiscordType
diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Events.hs b/deps/discord-haskell/src/Discord/Internal/Types/Events.hs
index d77cc96..5014d9f 100644
--- a/deps/discord-haskell/src/Discord/Internal/Types/Events.hs
+++ b/deps/discord-haskell/src/Discord/Internal/Types/Events.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-- | Data structures pertaining to gateway dispatch 'Event's
module Discord.Internal.Types.Events where
@@ -12,6 +13,7 @@ import Network.Socket (HostName)
import Data.Aeson
import Data.Aeson.Types
+import qualified Data.Aeson.KeyMap as KM
import qualified Data.Text as T
import Discord.Internal.Types.Prelude
@@ -39,11 +41,13 @@ data Event =
| ThreadCreate Channel
-- | thread was updated
| ThreadUpdate Channel
+ -- | thread member for the current user was updated
+ | ThreadMemberUpdate ThreadMemberUpdateFields
-- | thread was deleted
| ThreadDelete Channel
-- | sent when gaining access to a channel, contains all active threads in that channel
| ThreadListSync ThreadListSyncFields
- -- | thread member for the current user was updated
+ -- | member or the current user was added or removed from a thread
| ThreadMembersUpdate ThreadMembersUpdateFields
-- | message was pinned or unpinned
| ChannelPinsUpdate ChannelId (Maybe UTCTime)
@@ -116,6 +120,7 @@ data EventInternalParse =
| InternalChannelDelete Channel
| InternalThreadCreate Channel
| InternalThreadUpdate Channel
+ | InternalThreadMemberUpdate ThreadMemberUpdateFields
| InternalThreadDelete Channel
| InternalThreadListSync ThreadListSyncFields
| InternalThreadMembersUpdate ThreadMembersUpdateFields
@@ -174,17 +179,25 @@ data GuildCreateData = GuildCreateData
, guildCreateScheduledEvents :: ![ScheduledEvent]
} deriving (Show, Eq, Read)
-instance FromJSON GuildCreateData where
- parseJSON = withObject "GuildCreateData" $ \o ->
+parseGuildCreate :: Object -> Parser EventInternalParse
+parseGuildCreate o = do
+ guild :: Guild <- reparse o
+ let gid = guildId guild
+ channelValues :: [Object] <- o .: "channels"
+ threadValues :: [Object] <- o .: "threads"
+ let wellFormedChannels = fmap (Object . KM.insert "guild_id" (toJSON gid)) channelValues
+ wellFormedThreads = fmap (Object . KM.insert "guild_id" (toJSON gid)) threadValues
+ guildCreateData <-
GuildCreateData <$> o .: "joined_at"
<*> o .: "large"
<*> o .:? "unavailable"
<*> o .: "member_count"
<*> o .: "members"
- <*> o .: "channels"
- <*> o .: "threads"
+ <*> traverse parseJSON wellFormedChannels
+ <*> traverse parseJSON wellFormedThreads
<*> o .: "presences"
<*> o .: "guild_scheduled_events"
+ pure $ InternalGuildCreate guild guildCreateData
-- | Structure containing information about a reaction
data ReactionInfo = ReactionInfo
@@ -268,6 +281,7 @@ eventParse t o = case t of
"CHANNEL_DELETE" -> InternalChannelDelete <$> reparse o
"THREAD_CREATE" -> InternalThreadCreate <$> reparse o
"THREAD_UPDATE" -> InternalThreadUpdate <$> reparse o
+ "THREAD_MEMBER_UPDATE" -> InternalThreadMemberUpdate <$> reparse o
"THREAD_DELETE" -> InternalThreadDelete <$> reparse o
"THREAD_LIST_SYNC" -> InternalThreadListSync <$> reparse o
"THREAD_MEMBERS_UPDATE" -> InternalThreadMembersUpdate <$> reparse o
@@ -275,7 +289,7 @@ eventParse t o = case t of
stamp <- o .:? "last_pin_timestamp"
let utc = stamp >>= parseISO8601
pure (InternalChannelPinsUpdate id utc)
- "GUILD_CREATE" -> InternalGuildCreate <$> reparse o <*> reparse o
+ "GUILD_CREATE" -> parseGuildCreate o
"GUILD_UPDATE" -> InternalGuildUpdate <$> reparse o
"GUILD_DELETE" -> InternalGuildDelete <$> reparse o
"GUILD_BAN_ADD" -> InternalGuildBanAdd <$> o .: "guild_id" <*> o .: "user"
diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Gateway.hs b/deps/discord-haskell/src/Discord/Internal/Types/Gateway.hs
index a3b8f90..8ec1fed 100644
--- a/deps/discord-haskell/src/Discord/Internal/Types/Gateway.hs
+++ b/deps/discord-haskell/src/Discord/Internal/Types/Gateway.hs
@@ -129,9 +129,10 @@ data UpdateStatusVoiceOpts = UpdateStatusVoiceOpts
deriving (Show, Read, Eq, Ord)
-- | Options for `UpdateStatus`
+-- Presence Update - https://discord.com/developers/docs/topics/gateway-events#update-presence
data UpdateStatusOpts = UpdateStatusOpts
{ updateStatusOptsSince :: Maybe UTCTime
- , updateStatusOptsGame :: Maybe Activity
+ , updateStatusOptsActivities :: [Activity]
, updateStatusOptsNewStatus :: UpdateStatusType
, updateStatusOptsAFK :: Bool
}
@@ -214,17 +215,13 @@ instance ToJSON GatewaySendableInternal where
]
instance ToJSON GatewaySendable where
- toJSON (UpdateStatus (UpdateStatusOpts since game status afk)) = object [
+ toJSON (UpdateStatus (UpdateStatusOpts since activities status afk)) = object [
"op" .= (3 :: Int)
, "d" .= object [
"since" .= (since <&> \s -> 1000 * utcTimeToPOSIXSeconds s) -- takes UTCTime and returns unix time (in milliseconds)
, "afk" .= afk
, "status" .= statusString status
- , "game" .= (game <&> \a -> object [
- "name" .= activityName a
- , "type" .= fromDiscordType (activityType a)
- , "url" .= activityUrl a
- ])
+ , "activities" .= activities
]
]
toJSON (UpdateStatusVoice (UpdateStatusVoiceOpts guild channel mute deaf)) =
diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Guild.hs b/deps/discord-haskell/src/Discord/Internal/Types/Guild.hs
index 5bddfaf..d8f2cf3 100644
--- a/deps/discord-haskell/src/Discord/Internal/Types/Guild.hs
+++ b/deps/discord-haskell/src/Discord/Internal/Types/Guild.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE LambdaCase #-}
-- | Types relating to Discord Guilds (servers)
module Discord.Internal.Types.Guild where
@@ -7,15 +9,17 @@ module Discord.Internal.Types.Guild where
import Data.Time.Clock
import Data.Aeson
+import Data.Aeson.Types (Parser)
import qualified Data.Text as T
import Data.Data (Data)
-import Data.Default (Default(..))
+import Data.List
import Discord.Internal.Types.Prelude
import Discord.Internal.Types.Color (DiscordColor)
import Discord.Internal.Types.User (User)
import Discord.Internal.Types.Emoji (Emoji, StickerItem)
-import Data.List
+
+import qualified Data.Aeson.KeyMap as KM
-- | Guilds in Discord represent a collection of users and channels into an isolated
-- "Server"
@@ -121,24 +125,40 @@ instance FromJSON GuildUnavailable where
data PresenceInfo = PresenceInfo
{ presenceUserId :: UserId
-- , presenceRoles :: [RoleId]
- , presenceActivities :: Maybe [Activity]
+ -- | Activities and the names of their buttons. The buttons field of Activity
+ -- will be blank, as the additional maybe field will have the button names it
+ -- would contain.
+ , presenceActivities :: Maybe [(Activity, Maybe [T.Text])]
, presenceGuildId :: Maybe GuildId
- , presenceStatus :: T.Text
+ , presenceStatus :: Maybe T.Text
} deriving (Show, Read, Eq, Ord)
instance FromJSON PresenceInfo where
parseJSON = withObject "PresenceInfo" $ \o ->
PresenceInfo <$> (o .: "user" >>= (.: "id"))
- <*> o .: "activities"
+ <*> (o .:? "activities" >>= parseActivities)
<*> o .:? "guild_id"
- <*> o .: "status"
+ <*> o .:? "status"
+ where
+ parseActivities :: Maybe [Value] -> Parser (Maybe [(Activity, Maybe [T.Text])])
+ parseActivities = \case
+ Nothing -> pure Nothing
+ Just vs -> Just <$> mapM parseIncomingActivity vs
+ parseIncomingActivity :: Value -> Parser (Activity, Maybe [T.Text])
+ parseIncomingActivity = withObject "PI Activity w/ BtnNames" $ \o -> do
+ let o' = KM.delete "buttons" o
+ act <- parseJSON (Object o')
+ buttonNames <- o .:? "buttons"
+ pure (act, buttonNames)
-- | Object for a single activity
--
--- https://discord.com/developers/docs/topics/gateway#activity-object
+-- https://discord.com/developers/docs/topics/gateway-events#activity-object
--
-- When setting a bot's activity, only the name, url, and type are sent - and
-- it seems that not many types are permitted either.
+--
+-- Only youtube and twitch urls will work.
data Activity =
Activity
{ activityName :: T.Text -- ^ Name of activity
@@ -155,12 +175,15 @@ data Activity =
-- secrets
, activityInstance :: Maybe Bool -- ^ Whether or not the activity is an instanced game session
, activityFlags :: Maybe Integer -- ^ The flags https://discord.com/developers/docs/topics/gateway#activity-object-activity-flags
- , activityButtons :: Maybe [ActivityButton] -- ^ Custom buttons shown in Rich Presence
+ , activityButtons :: Maybe [ActivityButton] -- ^ Custom buttons shown in Rich Presence. When received, always Nothing!
}
deriving (Show, Read, Eq, Ord)
-instance Default Activity where
- def = Activity "discord-haskell" ActivityTypeGame Nothing 0 Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+-- | The quick and easy way to make an activity for a discord bot.
+--
+-- To set the `activityState` or `activityUrl`, please use record field syntax.
+mkActivity :: T.Text -> ActivityType -> Activity
+mkActivity name typ = Activity name typ Nothing (-1) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
instance FromJSON Activity where
parseJSON = withObject "Activity" $ \o -> do
@@ -180,6 +203,14 @@ instance FromJSON Activity where
<*> o .:? "flags"
<*> o .:? "buttons"
+instance ToJSON Activity where
+ toJSON Activity {..} = objectFromMaybes
+ [ "name" .== activityName
+ , "state" .=? activityState
+ , "type" .== fromDiscordType activityType
+ , if activityType == ActivityTypeStreaming then "url" .=? activityUrl else Nothing
+ ]
+
data ActivityTimestamps = ActivityTimestamps
{ activityTimestampsStart :: Maybe Integer -- ^ unix time in milliseconds
, activityTimestampsEnd :: Maybe Integer -- ^ unix time in milliseconds
diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Interactions.hs b/deps/discord-haskell/src/Discord/Internal/Types/Interactions.hs
index 173f908..d56006e 100644
--- a/deps/discord-haskell/src/Discord/Internal/Types/Interactions.hs
+++ b/deps/discord-haskell/src/Discord/Internal/Types/Interactions.hs
@@ -18,6 +18,7 @@ module Discord.Internal.Types.Interactions
InteractionToken,
ResolvedData (..),
MemberOrUser (..),
+ ModalData (..),
InteractionResponse (..),
interactionResponseBasic,
InteractionResponseAutocomplete (..),
diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Prelude.hs b/deps/discord-haskell/src/Discord/Internal/Types/Prelude.hs
index fd49a15..67b3ec2 100644
--- a/deps/discord-haskell/src/Discord/Internal/Types/Prelude.hs
+++ b/deps/discord-haskell/src/Discord/Internal/Types/Prelude.hs
@@ -3,7 +3,6 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-- | Provides base types and utility functions needed for modules in Discord.Internal.Types
@@ -49,7 +48,6 @@ module Discord.Internal.Types.Prelude
, (.==)
, (.=?)
- , AesonKey
, objectFromMaybes
, ChannelTypeOption (..)
@@ -71,10 +69,8 @@ import Web.Internal.HttpApiData
import qualified Data.ByteString as B
import qualified Data.Text as T
-
-#if MIN_VERSION_aeson(2, 0, 0)
import qualified Data.Aeson.Key as Key
-#endif
+import qualified Data.Text.Encoding as T.E
-- | Authorization token for the Discord API
newtype Auth = Auth T.Text
@@ -89,7 +85,7 @@ authToken (Auth tok) = let token = T.strip tok
-- | A unique integer identifier. Can be used to calculate the creation date of an entity.
newtype Snowflake = Snowflake { unSnowflake :: Word64 }
- deriving (Ord, Eq, Num, Integral, Enum, Real, Bits)
+ deriving (Ord, Eq)
instance Show Snowflake where
show (Snowflake a) = show a
@@ -114,7 +110,7 @@ instance ToHttpApiData Snowflake where
toUrlPiece = T.pack . show
newtype RolePermissions = RolePermissions { getRolePermissions :: Integer }
- deriving (Eq, Ord, Num, Bits, Enum, Real, Integral)
+ deriving (Eq, Ord, Bits)
instance Read RolePermissions where
readsPrec p = fmap (first RolePermissions) . readsPrec p
@@ -134,7 +130,7 @@ instance Show RolePermissions where
show = show . getRolePermissions
newtype DiscordId a = DiscordId { unId :: Snowflake }
- deriving (Ord, Eq, Num, Integral, Enum, Real, Bits)
+ deriving (Ord, Eq)
instance Show (DiscordId a) where
show = show . unId
@@ -228,7 +224,7 @@ type Shard = (Int, Int)
-- | Gets a creation date from a snowflake.
snowflakeCreationDate :: Snowflake -> UTCTime
-snowflakeCreationDate x = posixSecondsToUTCTime . realToFrac
+snowflakeCreationDate (Snowflake x) = posixSecondsToUTCTime . realToFrac
$ 1420070400 + quot (shiftR x 22) 1000
-- | Default timestamp
@@ -272,22 +268,10 @@ class Data a => InternalDiscordEnum a where
| fromIntegral (round i) == i = Just $ round i
| otherwise = Nothing
--- Aeson 2.0 uses KeyMaps with a defined Key type for its objects. Aeson up to
--- 1.5 uses HashMaps with Text for the key. Both types have an IsString instance.
--- To keep our version bounds as loose as possible while the Haskell ecosystem
--- (and thus our users) switch over to Aeson 2.0, we use some CPP to define a
--- AesonKey as an alias.
-#if MIN_VERSION_aeson(2, 0, 0)
-type AesonKey = Key.Key
-#else
-type AesonKey = T.Text
-#endif
-
-
-(.==) :: ToJSON a => AesonKey -> a -> Maybe Pair
+(.==) :: ToJSON a => Key.Key -> a -> Maybe Pair
k .== v = Just (k .= v)
-(.=?) :: ToJSON a => AesonKey -> Maybe a -> Maybe Pair
+(.=?) :: ToJSON a => Key.Key -> Maybe a -> Maybe Pair
k .=? (Just v) = Just (k .= v)
_ .=? Nothing = Nothing
@@ -301,7 +285,7 @@ objectFromMaybes = object . catMaybes
--
-- Public creation of this datatype should be done using the relevant smart
-- constructors for Emoji, Sticker, or Avatar.
-data Base64Image a = Base64Image T.Text T.Text
+data Base64Image a = Base64Image { mimeType :: T.Text, base64Data :: B.ByteString }
deriving (Show, Read, Eq, Ord)
-- | The ToJSON instance for Base64Image creates a string representation of the
@@ -309,7 +293,7 @@ data Base64Image a = Base64Image T.Text T.Text
--
-- The format is: @data:%MIME%;base64,%DATA%@.
instance ToJSON (Base64Image a) where
- toJSON (Base64Image mime im) = String $ "data:" <> mime <> ";base64," <> im
+ toJSON (Base64Image mime im) = String $ "data:" <> mime <> ";base64," <> T.E.decodeUtf8 im
-- | @getMimeType bs@ returns a possible mimetype for the given bytestring,
-- based on the first few magic bytes. It may return any of PNG/JPEG/GIF or WEBP
@@ -325,13 +309,13 @@ instance ToJSON (Base64Image a) where
getMimeType :: B.ByteString -> Maybe T.Text
getMimeType bs
| B.take 8 bs == "\x89\x50\x4E\x47\x0D\x0A\x1A\x0A"
- = Just "image/png"
+ = Just "image/png"
| B.take 3 bs == "\xff\xd8\xff" || B.take 4 (B.drop 6 bs) `elem` ["JFIF", "Exif"]
- = Just "image/jpeg"
+ = Just "image/jpeg"
| B.take 6 bs == "\x47\x49\x46\x38\x37\x61" || B.take 6 bs == "\x47\x49\x46\x38\x39\x61"
- = Just "image/gif"
+ = Just "image/gif"
| B.take 4 bs == "RIFF" && B.take 4 (B.drop 8 bs) == "WEBP"
- = Just "image/webp"
+ = Just "image/webp"
| otherwise = Nothing
-- | The different channel types. Used for application commands and components.
diff --git a/deps/discord-haskell/src/Discord/Internal/Types/RolePermissions.hs b/deps/discord-haskell/src/Discord/Internal/Types/RolePermissions.hs
index 3044e9e..6a760d7 100644
--- a/deps/discord-haskell/src/Discord/Internal/Types/RolePermissions.hs
+++ b/deps/discord-haskell/src/Discord/Internal/Types/RolePermissions.hs
@@ -18,8 +18,9 @@ import Discord.Internal.Types.Guild
Role (rolePerms),
roleIdToRole,
)
-import Discord.Internal.Types.Prelude (RolePermissions)
+import Discord.Internal.Types.Prelude (RolePermissions (..))
import Discord.Internal.Types.User (GuildMember (memberRoles))
+import Data.Foldable (foldl')
data PermissionFlag
= CREATE_INSTANT_INVITE
@@ -66,7 +67,7 @@ data PermissionFlag
deriving (Eq, Ord, Enum, Show)
permissionBits :: PermissionFlag -> RolePermissions
-permissionBits p = shift 1 (fromEnum p)
+permissionBits p = shift (RolePermissions 1) (fromEnum p)
-- | Check if a given role has all the permissions
hasRolePermissions :: [PermissionFlag] -> RolePermissions -> Bool
@@ -76,7 +77,7 @@ hasRolePermissions permissions rolePermissions = (.&.) combinedPermissions roleP
-- | Check if a given role has the permission
hasRolePermission :: PermissionFlag -> RolePermissions -> Bool
-hasRolePermission p r = (.&.) (permissionBits p) r > 0
+hasRolePermission p r = getRolePermissions (permissionBits p .&. r) > 0
-- | Replace a users rolePerms
-- with a complete new set of permissions
@@ -105,7 +106,7 @@ clearRolePermission :: PermissionFlag -> RolePermissions -> RolePermissions
clearRolePermission p = (.&.) (complement . permissionBits $ p)
combinePermissions :: [PermissionFlag] -> RolePermissions
-combinePermissions = foldr ((.|.) . permissionBits) 0
+combinePermissions = foldl' (\rp -> (rp .|.) . permissionBits) (RolePermissions 0)
-- | Check if any Role of an GuildMember has the needed permission
-- If the result of roleIdToRole is Nothing, it prepends a "False"