diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -6,6 +6,10 @@ ## master +## 1.12.0 + +[L0neGamer](https://github.com/aquarial/discord-haskell/pull/96) breaking changes and fixes to application commands, interactions, and components, and updates elsewhere + ## 1.11.0 [L0neGamer](https://github.com/aquarial/discord-haskell/pull/88) did a LOT of work wrangling the discord API for interactions and commands! diff --git a/discord-haskell.cabal b/discord-haskell.cabal --- a/discord-haskell.cabal +++ b/discord-haskell.cabal @@ -1,7 +1,7 @@ cabal-version: 2.0 name: discord-haskell -- library version is also noted at src/Discord/Rest/Prelude.hs -version: 1.11.0 +version: 1.12.0 description: Functions and data types to write discord bots. Official discord docs . . @@ -34,8 +34,19 @@ , text , unliftio , discord-haskell - -- , req {- needed for slash commands -} +-- executable interaction-commands +-- main-is: examples/interaction-commands.hs +-- default-language: Haskell2010 +-- ghc-options: -Wall +-- -fno-warn-type-defaults -fno-warn-unused-record-wildcards +-- -threaded +-- build-depends: base +-- , text +-- , unliftio +-- , discord-haskell +-- , bytestring + library ghc-options: -Wall -fno-warn-type-defaults -fno-warn-unused-record-wildcards @@ -73,6 +84,7 @@ , Discord.Internal.Types.ApplicationCommands , Discord.Internal.Types.Interactions , Discord.Internal.Types.Components + , Discord.Internal.Types.Color build-depends: base >= 4 && <5 , aeson diff --git a/examples/ping-pong.hs b/examples/ping-pong.hs --- a/examples/ping-pong.hs +++ b/examples/ping-pong.hs @@ -23,7 +23,7 @@ -- -- https://discord.com/channels/2385235298674262408/4286572469284672046 testserverid :: Snowflake -testserverid = 453207241294610442 +testserverid = -1 -- | Replies "pong" to every message that starts with "ping" pingpongExample :: IO () diff --git a/src/Discord/Interactions.hs b/src/Discord/Interactions.hs --- a/src/Discord/Interactions.hs +++ b/src/Discord/Interactions.hs @@ -1,7 +1,8 @@ module Discord.Interactions - ( module Discord.Internal.Types.ApplicationCommands - , module Discord.Internal.Types.Interactions - ) where + ( module Discord.Internal.Types.ApplicationCommands, + module Discord.Internal.Types.Interactions, + ) +where import Discord.Internal.Types.ApplicationCommands import Discord.Internal.Types.Interactions diff --git a/src/Discord/Internal/Gateway/Cache.hs b/src/Discord/Internal/Gateway/Cache.hs --- a/src/Discord/Internal/Gateway/Cache.hs +++ b/src/Discord/Internal/Gateway/Cache.hs @@ -54,9 +54,6 @@ adjustCache :: Cache -> EventInternalParse -> Cache adjustCache minfo event = case event of - --InternalChannelCreate Channel - --InternalChannelUpdate Channel - --InternalChannelDelete Channel InternalGuildCreate guild info -> let newChans = map (setChanGuildID (guildId guild)) $ guildChannels info g = M.insert (guildId guild) (guild, info { guildChannels = newChans }) (cacheGuilds minfo) diff --git a/src/Discord/Internal/Rest.hs b/src/Discord/Internal/Rest.hs --- a/src/Discord/Internal/Rest.hs +++ b/src/Discord/Internal/Rest.hs @@ -44,7 +44,7 @@ r <- readMVar m pure $ case eitherDecode <$> r of Right (Right o) -> Right o - (Right (Left er)) -> Left (RestCallInternalNoParse er (case r of + (Right (Left er)) -> Left (RestCallInternalNoParse er (case r of Right x -> x Left _ -> "")) Left e -> Left e diff --git a/src/Discord/Internal/Rest/ApplicationCommands.hs b/src/Discord/Internal/Rest/ApplicationCommands.hs --- a/src/Discord/Internal/Rest/ApplicationCommands.hs +++ b/src/Discord/Internal/Rest/ApplicationCommands.hs @@ -1,35 +1,36 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} module Discord.Internal.Rest.ApplicationCommands where -import Data.Aeson (ToJSON (toJSON), Value) -import Network.HTTP.Req as R - +import Data.Aeson (Value) import Discord.Internal.Rest.Prelude import Discord.Internal.Types import Discord.Internal.Types.ApplicationCommands - + ( ApplicationCommandPermissions, + GuildApplicationCommandPermissions(GuildApplicationCommandPermissions), + EditApplicationCommand, + CreateApplicationCommand, + ApplicationCommand ) +import Network.HTTP.Req as R instance Request (ApplicationCommandRequest a) where jsonRequest = applicationCommandJsonRequest majorRoute = applicationCommandMajorRoute data ApplicationCommandRequest a where - GetGlobalApplicationCommands :: ApplicationId -> ApplicationCommandRequest [InternalApplicationCommand] - CreateGlobalApplicationCommand :: ApplicationId -> CreateApplicationCommand -> ApplicationCommandRequest InternalApplicationCommand - GetGlobalApplicationCommand :: ApplicationId -> ApplicationCommandId -> ApplicationCommandRequest InternalApplicationCommand - EditGlobalApplicationCommand :: ApplicationId -> ApplicationCommandId -> EditApplicationCommand -> ApplicationCommandRequest InternalApplicationCommand + GetGlobalApplicationCommands :: ApplicationId -> ApplicationCommandRequest [ApplicationCommand] + CreateGlobalApplicationCommand :: ApplicationId -> CreateApplicationCommand -> ApplicationCommandRequest ApplicationCommand + GetGlobalApplicationCommand :: ApplicationId -> ApplicationCommandId -> ApplicationCommandRequest ApplicationCommand + EditGlobalApplicationCommand :: ApplicationId -> ApplicationCommandId -> EditApplicationCommand -> ApplicationCommandRequest ApplicationCommand DeleteGlobalApplicationCommand :: ApplicationId -> ApplicationCommandId -> ApplicationCommandRequest () BulkOverWriteGlobalApplicationCommand :: ApplicationId -> [CreateApplicationCommand] -> ApplicationCommandRequest () - GetGuildApplicationCommands :: ApplicationId -> GuildId -> ApplicationCommandRequest [InternalApplicationCommand] - CreateGuildApplicationCommand :: ApplicationId -> GuildId -> CreateApplicationCommand -> ApplicationCommandRequest InternalApplicationCommand - GetGuildApplicationCommand :: ApplicationId -> GuildId -> ApplicationCommandId -> ApplicationCommandRequest InternalApplicationCommand - EditGuildApplicationCommand :: ApplicationId -> GuildId -> ApplicationCommandId -> CreateApplicationCommand -> ApplicationCommandRequest InternalApplicationCommand + GetGuildApplicationCommands :: ApplicationId -> GuildId -> ApplicationCommandRequest [ApplicationCommand] + CreateGuildApplicationCommand :: ApplicationId -> GuildId -> CreateApplicationCommand -> ApplicationCommandRequest ApplicationCommand + GetGuildApplicationCommand :: ApplicationId -> GuildId -> ApplicationCommandId -> ApplicationCommandRequest ApplicationCommand + EditGuildApplicationCommand :: ApplicationId -> GuildId -> ApplicationCommandId -> CreateApplicationCommand -> ApplicationCommandRequest ApplicationCommand DeleteGuildApplicationCommand :: ApplicationId -> GuildId -> ApplicationCommandId -> ApplicationCommandRequest () BulkOverWriteGuildApplicationCommand :: ApplicationId -> GuildId -> [CreateApplicationCommand] -> ApplicationCommandRequest () GetGuildApplicationCommandPermissions :: ApplicationId -> GuildId -> ApplicationCommandRequest GuildApplicationCommandPermissions @@ -38,9 +39,6 @@ -- | The only parameters needed in the GuildApplicationCommandPermissions -- objects are id and permissions. BatchEditApplicationCommandPermissions :: ApplicationId -> GuildId -> [GuildApplicationCommandPermissions] -> ApplicationCommandRequest [GuildApplicationCommandPermissions] - --- TODO: permissions checks --- GetGuildApplicationCommandPermissions :: ApplicationId -> GuildID -> ApplicationCommandR applications :: ApplicationId -> R.Url 'R.Https applications s = baseUrl /: "applications" // s diff --git a/src/Discord/Internal/Rest/Channel.hs b/src/Discord/Internal/Rest/Channel.hs --- a/src/Discord/Internal/Rest/Channel.hs +++ b/src/Discord/Internal/Rest/Channel.hs @@ -26,12 +26,13 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Network.HTTP.Client (RequestBody (RequestBodyBS)) -import Network.HTTP.Client.MultipartFormData (partFileRequestBody, partBS, PartM) +import Network.HTTP.Client.MultipartFormData (partFileRequestBody, partBS) import Network.HTTP.Req ((/:)) import qualified Network.HTTP.Req as R import Discord.Internal.Rest.Prelude import Discord.Internal.Types +import Control.Monad (join) instance Request (ChannelRequest a) where majorRoute = channelMajorRoute @@ -51,8 +52,6 @@ GetChannelMessage :: (ChannelId, MessageId) -> ChannelRequest Message -- | Sends a message to a channel. CreateMessage :: ChannelId -> T.Text -> ChannelRequest Message - -- | Sends a message with an Embed to a channel. - CreateMessageEmbed :: ChannelId -> T.Text -> CreateEmbed -> ChannelRequest Message -- | Sends a message with a file to a channel. CreateMessageUploadFile :: ChannelId -> T.Text -> B.ByteString -> ChannelRequest Message -- | Sends a message with granular controls. @@ -102,18 +101,18 @@ data MessageDetailedOpts = MessageDetailedOpts { messageDetailedContent :: T.Text , messageDetailedTTS :: Bool - , messageDetailedEmbed :: Maybe CreateEmbed + , messageDetailedEmbeds :: Maybe [CreateEmbed] , messageDetailedFile :: Maybe (T.Text, B.ByteString) , messageDetailedAllowedMentions :: Maybe AllowedMentions , messageDetailedReference :: Maybe MessageReference - , messageDetailedComponents :: Maybe [Component] + , messageDetailedComponents :: Maybe [ComponentActionRow] , messageDetailedStickerIds :: Maybe [StickerId] - } deriving (Show, Read, Eq, Ord) + } deriving (Show, Eq, Ord, Read) instance Default MessageDetailedOpts where def = MessageDetailedOpts { messageDetailedContent = "" , messageDetailedTTS = False - , messageDetailedEmbed = Nothing + , messageDetailedEmbeds = Nothing , messageDetailedFile = Nothing , messageDetailedAllowedMentions = Nothing , messageDetailedReference = Nothing @@ -217,7 +216,6 @@ (GetChannelMessages chan _) -> "msg " <> show chan (GetChannelMessage (chan, _)) -> "get_msg " <> show chan (CreateMessage chan _) -> "msg " <> show chan - (CreateMessageEmbed chan _ _) -> "msg " <> show chan (CreateMessageUploadFile chan _ _) -> "msg " <> show chan (CreateMessageDetailed chan _) -> "msg " <> show chan (CreateReaction (chan, _) _) -> "add_react " <> show chan @@ -249,16 +247,6 @@ (_, Just a) -> "custom:" <> a (_, Nothing) -> noAngles -maybeEmbed :: Maybe CreateEmbed -> [PartM IO] -maybeEmbed = --maybe [] $ \embed -> ["embed" .= createEmbed embed] - let mkPart (name,content) = partFileRequestBody name (T.unpack name) (RequestBodyBS content) - uploads CreateEmbed{..} = [(n,c) | (n, Just (CreateEmbedImageUpload c)) <- - [ ("author.png", createEmbedAuthorIcon) - , ("thumbnail.png", createEmbedThumbnail) - , ("image.png", createEmbedImage) - , ("footer.png", createEmbedFooterIcon) ]] - in maybe [] (map mkPart . uploads) - channels :: R.Url 'R.Https channels = baseUrl /: "channels" @@ -274,7 +262,7 @@ Delete (channels // chan) mempty (GetChannelMessages chan (n,timing)) -> - let n' = if n < 1 then 1 else (if n > 100 then 100 else n) + let n' = max 1 (min 100 n) options = "limit" R.=: n' <> messageTimingToQuery timing in Get (channels // chan /: "messages") options @@ -286,35 +274,37 @@ body = pure $ R.ReqBodyJson $ object content in Post (channels // chan /: "messages") body mempty - (CreateMessageEmbed chan msg embed) -> - let partJson = partBS "payload_json" $ BL.toStrict $ encode $ toJSON $ object ["content" .= msg, "embed" .= createEmbed embed] - body = R.reqBodyMultipart (partJson : maybeEmbed (Just embed)) - in Post (channels // chan /: "messages") body mempty - (CreateMessageUploadFile chan fileName file) -> let part = partFileRequestBody "file" (T.unpack fileName) $ RequestBodyBS file body = R.reqBodyMultipart [part] in Post (channels // chan /: "messages") body mempty (CreateMessageDetailed chan msgOpts) -> - let fileUpload = messageDetailedFile msgOpts - filePart = case fileUpload of - Nothing -> [] - Just f -> [partFileRequestBody "file" (T.unpack $ fst f) - $ RequestBodyBS $ snd f] + let fileUpload = messageDetailedFile msgOpts + filePart = + ( case fileUpload of + Nothing -> [] + Just f -> + [ partFileRequestBody + "file" + (T.unpack $ fst f) + (RequestBodyBS $ snd f) + ] + ) + ++ join (maybe [] (maybeEmbed . Just <$>) (messageDetailedEmbeds msgOpts)) - payloadData = object $ [ "content" .= messageDetailedContent msgOpts - , "tts" .= messageDetailedTTS msgOpts ] ++ - [ name .= value | (name, Just value) <- - [ ("embed", toJSON . createEmbed <$> messageDetailedEmbed msgOpts) - , ("allowed_mentions", toJSON <$> messageDetailedAllowedMentions msgOpts) - , ("message_reference", toJSON <$> messageDetailedReference msgOpts) - , ("components", toJSON . (filterOutIncorrectEmoji <$>) <$> messageDetailedComponents msgOpts) - , ("sticker_ids", toJSON <$> messageDetailedStickerIds msgOpts) - ] ] - payloadPart = partBS "payload_json" $ BL.toStrict $ encode $ toJSON payloadData + payloadData = object $ [ "content" .= messageDetailedContent msgOpts + , "tts" .= messageDetailedTTS msgOpts ] ++ + [ name .= value | (name, Just value) <- + [ ("embeds", toJSON . (createEmbed <$>) <$> messageDetailedEmbeds msgOpts) + , ("allowed_mentions", toJSON <$> messageDetailedAllowedMentions msgOpts) + , ("message_reference", toJSON <$> messageDetailedReference msgOpts) + , ("components", toJSON <$> messageDetailedComponents msgOpts) + , ("sticker_ids", toJSON <$> messageDetailedStickerIds msgOpts) + ] ] + payloadPart = partBS "payload_json" $ BL.toStrict $ encode payloadData - body = R.reqBodyMultipart (payloadPart : filePart) + body = R.reqBodyMultipart (payloadPart : filePart) in Post (channels // chan /: "messages") body mempty (CreateReaction (chan, msgid) emoji) -> @@ -336,7 +326,7 @@ (GetReactions (chan, msgid) emoji (n, timing)) -> let e = cleanupEmoji emoji - n' = if n < 1 then 1 else (if n > 100 then 100 else n) + n' = max 1 (min 100 n) options = "limit" R.=: n' <> reactionTimingToQuery timing in Get (channels // chan /: "messages" // msgid /: "reactions" /: e) options diff --git a/src/Discord/Internal/Rest/Guild.hs b/src/Discord/Internal/Rest/Guild.hs --- a/src/Discord/Internal/Rest/Guild.hs +++ b/src/Discord/Internal/Rest/Guild.hs @@ -132,7 +132,7 @@ -- | 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. @@ -174,7 +174,7 @@ data ModifyGuildRoleOpts = ModifyGuildRoleOpts { modifyGuildRoleOptsName :: Maybe T.Text , modifyGuildRoleOptsPermissions :: Maybe T.Text - , modifyGuildRoleOptsColor :: Maybe ColorInteger + , modifyGuildRoleOptsColor :: Maybe DiscordColor , modifyGuildRoleOptsSeparateSidebar :: Maybe Bool , modifyGuildRoleOptsMentionable :: Maybe Bool } deriving (Show, Read, Eq, Ord) diff --git a/src/Discord/Internal/Rest/Interactions.hs b/src/Discord/Internal/Rest/Interactions.hs --- a/src/Discord/Internal/Rest/Interactions.hs +++ b/src/Discord/Internal/Rest/Interactions.hs @@ -1,25 +1,24 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} module Discord.Internal.Rest.Interactions where -import Data.Aeson (ToJSON (toJSON), Value) -import Network.HTTP.Req as R - +import Data.Aeson (encode) +import qualified Data.ByteString.Lazy as BL import Discord.Internal.Rest.Prelude import Discord.Internal.Types import Discord.Internal.Types.Interactions +import Network.HTTP.Client.MultipartFormData (PartM, partBS) +import Network.HTTP.Req as R data InteractionResponseRequest a where CreateInteractionResponse :: InteractionId -> InteractionToken -> InteractionResponse -> InteractionResponseRequest () GetOriginalInteractionResponse :: ApplicationId -> InteractionToken -> InteractionResponseRequest Message - EditOriginalInteractionResponse :: ApplicationId -> InteractionToken -> InteractionCallbackMessages -> InteractionResponseRequest Message + EditOriginalInteractionResponse :: ApplicationId -> InteractionToken -> InteractionResponseMessage -> InteractionResponseRequest Message DeleteOriginalInteractionResponse :: ApplicationId -> InteractionToken -> InteractionResponseRequest () - CreateFollowupInteractionMessage :: ApplicationId -> InteractionToken -> InteractionCallbackMessages -> InteractionResponseRequest Message + CreateFollowupInteractionMessage :: ApplicationId -> InteractionToken -> InteractionResponseMessage -> InteractionResponseRequest Message GetFollowupInteractionMessage :: ApplicationId -> InteractionToken -> MessageId -> InteractionResponseRequest Message EditFollowupInteractionMessage :: ApplicationId -> InteractionToken -> MessageId -> InteractionResponse -> InteractionResponseRequest Message DeleteFollowupInteractionMessage :: ApplicationId -> InteractionToken -> MessageId -> InteractionResponseRequest () @@ -49,11 +48,11 @@ (GetOriginalInteractionResponse aid it) -> Get (interaction aid it /: "@original") mempty (EditOriginalInteractionResponse aid it i) -> - Patch (interaction aid it /: "@original") (convert i) mempty + Patch (interaction aid it /: "@original") (convertIRM i) mempty (DeleteOriginalInteractionResponse aid it) -> Delete (interaction aid it /: "@original") mempty (CreateFollowupInteractionMessage aid it i) -> - Post (baseUrl /: "webhooks" // aid /: it) (convert i) mempty + Post (baseUrl /: "webhooks" // aid /: it) (convertIRM i) mempty (GetFollowupInteractionMessage aid it mid) -> Get (interaction aid it // mid) mempty (EditFollowupInteractionMessage aid it mid i) -> @@ -61,5 +60,13 @@ (DeleteFollowupInteractionMessage aid it mid) -> Delete (interaction aid it // mid) mempty where - convert :: (ToJSON a) => a -> RestIO (ReqBodyJson Value) - convert = (pure @RestIO) . R.ReqBodyJson . toJSON + convert :: InteractionResponse -> RestIO ReqBodyMultipart + convert ir@(InteractionResponseChannelMessage irm) = R.reqBodyMultipart (partBS "payload_json" (BL.toStrict $ encode ir) : convert' irm) + convert ir@(InteractionResponseUpdateMessage irm) = R.reqBodyMultipart (partBS "payload_json" (BL.toStrict $ encode ir) : convert' irm) + convert ir = R.reqBodyMultipart [partBS "payload_json" $ BL.toStrict $ encode ir] + convertIRM :: InteractionResponseMessage -> RestIO ReqBodyMultipart + convertIRM irm = R.reqBodyMultipart (partBS "payload_json" (BL.toStrict $ encode irm) : convert' irm) + convert' :: InteractionResponseMessage -> [PartM IO] + convert' InteractionResponseMessage {..} = case interactionResponseMessageEmbeds of + Nothing -> [] + Just f -> (maybeEmbed . Just) =<< f diff --git a/src/Discord/Internal/Rest/Prelude.hs b/src/Discord/Internal/Rest/Prelude.hs --- a/src/Discord/Internal/Rest/Prelude.hs +++ b/src/Discord/Internal/Rest/Prelude.hs @@ -12,6 +12,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE + import qualified Network.HTTP.Req as R import Discord.Internal.Types @@ -29,7 +30,7 @@ where -- | https://discord.com/developers/docs/reference#user-agent -- Second place where the library version is noted - agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 1.11.0)" + agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 1.12.0)" -- Append to an URL infixl 5 // diff --git a/src/Discord/Internal/Types.hs b/src/Discord/Internal/Types.hs --- a/src/Discord/Internal/Types.hs +++ b/src/Discord/Internal/Types.hs @@ -1,38 +1,31 @@ --- | Provides types and encoding/decoding code. Types should be identical to those provided --- in the Discord API documentation. +-- | 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.Channel - , module Discord.Internal.Types.Events - , module Discord.Internal.Types.Gateway - , module Discord.Internal.Types.Guild - , module Discord.Internal.Types.User - , module Discord.Internal.Types.Embed - , module Discord.Internal.Types.Components ---, module Discord.Internal.Types.ApplicationCommands ---, module Discord.Internal.Types.Interactions - , module Data.Aeson - , module Data.Time.Clock - , userFacingEvent - ) where + ( module Discord.Internal.Types.Prelude, + module Discord.Internal.Types.Channel, + module Discord.Internal.Types.Color, + module Discord.Internal.Types.Events, + module Discord.Internal.Types.Gateway, + module Discord.Internal.Types.Guild, + module Discord.Internal.Types.User, + module Discord.Internal.Types.Embed, + module Discord.Internal.Types.Components, + module Data.Aeson, + module Data.Time.Clock, + userFacingEvent, + ) +where +import Data.Aeson (Object, ToJSON (toJSON)) +import Data.Time.Clock (UTCTime (..)) import Discord.Internal.Types.Channel +import Discord.Internal.Types.Color +import Discord.Internal.Types.Components +import Discord.Internal.Types.Embed import Discord.Internal.Types.Events import Discord.Internal.Types.Gateway import Discord.Internal.Types.Guild -import Discord.Internal.Types.User -import Discord.Internal.Types.Embed import Discord.Internal.Types.Prelude -import Discord.Internal.Types.Components - --- import Discord.Internal.Types.ApplicationCommands -import Discord.Internal.Types.Interactions - - -import Data.Aeson (Object) -import Data.Time.Clock (UTCTime(..)) -import Data.Maybe (fromMaybe) - +import Discord.Internal.Types.User userFacingEvent :: EventInternalParse -> Event userFacingEvent event = case event of @@ -67,5 +60,5 @@ InternalPresenceUpdate a -> PresenceUpdate a InternalTypingStart a -> TypingStart a InternalUserUpdate a -> UserUpdate a - InternalInteractionCreate a -> InteractionCreate (fromMaybe (InteractionUnknown a) (fromInternal a)) + InternalInteractionCreate a -> InteractionCreate a InternalUnknownEvent a b -> UnknownEvent a b diff --git a/src/Discord/Internal/Types/ApplicationCommands.hs b/src/Discord/Internal/Types/ApplicationCommands.hs --- a/src/Discord/Internal/Types/ApplicationCommands.hs +++ b/src/Discord/Internal/Types/ApplicationCommands.hs @@ -10,246 +10,369 @@ module Discord.Internal.Types.ApplicationCommands ( ApplicationCommand (..), + ApplicationCommandOptions (..), ApplicationCommandOptionSubcommandOrGroup (..), ApplicationCommandOptionSubcommand (..), ApplicationCommandOptionValue (..), - InternalApplicationCommand (..), - CreateApplicationCommand (..), createApplicationCommandChatInput, createApplicationCommandUser, createApplicationCommandMessage, + CreateApplicationCommand (..), EditApplicationCommand (..), - ApplicationCommandType (..), - InternalApplicationCommandOption (..), - ApplicationCommandOptionType (..), - InternalApplicationCommandOptionChoice, + defaultEditApplicationCommand, Choice (..), ApplicationCommandChannelType (..), GuildApplicationCommandPermissions (..), ApplicationCommandPermissions (..), - ApplicationCommandPermissionType (..), - StringNumberValue (..), ) where -import Control.Applicative import Data.Aeson -import Data.Char (isLower) +import Data.Aeson.Types (Pair, Parser) import Data.Data (Data) -import Data.Default (Default (..)) -import Data.Maybe (fromJust, fromMaybe) +import Data.Foldable (Foldable (toList)) import Data.Scientific (Scientific) import qualified Data.Text as T -import Discord.Internal.Types.Prelude (ApplicationCommandId, ApplicationId, GuildId, Internals (..), Snowflake, makeTable, toMaybeJSON) +import Discord.Internal.Types.Prelude (ApplicationCommandId, ApplicationId, GuildId, InternalDiscordEnum (..), Snowflake, discordTypeParseJSON, toMaybeJSON) +-- | The structure for an application command. data ApplicationCommand = ApplicationCommandUser - { applicationCommandId :: ApplicationCommandId, + { -- | The id of the application command. + applicationCommandId :: ApplicationCommandId, + -- | The id of the application the command comes from. applicationCommandApplicationId :: ApplicationId, + -- | The guild the application command is registered in. applicationCommandGuildId :: Maybe GuildId, + -- | The name of the application command. applicationCommandName :: T.Text, - applicationCommandDefaultPermission :: Maybe Bool, + -- | Whether the command is enabled by default when the app is added to a guild. + applicationCommandDefaultPermission :: Bool, + -- | Autoincrementing version identifier updated during substantial record changes. applicationCommandVersion :: Snowflake } | ApplicationCommandMessage - { applicationCommandId :: ApplicationCommandId, + { -- | The id of the application command. + applicationCommandId :: ApplicationCommandId, + -- | The id of the application the command comes from. applicationCommandApplicationId :: ApplicationId, + -- | The guild the application command is registered in. applicationCommandGuildId :: Maybe GuildId, + -- | The name of the application command. applicationCommandName :: T.Text, - applicationCommandDefaultPermission :: Maybe Bool, + -- | Whether the command is enabled by default when the app is added to a guild. + applicationCommandDefaultPermission :: Bool, + -- | Autoincrementing version identifier updated during substantial record changes. applicationCommandVersion :: Snowflake } | ApplicationCommandChatInput - { applicationCommandId :: ApplicationCommandId, + { -- | The id of the application command. + applicationCommandId :: ApplicationCommandId, + -- | The id of the application the command comes from. applicationCommandApplicationId :: ApplicationId, + -- | The guild the application command is registered in. applicationCommandGuildId :: Maybe GuildId, + -- | The name of the application command. applicationCommandName :: T.Text, + -- | The description of the application command. applicationCommandDescription :: T.Text, + -- | The parameters for the command. applicationCommandOptions :: Maybe ApplicationCommandOptions, - applicationCommandDefaultPermission :: Maybe Bool, + -- | Whether the command is enabled by default when the app is added to a guild. + applicationCommandDefaultPermission :: Bool, + -- | Autoincrementing version identifier updated during substantial record changes. applicationCommandVersion :: Snowflake } - | ApplicationCommandUnknown InternalApplicationCommand deriving (Show, Eq, Read) +instance FromJSON ApplicationCommand where + parseJSON = + withObject + "ApplicationCommand" + ( \v -> do + acid <- v .: "id" + aid <- v .: "application_id" + gid <- v .:? "guild_id" + name <- v .: "name" + defPerm <- v .:? "default_permission" .!= True + version <- v .: "version" + t <- v .:? "type" :: Parser (Maybe Int) + case t of + (Just 2) -> return $ ApplicationCommandUser acid aid gid name defPerm version + (Just 3) -> return $ ApplicationCommandMessage acid aid gid name defPerm version + _ -> do + desc <- v .: "description" + options <- v .:? "options" + return $ ApplicationCommandChatInput acid aid gid name desc options defPerm version + ) + +-- | Either subcommands and groups, or values. data ApplicationCommandOptions = ApplicationCommandOptionsSubcommands [ApplicationCommandOptionSubcommandOrGroup] | ApplicationCommandOptionsValues [ApplicationCommandOptionValue] deriving (Show, Eq, Read) +instance FromJSON ApplicationCommandOptions where + parseJSON = + withArray + "ApplicationCommandOptions" + ( \a -> do + let a' = toList a + case a' of + [] -> return $ ApplicationCommandOptionsValues [] + (v' : _) -> + withObject + "ApplicationCommandOptions item" + ( \v -> do + t <- v .: "type" :: Parser Int + if t == 1 || t == 2 + then ApplicationCommandOptionsSubcommands <$> mapM parseJSON a' + else ApplicationCommandOptionsValues <$> mapM parseJSON a' + ) + v' + ) + +instance ToJSON ApplicationCommandOptions where + toJSON (ApplicationCommandOptionsSubcommands o) = toJSON o + toJSON (ApplicationCommandOptionsValues o) = toJSON o + +-- | Either a subcommand group or a subcommand. data ApplicationCommandOptionSubcommandOrGroup = ApplicationCommandOptionSubcommandGroup - { applicationCommandOptionSubcommandGroupName :: T.Text, + { -- | The name of the subcommand group + applicationCommandOptionSubcommandGroupName :: T.Text, + -- | The description of the subcommand group applicationCommandOptionSubcommandGroupDescription :: T.Text, + -- | The subcommands in this subcommand group applicationCommandOptionSubcommandGroupOptions :: [ApplicationCommandOptionSubcommand] } | ApplicationCommandOptionSubcommandOrGroupSubcommand ApplicationCommandOptionSubcommand deriving (Show, Eq, Read) +instance FromJSON ApplicationCommandOptionSubcommandOrGroup where + parseJSON = + withObject + "ApplicationCommandOptionSubcommandOrGroup" + ( \v -> do + t <- v .: "type" :: Parser Int + case t of + 2 -> + ApplicationCommandOptionSubcommandGroup + <$> v .: "name" + <*> v .: "description" + <*> v .: "options" + 1 -> ApplicationCommandOptionSubcommandOrGroupSubcommand <$> parseJSON (Object v) + _ -> fail "unexpected subcommand group type" + ) + +instance ToJSON ApplicationCommandOptionSubcommandOrGroup where + toJSON ApplicationCommandOptionSubcommandGroup {..} = + object + [ ("type", Number 2), + ("name", toJSON applicationCommandOptionSubcommandGroupName), + ("description", toJSON applicationCommandOptionSubcommandGroupDescription), + ("options", toJSON applicationCommandOptionSubcommandGroupOptions) + ] + toJSON (ApplicationCommandOptionSubcommandOrGroupSubcommand a) = toJSON a + +-- | Data for a single subcommand. data ApplicationCommandOptionSubcommand = ApplicationCommandOptionSubcommand - { applicationCommandOptionSubcommandName :: T.Text, + { -- | The name of the subcommand + applicationCommandOptionSubcommandName :: T.Text, + -- | The description of the subcommand applicationCommandOptionSubcommandDescription :: T.Text, + -- | What options are there in this subcommand applicationCommandOptionSubcommandOptions :: [ApplicationCommandOptionValue] } deriving (Show, Eq, Read) +instance FromJSON ApplicationCommandOptionSubcommand where + parseJSON = + withObject + "ApplicationCommandOptionSubcommand" + ( \v -> do + t <- v .: "type" :: Parser Int + case t of + 1 -> + ApplicationCommandOptionSubcommand + <$> v .: "name" + <*> v .: "description" + <*> v .:? "options" .!= [] + _ -> fail "unexpected subcommand type" + ) + +instance ToJSON ApplicationCommandOptionSubcommand where + toJSON ApplicationCommandOptionSubcommand {..} = + object + [ ("type", Number 1), + ("name", toJSON applicationCommandOptionSubcommandName), + ("description", toJSON applicationCommandOptionSubcommandDescription), + ("options", toJSON applicationCommandOptionSubcommandOptions) + ] + +-- | Data for a single value. data ApplicationCommandOptionValue = ApplicationCommandOptionValueString - { applicationCommandOptionValueName :: T.Text, + { -- | The name of the value + applicationCommandOptionValueName :: T.Text, + -- | The description of the value applicationCommandOptionValueDescription :: T.Text, - applicationCommandOptionValueRequired :: Maybe Bool, - applicationCommandOptionValueStringChoices :: Maybe [Choice T.Text], - applicationCommandOptionValueAutocomplete :: Maybe Bool + -- | Whether this option is required + applicationCommandOptionValueRequired :: Bool, + -- | Whether to autocomplete or have a list of named choices. For neither option, use `Left False` + applicationCommandOptionValueStringChoices :: AutocompleteOrChoice T.Text } | ApplicationCommandOptionValueInteger - { applicationCommandOptionValueName :: T.Text, + { -- | The name of the value + applicationCommandOptionValueName :: T.Text, + -- | The description of the value applicationCommandOptionValueDescription :: T.Text, - applicationCommandOptionValueRequired :: Maybe Bool, - applicationCommandOptionValueIntegerChoices :: Maybe [Choice Integer], + -- | Whether this option is required + applicationCommandOptionValueRequired :: Bool, + -- | Whether to autocomplete or have a list of named choices. For neither option, use `Left False` + applicationCommandOptionValueIntegerChoices :: AutocompleteOrChoice Integer, + -- | The lower bound of values permitted. If choices are provided or autocomplete is on, this can be ignored applicationCommandOptionValueIntegerMinVal :: Maybe Integer, - applicationCommandOptionValueIntegerMaxVal :: Maybe Integer, - applicationCommandOptionValueAutocomplete :: Maybe Bool + -- | The upper bound of values permitted. If choices are provided or autocomplete is on, this can be ignored + applicationCommandOptionValueIntegerMaxVal :: Maybe Integer } | ApplicationCommandOptionValueBoolean - { applicationCommandOptionValueName :: T.Text, + { -- | The name of the value + applicationCommandOptionValueName :: T.Text, + -- | The description of the value applicationCommandOptionValueDescription :: T.Text, - applicationCommandOptionValueRequired :: Maybe Bool + -- | Whether this option is required + applicationCommandOptionValueRequired :: Bool } | ApplicationCommandOptionValueUser - { applicationCommandOptionValueName :: T.Text, + { -- | The name of the value + applicationCommandOptionValueName :: T.Text, + -- | The description of the value applicationCommandOptionValueDescription :: T.Text, - applicationCommandOptionValueRequired :: Maybe Bool + -- | Whether this option is required + applicationCommandOptionValueRequired :: Bool } | ApplicationCommandOptionValueChannel - { applicationCommandOptionValueName :: T.Text, + { -- | The name of the value + applicationCommandOptionValueName :: T.Text, + -- | The description of the value applicationCommandOptionValueDescription :: T.Text, - applicationCommandOptionValueRequired :: Maybe Bool, + -- | Whether this option is required + applicationCommandOptionValueRequired :: Bool, + -- | What type of channel can be put in here applicationCommandOptionValueChannelTypes :: Maybe [ApplicationCommandChannelType] } | ApplicationCommandOptionValueRole - { applicationCommandOptionValueName :: T.Text, + { -- | The name of the value + applicationCommandOptionValueName :: T.Text, + -- | The description of the value applicationCommandOptionValueDescription :: T.Text, - applicationCommandOptionValueRequired :: Maybe Bool + -- | Whether this option is required + applicationCommandOptionValueRequired :: Bool } | ApplicationCommandOptionValueMentionable - { applicationCommandOptionValueName :: T.Text, + { -- | The name of the value + applicationCommandOptionValueName :: T.Text, + -- | The description of the value applicationCommandOptionValueDescription :: T.Text, - applicationCommandOptionValueRequired :: Maybe Bool + -- | Whether this option is required + applicationCommandOptionValueRequired :: Bool } | ApplicationCommandOptionValueNumber - { applicationCommandOptionValueName :: T.Text, + { -- | The name of the value + applicationCommandOptionValueName :: T.Text, + -- | The description of the value applicationCommandOptionValueDescription :: T.Text, - applicationCommandOptionValueRequired :: Maybe Bool, - applicationCommandOptionValueNumberChoices :: Maybe [Choice Scientific], + -- | Whether this option is required + applicationCommandOptionValueRequired :: Bool, + -- | Whether to autocomplete or have a list of named choices. For neither option, use `Left False` + applicationCommandOptionValueNumberChoices :: AutocompleteOrChoice Scientific, + -- | The lower bound of values permitted. If choices are provided or autocomplete is on, this can be ignored applicationCommandOptionValueNumberMinVal :: Maybe Scientific, - applicationCommandOptionValueNumberMaxVal :: Maybe Scientific, - applicationCommandOptionValueAutocomplete :: Maybe Bool + -- | The upper bound of values permitted. If choices are provided or autocomplete is on, this can be ignored + applicationCommandOptionValueNumberMaxVal :: Maybe Scientific } deriving (Show, Eq, Read) -instance Internals ApplicationCommandOptionValue InternalApplicationCommandOption where - toInternal ApplicationCommandOptionValueNumber {..} = InternalApplicationCommandOption ApplicationCommandOptionTypeNumber applicationCommandOptionValueName applicationCommandOptionValueDescription applicationCommandOptionValueRequired (((StringNumberValueNumber <$>) <$>) <$> applicationCommandOptionValueNumberChoices) Nothing Nothing applicationCommandOptionValueNumberMinVal applicationCommandOptionValueNumberMaxVal applicationCommandOptionValueAutocomplete - toInternal ApplicationCommandOptionValueInteger {..} = InternalApplicationCommandOption ApplicationCommandOptionTypeInteger applicationCommandOptionValueName applicationCommandOptionValueDescription applicationCommandOptionValueRequired (((StringNumberValueInteger <$>) <$>) <$> applicationCommandOptionValueIntegerChoices) Nothing Nothing (fromInteger <$> applicationCommandOptionValueIntegerMinVal) (fromInteger <$> applicationCommandOptionValueIntegerMaxVal) applicationCommandOptionValueAutocomplete - toInternal ApplicationCommandOptionValueString {..} = InternalApplicationCommandOption ApplicationCommandOptionTypeInteger applicationCommandOptionValueName applicationCommandOptionValueDescription applicationCommandOptionValueRequired (((StringNumberValueString <$>) <$>) <$> applicationCommandOptionValueStringChoices) Nothing Nothing Nothing Nothing applicationCommandOptionValueAutocomplete - toInternal ApplicationCommandOptionValueChannel {..} = InternalApplicationCommandOption ApplicationCommandOptionTypeChannel applicationCommandOptionValueName applicationCommandOptionValueDescription applicationCommandOptionValueRequired Nothing Nothing applicationCommandOptionValueChannelTypes Nothing Nothing Nothing - toInternal ApplicationCommandOptionValueBoolean {..} = InternalApplicationCommandOption ApplicationCommandOptionTypeBoolean applicationCommandOptionValueName applicationCommandOptionValueDescription applicationCommandOptionValueRequired Nothing Nothing Nothing Nothing Nothing Nothing - toInternal ApplicationCommandOptionValueUser {..} = InternalApplicationCommandOption ApplicationCommandOptionTypeUser applicationCommandOptionValueName applicationCommandOptionValueDescription applicationCommandOptionValueRequired Nothing Nothing Nothing Nothing Nothing Nothing - toInternal ApplicationCommandOptionValueRole {..} = InternalApplicationCommandOption ApplicationCommandOptionTypeRole applicationCommandOptionValueName applicationCommandOptionValueDescription applicationCommandOptionValueRequired Nothing Nothing Nothing Nothing Nothing Nothing - toInternal ApplicationCommandOptionValueMentionable {..} = InternalApplicationCommandOption ApplicationCommandOptionTypeMentionable applicationCommandOptionValueName applicationCommandOptionValueDescription applicationCommandOptionValueRequired Nothing Nothing Nothing Nothing Nothing Nothing - - fromInternal InternalApplicationCommandOption {internalApplicationCommandOptionType = ApplicationCommandOptionTypeNumber, ..} = do - cs <- maybe (Just []) (mapM extractChoices) internalApplicationCommandOptionChoices - return $ ApplicationCommandOptionValueNumber internalApplicationCommandOptionName internalApplicationCommandOptionDescription internalApplicationCommandOptionRequired (fromResult cs) internalApplicationCommandOptionMinVal internalApplicationCommandOptionMaxVal internalApplicationCommandOptionAutocomplete - where - extractChoices (Choice s (StringNumberValueNumber n)) = Just (Choice s n) - extractChoices _ = Nothing - fromResult [] = Nothing - fromResult is = Just is - fromInternal InternalApplicationCommandOption {internalApplicationCommandOptionType = ApplicationCommandOptionTypeInteger, ..} = do - cs <- maybe (Just []) (mapM extractChoices) internalApplicationCommandOptionChoices - return $ ApplicationCommandOptionValueInteger internalApplicationCommandOptionName internalApplicationCommandOptionDescription internalApplicationCommandOptionRequired (fromResult cs) (round <$> internalApplicationCommandOptionMinVal) (round <$> internalApplicationCommandOptionMaxVal) internalApplicationCommandOptionAutocomplete - where - extractChoices (Choice s (StringNumberValueInteger n)) = Just (Choice s n) - extractChoices _ = Nothing - fromResult [] = Nothing - fromResult is = Just is - -- note with the above: the bounds are rounded for simplicity but ideally they wouldn't be - fromInternal InternalApplicationCommandOption {internalApplicationCommandOptionType = ApplicationCommandOptionTypeString, ..} = do - cs <- maybe (Just []) (mapM extractChoices) internalApplicationCommandOptionChoices - return $ ApplicationCommandOptionValueString internalApplicationCommandOptionName internalApplicationCommandOptionDescription internalApplicationCommandOptionRequired (fromResult cs) internalApplicationCommandOptionAutocomplete - where - extractChoices (Choice s (StringNumberValueString n)) = Just (Choice s n) - extractChoices _ = Nothing - fromResult [] = Nothing - fromResult is = Just is - fromInternal InternalApplicationCommandOption {internalApplicationCommandOptionType = ApplicationCommandOptionTypeBoolean, ..} = Just $ ApplicationCommandOptionValueBoolean internalApplicationCommandOptionName internalApplicationCommandOptionDescription internalApplicationCommandOptionRequired - fromInternal InternalApplicationCommandOption {internalApplicationCommandOptionType = ApplicationCommandOptionTypeUser, ..} = Just $ ApplicationCommandOptionValueUser internalApplicationCommandOptionName internalApplicationCommandOptionDescription internalApplicationCommandOptionRequired - fromInternal InternalApplicationCommandOption {internalApplicationCommandOptionType = ApplicationCommandOptionTypeRole, ..} = Just $ ApplicationCommandOptionValueRole internalApplicationCommandOptionName internalApplicationCommandOptionDescription internalApplicationCommandOptionRequired - fromInternal InternalApplicationCommandOption {internalApplicationCommandOptionType = ApplicationCommandOptionTypeMentionable, ..} = Just $ ApplicationCommandOptionValueMentionable internalApplicationCommandOptionName internalApplicationCommandOptionDescription internalApplicationCommandOptionRequired - fromInternal InternalApplicationCommandOption {internalApplicationCommandOptionType = ApplicationCommandOptionTypeChannel, ..} = Just $ ApplicationCommandOptionValueChannel internalApplicationCommandOptionName internalApplicationCommandOptionDescription internalApplicationCommandOptionRequired internalApplicationCommandOptionChannelTypes - fromInternal _ = Nothing - -instance Internals ApplicationCommandOptionSubcommand InternalApplicationCommandOption where - toInternal ApplicationCommandOptionSubcommand {..} = InternalApplicationCommandOption ApplicationCommandOptionTypeSubcommand applicationCommandOptionSubcommandName applicationCommandOptionSubcommandDescription Nothing Nothing (Just $ toInternal <$> applicationCommandOptionSubcommandOptions) Nothing Nothing Nothing Nothing - - fromInternal InternalApplicationCommandOption {internalApplicationCommandOptionType = ApplicationCommandOptionTypeSubcommand, ..} = do - os <- maybe (Just []) (mapM fromInternal) internalApplicationCommandOptionOptions - return $ ApplicationCommandOptionSubcommand internalApplicationCommandOptionName internalApplicationCommandOptionDescription os - fromInternal _ = Nothing - -instance Internals ApplicationCommandOptionSubcommandOrGroup InternalApplicationCommandOption where - toInternal (ApplicationCommandOptionSubcommandOrGroupSubcommand s) = toInternal s - toInternal ApplicationCommandOptionSubcommandGroup {..} = InternalApplicationCommandOption ApplicationCommandOptionTypeSubcommandGroup applicationCommandOptionSubcommandGroupName applicationCommandOptionSubcommandGroupDescription Nothing Nothing (Just $ toInternal <$> applicationCommandOptionSubcommandGroupOptions) Nothing Nothing Nothing Nothing - - fromInternal io@InternalApplicationCommandOption {internalApplicationCommandOptionType = ApplicationCommandOptionTypeSubcommand, ..} = ApplicationCommandOptionSubcommandOrGroupSubcommand <$> fromInternal io - fromInternal InternalApplicationCommandOption {internalApplicationCommandOptionType = ApplicationCommandOptionTypeSubcommandGroup, ..} = do - os <- maybe (Just []) (mapM fromInternal) internalApplicationCommandOptionOptions - return $ ApplicationCommandOptionSubcommandGroup internalApplicationCommandOptionName internalApplicationCommandOptionDescription os - fromInternal _ = Nothing - -instance Internals ApplicationCommandOptions [InternalApplicationCommandOption] where - toInternal (ApplicationCommandOptionsSubcommands is) = toInternal <$> is - toInternal (ApplicationCommandOptionsValues is) = toInternal <$> is - - fromInternal is = (ApplicationCommandOptionsSubcommands <$> mapM fromInternal is) <|> (ApplicationCommandOptionsValues <$> mapM fromInternal is) - -instance Internals ApplicationCommand InternalApplicationCommand where - toInternal ApplicationCommandUser {..} = InternalApplicationCommand applicationCommandId (Just ApplicationCommandTypeUser) applicationCommandApplicationId applicationCommandGuildId applicationCommandName "" Nothing applicationCommandDefaultPermission applicationCommandVersion - toInternal ApplicationCommandMessage {..} = InternalApplicationCommand applicationCommandId (Just ApplicationCommandTypeMessage) applicationCommandApplicationId applicationCommandGuildId applicationCommandName "" Nothing applicationCommandDefaultPermission applicationCommandVersion - toInternal ApplicationCommandChatInput {..} = InternalApplicationCommand applicationCommandId (Just ApplicationCommandTypeChatInput) applicationCommandApplicationId applicationCommandGuildId applicationCommandName applicationCommandDescription (toInternal <$> applicationCommandOptions) applicationCommandDefaultPermission applicationCommandVersion - toInternal (ApplicationCommandUnknown ai) = ai - - fromInternal InternalApplicationCommand {internalApplicationCommandType = Just ApplicationCommandTypeUser, ..} = Just $ ApplicationCommandUser internalApplicationCommandId internalApplicationCommandApplicationId internalApplicationCommandGuildId internalApplicationCommandName internalApplicationCommandDefaultPermission internalApplicationCommandVersion - fromInternal InternalApplicationCommand {internalApplicationCommandType = Just ApplicationCommandTypeMessage, ..} = Just $ ApplicationCommandMessage internalApplicationCommandId internalApplicationCommandApplicationId internalApplicationCommandGuildId internalApplicationCommandName internalApplicationCommandDefaultPermission internalApplicationCommandVersion - fromInternal a@InternalApplicationCommand {internalApplicationCommandType = Just ApplicationCommandTypeChatInput, ..} = Just $ fromMaybe (ApplicationCommandUnknown a) $ ((internalApplicationCommandOptions <|> Just []) >>= fromInternal) >>= \iOptions -> Just $ ApplicationCommandChatInput internalApplicationCommandId internalApplicationCommandApplicationId internalApplicationCommandGuildId internalApplicationCommandName internalApplicationCommandDescription (Just iOptions) internalApplicationCommandDefaultPermission internalApplicationCommandVersion - fromInternal a = fromInternal (a {internalApplicationCommandType = Just ApplicationCommandTypeChatInput}) - --- Just $ ApplicationCommandMessage internalApplicationCommandId internalApplicationCommandApplicationId internalApplicationCommandGuildId internalApplicationCommandName internalApplicationCommandDefaultPermission internalApplicationCommandVersion - --- | What type of application command. Represents slash commands, right clicking --- a user, and right clicking a message respectively. -data ApplicationCommandType - = -- | Slash commands - ApplicationCommandTypeChatInput - | -- | User commands - ApplicationCommandTypeUser - | -- | Message commands - ApplicationCommandTypeMessage - deriving (Show, Read, Data, Eq) +instance FromJSON ApplicationCommandOptionValue where + parseJSON = + withObject + "ApplicationCommandOptionValue" + ( \v -> do + name <- v .: "name" + desc <- v .: "description" + required <- v .:? "required" .!= False + t <- v .: "type" :: Parser Int + case t of + 3 -> + ApplicationCommandOptionValueString name desc required + <$> parseJSON (Object v) + 4 -> + ApplicationCommandOptionValueInteger name desc required + <$> parseJSON (Object v) + <*> v .:? "min_value" + <*> v .:? "max_value" + 10 -> + ApplicationCommandOptionValueNumber name desc required + <$> parseJSON (Object v) + <*> v .:? "min_value" + <*> v .:? "max_value" + 7 -> + ApplicationCommandOptionValueChannel name desc required + <$> v .:? "channel_types" + 5 -> return $ ApplicationCommandOptionValueBoolean name desc required + 6 -> return $ ApplicationCommandOptionValueUser name desc required + 8 -> return $ ApplicationCommandOptionValueRole name desc required + 9 -> return $ ApplicationCommandOptionValueMentionable name desc required + _ -> fail "unknown application command option value type" + ) -instance Enum ApplicationCommandType where - fromEnum ApplicationCommandTypeChatInput = 1 - fromEnum ApplicationCommandTypeUser = 2 - fromEnum ApplicationCommandTypeMessage = 3 - toEnum a = fromJust $ lookup a table +instance ToJSON ApplicationCommandOptionValue where + toJSON ApplicationCommandOptionValueString {..} = + object + [ ("type", Number 3), + ("name", toJSON applicationCommandOptionValueName), + ("description", toJSON applicationCommandOptionValueDescription), + ("required", toJSON applicationCommandOptionValueRequired), + choiceOrAutocompleteToJSON applicationCommandOptionValueStringChoices + ] + toJSON ApplicationCommandOptionValueInteger {..} = + object + [ ("type", Number 4), + ("name", toJSON applicationCommandOptionValueName), + ("description", toJSON applicationCommandOptionValueDescription), + ("required", toJSON applicationCommandOptionValueRequired), + choiceOrAutocompleteToJSON applicationCommandOptionValueIntegerChoices + ] + toJSON ApplicationCommandOptionValueNumber {..} = + object + [ ("type", Number 10), + ("name", toJSON applicationCommandOptionValueName), + ("description", toJSON applicationCommandOptionValueDescription), + ("required", toJSON applicationCommandOptionValueRequired), + choiceOrAutocompleteToJSON applicationCommandOptionValueNumberChoices + ] + toJSON ApplicationCommandOptionValueChannel {..} = + object + [ ("type", Number 7), + ("name", toJSON applicationCommandOptionValueName), + ("description", toJSON applicationCommandOptionValueDescription), + ("required", toJSON applicationCommandOptionValueRequired), + ("channel_types", toJSON applicationCommandOptionValueChannelTypes) + ] + toJSON acov = + object + [ ("type", Number (t acov)), + ("name", toJSON $ applicationCommandOptionValueName acov), + ("description", toJSON $ applicationCommandOptionValueDescription acov), + ("required", toJSON $ applicationCommandOptionValueRequired acov) + ] where - table = makeTable ApplicationCommandTypeChatInput - -instance ToJSON ApplicationCommandType where - toJSON = toJSON . fromEnum - -instance FromJSON ApplicationCommandType where - parseJSON = withScientific "ApplicationCommandType" (return . toEnum . round) + t ApplicationCommandOptionValueBoolean {} = 5 + t ApplicationCommandOptionValueUser {} = 6 + t ApplicationCommandOptionValueRole {} = 8 + t ApplicationCommandOptionValueMentionable {} = 9 + t _ = -1 -- | Data type to be used when creating application commands. The specification -- is below. @@ -267,84 +390,124 @@ -- of command nesting permitted. -- -- https://discord.com/developers/docs/interactions/application-commands#create-global-application-command -data CreateApplicationCommand = CreateApplicationCommand - { -- | The application command name (1-32 chars). - createApplicationCommandName :: T.Text, - -- | The application command description (1-100 chars). Has to be empty for - -- non-slash commands. - createApplicationCommandDescription :: T.Text, - -- | What options the application (max length 25). Has to be `Nothing` for - -- non-slash commands. - createApplicationCommandOptions :: Maybe [InternalApplicationCommandOption], - -- | Whether the command is enabled by default when the application is added - -- to a guild. Defaults to true if not present - createApplicationCommandDefaultPermission :: Maybe Bool, - -- | What the type of the command is. If `Nothing`, defaults to slash - -- commands. - createApplicationCommandType :: Maybe ApplicationCommandType - } +data CreateApplicationCommand + = CreateApplicationCommandChatInput + { -- | The application command name (1-32 chars). + createApplicationCommandName :: T.Text, + -- | The application command description (1-100 chars). Has to be empty for + -- non-slash commands. + createApplicationCommandDescription :: T.Text, + -- | What options the application (max length 25). Has to be `Nothing` for + -- non-slash commands. + createApplicationCommandOptions :: Maybe ApplicationCommandOptions, + -- | Whether the command is enabled by default when the application is added + -- to a guild. + createApplicationCommandDefaultPermission :: Bool + } + | CreateApplicationCommandUser + { -- | The application command name (1-32 chars). + createApplicationCommandName :: T.Text, + -- | Whether the command is enabled by default when the application is added + -- to a guild. + createApplicationCommandDefaultPermission :: Bool + } + | CreateApplicationCommandMessage + { -- | The application command name (1-32 chars). + createApplicationCommandName :: T.Text, + -- | Whether the command is enabled by default when the application is added + -- to a guild. + createApplicationCommandDefaultPermission :: Bool + } deriving (Show, Eq, Read) instance ToJSON CreateApplicationCommand where - toJSON CreateApplicationCommand {..} = + toJSON CreateApplicationCommandChatInput {..} = object [ (name, value) | (name, Just value) <- [ ("name", toMaybeJSON createApplicationCommandName), ("description", toMaybeJSON createApplicationCommandDescription), ("options", toJSON <$> createApplicationCommandOptions), - ("default_permission", toJSON <$> createApplicationCommandDefaultPermission), - ("type", toJSON <$> createApplicationCommandType) + ("default_permission", toMaybeJSON createApplicationCommandDefaultPermission), + ("type", Just $ Number 1) ] ] + toJSON CreateApplicationCommandUser {..} = + object + [ (name, value) + | (name, Just value) <- + [ ("name", toMaybeJSON createApplicationCommandName), + ("default_permission", toMaybeJSON createApplicationCommandDefaultPermission), + ("type", Just $ Number 2) + ] + ] + toJSON CreateApplicationCommandMessage {..} = + object + [ (name, value) + | (name, Just value) <- + [ ("name", toMaybeJSON createApplicationCommandName), + ("default_permission", toMaybeJSON createApplicationCommandDefaultPermission), + ("type", Just $ Number 3) + ] + ] +nameIsValid :: Bool -> T.Text -> Bool +nameIsValid isChatInput name = l >= 1 && l <= 32 && (isChatInput <= T.all (`elem` validChars) name) + where + l = T.length name + validChars = '-' : ['a' .. 'z'] + -- | Create the basics for a chat input (slash command). Use record overwriting -- to enter the other values. The name needs to be all lower case letters, and -- between 1 and 32 characters. The description has to be non-empty and less -- than or equal to 100 characters. createApplicationCommandChatInput :: T.Text -> T.Text -> Maybe CreateApplicationCommand createApplicationCommandChatInput name desc - | T.all isLower name && not (T.null desc) && l >= 1 && l <= 32 && T.length desc <= 100 = Just $ CreateApplicationCommand name desc Nothing Nothing (Just ApplicationCommandTypeChatInput) + | nameIsValid True name && not (T.null desc) && T.length desc <= 100 = Just $ CreateApplicationCommandChatInput name desc Nothing True | otherwise = Nothing - where - l = T.length name -- | Create the basics for a user command. Use record overwriting to enter the -- other values. The name needs to be between 1 and 32 characters. createApplicationCommandUser :: T.Text -> Maybe CreateApplicationCommand createApplicationCommandUser name - | l >= 1 && l <= 32 = Just $ CreateApplicationCommand name "" Nothing Nothing (Just ApplicationCommandTypeUser) + | nameIsValid False name = Just $ CreateApplicationCommandUser name True | otherwise = Nothing - where - l = T.length name -- | Create the basics for a message command. Use record overwriting to enter -- the other values. The name needs to be between 1 and 32 characters. createApplicationCommandMessage :: T.Text -> Maybe CreateApplicationCommand createApplicationCommandMessage name - | l >= 1 && l <= 32 = Just $ CreateApplicationCommand name "" Nothing Nothing (Just ApplicationCommandTypeMessage) + | nameIsValid False name = Just $ CreateApplicationCommandMessage name True | otherwise = Nothing - where - l = T.length name -- | Data type to be used when editing application commands. The specification -- is below. See `CreateApplicationCommand` for an explanation for the -- parameters. -- -- https://discord.com/developers/docs/interactions/application-commands#edit-global-application-command -data EditApplicationCommand = EditApplicationCommand - { editApplicationCommandName :: Maybe T.Text, - editApplicationCommandDescription :: Maybe T.Text, - editApplicationCommandOptions :: Maybe [InternalApplicationCommandOption], - editApplicationCommandDefaultPermission :: Maybe Bool, - editApplicationCommandType :: Maybe ApplicationCommandType - } +data EditApplicationCommand + = EditApplicationCommandChatInput + { editApplicationCommandName :: Maybe T.Text, + editApplicationCommandDescription :: Maybe T.Text, + editApplicationCommandOptions :: Maybe ApplicationCommandOptions, + editApplicationCommandDefaultPermission :: Maybe Bool + } + | EditApplicationCommandUser + { editApplicationCommandName :: Maybe T.Text, + editApplicationCommandDefaultPermission :: Maybe Bool + } + | EditApplicationCommandMessage + { editApplicationCommandName :: Maybe T.Text, + editApplicationCommandDefaultPermission :: Maybe Bool + } -instance Default EditApplicationCommand where - def = EditApplicationCommand Nothing Nothing Nothing Nothing Nothing +defaultEditApplicationCommand :: Int -> EditApplicationCommand +defaultEditApplicationCommand 2 = EditApplicationCommandUser Nothing Nothing +defaultEditApplicationCommand 3 = EditApplicationCommandMessage Nothing Nothing +defaultEditApplicationCommand _ = EditApplicationCommandChatInput Nothing Nothing Nothing Nothing instance ToJSON EditApplicationCommand where - toJSON EditApplicationCommand {..} = + toJSON EditApplicationCommandChatInput {..} = object [ (name, value) | (name, Just value) <- @@ -352,181 +515,27 @@ ("description", toJSON <$> editApplicationCommandDescription), ("options", toJSON <$> editApplicationCommandOptions), ("default_permission", toJSON <$> editApplicationCommandDefaultPermission), - ("type", toJSON <$> editApplicationCommandType) + ("type", Just $ Number 1) ] ] - --- | The full information about an application command, obtainable with the --- various get requests. In theory, you never need to construct one of these - --- so if you are, reconsider what you're doing. --- --- https://discord.com/developers/docs/interactions/application-commands#application-command-object-application-command-structure -data InternalApplicationCommand = InternalApplicationCommand - { -- | Unique id of the command. - internalApplicationCommandId :: ApplicationCommandId, - -- | The type of the command. - internalApplicationCommandType :: Maybe ApplicationCommandType, - -- | Unique id of the parent application (the bot). - internalApplicationCommandApplicationId :: ApplicationId, - -- | The guild id of the command if not global. - internalApplicationCommandGuildId :: Maybe GuildId, - -- | Must be 1-32 characters. - internalApplicationCommandName :: T.Text, - -- | Must be empty for USER and MESSAGE commands, otherwise 1-100 chars. - internalApplicationCommandDescription :: T.Text, - -- | CHAT_INPUT only, parameters to command - internalApplicationCommandOptions :: Maybe [InternalApplicationCommandOption], - -- | whether the command is enabled by default when the app is added to a - -- guild. Defaults to true. - internalApplicationCommandDefaultPermission :: Maybe Bool, - internalApplicationCommandVersion :: Snowflake - } - deriving (Show, Eq, Read) - -instance FromJSON InternalApplicationCommand where - parseJSON = - withObject - "InternalApplicationCommand" - ( \v -> - InternalApplicationCommand - <$> v .: "id" - <*> v .:? "type" - <*> v .: "application_id" - <*> v .:? "guild_id" - <*> v .: "name" - <*> v .: "description" - <*> v .:? "options" - <*> v .:? "default_permission" - <*> v .: "version" - ) - --- | This is the structure that designates different options for slash commands. --- --- https://discord.com/developers/docs/interactions/application-commands#application-command-object-application-command-option-structure -data InternalApplicationCommandOption = InternalApplicationCommandOption - { -- | What the type of this option is. - internalApplicationCommandOptionType :: ApplicationCommandOptionType, - -- | The name of the option . 1-32 characters - internalApplicationCommandOptionName :: T.Text, - -- | 1-100 characters - internalApplicationCommandOptionDescription :: T.Text, - -- | Is the parameter required? default false - internalApplicationCommandOptionRequired :: Maybe Bool, - -- | If specified, these are the only valid options to choose from. Type - -- depends on optionType, and can only be specified for STRING, INTEGER or - -- NUMBER types. - internalApplicationCommandOptionChoices :: Maybe [InternalApplicationCommandOptionChoice], - -- | If the option type is a subcommand or subcommand group type, these are - -- the parameters to the subcommand. - internalApplicationCommandOptionOptions :: Maybe [InternalApplicationCommandOption], - -- | If option is channel type, these are the only channel types allowed. - internalApplicationCommandOptionChannelTypes :: Maybe [ApplicationCommandChannelType], - -- | If option is number type, minimum value for the number - internalApplicationCommandOptionMinVal :: Maybe Scientific, - -- | if option is number type, maximum value for the number - internalApplicationCommandOptionMaxVal :: Maybe Scientific, - -- | Enable auto complete interactions. may not be set to true if choices is present. - internalApplicationCommandOptionAutocomplete :: Maybe Bool - } - deriving (Show, Eq, Read) - -instance ToJSON InternalApplicationCommandOption where - toJSON InternalApplicationCommandOption {..} = + toJSON EditApplicationCommandUser {..} = object [ (name, value) | (name, Just value) <- - [ ("type", toMaybeJSON internalApplicationCommandOptionType), - ("name", toMaybeJSON internalApplicationCommandOptionName), - ("description", toMaybeJSON internalApplicationCommandOptionDescription), - ("required", toJSON <$> internalApplicationCommandOptionRequired), - ("choices", toJSON <$> internalApplicationCommandOptionChoices), - ("options", toJSON <$> internalApplicationCommandOptionOptions), - ("channel_types", toJSON <$> internalApplicationCommandOptionChannelTypes), - ("min_val", toJSON <$> internalApplicationCommandOptionMinVal), - ("max_val", toJSON <$> internalApplicationCommandOptionMaxVal), - ("autocomplete", toJSON <$> internalApplicationCommandOptionAutocomplete) + [ ("name", toJSON <$> editApplicationCommandName), + ("default_permission", toJSON <$> editApplicationCommandDefaultPermission), + ("type", Just $ Number 2) ] ] - -instance FromJSON InternalApplicationCommandOption where - parseJSON = - withObject - "InternalApplicationCommandOption" - ( \v -> - InternalApplicationCommandOption - <$> v .: "type" - <*> v .: "name" - <*> v .: "description" - <*> v .:? "required" - <*> v .:? "choices" - <*> v .:? "options" - <*> v .:? "channel_types" - <*> v .:? "min_val" - <*> v .:? "max_val" - <*> v .:? "autocomplete" - ) - --- | What type of command option. Can represent a wide variety of types, so --- please check out the documentation below. --- --- https://discord.com/developers/docs/interactions/application-commands#application-command-object-application-command-option-type -data ApplicationCommandOptionType - = -- | A subcommand. It can take further options, excluding sub commands and - -- sub command groups. - ApplicationCommandOptionTypeSubcommand - | -- | A subcommand group. It can take further options, excluding sub command - -- groups. - ApplicationCommandOptionTypeSubcommandGroup - | -- | Can typically be provided with default values. - ApplicationCommandOptionTypeString - | -- | Can typically be provided with default values, and possibly with - -- minimum and maximum values. - ApplicationCommandOptionTypeInteger - | ApplicationCommandOptionTypeBoolean - | ApplicationCommandOptionTypeUser - | -- | Can be limited in the types of the channel allowed. - ApplicationCommandOptionTypeChannel - | ApplicationCommandOptionTypeRole - | -- | Users and roles. - ApplicationCommandOptionTypeMentionable - | -- | Can typically be provided with default values, and possibly with - -- minimum and maximum values. Represents a double. - ApplicationCommandOptionTypeNumber - deriving (Show, Read, Data, Eq) - -instance Enum ApplicationCommandOptionType where - fromEnum ApplicationCommandOptionTypeSubcommand = 1 - fromEnum ApplicationCommandOptionTypeSubcommandGroup = 2 - fromEnum ApplicationCommandOptionTypeString = 3 - fromEnum ApplicationCommandOptionTypeInteger = 4 - fromEnum ApplicationCommandOptionTypeBoolean = 5 - fromEnum ApplicationCommandOptionTypeUser = 6 - fromEnum ApplicationCommandOptionTypeChannel = 7 - fromEnum ApplicationCommandOptionTypeRole = 8 - fromEnum ApplicationCommandOptionTypeMentionable = 9 - fromEnum ApplicationCommandOptionTypeNumber = 10 - toEnum a = fromJust $ lookup a table - where - table = makeTable ApplicationCommandOptionTypeSubcommand - -instance ToJSON ApplicationCommandOptionType where - toJSON = toJSON . fromEnum - -instance FromJSON ApplicationCommandOptionType where - parseJSON = withScientific "ApplicationCommandOptionType" (return . toEnum . round) - --- | Utility data type to store strings or number types. -data StringNumberValue = StringNumberValueString T.Text | StringNumberValueNumber Scientific | StringNumberValueInteger Integer - deriving (Show, Read, Eq) - -instance ToJSON StringNumberValue where - toJSON (StringNumberValueString s) = toJSON s - toJSON (StringNumberValueNumber i) = toJSON i - toJSON (StringNumberValueInteger i) = toJSON i - -instance FromJSON StringNumberValue where - parseJSON (String t) = return $ StringNumberValueString t - parseJSON v = (StringNumberValueInteger <$> parseJSON v) <|> (StringNumberValueNumber <$> parseJSON v) + toJSON EditApplicationCommandMessage {..} = + object + [ (name, value) + | (name, Just value) <- + [ ("name", toJSON <$> editApplicationCommandName), + ("default_permission", toJSON <$> editApplicationCommandDefaultPermission), + ("type", Just $ Number 3) + ] + ] data Choice a = Choice {choiceName :: T.Text, choiceValue :: a} deriving (Show, Read, Eq) @@ -534,14 +543,6 @@ instance Functor Choice where fmap f (Choice s a) = Choice s (f a) -type InternalApplicationCommandOptionChoice = Choice StringNumberValue - --- | The choices for a particular option. --- data InternalApplicationCommandOptionChoice = InternalApplicationCommandOptionChoice --- { internalApplicationCommandOptionChoiceName :: T.Text, --- internalApplicationCommandOptionChoiceValue :: StringNumberValue --- } --- deriving (Show, Read, Eq) instance (ToJSON a) => ToJSON (Choice a) where toJSON Choice {..} = object [("name", toJSON choiceName), ("value", toJSON choiceValue)] @@ -555,6 +556,23 @@ <*> v .: "value" ) +type AutocompleteOrChoice a = Either Bool [Choice a] + +instance {-# OVERLAPPING #-} (FromJSON a) => FromJSON (AutocompleteOrChoice a) where + parseJSON = + withObject + "AutocompleteOrChoice" + ( \v -> do + mcs <- v .:! "choices" + case mcs of + Nothing -> Left <$> v .:? "autocomplete" .!= False + Just cs -> return $ Right cs + ) + +choiceOrAutocompleteToJSON :: (ToJSON a) => AutocompleteOrChoice a -> Pair +choiceOrAutocompleteToJSON (Left b) = ("autocomplete", toJSON b) +choiceOrAutocompleteToJSON (Right cs) = ("choices", toJSON cs) + -- | The different channel types. -- -- https://discord.com/developers/docs/resources/channel#channel-object-channel-types @@ -575,7 +593,7 @@ ApplicationCommandChannelTypeGuildStore | -- | A temporary sub-channel within a guild_news channel. ApplicationCommandChannelTypeGuildNewsThread - | -- | A temporary sub-channel within a guild_text channel + | -- | A temporary sub-channel within a guild_text channel. ApplicationCommandChannelTypeGuildPublicThread | -- | A temporary sub-channel within a GUILD_TEXT channel that is only -- viewable by those invited and those with the MANAGE_THREADS permission @@ -584,36 +602,34 @@ ApplicationCommandChannelTypeGuildStageVoice deriving (Show, Read, Data, Eq) -instance Enum ApplicationCommandChannelType where - fromEnum ApplicationCommandChannelTypeGuildText = 0 - fromEnum ApplicationCommandChannelTypeDM = 1 - fromEnum ApplicationCommandChannelTypeGuildVoice = 2 - fromEnum ApplicationCommandChannelTypeGroupDM = 3 - fromEnum ApplicationCommandChannelTypeGuildCategory = 4 - fromEnum ApplicationCommandChannelTypeGuildNews = 5 - fromEnum ApplicationCommandChannelTypeGuildStore = 6 - fromEnum ApplicationCommandChannelTypeGuildNewsThread = 10 - fromEnum ApplicationCommandChannelTypeGuildPublicThread = 11 - fromEnum ApplicationCommandChannelTypeGuildPrivateThread = 12 - fromEnum ApplicationCommandChannelTypeGuildStageVoice = 13 - toEnum a = fromJust $ lookup a table - where - table = makeTable ApplicationCommandChannelTypeGuildText +instance InternalDiscordEnum ApplicationCommandChannelType where + discordTypeStartValue = ApplicationCommandChannelTypeGuildText + fromDiscordType ApplicationCommandChannelTypeGuildText = 0 + fromDiscordType ApplicationCommandChannelTypeDM = 1 + fromDiscordType ApplicationCommandChannelTypeGuildVoice = 2 + fromDiscordType ApplicationCommandChannelTypeGroupDM = 3 + fromDiscordType ApplicationCommandChannelTypeGuildCategory = 4 + fromDiscordType ApplicationCommandChannelTypeGuildNews = 5 + fromDiscordType ApplicationCommandChannelTypeGuildStore = 6 + fromDiscordType ApplicationCommandChannelTypeGuildNewsThread = 10 + fromDiscordType ApplicationCommandChannelTypeGuildPublicThread = 11 + fromDiscordType ApplicationCommandChannelTypeGuildPrivateThread = 12 + fromDiscordType ApplicationCommandChannelTypeGuildStageVoice = 13 instance ToJSON ApplicationCommandChannelType where - toJSON = toJSON . fromEnum + toJSON = toJSON . fromDiscordType instance FromJSON ApplicationCommandChannelType where - parseJSON = withScientific "ApplicationCommandChannelType" (return . toEnum . round) + parseJSON = discordTypeParseJSON "ApplicationCommandChannelType" data GuildApplicationCommandPermissions = GuildApplicationCommandPermissions - { -- | The id of the command + { -- | The id of the command. guildApplicationCommandPermissionsId :: ApplicationCommandId, - -- | The id of the application + -- | The id of the application. guildApplicationCommandPermissionsApplicationId :: ApplicationId, - -- | The id of the guild + -- | The id of the guild. guildApplicationCommandPermissionsGuildId :: GuildId, - -- | The permissions for the command in the guild + -- | The permissions for the command in the guild. guildApplicationCommandPermissionsPermissions :: [ApplicationCommandPermissions] } deriving (Show, Eq, Ord, Read) @@ -642,12 +658,14 @@ ] ] +-- | Application command permissions allow you to enable or disable commands for +-- specific users or roles within a guild. data ApplicationCommandPermissions = ApplicationCommandPermissions - { -- | The id of the role or user + { -- | The id of the role or user. applicationCommandPermissionsId :: Snowflake, - -- | Choose either role or user - applicationCommandPermissionsType :: ApplicationCommandPermissionType, - -- | Whether to allow or not + -- | Choose either role (1) or user (2). + applicationCommandPermissionsType :: Integer, + -- | Whether to allow or not. applicationCommandPermissionsPermission :: Bool } deriving (Show, Eq, Ord, Read) @@ -673,21 +691,3 @@ ("permission", toMaybeJSON applicationCommandPermissionsPermission) ] ] - -data ApplicationCommandPermissionType - = ApplicationCommandPermissionTypeRole - | ApplicationCommandPermissionTypeUser - deriving (Show, Eq, Ord, Read, Data) - -instance Enum ApplicationCommandPermissionType where - fromEnum ApplicationCommandPermissionTypeRole = 1 - fromEnum ApplicationCommandPermissionTypeUser = 2 - toEnum a = fromJust $ lookup a table - where - table = makeTable ApplicationCommandPermissionTypeRole - -instance ToJSON ApplicationCommandPermissionType where - toJSON = toJSON . fromEnum - -instance FromJSON ApplicationCommandPermissionType where - parseJSON = withScientific "ApplicationCommandPermissionType" (return . toEnum . round) diff --git a/src/Discord/Internal/Types/Channel.hs b/src/Discord/Internal/Types/Channel.hs --- a/src/Discord/Internal/Types/Channel.hs +++ b/src/Discord/Internal/Types/Channel.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -17,9 +18,8 @@ import Discord.Internal.Types.User (User(..), GuildMember) import Discord.Internal.Types.Embed import Data.Data (Data) -import Data.Maybe (fromJust) import Data.Bits -import Discord.Internal.Types.Components (Component, Emoji) +import Discord.Internal.Types.Components (ComponentActionRow, Emoji) -- | Guild channels represent an isolated set of users and messages in a Guild (Server) data Channel @@ -292,16 +292,15 @@ , messageWebhookId :: Maybe WebhookId -- ^ The webhook id of the webhook that made the message , messageType :: MessageType -- ^ What type of message is this. , messageActivity :: Maybe MessageActivity -- ^ sent with Rich Presence-related chat embeds - -- , messageApplication :: Maybe ??? -- ^ a partial application object , messageApplicationId :: Maybe ApplicationId -- ^ if the message is a response to an Interaction, this is the id of the interaction's application , messageReference :: Maybe MessageReference -- ^ Reference IDs of the original message , messageFlags :: Maybe MessageFlags -- ^ Various message flags , messageReferencedMessage :: Maybe Message -- ^ The full original message , messageInteraction :: Maybe MessageInteraction -- ^ sent if message is an interaction response , messageThread :: Maybe Channel -- ^ the thread that was started from this message, includes thread member object - , messageComponents :: Maybe [Component] -- ^ sent if the message contains components like buttons, action rows, or other interactive components - , messageStickerItems :: Maybe [StickerItem] -- ^ sent if the message contains stickers - } deriving (Show, Read, Eq, Ord) + , messageComponents :: Maybe [ComponentActionRow] -- ^ sent if the message contains components like buttons, action rows, or other interactive components + , messageStickerItems :: Maybe [StickerItem] -- ^ sent if the message contains stickers + } deriving (Show, Eq, Ord, Read) instance FromJSON Message where parseJSON = withObject "Message" $ \o -> @@ -449,19 +448,17 @@ | StickerFormatTypeLOTTIE deriving (Show, Read, Eq, Ord, Data) -instance Enum StickerFormatType where - fromEnum StickerFormatTypePNG = 1 - fromEnum StickerFormatTypeAPNG = 2 - fromEnum StickerFormatTypeLOTTIE = 3 - toEnum a = fromJust $ lookup a table - where - table = makeTable StickerFormatTypePNG +instance InternalDiscordEnum StickerFormatType where + discordTypeStartValue = StickerFormatTypePNG + fromDiscordType StickerFormatTypePNG = 1 + fromDiscordType StickerFormatTypeAPNG = 2 + fromDiscordType StickerFormatTypeLOTTIE = 3 instance ToJSON StickerFormatType where - toJSON = toJSON . fromEnum + toJSON = toJSON . fromDiscordType instance FromJSON StickerFormatType where - parseJSON = withScientific "StickerFormatType" (return . toEnum . round) + parseJSON = discordTypeParseJSON "StickerFormatType" -- | Represents an attached to a message file. data Attachment = Attachment @@ -539,9 +536,9 @@ data MessageType - = MessageTypeDefault - | MessageTypeRecipientAdd - | MessageTypeRecipientRemove + = MessageTypeDefault + | MessageTypeRecipientAdd + | MessageTypeRecipientRemove | MessageTypeCall | MessageTypeChannelNameChange | MessageTypeChannelIconChange @@ -564,39 +561,37 @@ | MessageTypeContextMenuCommand deriving (Show, Read, Data, Eq, Ord) -instance Enum MessageType where - fromEnum MessageTypeDefault = 0 - fromEnum MessageTypeRecipientAdd = 1 - fromEnum MessageTypeRecipientRemove = 2 - fromEnum MessageTypeCall = 3 - fromEnum MessageTypeChannelNameChange = 4 - fromEnum MessageTypeChannelIconChange = 5 - fromEnum MessageTypeChannelPinnedMessage = 6 - fromEnum MessageTypeGuildMemberJoin = 7 - fromEnum MessageTypeUserPremiumGuildSubscription = 8 - fromEnum MessageTypeUserPremiumGuildSubscriptionTier1 = 9 - fromEnum MessageTypeUserPremiumGuildSubscriptionTier2 = 10 - fromEnum MessageTypeUserPremiumGuildSubscriptionTier3 = 11 - fromEnum MessageTypeChannelFollowAdd = 12 - fromEnum MessageTypeGuildDiscoveryDisqualified = 14 - fromEnum MessageTypeGuildDiscoveryRequalified = 15 - fromEnum MessageTypeGuildDiscoveryGracePeriodInitialWarning = 16 - fromEnum MessageTypeGuildDiscoveryGracePeriodFinalWarning = 17 - fromEnum MessageTypeThreadCreated = 18 - fromEnum MessageTypeReply = 19 - fromEnum MessageTypeChatInputCommand = 20 - fromEnum MessageTypeThreadStarterMessage = 21 - fromEnum MessageTypeGuildInviteReminder = 22 - fromEnum MessageTypeContextMenuCommand = 23 - toEnum a = fromJust $ lookup a table - where - table = makeTable MessageTypeDefault +instance InternalDiscordEnum MessageType where + discordTypeStartValue = MessageTypeDefault + fromDiscordType MessageTypeDefault = 0 + fromDiscordType MessageTypeRecipientAdd = 1 + fromDiscordType MessageTypeRecipientRemove = 2 + fromDiscordType MessageTypeCall = 3 + fromDiscordType MessageTypeChannelNameChange = 4 + fromDiscordType MessageTypeChannelIconChange = 5 + fromDiscordType MessageTypeChannelPinnedMessage = 6 + fromDiscordType MessageTypeGuildMemberJoin = 7 + fromDiscordType MessageTypeUserPremiumGuildSubscription = 8 + fromDiscordType MessageTypeUserPremiumGuildSubscriptionTier1 = 9 + fromDiscordType MessageTypeUserPremiumGuildSubscriptionTier2 = 10 + fromDiscordType MessageTypeUserPremiumGuildSubscriptionTier3 = 11 + fromDiscordType MessageTypeChannelFollowAdd = 12 + fromDiscordType MessageTypeGuildDiscoveryDisqualified = 14 + fromDiscordType MessageTypeGuildDiscoveryRequalified = 15 + fromDiscordType MessageTypeGuildDiscoveryGracePeriodInitialWarning = 16 + fromDiscordType MessageTypeGuildDiscoveryGracePeriodFinalWarning = 17 + fromDiscordType MessageTypeThreadCreated = 18 + fromDiscordType MessageTypeReply = 19 + fromDiscordType MessageTypeChatInputCommand = 20 + fromDiscordType MessageTypeThreadStarterMessage = 21 + fromDiscordType MessageTypeGuildInviteReminder = 22 + fromDiscordType MessageTypeContextMenuCommand = 23 instance ToJSON MessageType where - toJSON = toJSON . fromEnum + toJSON = toJSON . fromDiscordType instance FromJSON MessageType where - parseJSON = withScientific "MessageType" (return . toEnum . round) + parseJSON = discordTypeParseJSON "MessageType" data MessageActivity = MessageActivity { messageActivityType :: MessageActivityType @@ -622,23 +617,21 @@ | MessageActivityTypeJoinRequest -- ^ Request to join a Rich Presence event deriving (Show, Read, Data, Eq, Ord) -instance Enum MessageActivityType where - fromEnum MessageActivityTypeJoin = 1 - fromEnum MessageActivityTypeSpectate = 2 - fromEnum MessageActivityTypeListen = 3 - fromEnum MessageActivityTypeJoinRequest = 4 - toEnum a = fromJust $ lookup a table - where - table = makeTable MessageActivityTypeJoin +instance InternalDiscordEnum MessageActivityType where + discordTypeStartValue = MessageActivityTypeJoin + fromDiscordType MessageActivityTypeJoin = 1 + fromDiscordType MessageActivityTypeSpectate = 2 + fromDiscordType MessageActivityTypeListen = 3 + fromDiscordType MessageActivityTypeJoinRequest = 4 instance ToJSON MessageActivityType where - toJSON = toJSON . fromEnum + toJSON = toJSON . fromDiscordType instance FromJSON MessageActivityType where - parseJSON = withScientific "MessageActivityType" (return . toEnum . round) + parseJSON = discordTypeParseJSON "MessageActivityType" -- | Types of flags to attach to the message. -data MessageFlag = +data MessageFlag = MessageFlagCrossposted | MessageFlagIsCrosspost | MessageFlagSupressEmbeds @@ -652,35 +645,36 @@ newtype MessageFlags = MessageFlags [MessageFlag] deriving (Show, Read, Eq, Ord) -instance Enum MessageFlag where - fromEnum MessageFlagCrossposted = 1 `shift` 0 - fromEnum MessageFlagIsCrosspost = 1 `shift` 1 - fromEnum MessageFlagSupressEmbeds = 1 `shift` 2 - fromEnum MessageFlagSourceMessageDeleted = 1 `shift` 3 - fromEnum MessageFlagUrgent = 1 `shift` 4 - fromEnum MessageFlagHasThread = 1 `shift` 5 - fromEnum MessageFlagEphemeral = 1 `shift` 6 - fromEnum MessageFlagLoading = 1 `shift` 7 - toEnum a = fromJust $ lookup a table - where - table = makeTable MessageFlagCrossposted +instance InternalDiscordEnum MessageFlag where + discordTypeStartValue = MessageFlagCrossposted + fromDiscordType MessageFlagCrossposted = 1 `shift` 0 + fromDiscordType MessageFlagIsCrosspost = 1 `shift` 1 + fromDiscordType MessageFlagSupressEmbeds = 1 `shift` 2 + fromDiscordType MessageFlagSourceMessageDeleted = 1 `shift` 3 + fromDiscordType MessageFlagUrgent = 1 `shift` 4 + fromDiscordType MessageFlagHasThread = 1 `shift` 5 + fromDiscordType MessageFlagEphemeral = 1 `shift` 6 + fromDiscordType MessageFlagLoading = 1 `shift` 7 instance ToJSON MessageFlags where - toJSON (MessageFlags fs) = Number $ fromInteger $ fromIntegral $ foldr (.|.) 0 (fromEnum <$> fs) + toJSON (MessageFlags fs) = Number $ fromInteger $ fromIntegral $ foldr (.|.) 0 (fromDiscordType <$> fs) -- TODO: maybe make this a type class or something - the ability to handle flags automatically would be Very Good. instance FromJSON MessageFlags where - parseJSON = withScientific "MessageFlags" (\s -> let i = round s in if i /= (i .&. range) then fail "could not get message flags" else return $ MessageFlags (snd <$> filter (\(i',_) -> i .&. i' == i') table)) - where - table = makeTable MessageFlagCrossposted - range = sum $ fst <$> table + parseJSON = withScientific "MessageFlags" $ \s -> + let i = round s + range = sum $ fst <$> (discordTypeTable @MessageFlag) + in if i /= (i .&. range) + then fail "could not get message flags" + else return $ MessageFlags (snd <$> filter (\(i',_) -> i .&. i' == i') discordTypeTable) +-- | This is sent on the message object when the message is a response to an Interaction without an existing message (i.e., any non-component interaction). data MessageInteraction = MessageInteraction - { messageInteractionId :: InteractionId - , messageInteractionType :: InteractionType - , messageInteractionName :: T.Text - , messageInteractionUser :: User + { messageInteractionId :: InteractionId -- ^ Id of the interaction + , messageInteractionType :: Integer -- ^ Type of the interaction (liekly always application command) + , messageInteractionName :: T.Text -- ^ Name of the interaction + , messageInteractionUser :: User -- ^ User who invoked the interaction } deriving (Show, Eq, Ord, Read) instance ToJSON MessageInteraction where @@ -698,4 +692,3 @@ <*> o .: "type" <*> o .: "name" <*> o .: "user" - diff --git a/src/Discord/Internal/Types/Color.hs b/src/Discord/Internal/Types/Color.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Types/Color.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Data structures pertaining to Discord Colors +module Discord.Internal.Types.Color where + + +import Text.Read (readMaybe) +import Data.Maybe (fromMaybe) +import Data.Char (toLower) +import Data.Aeson +import Data.Data +import Control.Applicative (Alternative((<|>))) +import Data.Bits (Bits((.&.))) + + +import Discord.Internal.Types.Prelude (InternalDiscordEnum(..)) + +-- | Color names +-- Color is a bit of a mess on discord embeds. +-- I've here stolen the pallet list from https://gist.github.com/thomasbnt/b6f455e2c7d743b796917fa3c205f812 +-- +-- All discord embed color stuff is credited to +-- https://github.com/WarwickTabletop/tablebot/pull/34 +data DiscordColor + = DiscordColorRGB Integer Integer Integer + | DiscordColorDefault + | DiscordColorAqua + | DiscordColorDarkAqua + | DiscordColorGreen + | DiscordColorDarkGreen + | DiscordColorBlue + | DiscordColorDarkBlue + | DiscordColorPurple + | DiscordColorDarkPurple + | DiscordColorLuminousVividPink + | DiscordColorDarkVividPink + | DiscordColorGold + | DiscordColorDarkGold + | DiscordColorOrange + | DiscordColorDarkOrange + | DiscordColorRed + | DiscordColorDarkRed + | DiscordColorGray + | DiscordColorDarkGray + | DiscordColorDarkerGray + | DiscordColorLightGray + | DiscordColorNavy + | DiscordColorDarkNavy + | DiscordColorYellow + | DiscordColorDiscordWhite + | DiscordColorDiscordBlurple + | DiscordColorDiscordGrayple + | DiscordColorDiscordDarkButNotBlack + | DiscordColorDiscordNotQuiteBlack + | DiscordColorDiscordGreen + | DiscordColorDiscordYellow + | DiscordColorDiscordFuschia + | DiscordColorDiscordRed + | DiscordColorDiscordBlack + deriving (Show, Read, Eq, Ord, Data) + +-- | @hexToRGB@ attempts to convert a potential hex string into its decimal RGB +-- components. +hexToRGB :: String -> Maybe (Integer, Integer, Integer) +hexToRGB hex = do + let h = map toLower hex + r <- take2 h >>= toDec + g <- drop2 h >>= take2 >>= toDec + b <- drop2 h >>= drop2 >>= toDec + return (r, g, b) + where + take2 (a:b:_) = Just [a, b] + take2 _ = Nothing + drop2 (_ : _ : as) = Just as + drop2 _ = Nothing + toDec :: String -> Maybe Integer + toDec [s, u] = do + a <- charToDec s + b <- charToDec u + return $ a * 16 + b + toDec _ = Nothing + charToDec :: Char -> Maybe Integer + charToDec 'a' = Just 10 + charToDec 'b' = Just 11 + charToDec 'c' = Just 12 + charToDec 'd' = Just 13 + charToDec 'e' = Just 14 + charToDec 'f' = Just 15 + charToDec c = readMaybe [c] + +-- | @hexToDiscordColor@ converts a potential hex string into a DiscordColor, +-- evaluating to Default if it fails. +hexToDiscordColor :: String -> DiscordColor +hexToDiscordColor hex = + let (r, g, b) = fromMaybe (0, 0, 0) $ hexToRGB hex + in DiscordColorRGB r g b + +colorToInternal :: DiscordColor -> Integer +-- colorToInternal (DiscordColor i) = i +colorToInternal (DiscordColorRGB r g b) = (r * 256 + g) * 256 + b +colorToInternal DiscordColorDefault = 0 +colorToInternal DiscordColorAqua = 1752220 +colorToInternal DiscordColorDarkAqua = 1146986 +colorToInternal DiscordColorGreen = 3066993 +colorToInternal DiscordColorDarkGreen = 2067276 +colorToInternal DiscordColorBlue = 3447003 +colorToInternal DiscordColorDarkBlue = 2123412 +colorToInternal DiscordColorPurple = 10181046 +colorToInternal DiscordColorDarkPurple = 7419530 +colorToInternal DiscordColorLuminousVividPink = 15277667 +colorToInternal DiscordColorDarkVividPink = 11342935 +colorToInternal DiscordColorGold = 15844367 +colorToInternal DiscordColorDarkGold = 12745742 +colorToInternal DiscordColorOrange = 15105570 +colorToInternal DiscordColorDarkOrange = 11027200 +colorToInternal DiscordColorRed = 15158332 +colorToInternal DiscordColorDarkRed = 10038562 +colorToInternal DiscordColorGray = 9807270 +colorToInternal DiscordColorDarkGray = 9936031 +colorToInternal DiscordColorDarkerGray = 8359053 +colorToInternal DiscordColorLightGray = 12370112 +colorToInternal DiscordColorNavy = 3426654 +colorToInternal DiscordColorDarkNavy = 2899536 +colorToInternal DiscordColorYellow = 16776960 +colorToInternal DiscordColorDiscordWhite = 16777215 +colorToInternal DiscordColorDiscordBlurple = 5793266 +colorToInternal DiscordColorDiscordGrayple = 10070709 +colorToInternal DiscordColorDiscordDarkButNotBlack = 2895667 +colorToInternal DiscordColorDiscordNotQuiteBlack = 2303786 +colorToInternal DiscordColorDiscordGreen = 5763719 +colorToInternal DiscordColorDiscordYellow = 16705372 +colorToInternal DiscordColorDiscordFuschia = 15418782 +colorToInternal DiscordColorDiscordRed = 15548997 +colorToInternal DiscordColorDiscordBlack = 16777215 + +convertToRGB :: Integer -> DiscordColor +convertToRGB i = DiscordColorRGB (div i (256 * 256) .&. 255) (div i 256 .&. 255) (i .&. 255) + +instance InternalDiscordEnum DiscordColor where + discordTypeStartValue = DiscordColorDefault + fromDiscordType = fromIntegral . colorToInternal + discordTypeTable = map (\d -> (fromDiscordType d, d)) (makeTable discordTypeStartValue) + where + makeTable :: Data b => b -> [b] + makeTable t = map (fromConstrB (fromConstr (toConstr (0 :: Int)))) (dataTypeConstrs $ dataTypeOf t) + +instance ToJSON DiscordColor where + toJSON = toJSON . fromDiscordType + +instance FromJSON DiscordColor where + parseJSON = + withScientific + "DiscordColor" + ( \v -> + discordTypeParseJSON "DiscordColor" (Number v) + <|> ( case maybeInt v >>= Just . convertToRGB of + Nothing -> fail $ "could not parse discord color: " ++ show v + Just d -> return d + ) + ) + where + maybeInt i + | fromIntegral (round i) == i = Just $ round i + | otherwise = Nothing diff --git a/src/Discord/Internal/Types/Components.hs b/src/Discord/Internal/Types/Components.hs --- a/src/Discord/Internal/Types/Components.hs +++ b/src/Discord/Internal/Types/Components.hs @@ -1,219 +1,278 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module Discord.Internal.Types.Components where +module Discord.Internal.Types.Components + ( ComponentActionRow (..), + ComponentButton (..), + ButtonStyle (..), + mkButton, + ComponentSelectMenu (..), + mkSelectMenu, + SelectOption (..), + mkSelectOption, + Emoji (..), + mkEmoji, + ) +where import Data.Aeson -import Data.Data (Data) -import Data.Maybe (fromJust, fromMaybe) +import Data.Aeson.Types (Parser) +import Data.Foldable (Foldable (toList)) +import Data.Scientific (Scientific) import qualified Data.Text as T -import Data.Tuple (swap) -import Discord.Internal.Types.Prelude (EmojiId, Internals (..), RoleId, makeTable, toMaybeJSON) +import Discord.Internal.Types.Prelude (EmojiId, RoleId, toMaybeJSON) import Discord.Internal.Types.User (User) -import qualified Network.HTTP.Req as R +data ComponentActionRow = ComponentActionRowButton [ComponentButton] | ComponentActionRowSelectMenu ComponentSelectMenu + deriving (Show, Eq, Ord, Read) + +instance FromJSON ComponentActionRow where + parseJSON = + withObject + "ComponentActionRow" + ( \cs -> do + a <- cs .: "components" :: Parser Array + let a' = toList a + case a' of + [] -> return $ ComponentActionRowButton [] + (c : _) -> + withObject + "ComponentActionRow item" + ( \v -> do + t <- v .: "type" :: Parser Int + case t of + 2 -> ComponentActionRowButton <$> mapM parseJSON a' + 3 -> ComponentActionRowSelectMenu <$> parseJSON c + _ -> fail $ "unknown component type: " ++ show t + ) + c + ) + +instance ToJSON ComponentActionRow where + toJSON (ComponentActionRowButton bs) = object [("type", Number 1), ("components", toJSON bs)] + toJSON (ComponentActionRowSelectMenu bs) = object [("type", Number 1), ("components", toJSON [bs])] + -- | Component type for a button, split into URL button and not URL button. -- -- Don't directly send button components - they need to be within an action row. data ComponentButton = ComponentButton - { componentButtonCustomId :: T.Text, + { -- | Dev indentifier + componentButtonCustomId :: T.Text, + -- | Whether the button is disabled componentButtonDisabled :: Bool, + -- | What is the style of the button componentButtonStyle :: ButtonStyle, + -- | What is the user-facing label of the button componentButtonLabel :: T.Text, + -- | What emoji is displayed on the button componentButtonEmoji :: Maybe Emoji } | ComponentButtonUrl - { componentButtonUrl :: R.Url 'R.Https, + { -- | The url for the button. If this is not a valid url, everything will + -- break + componentButtonUrl :: T.Text, + -- | Whether the button is disabled componentButtonDisabled :: Bool, + -- | What is the user-facing label of the button componentButtonLabel :: T.Text, + -- | What emoji is displayed on the button componentButtonEmoji :: Maybe Emoji } - deriving (Show, Eq) + deriving (Show, Eq, Ord, Read) -data ButtonStyle = ButtonStylePrimary | ButtonStyleSecondary | ButtonStyleSuccess | ButtonStyleDanger - deriving (Show, Eq, Read) +-- | Takes the label and the custom id of the button that is to be generated. +mkButton :: T.Text -> T.Text -> ComponentButton +mkButton label customId = ComponentButton customId False ButtonStyleSecondary label Nothing -buttonStyles :: [(ButtonStyle, InternalButtonStyle)] -buttonStyles = - [ (ButtonStylePrimary, InternalButtonStylePrimary), - (ButtonStyleSecondary, InternalButtonStyleSecondary), - (ButtonStyleSuccess, InternalButtonStyleSuccess), - (ButtonStyleDanger, InternalButtonStyleDanger) - ] +instance FromJSON ComponentButton where + parseJSON = + withObject + "ComponentButton" + ( \v -> do + t <- v .: "type" :: Parser Int + case t of + 2 -> do + disabled <- v .:? "disabled" .!= False + label <- v .: "label" + partialEmoji <- v .:? "emoji" + style <- v .: "style" :: Parser Scientific + case style of + 5 -> + ComponentButtonUrl + <$> v .: "url" + <*> return disabled + <*> return label + <*> return partialEmoji + _ -> + ComponentButton + <$> v .: "custom_id" + <*> return disabled + <*> parseJSON (Number style) + <*> return label + <*> return partialEmoji + _ -> fail "expected button type, got a different component" + ) -instance Internals ButtonStyle InternalButtonStyle where - toInternal a = fromJust (lookup a buttonStyles) - fromInternal b = lookup b (swap <$> buttonStyles) +instance ToJSON ComponentButton where + toJSON ComponentButtonUrl {..} = + object + [ (name, value) + | (name, Just value) <- + [ ("type", Just $ Number 2), + ("style", Just $ Number 5), + ("label", toMaybeJSON componentButtonLabel), + ("disabled", toMaybeJSON componentButtonDisabled), + ("url", toMaybeJSON componentButtonUrl), + ("emoji", toJSON <$> componentButtonEmoji) + ] + ] + toJSON ComponentButton {..} = + object + [ (name, value) + | (name, Just value) <- + [ ("type", Just $ Number 2), + ("style", Just $ toJSON componentButtonStyle), + ("label", toMaybeJSON componentButtonLabel), + ("disabled", toMaybeJSON componentButtonDisabled), + ("custom_id", toMaybeJSON componentButtonCustomId), + ("emoji", toJSON <$> componentButtonEmoji) + ] + ] +-- | Buttton colors. +data ButtonStyle + = -- | Blurple button + ButtonStylePrimary + | -- | Grey button + ButtonStyleSecondary + | -- | Green button + ButtonStyleSuccess + | -- | Red button + ButtonStyleDanger + deriving (Show, Eq, Ord, Read) + +instance FromJSON ButtonStyle where + parseJSON = + withScientific + "ButtonStyle" + ( \case + 1 -> return ButtonStylePrimary + 2 -> return ButtonStyleSecondary + 3 -> return ButtonStyleSuccess + 4 -> return ButtonStyleDanger + _ -> fail "unrecognised non-url button style" + ) + +instance ToJSON ButtonStyle where + toJSON ButtonStylePrimary = Number 1 + toJSON ButtonStyleSecondary = Number 2 + toJSON ButtonStyleSuccess = Number 3 + toJSON ButtonStyleDanger = Number 4 + -- | Component type for a select menus. -- -- Don't directly send select menus - they need to be within an action row. data ComponentSelectMenu = ComponentSelectMenu - { componentSelectMenuCustomId :: T.Text, + { -- | Dev identifier + componentSelectMenuCustomId :: T.Text, + -- | Whether the select menu is disabled componentSelectMenuDisabled :: Bool, + -- | What options are in this select menu (up to 25) componentSelectMenuOptions :: [SelectOption], + -- | Placeholder text if nothing is selected componentSelectMenuPlaceholder :: Maybe T.Text, + -- | Minimum number of values to select (def 1, min 0, max 25) componentSelectMenuMinValues :: Maybe Integer, + -- | Maximum number of values to select (def 1, max 25) componentSelectMenuMaxValues :: Maybe Integer } - deriving (Show, Eq, Read) - -data ComponentActionRow = ComponentActionRowButton [ComponentButton] | ComponentActionRowSelectMenu ComponentSelectMenu - deriving (Show, Eq) + deriving (Show, Eq, Ord, Read) -validPartialEmoji :: Emoji -> Maybe Emoji -validPartialEmoji Emoji {..} = do - eid <- emojiId - ean <- emojiAnimated - return $ Emoji (Just eid) emojiName Nothing Nothing Nothing (Just ean) +-- | Takes the custom id and the options of the select menu that is to be +-- generated. +mkSelectMenu :: T.Text -> [SelectOption] -> ComponentSelectMenu +mkSelectMenu customId sos = ComponentSelectMenu customId False sos Nothing Nothing Nothing -instance Internals ComponentActionRow Component where - toInternal (ComponentActionRowButton as) = Component ComponentTypeActionRow Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing (Just (toInternal' <$> as)) - where - toInternal' ComponentButtonUrl {..} = Component ComponentTypeButton Nothing (Just componentButtonDisabled) (Just InternalButtonStyleLink) (Just componentButtonLabel) componentButtonEmoji (Just (R.renderUrl componentButtonUrl)) Nothing Nothing Nothing Nothing Nothing - toInternal' ComponentButton {..} = Component ComponentTypeButton (Just componentButtonCustomId) (Just componentButtonDisabled) (Just (toInternal componentButtonStyle)) (Just componentButtonLabel) componentButtonEmoji Nothing Nothing Nothing Nothing Nothing Nothing - toInternal (ComponentActionRowSelectMenu ComponentSelectMenu {..}) = Component ComponentTypeActionRow Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing (Just [Component ComponentTypeSelectMenu (Just componentSelectMenuCustomId) (Just componentSelectMenuDisabled) Nothing Nothing Nothing Nothing (Just componentSelectMenuOptions) componentSelectMenuPlaceholder componentSelectMenuMinValues componentSelectMenuMaxValues Nothing]) +instance FromJSON ComponentSelectMenu where + parseJSON = + withObject + "ComponentSelectMenu" + ( \v -> + do + t <- v .: "type" :: Parser Int + case t of + 3 -> + ComponentSelectMenu + <$> v .: "custom_id" + <*> v .:? "disabled" .!= False + <*> v .: "options" + <*> v .:? "placeholder" + <*> v .:? "min_values" + <*> v .:? "max_values" + _ -> fail "expected select menu type, got different component" + ) - fromInternal Component {componentType = ComponentTypeActionRow, componentComponents = (Just (Component {componentType = ComponentTypeSelectMenu, ..} : _))} = do - cid <- componentCustomId - cd <- componentDisabled - co <- componentOptions - return $ ComponentActionRowSelectMenu $ ComponentSelectMenu cid cd co componentPlaceholder componentMinValues componentMaxValues - fromInternal Component {componentType = ComponentTypeActionRow, componentComponents = compComps} = compComps >>= mapM fromInternal' >>= Just . ComponentActionRowButton - where - fromInternal' Component {componentType = ComponentTypeButton, componentStyle = Just InternalButtonStyleLink, ..} = do - url <- R.https <$> componentUrl - label <- componentLabel - return $ ComponentButtonUrl url (fromMaybe False componentDisabled) label componentEmoji - fromInternal' Component {componentType = ComponentTypeButton, ..} = do - customId <- componentCustomId - label <- componentLabel - style <- componentStyle >>= fromInternal - return $ ComponentButton customId (fromMaybe False componentDisabled) style label componentEmoji - fromInternal' _ = Nothing - fromInternal _ = Nothing +instance ToJSON ComponentSelectMenu where + toJSON ComponentSelectMenu {..} = + object + [ (name, value) + | (name, Just value) <- + [ ("type", Just $ Number 3), + ("custom_id", toMaybeJSON componentSelectMenuCustomId), + ("disabled", toMaybeJSON componentSelectMenuDisabled), + ("options", toMaybeJSON componentSelectMenuOptions), + ("placeholder", toJSON <$> componentSelectMenuPlaceholder), + ("min_values", toJSON <$> componentSelectMenuMinValues), + ("max_values", toJSON <$> componentSelectMenuMaxValues) + ] + ] -data Component = Component - { componentType :: ComponentType, - -- | Buttons and Select Menus only - componentCustomId :: Maybe T.Text, - -- | Buttons and Select Menus only - componentDisabled :: Maybe Bool, - -- | Button only - componentStyle :: Maybe InternalButtonStyle, - -- | Button only - componentLabel :: Maybe T.Text, - -- | Button only - componentEmoji :: Maybe Emoji, - -- | Button only, link buttons only - componentUrl :: Maybe T.Text, - -- | Select Menus only, max 25 - componentOptions :: Maybe [SelectOption], - -- | Select Menus only, max 100 chars - componentPlaceholder :: Maybe T.Text, - -- | Select Menus only, min values to choose, default 1 - componentMinValues :: Maybe Integer, - -- | Select Menus only, max values to choose, default 1 - componentMaxValues :: Maybe Integer, - -- | Action Rows only - componentComponents :: Maybe [Component] +-- | A single option in a select menu. +data SelectOption = SelectOption + { -- | User facing option name + selectOptionLabel :: T.Text, + -- | Dev facing option value + selectOptionValue :: T.Text, + -- | additional description + selectOptionDescription :: Maybe T.Text, + -- | A partial emoji to show with the object (id, name, animated) + selectOptionEmoji :: Maybe Emoji, + -- | Use this value by default + selectOptionDefault :: Maybe Bool } deriving (Show, Eq, Ord, Read) -instance FromJSON Component where - parseJSON = withObject "Component" $ \o -> - Component <$> o .: "type" - <*> o .:? "custom_id" - <*> o .:? "disabled" - <*> o .:? "style" - <*> o .:? "label" +-- | Make a select option from the given label and value. +mkSelectOption :: T.Text -> T.Text -> SelectOption +mkSelectOption label value = SelectOption label value Nothing Nothing Nothing + +instance FromJSON SelectOption where + parseJSON = withObject "SelectOption" $ \o -> + SelectOption <$> o .: "label" + <*> o .: "value" + <*> o .:? "description" <*> o .:? "emoji" - <*> o .:? "url" - <*> o .:? "options" - <*> o .:? "placeholder" - <*> o .:? "min_values" - <*> o .:? "max_values" - <*> o .:? "components" + <*> o .:? "default" -instance ToJSON Component where - toJSON Component {..} = +instance ToJSON SelectOption where + toJSON SelectOption {..} = object [ (name, value) | (name, Just value) <- - [ ("type", toMaybeJSON componentType), - ("custom_id", toJSON <$> componentCustomId), - ("disabled", toJSON <$> componentDisabled), - ("style", toJSON <$> componentStyle), - ("label", toJSON <$> componentLabel), - ("emoji", toJSON <$> componentEmoji), - ("url", toJSON <$> componentUrl), - ("options", toJSON <$> componentOptions), - ("placeholder", toJSON <$> componentPlaceholder), - ("min_values", toJSON <$> componentMinValues), - ("max_values", toJSON <$> componentMaxValues), - ("components", toJSON <$> componentComponents) + [ ("label", toMaybeJSON selectOptionLabel), + ("value", toMaybeJSON selectOptionValue), + ("description", toJSON <$> selectOptionDescription), + ("emoji", toJSON <$> selectOptionEmoji), + ("default", toJSON <$> selectOptionDefault) ] ] --- | The different types of components -data ComponentType - = -- | A container for other components - ComponentTypeActionRow - | -- | A button - ComponentTypeButton - | -- | A select menu for picking from choices - ComponentTypeSelectMenu - deriving (Show, Read, Eq, Ord, Data) - -instance Enum ComponentType where - fromEnum ComponentTypeActionRow = 1 - fromEnum ComponentTypeButton = 2 - fromEnum ComponentTypeSelectMenu = 3 - toEnum a = fromJust $ lookup a table - where - table = makeTable ComponentTypeActionRow - -instance ToJSON ComponentType where - toJSON = toJSON . fromEnum - -instance FromJSON ComponentType where - parseJSON = withScientific "StickerFormatType" (return . toEnum . round) - -data InternalButtonStyle - = -- | Blurple button - InternalButtonStylePrimary - | -- | Grey button - InternalButtonStyleSecondary - | -- | Green button - InternalButtonStyleSuccess - | -- | Red button - InternalButtonStyleDanger - | -- | Grey button, navigates to URL - InternalButtonStyleLink - deriving (Show, Read, Eq, Ord, Data) - -instance Enum InternalButtonStyle where - fromEnum InternalButtonStylePrimary = 1 - fromEnum InternalButtonStyleSecondary = 2 - fromEnum InternalButtonStyleSuccess = 3 - fromEnum InternalButtonStyleDanger = 4 - fromEnum InternalButtonStyleLink = 5 - toEnum a = fromJust $ lookup a table - where - table = makeTable InternalButtonStylePrimary - -instance ToJSON InternalButtonStyle where - toJSON = toJSON . fromEnum - -instance FromJSON InternalButtonStyle where - parseJSON = withScientific "InternalButtonStyle" (return . toEnum . round) - -- | Represents an emoticon (emoji) data Emoji = Emoji { -- | The emoji id @@ -231,6 +290,10 @@ } deriving (Show, Read, Eq, Ord) +-- | Make an emoji with only a name +mkEmoji :: T.Text -> Emoji +mkEmoji t = Emoji Nothing t Nothing Nothing Nothing Nothing + instance FromJSON Emoji where parseJSON = withObject "Emoji" $ \o -> Emoji <$> o .:? "id" @@ -253,44 +316,3 @@ ("animated", toJSON <$> emojiAnimated) ] ] - -data SelectOption = SelectOption - { -- | User facing option name - selectOptionLabel :: T.Text, - -- | Dev facing option value - selectOptionValue :: T.Text, - -- | additional description - selectOptionDescription :: Maybe T.Text, - -- | A partial emoji to show with the object (id, name, animated) - selectOptionEmoji :: Maybe Emoji, - -- | Use this value by default - selectOptionDefault :: Maybe Bool - } - deriving (Show, Eq, Ord, Read) - -instance FromJSON SelectOption where - parseJSON = withObject "SelectOption" $ \o -> - SelectOption <$> o .: "label" - <*> o .: "value" - <*> o .:? "description" - <*> o .:? "emoji" - <*> o .:? "default" - -instance ToJSON SelectOption where - toJSON SelectOption {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("label", toMaybeJSON selectOptionLabel), - ("value", toMaybeJSON selectOptionValue), - ("description", toJSON <$> selectOptionDescription), - ("emoji", toJSON <$> selectOptionEmoji), - ("default", toJSON <$> selectOptionDefault) - ] - ] - -filterOutIncorrectEmoji :: Component -> Component -filterOutIncorrectEmoji c@Component {componentType = ComponentTypeActionRow, componentComponents = (Just cs)} = c {componentComponents = Just (filterOutIncorrectEmoji <$> cs)} -filterOutIncorrectEmoji c@Component {componentType = ComponentTypeSelectMenu, componentOptions = (Just os)} = c {componentOptions = Just ((\so -> so {selectOptionEmoji = selectOptionEmoji so >>= validPartialEmoji}) <$> os)} -filterOutIncorrectEmoji c@Component {componentType = ComponentTypeButton, componentEmoji = (Just e)} = c {componentEmoji = validPartialEmoji e} -filterOutIncorrectEmoji c = c diff --git a/src/Discord/Internal/Types/Embed.hs b/src/Discord/Internal/Types/Embed.hs --- a/src/Discord/Internal/Types/Embed.hs +++ b/src/Discord/Internal/Types/Embed.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} -- | Data structures pertaining to Discord Embed @@ -9,9 +10,13 @@ import Data.Default (Default, def) import qualified Data.Text as T import qualified Data.ByteString as B +import Data.Functor ((<&>)) -import Discord.Internal.Types.Prelude +import Network.HTTP.Client.MultipartFormData (PartM, partFileRequestBody) +import Network.HTTP.Client (RequestBody(RequestBodyBS)) +import Discord.Internal.Types.Color (DiscordColor) + createEmbed :: CreateEmbed -> Embed createEmbed CreateEmbed{..} = let @@ -21,16 +26,16 @@ embedImageToUrl :: T.Text -> CreateEmbedImage -> T.Text embedImageToUrl place cei = case cei of CreateEmbedImageUrl t -> t - CreateEmbedImageUpload _ -> "attachment://" <> place <> ".png" + CreateEmbedImageUpload _ -> T.filter (/=' ') $ "attachment://" <> createEmbedTitle <> place <> ".png" - embedAuthor = EmbedAuthor (emptyMaybe createEmbedAuthorName) + embedAuthor = EmbedAuthor createEmbedAuthorName (emptyMaybe createEmbedAuthorUrl) (embedImageToUrl "author" <$> createEmbedAuthorIcon) Nothing - embedImage = EmbedImage (embedImageToUrl "image" <$> createEmbedImage) - Nothing Nothing Nothing - embedThumbnail = EmbedThumbnail (embedImageToUrl "thumbnail" <$> createEmbedThumbnail) - Nothing Nothing Nothing + embedImage = (embedImageToUrl "image" <$> createEmbedImage) <&> + \image -> EmbedImage image Nothing Nothing Nothing + embedThumbnail = (embedImageToUrl "thumbnail" <$> createEmbedThumbnail) <&> + \thumbnail -> EmbedThumbnail thumbnail Nothing Nothing Nothing embedFooter = EmbedFooter createEmbedFooterText (embedImageToUrl "footer" <$> createEmbedFooterIcon) Nothing @@ -38,16 +43,15 @@ in Embed { embedAuthor = Just embedAuthor , embedTitle = emptyMaybe createEmbedTitle , embedUrl = emptyMaybe createEmbedUrl - , embedThumbnail = Just embedThumbnail + , embedThumbnail = embedThumbnail , embedDescription = emptyMaybe createEmbedDescription , embedFields = createEmbedFields - , embedImage = Just embedImage + , embedImage = embedImage , embedFooter = Just embedFooter , embedColor = createEmbedColor - , embedTimestamp = Nothing + , embedTimestamp = createEmbedTimestamp -- can't set these - , embedType = Nothing , embedVideo = Nothing , embedProvider = Nothing } @@ -64,8 +68,8 @@ , createEmbedImage :: Maybe CreateEmbedImage , createEmbedFooterText :: T.Text , createEmbedFooterIcon :: Maybe CreateEmbedImage - , createEmbedColor :: Maybe ColorInteger ---, createEmbedTimestamp :: Maybe UTCTime + , createEmbedColor :: Maybe DiscordColor + , createEmbedTimestamp :: Maybe UTCTime } deriving (Show, Read, Eq, Ord) data CreateEmbedImage = CreateEmbedImageUrl T.Text @@ -73,7 +77,7 @@ deriving (Show, Read, Eq, Ord) instance Default CreateEmbed where - def = CreateEmbed "" "" Nothing "" "" Nothing "" [] Nothing "" Nothing Nothing -- Nothing + def = CreateEmbed "" "" Nothing "" "" Nothing "" [] Nothing "" Nothing Nothing Nothing -- | An embed attached to a message. data Embed = Embed @@ -85,9 +89,8 @@ , embedFields :: [EmbedField] -- ^ Fields of the embed , embedImage :: Maybe EmbedImage , embedFooter :: Maybe EmbedFooter - , embedColor :: Maybe ColorInteger -- ^ The embed color + , embedColor :: Maybe DiscordColor -- ^ The embed color , embedTimestamp :: Maybe UTCTime -- ^ The time of the embed content - , embedType :: Maybe T.Text -- ^ Type of embed (Always "rich" for users) , embedVideo :: Maybe EmbedVideo -- ^ Only present for "video" types , embedProvider :: Maybe EmbedProvider -- ^ Only present for "video" types } deriving (Show, Read, Eq, Ord) @@ -105,7 +108,6 @@ , "footer" .= embedFooter , "color" .= embedColor , "timestamp" .= embedTimestamp - , "type" .= embedType , "video" .= embedVideo , "provider" .= embedProvider ] @@ -122,13 +124,12 @@ <*> o .:? "footer" <*> o .:? "color" <*> o .:? "timestamp" - <*> o .:? "type" <*> o .:? "video" <*> o .:? "provider" data EmbedThumbnail = EmbedThumbnail - { embedThumbnailUrl :: Maybe T.Text + { embedThumbnailUrl :: T.Text , embedThumbnailProxyUrl :: Maybe T.Text , embedThumbnailHeight :: Maybe Integer , embedThumbnailWidth :: Maybe Integer @@ -144,32 +145,35 @@ instance FromJSON EmbedThumbnail where parseJSON = withObject "thumbnail" $ \o -> - EmbedThumbnail <$> o .:? "url" + EmbedThumbnail <$> o .: "url" <*> o .:? "proxy_url" <*> o .:? "height" <*> o .:? "width" data EmbedVideo = EmbedVideo { embedVideoUrl :: Maybe T.Text + , embedProxyUrl :: Maybe T.Text , embedVideoHeight :: Maybe Integer , embedVideoWidth :: Maybe Integer } deriving (Show, Read, Eq, Ord) instance ToJSON EmbedVideo where - toJSON (EmbedVideo a b c) = object + toJSON (EmbedVideo a a' b c) = object [ "url" .= a , "height" .= b , "width" .= c + , "proxy_url" .= a' ] instance FromJSON EmbedVideo where parseJSON = withObject "video" $ \o -> EmbedVideo <$> o .:? "url" + <*> o .:? "proxy_url" <*> o .:? "height" <*> o .:? "width" data EmbedImage = EmbedImage - { embedImageUrl :: Maybe T.Text + { embedImageUrl :: T.Text , embedImageProxyUrl :: Maybe T.Text , embedImageHeight :: Maybe Integer , embedImageWidth :: Maybe Integer @@ -185,7 +189,7 @@ instance FromJSON EmbedImage where parseJSON = withObject "image" $ \o -> - EmbedImage <$> o .:? "url" + EmbedImage <$> o .: "url" <*> o .:? "proxy_url" <*> o .:? "height" <*> o .:? "width" @@ -207,7 +211,7 @@ <*> o .:? "url" data EmbedAuthor = EmbedAuthor - { embedAuthorName :: Maybe T.Text + { embedAuthorName :: T.Text , embedAuthorUrl :: Maybe T.Text , embedAuthorIconUrl :: Maybe T.Text , embedAuthorProxyIconUrl :: Maybe T.Text @@ -223,7 +227,7 @@ instance FromJSON EmbedAuthor where parseJSON = withObject "author" $ \o -> - EmbedAuthor <$> o .:? "name" + EmbedAuthor <$> o .: "name" <*> o .:? "url" <*> o .:? "icon_url" <*> o .:? "proxy_icon_url" @@ -265,3 +269,14 @@ EmbedField <$> o .: "name" <*> o .: "value" <*> o .:? "inline" + + +maybeEmbed :: Maybe CreateEmbed -> [PartM IO] +maybeEmbed = + let mkPart (name,content) = partFileRequestBody name (T.unpack name) (RequestBodyBS content) + uploads CreateEmbed{..} = [(T.filter (/=' ') $ createEmbedTitle<>n,c) | (n, Just (CreateEmbedImageUpload c)) <- + [ ("author.png", createEmbedAuthorIcon) + , ("thumbnail.png", createEmbedThumbnail) + , ("image.png", createEmbedImage) + , ("footer.png", createEmbedFooterIcon) ]] + in maybe [] (map mkPart . uploads) diff --git a/src/Discord/Internal/Types/Events.hs b/src/Discord/Internal/Types/Events.hs --- a/src/Discord/Internal/Types/Events.hs +++ b/src/Discord/Internal/Types/Events.hs @@ -15,9 +15,9 @@ import Discord.Internal.Types.Prelude import Discord.Internal.Types.Channel -import Discord.Internal.Types.Guild ( Role, GuildInfo, GuildUnavailable, Guild ) +import Discord.Internal.Types.Guild (Role, GuildInfo, GuildUnavailable, Guild) import Discord.Internal.Types.User (User, GuildMember) -import Discord.Internal.Types.Interactions (InternalInteraction, Interaction) +import Discord.Internal.Types.Interactions (Interaction) import Discord.Internal.Types.Components (Emoji) @@ -58,7 +58,7 @@ -- | VoiceStateUpdate -- | VoiceServerUpdate | UnknownEvent T.Text Object - deriving (Show, Read, Eq) + deriving (Show, Eq) data EventInternalParse = InternalReady Int User [Channel] [GuildUnavailable] T.Text (Maybe Shard) PartialApplication @@ -92,11 +92,11 @@ | InternalPresenceUpdate PresenceInfo | InternalTypingStart TypingInfo | InternalUserUpdate User - | InternalInteractionCreate InternalInteraction - -- | InternalVoiceStateUpdate - -- | InternalVoiceServerUpdate + | InternalInteractionCreate Interaction + -- -- | InternalVoiceStateUpdate + -- -- | InternalVoiceServerUpdate | InternalUnknownEvent T.Text Object - deriving (Show, Read, Eq) + deriving (Show, Eq, Read) data PartialApplication = PartialApplication { partialApplicationID :: ApplicationId diff --git a/src/Discord/Internal/Types/Gateway.hs b/src/Discord/Internal/Types/Gateway.hs --- a/src/Discord/Internal/Types/Gateway.hs +++ b/src/Discord/Internal/Types/Gateway.hs @@ -30,7 +30,7 @@ | Hello Integer | HeartbeatAck | ParseError T.Text - deriving (Show, Read, Eq) + deriving (Show, Eq, Read) -- | Sent to gateway by our library data GatewaySendableInternal @@ -80,7 +80,7 @@ compileGatewayIntent :: GatewayIntent -> Int compileGatewayIntent GatewayIntent{..} = sum $ [ if on then flag else 0 - | (flag, on) <- [ (2 ^ 0, gatewayIntentGuilds) + | (flag, on) <- [ ( 1, gatewayIntentGuilds) , (2 ^ 1, gatewayIntentMembers) , (2 ^ 2, gatewayIntentBans) , (2 ^ 3, gatewayIntentEmojis) @@ -169,7 +169,7 @@ ejson <- o .: "d" case ejson of Object hm -> Dispatch <$> eventParse etype hm <*> o .: "s" - _other -> Dispatch (InternalUnknownEvent ("Dispatch payload wasn't an object") o) + _other -> Dispatch (InternalUnknownEvent "Dispatch payload wasn't an object" o) <$> o .: "s" 1 -> HeartbeatRequest . fromMaybe 0 . readMaybe <$> o .: "d" 7 -> pure Reconnect diff --git a/src/Discord/Internal/Types/Guild.hs b/src/Discord/Internal/Types/Guild.hs --- a/src/Discord/Internal/Types/Guild.hs +++ b/src/Discord/Internal/Types/Guild.hs @@ -10,6 +10,7 @@ import qualified Data.Text as T import Discord.Internal.Types.Prelude +import Discord.Internal.Types.Color (DiscordColor) import Discord.Internal.Types.Channel (Channel) import Discord.Internal.Types.User (User, GuildMember) import Discord.Internal.Types.Components (Emoji) @@ -116,10 +117,10 @@ Role { roleId :: RoleId -- ^ The role id , roleName :: T.Text -- ^ The role name - , roleColor :: ColorInteger -- ^ Integer representation of color code + , roleColor :: DiscordColor -- ^ Integer representation of color code , roleHoist :: Bool -- ^ If the role is pinned in the user listing , rolePos :: Integer -- ^ Position of this role - , rolePerms :: T.Text -- ^ Permission bit set + , rolePerms :: T.Text -- ^ Permission bit set , roleManaged :: Bool -- ^ Whether this role is managed by an integration , roleMention :: Bool -- ^ Whether this role is mentionable } deriving (Show, Read, Eq, Ord) diff --git a/src/Discord/Internal/Types/Interactions.hs b/src/Discord/Internal/Types/Interactions.hs --- a/src/Discord/Internal/Types/Interactions.hs +++ b/src/Discord/Internal/Types/Interactions.hs @@ -1,9 +1,10 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} module Discord.Internal.Types.Interactions @@ -14,22 +15,16 @@ InteractionDataApplicationCommandOptionSubcommandOrGroup (..), InteractionDataApplicationCommandOptionSubcommand (..), InteractionDataApplicationCommandOptionValue (..), - ApplicationCommandInteractionDataValue (..), - InternalInteraction (..), InteractionToken, - InteractionType, - InternalInteractionData (..), ResolvedData (..), - InternalInteractionDataApplicationCommandOption (..), + MemberOrUser (..), InteractionResponse (..), interactionResponseBasic, - InteractionCallbackType (..), - InteractionCallbackData (..), - InteractionCallbackAutocomplete, - InteractionCallbackMessages (..), - interactionCallbackMessagesBasic, - InteractionCallbackDataFlags (..), - InteractionCallbackDataFlag (..), + InteractionResponseAutocomplete (..), + InteractionResponseMessage (..), + interactionResponseMessageBasic, + InteractionResponseMessageFlags (..), + InteractionResponseMessageFlag (..), ) where @@ -37,344 +32,393 @@ import Data.Aeson import Data.Aeson.Types (Parser) import Data.Bits (Bits (shift, (.|.))) -import Data.Data (Data) -import Data.Maybe (fromJust, fromMaybe) +import Data.Foldable (Foldable (toList)) import Data.Scientific (Scientific) import qualified Data.Text as T -import Discord.Internal.Types.ApplicationCommands - ( - InternalApplicationCommandOptionChoice, - ApplicationCommandOptionType (..), - ApplicationCommandType (..), - ) +import Discord.Internal.Types.ApplicationCommands (Choice) import Discord.Internal.Types.Channel (AllowedMentions, Attachment, Message) -import Discord.Internal.Types.Components (Component, ComponentType (..)) -import Discord.Internal.Types.Embed (Embed) -import Discord.Internal.Types.Prelude (ApplicationId, ApplicationCommandId, ChannelId, GuildId, InteractionId, InteractionToken, InteractionType (..), Internals (..), MessageId, Snowflake, UserId, makeTable, toMaybeJSON) +import Discord.Internal.Types.Components (ComponentActionRow) +import Discord.Internal.Types.Embed (CreateEmbed, createEmbed) +import Discord.Internal.Types.Prelude (ApplicationCommandId, ApplicationId, ChannelId, GuildId, InteractionId, InteractionToken, MessageId, RoleId, Snowflake, UserId) import Discord.Internal.Types.User (GuildMember, User) -import Debug.Trace - +-- | An interaction received from discord. data Interaction = InteractionComponent - { interactionId :: InteractionId, + { -- | The id of this interaction. + interactionId :: InteractionId, + -- | The id of the application that this interaction belongs to. interactionApplicationId :: ApplicationId, - interactionDataComponent :: Maybe InteractionDataComponent, -- referenced as Data in API + -- | The data for this interaction. + interactionDataComponent :: InteractionDataComponent, + -- | What guild this interaction comes from. interactionGuildId :: Maybe GuildId, + -- | What channel this interaction comes from. interactionChannelId :: Maybe ChannelId, - interactionMember :: Maybe GuildMember, - interactionUser :: Maybe User, + -- | What user/member this interaction comes from. + interactionUser :: MemberOrUser, + -- | The unique token that represents this interaction. interactionToken :: InteractionToken, + -- | What version of interaction is this (always 1). interactionVersion :: Int, - interactionMessage :: Message + -- | What message is associated with this interaction. + interactionMessage :: Message, + -- | The invoking user's preferred locale. + interactionLocale :: T.Text, + -- | The invoking guild's preferred locale. + interactionGuildLocale :: Maybe T.Text } | InteractionPing - { interactionId :: InteractionId, + { -- | The id of this interaction. + interactionId :: InteractionId, + -- | The id of the application that this interaction belongs to. interactionApplicationId :: ApplicationId, + -- | The unique token that represents this interaction. interactionToken :: InteractionToken, + -- | What version of interaction is this (always 1). interactionVersion :: Int } | InteractionApplicationCommand - { interactionId :: InteractionId, + { -- | The id of this interaction. + interactionId :: InteractionId, + -- | The id of the application that this interaction belongs to. interactionApplicationId :: ApplicationId, - interactionDataApplicationCommand :: Maybe InteractionDataApplicationCommand, -- referenced as Data in API + -- | The data for this interaction. + interactionDataApplicationCommand :: InteractionDataApplicationCommand, + -- | What guild this interaction comes from. interactionGuildId :: Maybe GuildId, + -- | What channel this interaction comes from. interactionChannelId :: Maybe ChannelId, - interactionMember :: Maybe GuildMember, - interactionUser :: Maybe User, + -- | What user/member this interaction comes from. + interactionUser :: MemberOrUser, + -- | The unique token that represents this interaction. interactionToken :: InteractionToken, - interactionVersion :: Int + -- | What version of interaction is this (always 1). + interactionVersion :: Int, + -- | The invoking user's preferred locale. + interactionLocale :: T.Text, + -- | The invoking guild's preferred locale. + interactionGuildLocale :: Maybe T.Text } | InteractionApplicationCommandAutocomplete - { interactionId :: InteractionId, + { -- | The id of this interaction. + interactionId :: InteractionId, + -- | The id of the application that this interaction belongs to. interactionApplicationId :: ApplicationId, - interactionDataApplicationCommand :: Maybe InteractionDataApplicationCommand, -- referenced as Data in API + -- | The data for this interaction. + interactionDataApplicationCommand :: InteractionDataApplicationCommand, + -- | What guild this interaction comes from. interactionGuildId :: Maybe GuildId, + -- | What channel this interaction comes from. interactionChannelId :: Maybe ChannelId, - interactionMember :: Maybe GuildMember, - interactionUser :: Maybe User, + -- | What user/member this interaction comes from. + interactionUser :: MemberOrUser, + -- | The unique token that represents this interaction. interactionToken :: InteractionToken, - interactionVersion :: Int + -- | What version of interaction is this (always 1). + interactionVersion :: Int, + -- | The invoking user's preferred locale. + interactionLocale :: T.Text, + -- | The invoking guild's preferred locale. + interactionGuildLocale :: Maybe T.Text } - | InteractionUnknown InternalInteraction - deriving (Show, Read, Eq) + deriving (Show, Eq, Read) +instance FromJSON Interaction where + parseJSON = + withObject + "Interaction" + ( \v -> do + iid <- v .: "id" + aid <- v .: "application_id" + gid <- v .:? "guild_id" + cid <- v .:? "channel_id" + tok <- v .: "token" + version <- v .: "version" + glocale <- v .:? "guild_locale" + t <- v .: "type" :: Parser Int + case t of + 1 -> return $ InteractionPing iid aid tok version + 2 -> + InteractionApplicationCommand iid aid + <$> v .: "data" + <*> return gid + <*> return cid + <*> parseJSON (Object v) + <*> return tok + <*> return version + <*> v .: "locale" + <*> return glocale + 3 -> + InteractionComponent iid aid + <$> v .: "data" + <*> return gid + <*> return cid + <*> parseJSON (Object v) + <*> return tok + <*> return version + <*> v .: "message" + <*> v .: "locale" + <*> return glocale + 4 -> + InteractionApplicationCommandAutocomplete iid aid + <$> v .: "data" + <*> return gid + <*> return cid + <*> parseJSON (Object v) + <*> return tok + <*> return version + <*> v .: "locale" + <*> return glocale + _ -> fail "unknown interaction type" + ) + +newtype MemberOrUser = MemberOrUser (Either GuildMember User) deriving (Show, Eq, Read) + +instance {-# OVERLAPPING #-} FromJSON MemberOrUser where + parseJSON = + withObject + "MemberOrUser" + ( \v -> MemberOrUser <$> ((Left <$> v .: "member") <|> (Right <$> v .: "user")) + ) + data InteractionDataComponent = InteractionDataComponentButton - { -- | Component only, the unique id + { -- | The unique id of the component (up to 100 characters). interactionDataComponentCustomId :: T.Text } | InteractionDataComponentSelectMenu - { interactionDataComponentCustomId :: T.Text, + { -- | The unique id of the component (up to 100 characters). + interactionDataComponentCustomId :: T.Text, + -- | Values for the select menu. interactionDataComponentValues :: [T.Text] } deriving (Show, Read, Eq) +instance FromJSON InteractionDataComponent where + parseJSON = + withObject + "InteractionDataComponent" + ( \v -> do + cid <- v .: "custom_id" + t <- v .: "component_type" :: Parser Int + case t of + 2 -> return $ InteractionDataComponentButton cid + 3 -> + InteractionDataComponentSelectMenu cid + <$> v .: "values" + _ -> fail "unknown interaction data component type" + ) + data InteractionDataApplicationCommand = InteractionDataApplicationCommandUser - { -- | id of the invoked command + { -- | Id of the invoked command. interactionDataApplicationCommandId :: ApplicationCommandId, - -- | name of the invoked command + -- | Name of the invoked command. interactionDataApplicationCommandName :: T.Text, - -- | the resolved data in the command + -- | The resolved data in the command. interactionDataApplicationCommandResolvedData :: Maybe ResolvedData, - -- | the target of the command + -- | The id of the user that is the target. interactionDataApplicationCommandTargetId :: UserId } | InteractionDataApplicationCommandMessage - { -- | Application command only, id of the invoked command + { -- | Id of the invoked command. interactionDataApplicationCommandId :: ApplicationCommandId, - -- | Application command only, name of the invoked command + -- | Name of the invoked command. interactionDataApplicationCommandName :: T.Text, + -- | The resolved data in the command. interactionDataApplicationCommandResolvedData :: Maybe ResolvedData, + -- | The id of the message that is the target. interactionDataApplicationCommandTargetId :: MessageId } | InteractionDataApplicationCommandChatInput - { -- | Application command only, id of the invoked command + { -- | Id of the invoked command. interactionDataApplicationCommandId :: ApplicationCommandId, - -- | Application command only, name of the invoked command + -- | Name of the invoked command. interactionDataApplicationCommandName :: T.Text, + -- | The resolved data in the command. interactionDataApplicationCommandResolvedData :: Maybe ResolvedData, + -- | The options of the application command. interactionDataApplicationCommandOptions :: Maybe InteractionDataApplicationCommandOptions } deriving (Show, Read, Eq) +instance FromJSON InteractionDataApplicationCommand where + parseJSON = + withObject + "InteractionDataApplicationCommand" + ( \v -> do + aci <- v .: "id" + name <- v .: "name" + rd <- v .:? "resolved_data" + t <- v .: "type" :: Parser Int + case t of + 1 -> + InteractionDataApplicationCommandChatInput aci name rd + <$> v .:? "options" + 2 -> + InteractionDataApplicationCommandUser aci name rd + <$> v .: "target_id" + 3 -> + InteractionDataApplicationCommandMessage aci name rd + <$> v .: "target_id" + _ -> fail "unknown interaction data component type" + ) + +-- | Either subcommands and groups, or values. data InteractionDataApplicationCommandOptions = InteractionDataApplicationCommandOptionsSubcommands [InteractionDataApplicationCommandOptionSubcommandOrGroup] | InteractionDataApplicationCommandOptionsValues [InteractionDataApplicationCommandOptionValue] deriving (Show, Read, Eq) +instance FromJSON InteractionDataApplicationCommandOptions where + parseJSON = + withArray + "InteractionDataApplicationCommandOptions" + ( \a -> do + let a' = toList a + case a' of + [] -> return $ InteractionDataApplicationCommandOptionsValues [] + (v' : _) -> + withObject + "InteractionDataApplicationCommandOptions item" + ( \v -> do + t <- v .: "type" :: Parser Int + if t == 1 || t == 2 + then InteractionDataApplicationCommandOptionsSubcommands <$> mapM parseJSON a' + else InteractionDataApplicationCommandOptionsValues <$> mapM parseJSON a' + ) + v' + ) + +-- | Either a subcommand group or a subcommand. data InteractionDataApplicationCommandOptionSubcommandOrGroup = InteractionDataApplicationCommandOptionSubcommandGroup { interactionDataApplicationCommandOptionSubcommandGroupName :: T.Text, interactionDataApplicationCommandOptionSubcommandGroupOptions :: [InteractionDataApplicationCommandOptionSubcommand], - interactionDataApplicationCommandOptionSubcommandGroupFocused :: Maybe Bool + interactionDataApplicationCommandOptionSubcommandGroupFocused :: Bool } | InteractionDataApplicationCommandOptionSubcommandOrGroupSubcommand InteractionDataApplicationCommandOptionSubcommand deriving (Show, Read, Eq) +instance FromJSON InteractionDataApplicationCommandOptionSubcommandOrGroup where + parseJSON = + withObject + "InteractionDataApplicationCommandOptionSubcommandOrGroup" + ( \v -> do + t <- v .: "type" :: Parser Int + case t of + 2 -> + InteractionDataApplicationCommandOptionSubcommandGroup + <$> v .: "name" + <*> v .: "options" + <*> v .:? "focused" .!= False + 1 -> InteractionDataApplicationCommandOptionSubcommandOrGroupSubcommand <$> parseJSON (Object v) + _ -> fail "unexpected subcommand group type" + ) + +-- | Data for a single subcommand. data InteractionDataApplicationCommandOptionSubcommand = InteractionDataApplicationCommandOptionSubcommand { interactionDataApplicationCommandOptionSubcommandName :: T.Text, interactionDataApplicationCommandOptionSubcommandOptions :: [InteractionDataApplicationCommandOptionValue], - interactionDataApplicationCommandOptionSubcommandFocused :: Maybe Bool - } - deriving (Show, Read, Eq) - -data InteractionDataApplicationCommandOptionValue = InteractionDataApplicationCommandOptionValue - { interactionDataApplicationCommandOptionValueName :: T.Text, - interactionDataApplicationCommandOptionValueValue :: ApplicationCommandInteractionDataValue, - interactionDataApplicationCommandOptionValueFocused :: Maybe Bool - } - deriving (Show, Read, Eq) - -instance Internals InteractionDataApplicationCommandOptionValue InternalInteractionDataApplicationCommandOption where - toInternal InteractionDataApplicationCommandOptionValue {..} = InternalInteractionDataApplicationCommandOption interactionDataApplicationCommandOptionValueName (getTypeFromACIDV interactionDataApplicationCommandOptionValueValue) (Just interactionDataApplicationCommandOptionValueValue) Nothing interactionDataApplicationCommandOptionValueFocused - - fromInternal InternalInteractionDataApplicationCommandOption {..} - | internalInteractionDataApplicationCommandOptionType `elem` [ApplicationCommandOptionTypeSubcommand, ApplicationCommandOptionTypeSubcommandGroup] = Nothing - | otherwise = do - v <- trace ("this" ++ show internalInteractionDataApplicationCommandOptionValue) internalInteractionDataApplicationCommandOptionValue - return $ InteractionDataApplicationCommandOptionValue internalInteractionDataApplicationCommandOptionName v internalInteractionDataApplicationCommandOptionFocused - -instance Internals InteractionDataApplicationCommandOptionSubcommand InternalInteractionDataApplicationCommandOption where - toInternal InteractionDataApplicationCommandOptionSubcommand {..} = - InternalInteractionDataApplicationCommandOption interactionDataApplicationCommandOptionSubcommandName ApplicationCommandOptionTypeSubcommand Nothing (Just $ toInternal <$> interactionDataApplicationCommandOptionSubcommandOptions) interactionDataApplicationCommandOptionSubcommandFocused - - fromInternal InternalInteractionDataApplicationCommandOption {internalInteractionDataApplicationCommandOptionType = ApplicationCommandOptionTypeSubcommand, ..} = do - o <- internalInteractionDataApplicationCommandOptionOptions - o' <- mapM fromInternal o - return $ InteractionDataApplicationCommandOptionSubcommand internalInteractionDataApplicationCommandOptionName o' internalInteractionDataApplicationCommandOptionFocused - fromInternal _ = Nothing - -instance Internals InteractionDataApplicationCommandOptionSubcommandOrGroup InternalInteractionDataApplicationCommandOption where - toInternal InteractionDataApplicationCommandOptionSubcommandGroup {..} = - InternalInteractionDataApplicationCommandOption interactionDataApplicationCommandOptionSubcommandGroupName ApplicationCommandOptionTypeSubcommand Nothing (Just $ toInternal <$> interactionDataApplicationCommandOptionSubcommandGroupOptions) interactionDataApplicationCommandOptionSubcommandGroupFocused - toInternal (InteractionDataApplicationCommandOptionSubcommandOrGroupSubcommand s) = toInternal s - - fromInternal InternalInteractionDataApplicationCommandOption {internalInteractionDataApplicationCommandOptionType = ApplicationCommandOptionTypeSubcommandGroup, ..} = do - o <- internalInteractionDataApplicationCommandOptionOptions - o' <- mapM fromInternal o - return $ InteractionDataApplicationCommandOptionSubcommandGroup internalInteractionDataApplicationCommandOptionName o' internalInteractionDataApplicationCommandOptionFocused - fromInternal i@InternalInteractionDataApplicationCommandOption {internalInteractionDataApplicationCommandOptionType = ApplicationCommandOptionTypeSubcommand, ..} = InteractionDataApplicationCommandOptionSubcommandOrGroupSubcommand <$> fromInternal i - fromInternal _ = Nothing - -instance Internals InteractionDataApplicationCommandOptions [InternalInteractionDataApplicationCommandOption] where - toInternal (InteractionDataApplicationCommandOptionsSubcommands lst) = toInternal <$> lst - toInternal (InteractionDataApplicationCommandOptionsValues lst) = toInternal <$> lst - - fromInternal is = (InteractionDataApplicationCommandOptionsSubcommands <$> mapM fromInternal is) <|> (InteractionDataApplicationCommandOptionsValues <$> mapM fromInternal is) - -instance Internals InteractionDataApplicationCommand InternalInteractionData where - toInternal InteractionDataApplicationCommandUser {..} = InternalInteractionData (Just interactionDataApplicationCommandId) (Just interactionDataApplicationCommandName) (Just ApplicationCommandTypeUser) interactionDataApplicationCommandResolvedData Nothing Nothing Nothing Nothing Nothing - toInternal InteractionDataApplicationCommandMessage {..} = InternalInteractionData (Just interactionDataApplicationCommandId) (Just interactionDataApplicationCommandName) (Just ApplicationCommandTypeMessage) interactionDataApplicationCommandResolvedData Nothing Nothing Nothing Nothing Nothing - toInternal InteractionDataApplicationCommandChatInput {..} = InternalInteractionData (Just interactionDataApplicationCommandId) (Just interactionDataApplicationCommandName) (Just ApplicationCommandTypeMessage) interactionDataApplicationCommandResolvedData (toInternal <$> interactionDataApplicationCommandOptions) Nothing Nothing Nothing Nothing - - fromInternal InternalInteractionData {internalInteractionDataApplicationCommandType = Just ApplicationCommandTypeUser, ..} = do - aid <- internalInteractionDataApplicationCommandId - name <- internalInteractionDataApplicationCommandName - tid <- internalInteractionDataTargetId - return $ InteractionDataApplicationCommandUser aid name internalInteractionDataResolved tid - fromInternal InternalInteractionData {internalInteractionDataApplicationCommandType = Just ApplicationCommandTypeMessage, ..} = do - aid <- internalInteractionDataApplicationCommandId - name <- internalInteractionDataApplicationCommandName - tid <- internalInteractionDataTargetId - return $ InteractionDataApplicationCommandMessage aid name internalInteractionDataResolved tid - fromInternal InternalInteractionData {internalInteractionDataApplicationCommandType = Just ApplicationCommandTypeChatInput, ..} = do - aid <- internalInteractionDataApplicationCommandId - name <- internalInteractionDataApplicationCommandName - return $ InteractionDataApplicationCommandChatInput aid name internalInteractionDataResolved (internalInteractionDataOptions >>= fromInternal) - fromInternal _ = Nothing - -instance Internals InteractionDataComponent InternalInteractionData where - toInternal InteractionDataComponentButton {..} = InternalInteractionData Nothing Nothing Nothing Nothing Nothing (Just interactionDataComponentCustomId) (Just ComponentTypeButton) Nothing Nothing - toInternal InteractionDataComponentSelectMenu {..} = InternalInteractionData Nothing Nothing Nothing Nothing Nothing (Just interactionDataComponentCustomId) (Just ComponentTypeSelectMenu) (Just interactionDataComponentValues) Nothing - - fromInternal InternalInteractionData {internalInteractionDataComponentType = Just ComponentTypeButton, ..} = InteractionDataComponentButton <$> internalInteractionDataCustomId - fromInternal InternalInteractionData {internalInteractionDataComponentType = Just ComponentTypeSelectMenu, ..} = InteractionDataComponentSelectMenu <$> internalInteractionDataCustomId <*> internalInteractionDataValues - fromInternal _ = Nothing - -instance Internals Interaction InternalInteraction where - toInternal InteractionPing {..} = InternalInteraction interactionId interactionApplicationId InteractionTypePing Nothing Nothing Nothing Nothing Nothing interactionToken interactionVersion Nothing - toInternal InteractionComponent {..} = InternalInteraction interactionId interactionApplicationId InteractionTypeMessageComponent (toInternal <$> interactionDataComponent) interactionGuildId interactionChannelId interactionMember interactionUser interactionToken interactionVersion (Just interactionMessage) - toInternal InteractionApplicationCommand {..} = InternalInteraction interactionId interactionApplicationId InteractionTypeApplicationCommand (toInternal <$> interactionDataApplicationCommand) interactionGuildId interactionChannelId interactionMember interactionUser interactionToken interactionVersion Nothing - toInternal InteractionApplicationCommandAutocomplete {..} = InternalInteraction interactionId interactionApplicationId InteractionTypeApplicationCommandAutocomplete (toInternal <$> interactionDataApplicationCommand) interactionGuildId interactionChannelId interactionMember interactionUser interactionToken interactionVersion Nothing - toInternal (InteractionUnknown i) = i - - fromInternal InternalInteraction {internalInteractionType = InteractionTypePing, ..} = Just $ InteractionPing internalInteractionId internalInteractionApplicationId internalInteractionToken internalInteractionVersion - fromInternal i@InternalInteraction {internalInteractionType = InteractionTypeMessageComponent, ..} = Just $ fromMaybe (InteractionUnknown i) $ internalInteractionMessage >>= Just . InteractionComponent internalInteractionId internalInteractionApplicationId (internalInteractionData >>= fromInternal) internalInteractionGuildId internalInteractionChannelId internalInteractionMember internalInteractionUser internalInteractionToken internalInteractionVersion - fromInternal i@InternalInteraction {internalInteractionType=InteractionTypeApplicationCommandAutocomplete,..} = Just $ fromMaybe (InteractionUnknown i) $ process internalInteractionData - where process Nothing = Just $ InteractionApplicationCommandAutocomplete internalInteractionId internalInteractionApplicationId Nothing internalInteractionGuildId internalInteractionChannelId internalInteractionMember internalInteractionUser internalInteractionToken internalInteractionVersion - process (Just d) = fromInternal d >>= \d' -> Just $ InteractionApplicationCommandAutocomplete internalInteractionId internalInteractionApplicationId (Just d') internalInteractionGuildId internalInteractionChannelId internalInteractionMember internalInteractionUser internalInteractionToken internalInteractionVersion - fromInternal i@InternalInteraction {internalInteractionType=InteractionTypeApplicationCommand,..} = Just $ fromMaybe (InteractionUnknown i) $ process internalInteractionData - where process Nothing = Just $ InteractionApplicationCommand internalInteractionId internalInteractionApplicationId Nothing internalInteractionGuildId internalInteractionChannelId internalInteractionMember internalInteractionUser internalInteractionToken internalInteractionVersion - process (Just d) = fromInternal d >>= \d' -> Just $ InteractionApplicationCommand internalInteractionId internalInteractionApplicationId (Just d') internalInteractionGuildId internalInteractionChannelId internalInteractionMember internalInteractionUser internalInteractionToken internalInteractionVersion - -- Just $ InteractionApplicationCommand internalInteractionId internalInteractionApplicationId (internalInteractionType == InteractionTypeApplicationCommandAutocomplete) (internalInteractionData >>= fromInternal) internalInteractionGuildId internalInteractionChannelId internalInteractionMember internalInteractionUser internalInteractionToken internalInteractionVersion - --- instance Internals Interaction InternalInteraction where - --- application command id --- application command name --- application command type -- this should be defined in the constructor! --- resolved data -- this should be formalised and integrated, instead of being --- left as values --- options -- only present if type is subcommand or subcommand group - --- | This is the data that is recieved when an interaction occurs. --- --- https://discord.com/developers/docs/interactions/receiving-and-responding#interaction-object-interaction-structure -data InternalInteraction = InternalInteraction - { internalInteractionId :: InteractionId, - internalInteractionApplicationId :: ApplicationId, - internalInteractionType :: InteractionType, -- referenced as Type in API - internalInteractionData :: Maybe InternalInteractionData, -- referenced as Data in API - internalInteractionGuildId :: Maybe GuildId, - internalInteractionChannelId :: Maybe ChannelId, - internalInteractionMember :: Maybe GuildMember, - internalInteractionUser :: Maybe User, - internalInteractionToken :: InteractionToken, - internalInteractionVersion :: Int, - internalInteractionMessage :: Maybe Message + interactionDataApplicationCommandOptionSubcommandFocused :: Bool } deriving (Show, Read, Eq) -instance ToJSON InternalInteraction where - toJSON InternalInteraction {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("id", toMaybeJSON internalInteractionId), - ("application_id", toMaybeJSON internalInteractionApplicationId), - ("type", toMaybeJSON internalInteractionType), - ("data", toJSON <$> internalInteractionData), - ("guild_id", toJSON <$> internalInteractionGuildId), - ("channel_id", toJSON <$> internalInteractionChannelId), - ("member", toJSON <$> internalInteractionMember), - ("user", toJSON <$> internalInteractionUser), - ("token", toMaybeJSON internalInteractionToken), - ("version", toMaybeJSON internalInteractionVersion), - ("message", toJSON <$> internalInteractionMessage) - ] - ] - -instance FromJSON InternalInteraction where +instance FromJSON InteractionDataApplicationCommandOptionSubcommand where parseJSON = withObject - "InternalInteraction" - ( \v -> - InternalInteraction - <$> v .: "id" - <*> v .: "application_id" - <*> v .: "type" - <*> v .:? "data" - <*> v .:? "guild_id" - <*> v .:? "channel_id" - <*> v .:? "member" - <*> v .:? "user" - <*> v .: "token" - <*> v .: "version" - <*> v .:? "message" + "InteractionDataApplicationCommandOptionSubcommand" + ( \v -> do + t <- v .: "type" :: Parser Int + case t of + 1 -> + InteractionDataApplicationCommandOptionSubcommand + <$> v .: "name" + <*> v .:? "options" .!= [] + <*> v .:? "focused" .!= False + _ -> fail "unexpected subcommand type" ) --- | This is received if the interaction was a component or application command. --- --- https://discord.com/developers/docs/interactions/receiving-and-responding#interaction-object-interaction-data-structure -data InternalInteractionData = InternalInteractionData - { -- | Application command only, id of the invoked command - internalInteractionDataApplicationCommandId :: Maybe ApplicationCommandId, - -- | Application command only, name of the invoked command - internalInteractionDataApplicationCommandName :: Maybe T.Text, - -- | Application command only, the type of the invoked command - internalInteractionDataApplicationCommandType :: Maybe ApplicationCommandType, - -- | Application command only, converted users, roles, channels - internalInteractionDataResolved :: Maybe ResolvedData, - -- | Application command only, params and values - internalInteractionDataOptions :: Maybe [InternalInteractionDataApplicationCommandOption], - -- | Component only, the unique id - internalInteractionDataCustomId :: Maybe T.Text, - -- | Component only, the type of the component - internalInteractionDataComponentType :: Maybe ComponentType, - -- | Component only, the selected options if component is the select type - internalInteractionDataValues :: Maybe [T.Text], - -- | This is the id of the user or message being targetted by a user command - -- or a message command - internalInteractionDataTargetId :: Maybe Snowflake - } +-- | Data for a single value. +data InteractionDataApplicationCommandOptionValue + = InteractionDataApplicationCommandOptionValueString + { interactionDataApplicationCommandOptionValueName :: T.Text, + interactionDataApplicationCommandOptionValueStringValue :: Either T.Text T.Text + } + | InteractionDataApplicationCommandOptionValueInteger + { interactionDataApplicationCommandOptionValueName :: T.Text, + interactionDataApplicationCommandOptionValueIntegerValue :: Either T.Text Integer + } + | InteractionDataApplicationCommandOptionValueBoolean + { interactionDataApplicationCommandOptionValueName :: T.Text, + interactionDataApplicationCommandOptionValueBooleanValue :: Bool + } + | InteractionDataApplicationCommandOptionValueUser + { interactionDataApplicationCommandOptionValueName :: T.Text, + interactionDataApplicationCommandOptionValueUserValue :: UserId + } + | InteractionDataApplicationCommandOptionValueChannel + { interactionDataApplicationCommandOptionValueName :: T.Text, + interactionDataApplicationCommandOptionValueChannelValue :: ChannelId + } + | InteractionDataApplicationCommandOptionValueRole + { interactionDataApplicationCommandOptionValueName :: T.Text, + interactionDataApplicationCommandOptionValueRoleValue :: RoleId + } + | InteractionDataApplicationCommandOptionValueMentionable + { interactionDataApplicationCommandOptionValueName :: T.Text, + interactionDataApplicationCommandOptionValueMentionableValue :: Snowflake + } + | InteractionDataApplicationCommandOptionValueNumber + { interactionDataApplicationCommandOptionValueName :: T.Text, + interactionDataApplicationCommandOptionValueNumberValue :: Either T.Text Scientific + } deriving (Show, Read, Eq) -instance ToJSON InternalInteractionData where - toJSON InternalInteractionData {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("id", toJSON <$> internalInteractionDataApplicationCommandId), - ("name", toJSON <$> internalInteractionDataApplicationCommandName), - ("type", toJSON <$> internalInteractionDataApplicationCommandType), - ("resolved", toJSON <$> internalInteractionDataResolved), - ("options", toJSON <$> internalInteractionDataOptions), - ("custom_id", toJSON <$> internalInteractionDataCustomId), - ("component_type", toJSON <$> internalInteractionDataComponentType), - ("values", toJSON <$> internalInteractionDataValues), - ("target_id", toJSON <$> internalInteractionDataTargetId) - ] - ] - -instance FromJSON InternalInteractionData where +instance FromJSON InteractionDataApplicationCommandOptionValue where parseJSON = withObject - "InternalInteractionData" - ( \v -> - InternalInteractionData - <$> v .:? "id" - <*> v .:? "name" - <*> v .:? "type" - <*> v .:? "resolved" - <*> v .:? "options" - <*> v .:? "custom_id" - <*> v .:? "component_type" - <*> v .:? "values" - <*> v .:? "target_id" + "InteractionDataApplicationCommandOptionValue" + ( \v -> do + name <- v .: "name" + focused <- v .:? "focused" .!= False + t <- v .: "type" :: Parser Int + case t of + 3 -> + InteractionDataApplicationCommandOptionValueString name + <$> parseValue v focused + 4 -> + InteractionDataApplicationCommandOptionValueInteger name + <$> parseValue v focused + 10 -> + InteractionDataApplicationCommandOptionValueNumber name + <$> parseValue v focused + 5 -> + InteractionDataApplicationCommandOptionValueBoolean name + <$> v .: "value" + 6 -> + InteractionDataApplicationCommandOptionValueUser name + <$> v .: "value" + 7 -> + InteractionDataApplicationCommandOptionValueChannel name + <$> v .: "value" + 8 -> + InteractionDataApplicationCommandOptionValueRole name + <$> v .: "value" + 9 -> + InteractionDataApplicationCommandOptionValueMentionable name + <$> v .: "value" + _ -> fail $ "unexpected interaction data application command option value type: " ++ show t ) +parseValue :: (FromJSON a) => Object -> Bool -> Parser (Either T.Text a) +parseValue o True = Left <$> o .: "value" +parseValue o False = Right <$> o .: "value" + +-- resolved data -- this should be formalised and integrated, instead of being +-- left as values + -- | I'm not sure what this stuff is, so you're on your own. -- -- It's not worth the time working out how to create this stuff. @@ -413,141 +457,72 @@ <*> v .:? "channels" ) --- | The application command payload for an interaction. -data InternalInteractionDataApplicationCommandOption = InternalInteractionDataApplicationCommandOption - { internalInteractionDataApplicationCommandOptionName :: T.Text, - internalInteractionDataApplicationCommandOptionType :: ApplicationCommandOptionType, - -- | The value itself. Mutually exclusive with options. Docs are wrong that it's only numbers and strings. - internalInteractionDataApplicationCommandOptionValue :: Maybe ApplicationCommandInteractionDataValue, - -- | Only present in group subcommands and subcommands. Mutually exclusive with value. - internalInteractionDataApplicationCommandOptionOptions :: Maybe [InternalInteractionDataApplicationCommandOption], - -- | Whether this is the field that the user is currently typing in. - internalInteractionDataApplicationCommandOptionFocused :: Maybe Bool - } - deriving (Show, Read, Eq) - -instance ToJSON InternalInteractionDataApplicationCommandOption where - toJSON InternalInteractionDataApplicationCommandOption {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("name", toMaybeJSON internalInteractionDataApplicationCommandOptionName), - ("type", toMaybeJSON internalInteractionDataApplicationCommandOptionType), - ("value", toJSON <$> internalInteractionDataApplicationCommandOptionValue), - ("options", toJSON <$> internalInteractionDataApplicationCommandOptionOptions), - ("focused", toJSON <$> internalInteractionDataApplicationCommandOptionFocused) - ] - ] - -instance FromJSON InternalInteractionDataApplicationCommandOption where - parseJSON = - withObject - "InternalInteractionDataApplicationCommandOption" - ( \v -> - InternalInteractionDataApplicationCommandOption - <$> v .: "name" - <*> typeParser v - <*> (typeParser v >>= \t -> v .:? "value" >>= valueParser t) - <*> v .:? "options" - <*> v .:? "focused" - ) - where - typeParser v = v .: "type" - valueParser t (Just v) = parseJSONACIDV t v - valueParser _ Nothing = return Nothing - -- | The data to respond to an interaction with. Unless specified otherwise, you -- only have three seconds to reply to an interaction before a failure state is -- given. -data InteractionResponse = InteractionResponse - { interactionResponseType :: InteractionCallbackType, - interactionResponseData :: Maybe InteractionCallbackData - } - deriving (Show, Read, Eq) +data InteractionResponse + = -- | ACK a Ping + InteractionResponsePong + | -- | Respond to an interaction with a message + InteractionResponseChannelMessage InteractionResponseMessage + | -- | ACK an interaction and edit a response later (use `CreateFollowupInteractionMessage` and `InteractionResponseMessage` to do so). User sees loading state. + InteractionResponseDeferChannelMessage + | -- | for components, ACK an interaction and edit the original message later; the user does not see a loading state. + InteractionResponseDeferUpdateMessage + | -- | for components, edit the message the component was attached to + InteractionResponseUpdateMessage InteractionResponseMessage + | -- | respond to an autocomplete interaction with suggested choices + InteractionResponseAutocompleteResult InteractionResponseAutocomplete +-- | A basic interaction response, sending back the given text. interactionResponseBasic :: T.Text -> InteractionResponse -interactionResponseBasic t = InteractionResponse InteractionCallbackTypeChannelMessageWithSource (Just . InteractionCallbackDataMessages $ interactionCallbackMessagesBasic t) +interactionResponseBasic t = InteractionResponseChannelMessage (interactionResponseMessageBasic t) instance ToJSON InteractionResponse where - toJSON InteractionResponse {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("type", toMaybeJSON interactionResponseType), - ("data", toJSON <$> interactionResponseData) - ] - ] - --- | What's the type of the response? -data InteractionCallbackType - = -- | Responds to a PING. - InteractionCallbackTypePong - | -- | Respond with a message to the interaction - InteractionCallbackTypeChannelMessageWithSource - | -- | Respond with a message to the interaction, after a delay. Sending this - -- back means the interaction token lasts for 15 minutes. - InteractionCallbackTypeDeferredChannelMessageWithSource - | -- | For components, edit the original message later. - InteractionCallbackTypeDeferredUpdateMessage - | -- | For components, edit the original message. - InteractionCallbackTypeUpdateMessage - | -- | Respond to an autocomplete interaction with suggested choices. - InteractionCallbackTypeApplicationCommandAutocompleteResult - deriving (Show, Read, Eq, Data) - -instance Enum InteractionCallbackType where - fromEnum InteractionCallbackTypePong = 1 - fromEnum InteractionCallbackTypeChannelMessageWithSource = 4 - fromEnum InteractionCallbackTypeDeferredChannelMessageWithSource = 5 - fromEnum InteractionCallbackTypeDeferredUpdateMessage = 6 - fromEnum InteractionCallbackTypeUpdateMessage = 7 - fromEnum InteractionCallbackTypeApplicationCommandAutocompleteResult = 8 - toEnum a = fromJust $ lookup a table - where - table = makeTable InteractionCallbackTypePong - -instance ToJSON InteractionCallbackType where - toJSON = toJSON . fromEnum - --- | Convenience wrapper for two separate types of callback. -data InteractionCallbackData - = InteractionCallbackDataMessages InteractionCallbackMessages - | InteractionCallbackDataAutocomplete InteractionCallbackAutocomplete - deriving (Show, Read, Eq) + toJSON InteractionResponsePong = object [("type", Number 1)] + toJSON InteractionResponseDeferChannelMessage = object [("type", Number 5)] + toJSON InteractionResponseDeferUpdateMessage = object [("type", Number 6)] + toJSON (InteractionResponseChannelMessage ms) = object [("type", Number 4), ("data", toJSON ms)] + toJSON (InteractionResponseUpdateMessage ms) = object [("type", Number 7), ("data", toJSON ms)] + toJSON (InteractionResponseAutocompleteResult ms) = object [("type", Number 8), ("data", toJSON ms)] -instance ToJSON InteractionCallbackData where - toJSON (InteractionCallbackDataMessages icdm) = toJSON icdm - toJSON (InteractionCallbackDataAutocomplete icda) = toJSON icda +data InteractionResponseAutocomplete = InteractionResponseAutocompleteString [Choice T.Text] | InteractionResponseAutocompleteInteger [Choice Integer] | InteractionResponseAutocompleteNumber [Choice Scientific] + deriving (Show, Eq) -type InteractionCallbackAutocomplete = [InternalApplicationCommandOptionChoice] +instance ToJSON InteractionResponseAutocomplete where + toJSON (InteractionResponseAutocompleteString cs) = object [("choices", toJSON cs)] + toJSON (InteractionResponseAutocompleteInteger cs) = object [("choices", toJSON cs)] + toJSON (InteractionResponseAutocompleteNumber cs) = object [("choices", toJSON cs)] -- | A cut down message structure. -data InteractionCallbackMessages = InteractionCallbackMessages - { interactionCallbackMessagesTTS :: Maybe Bool, - interactionCallbackMessagesContent :: Maybe T.Text, - interactionCallbackMessagesEmbeds :: Maybe [Embed], - interactionCallbackMessagesAllowedMentions :: Maybe AllowedMentions, - interactionCallbackMessagesFlags :: Maybe InteractionCallbackDataFlags, - interactionCallbackMessagesComponents :: Maybe [Component], - interactionCallbackMessagesAttachments :: Maybe [Attachment] +data InteractionResponseMessage = InteractionResponseMessage + { interactionResponseMessageTTS :: Maybe Bool, + interactionResponseMessageContent :: Maybe T.Text, + interactionResponseMessageEmbeds :: Maybe [CreateEmbed], + interactionResponseMessageAllowedMentions :: Maybe AllowedMentions, + interactionResponseMessageFlags :: Maybe InteractionResponseMessageFlags, + interactionResponseMessageComponents :: Maybe [ComponentActionRow], + interactionResponseMessageAttachments :: Maybe [Attachment] } - deriving (Show, Read, Eq) + deriving (Show, Eq) -interactionCallbackMessagesBasic :: T.Text -> InteractionCallbackMessages -interactionCallbackMessagesBasic t = InteractionCallbackMessages Nothing (Just t) Nothing Nothing Nothing Nothing Nothing +-- | A basic interaction response, sending back the given text. This is +-- effectively a helper function. +interactionResponseMessageBasic :: T.Text -> InteractionResponseMessage +interactionResponseMessageBasic t = InteractionResponseMessage Nothing (Just t) Nothing Nothing Nothing Nothing Nothing -instance ToJSON InteractionCallbackMessages where - toJSON InteractionCallbackMessages {..} = +instance ToJSON InteractionResponseMessage where + toJSON InteractionResponseMessage {..} = object [ (name, value) | (name, Just value) <- - [ ("tts", toJSON <$> interactionCallbackMessagesTTS), - ("content", toJSON <$> interactionCallbackMessagesContent), - ("embeds", toJSON <$> interactionCallbackMessagesEmbeds), - ("allowed_mentions", toJSON <$> interactionCallbackMessagesAllowedMentions), - ("flags", toJSON <$> interactionCallbackMessagesFlags), - ("components", toJSON <$> interactionCallbackMessagesComponents), - ("attachments", toJSON <$> interactionCallbackMessagesAttachments) + [ ("tts", toJSON <$> interactionResponseMessageTTS), + ("content", toJSON <$> interactionResponseMessageContent), + ("embeds", toJSON . (createEmbed <$>) <$> interactionResponseMessageEmbeds), + ("allowed_mentions", toJSON <$> interactionResponseMessageAllowedMentions), + ("flags", toJSON <$> interactionResponseMessageFlags), + ("components", toJSON <$> interactionResponseMessageComponents), + ("attachments", toJSON <$> interactionResponseMessageAttachments) ] ] @@ -555,60 +530,17 @@ -- -- Currently the only flag is EPHERMERAL, which means only the user can see the -- message. -data InteractionCallbackDataFlag = InteractionCallbackDataFlagEphermeral +data InteractionResponseMessageFlag = InteractionResponseMessageFlagEphermeral deriving (Show, Read, Eq) -newtype InteractionCallbackDataFlags = InteractionCallbackDataFlags [InteractionCallbackDataFlag] +newtype InteractionResponseMessageFlags = InteractionResponseMessageFlags [InteractionResponseMessageFlag] deriving (Show, Read, Eq) -instance Enum InteractionCallbackDataFlag where - fromEnum InteractionCallbackDataFlagEphermeral = 1 `shift` 6 +instance Enum InteractionResponseMessageFlag where + fromEnum InteractionResponseMessageFlagEphermeral = 1 `shift` 6 toEnum i - | i == 1 `shift` 6 = InteractionCallbackDataFlagEphermeral + | i == 1 `shift` 6 = InteractionResponseMessageFlagEphermeral | otherwise = error $ "could not find InteractionCallbackDataFlag `" ++ show i ++ "`" -instance ToJSON InteractionCallbackDataFlags where - toJSON (InteractionCallbackDataFlags fs) = Number $ fromInteger $ fromIntegral $ foldr (.|.) 0 (fromEnum <$> fs) - -data ApplicationCommandInteractionDataValue - = ApplicationCommandInteractionDataValueString T.Text - | ApplicationCommandInteractionDataValueInteger Integer - | ApplicationCommandInteractionDataValueBoolean Bool - | ApplicationCommandInteractionDataValueUser Snowflake - | ApplicationCommandInteractionDataValueChannel Snowflake - | ApplicationCommandInteractionDataValueRole Snowflake - | ApplicationCommandInteractionDataValueMentionable Snowflake - | ApplicationCommandInteractionDataValueNumber Scientific - deriving (Show, Eq, Ord, Read) - -getTypeFromACIDV :: ApplicationCommandInteractionDataValue -> ApplicationCommandOptionType -getTypeFromACIDV acidv = case acidv of - ApplicationCommandInteractionDataValueString _ -> ApplicationCommandOptionTypeString - ApplicationCommandInteractionDataValueInteger _ -> ApplicationCommandOptionTypeInteger - ApplicationCommandInteractionDataValueBoolean _ -> ApplicationCommandOptionTypeBoolean - ApplicationCommandInteractionDataValueUser _ -> ApplicationCommandOptionTypeUser - ApplicationCommandInteractionDataValueChannel _ -> ApplicationCommandOptionTypeChannel - ApplicationCommandInteractionDataValueRole _ -> ApplicationCommandOptionTypeRole - ApplicationCommandInteractionDataValueMentionable _ -> ApplicationCommandOptionTypeMentionable - ApplicationCommandInteractionDataValueNumber _ -> ApplicationCommandOptionTypeNumber - -instance ToJSON ApplicationCommandInteractionDataValue where - toJSON (ApplicationCommandInteractionDataValueString t) = String t - toJSON (ApplicationCommandInteractionDataValueNumber t) = Number t - toJSON (ApplicationCommandInteractionDataValueInteger t) = Number $ fromInteger t - toJSON (ApplicationCommandInteractionDataValueBoolean t) = Bool t - toJSON (ApplicationCommandInteractionDataValueUser t) = toJSON t - toJSON (ApplicationCommandInteractionDataValueChannel t) = toJSON t - toJSON (ApplicationCommandInteractionDataValueRole t) = toJSON t - toJSON (ApplicationCommandInteractionDataValueMentionable t) = toJSON t - -parseJSONACIDV :: ApplicationCommandOptionType -> Value -> Parser (Maybe ApplicationCommandInteractionDataValue) -parseJSONACIDV ApplicationCommandOptionTypeString (String t) = return $ return (ApplicationCommandInteractionDataValueString t) -parseJSONACIDV ApplicationCommandOptionTypeInteger n = Just . ApplicationCommandInteractionDataValueInteger <$> parseJSON n -parseJSONACIDV ApplicationCommandOptionTypeNumber (Number t) = return $ return (ApplicationCommandInteractionDataValueNumber t) -parseJSONACIDV ApplicationCommandOptionTypeBoolean (Bool t) = return $ return (ApplicationCommandInteractionDataValueBoolean t) -parseJSONACIDV ApplicationCommandOptionTypeUser t = Just . ApplicationCommandInteractionDataValueUser <$> parseJSON t -parseJSONACIDV ApplicationCommandOptionTypeChannel t = Just . ApplicationCommandInteractionDataValueChannel <$> parseJSON t -parseJSONACIDV ApplicationCommandOptionTypeRole t = Just . ApplicationCommandInteractionDataValueRole <$> parseJSON t -parseJSONACIDV ApplicationCommandOptionTypeMentionable t = Just . ApplicationCommandInteractionDataValueMentionable <$> parseJSON t -parseJSONACIDV t v = fail $ "could not parse type " ++ show t ++ " from " ++ show v +instance ToJSON InteractionResponseMessageFlags where + toJSON (InteractionResponseMessageFlags fs) = Number $ fromInteger $ fromIntegral $ foldr (.|.) 0 (fromEnum <$> fs) diff --git a/src/Discord/Internal/Types/Prelude.hs b/src/Discord/Internal/Types/Prelude.hs --- a/src/Discord/Internal/Types/Prelude.hs +++ b/src/Discord/Internal/Types/Prelude.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} -- | Provides base types and utility functions needed for modules in Discord.Internal.Types module Discord.Internal.Types.Prelude where @@ -14,16 +14,14 @@ import Data.Time.Clock import qualified Data.Text as T import Data.Time.Clock.POSIX -import Control.Monad (mzero) import Data.Functor.Compose (Compose(Compose, getCompose)) import Data.Bifunctor (first) import Text.Read (readMaybe) import Data.Data (Data (dataTypeOf), dataTypeConstrs, fromConstr) -import Data.Maybe (fromJust) -- | Authorization token for the Discord API -data Auth = Auth T.Text +newtype Auth = Auth T.Text deriving (Show, Read, Eq, Ord) @@ -47,10 +45,14 @@ toJSON (Snowflake snowflake) = String . T.pack $ show snowflake instance FromJSON Snowflake where - parseJSON (String snowflake) = case readMaybe (T.unpack snowflake) of - Nothing -> fail "null snowflake" - (Just i) -> pure i - parseJSON _ = mzero + parseJSON = + withText + "Snowflake" + ( \snowflake -> + case readMaybe (T.unpack snowflake) of + Nothing -> fail "null snowflake" + (Just i) -> pure i + ) type ChannelId = Snowflake type StageId = Snowflake @@ -65,7 +67,7 @@ type IntegrationId = Snowflake type WebhookId = Snowflake type ParentId = Snowflake -type ApplicationId = Snowflake +type ApplicationId = Snowflake type ApplicationCommandId = Snowflake type InteractionId = Snowflake type InteractionToken = T.Text @@ -80,42 +82,42 @@ epochTime :: UTCTime epochTime = posixSecondsToUTCTime 0 -type ColorInteger = Integer - -makeTable :: (Data t, Enum t) => t -> [(Int, t)] -makeTable t = map (\cData -> let c = fromConstr cData in (fromEnum c, c)) (dataTypeConstrs $ dataTypeOf t) +{- -toMaybeJSON :: (ToJSON a) => a -> Maybe Value -toMaybeJSON = return . toJSON +InternalDiscordEnum is a hack-y typeclass, but it's the best solution overall. +The best we can do is prevent the end-user from seeing this. --- | What type of interaction has a user requested? Each requires its own type --- of response. -data InteractionType - = InteractionTypePing - | InteractionTypeApplicationCommand - | InteractionTypeMessageComponent - | InteractionTypeApplicationCommandAutocomplete - deriving (Show, Read, Data, Eq, Ord) +typeclass Bounded (minBound + maxBound) could replace discordTypeStartValue, but +it can't derive instances for types like DiscordColor, which have simple sum types involved. -instance Enum InteractionType where - fromEnum InteractionTypePing = 1 - fromEnum InteractionTypeApplicationCommand = 2 - fromEnum InteractionTypeMessageComponent = 3 - fromEnum InteractionTypeApplicationCommandAutocomplete = 4 - toEnum a = fromJust $ lookup a table - where - table = makeTable InteractionTypePing +typeclass Enum (toEnum + fromEnum) requires defining both A->Int and Int->A. +If we handle both at once (with an inline map), it's no longer typesafe. -instance ToJSON InteractionType where - toJSON = toJSON . fromEnum +External packages exist, but bloat our dependencies -instance FromJSON InteractionType where - parseJSON = withScientific "InteractionType" (return . toEnum . round) +-} +class Data a => InternalDiscordEnum a where + discordTypeStartValue :: a + fromDiscordType :: a -> Int + discordTypeTable :: [(Int, a)] + discordTypeTable = map (\d -> (fromDiscordType d, d)) (makeTable discordTypeStartValue) + where + makeTable :: Data b => b -> [b] + makeTable t = map fromConstr (dataTypeConstrs $ dataTypeOf t) -class Internals a b where - toInternal :: a -> b - fromInternal :: b -> Maybe a + discordTypeParseJSON :: String -> Value -> Parser a + discordTypeParseJSON name = + withScientific + name + ( \i -> do + case maybeInt i >>= (`lookup` discordTypeTable) of + Nothing -> fail $ "could not parse type: " ++ show i + Just d -> return d + ) + where + maybeInt i + | fromIntegral (round i) == i = Just $ round i + | otherwise = Nothing -instance Internals a a where - toInternal = id - fromInternal = Just +toMaybeJSON :: (ToJSON a) => a -> Maybe Value +toMaybeJSON = return . toJSON diff --git a/src/Discord/Types.hs b/src/Discord/Types.hs --- a/src/Discord/Types.hs +++ b/src/Discord/Types.hs @@ -1,3 +1,4 @@ +-- | Re-export user-visible types module Discord.Types ( module Discord.Internal.Types ) where @@ -6,4 +7,9 @@ ( GatewaySendableInternal(..) , GatewayReceivable(..) , EventInternalParse(..) + , InternalDiscordEnum(..) + + , colorToInternal + , convertToRGB + , hexToRGB )