diff options
Diffstat (limited to 'deps/discord-haskell/src/Discord/Internal/Rest')
6 files changed, 105 insertions, 27 deletions
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 _ _ -> [] |