diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,54 +1,81 @@ -# discord-haskell [![Build Status](https://app.travis-ci.com/aquarial/discord-haskell.svg?branch=master)](https://app.travis-ci.com/github/aquarial/discord-haskell) [![Hackage version](http://img.shields.io/hackage/v/discord-haskell.svg?label=Hackage)](https://hackage.haskell.org/package/discord-haskell) [![Discord server](https://discord.com/api/guilds/918577626954739722/widget.png?style=shield)](https://discord.gg/eaRAGgX3bK) +# discord-haskell [![CI Status](https://github.com/aquarial/discord-haskell/actions/workflows/main.yml/badge.svg)](https://github.com/aquarial/discord-haskell/actions/) [![Hackage version](http://img.shields.io/hackage/v/discord-haskell.svg?label=Hackage)](https://hackage.haskell.org/package/discord-haskell) [![Discord server](https://discord.com/api/guilds/918577626954739722/widget.png?style=shield)](https://discord.gg/eaRAGgX3bK) -Build that discord bot in Haskell! Also checkout the [calamity haskell library](https://github.com/nitros12/calamity) +## About + +Build that discord bot in Haskell! Also checkout the [calamity haskell library](https://github.com/nitros12/calamity) for a more advanced interface than `discord-haskell`. -### Discord Server +### Documentation -Created a discord server: https://discord.gg/eaRAGgX3bK +#### Local Documentation +Find docs on features, metadata, and parts is found in [./docs/README.md#Documentation](./docs/README.md#Documentation) + +#### Discord Server + +Current project discord server: + Ask questions, get updates, request features, etc +#### Official Discord Documentation + +The [official discord documentation](https://discord.com/developers/docs/intro) +lists the rest requests, gateway events, and gateway sendables. The library +matches very closely. + +For example: +[Get Channel](https://discord.com/developers/docs/resources/channel#get-channel) +and discord-haskell has a rest request ADT including +`[GetChannel :: ChannelId -> ChannelRequest Channel]`. Similar matching exists for gateway `Event`s. + +#### Open an Issue + +If something goes wrong: check the error message, (optional: check log file), make sure you have the most recent version, ask on discord, or open a github issue. + +## Implementation and Progress + ### Quickstart -This is an example bot that replies "pong" to messages that start with "ping". Also checkout the [other examples](./examples/) +This is an example bot that replies "pong" to messages that start with "ping". Also checkout the [other examples](./examples/) for things like state management. ```haskell {-# LANGUAGE OverloadedStrings #-} -- allows "string literals" to be Text - import Control.Monad (when, void) import Data.Text (isPrefixOf, toLower, Text) import qualified Data.Text.IO as TIO - import UnliftIO.Concurrent - import Discord import Discord.Types import qualified Discord.Requests as R -- | Replies "pong" to every message that starts with "ping" pingpongExample :: IO () -pingpongExample = do userFacingError <- runDiscord $ def - { discordToken = "Bot ZZZZZZZZZZZZZZZZZZZ" - , discordOnEvent = eventHandler } - TIO.putStrLn userFacingError +pingpongExample = do + userFacingError <- runDiscord $ def + { discordToken = "Bot ZZZZZZZZZZZZZZZZZZZ" + , discordOnEvent = eventHandler + , discordOnLog = \s -> TIO.putStrLn s + , discordForkThreadForEvents = True } + TIO.putStrLn userFacingError + -- userFacingError is an unrecoverable error + -- put normal 'cleanup' code in discordOnEnd (see examples) eventHandler :: Event -> DiscordHandler () eventHandler event = case event of MessageCreate m -> when (not (fromBot m) && isPing m) $ do - void $ restCall (R.CreateReaction (messageChannel m, messageId m) "eyes") + void $ restCall (R.CreateReaction (messageChannelId m, messageId m) "eyes") threadDelay (2 * 10^6) - void $ restCall (R.CreateMessage (messageChannel m) "Pong!") + void $ restCall (R.CreateMessage (messageChannelId m) "Pong!") _ -> return () fromBot :: Message -> Bool fromBot = userIsBot . messageAuthor isPing :: Message -> Bool -isPing = ("ping" `isPrefixOf`) . toLower . messageText +isPing = ("ping" `isPrefixOf`) . toLower . messageContent ``` -``` +```cabal -- ping-pong.cabal executable haskell-bot @@ -101,75 +128,4 @@ for some help setting up your bot token -### Emoji - -For single character Emoji you can use the unicode name ("eyes", "fire", etc). - -For multi-character Emoji you must use the discord format. Type `\:emoji:` into -a discord chat and paste that into the Text - -For example `:thumbsup::skin-tone-3:` is `"👍\127997"`. -A custom emoji will look like `` or `name:id_number`. - -See [examples/ping-pong.hs](https://github.com/aquarial/discord-haskell/blob/master/examples/ping-pong.hs) - for a `CreateReaction` request in use. -### Embeds - -Embeds are special messages with boarders and images. [Example embed created by discord-haskell](./examples/embed-photo.jpg) - -The `Embed` record (and sub-records) store embed data received from Discord. - -The `CreateEmbed` record stores data when we want to create an embed. - -`CreateEmbed` has a `Default` instance, so you only need to specify the fields you use: - -```haskell -_ <- restCall (R.CreateMessageEmbed "Pong!" $ - def { createEmbedTitle = "Pong Embed" - , createEmbedImage = Just $ CreateEmbedImageUpload - , createEmbedThumbnail = Just $ CreateEmbedImageUrl - "https://avatars2.githubusercontent.com/u/37496339" - }) -``` - -Uploading a file each time is slow, prefer uploading images to a hosting site like imgur.com, and then referencing them. - -### Limitations - -The following features are not implemented: - -- Voice & Audio -- Authenticating with a user token - -### Debugging - -Always print the userFacingError Text returned from `runDiscord`. I use this to record -errors that cannot be recovered from. - -If something else goes wrong with the library please open an issue. It is helpful, -but not always necessary, to attach a log of what's going on when the library -crashes. - -Assign a handler to the `discordOnLog :: Text -> IO ()` to print info as it happens. -Remember to remove sensitive information before posting. - -### Getting Help - -#### Official discord docs - -For a list of rest requests, gateway events, and gateway sendables go ggto the -[official discord documentation](https://discord.com/developers/docs/intro) - -The rest requests line up very closely. The documentation lists -[Get Channel](https://discord.com/developers/docs/resources/channel#get-channel) -and discord-haskell has `GetChannel :: ChannelId -> ChannelRequest Channel`. Same for gateway `Event`s. - -#### Examples - -The [examples](https://github.com/aquarial/discord-haskell/tree/master/examples) were crafted -to display a variety of use cases. Read them with care. - -#### Open an Issue - -For deeper questions about how the library functions, feel free to open an issue. diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -6,6 +6,15 @@ ## master +## 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! + + +[L0neGamer](https://github.com/aquarial/discord-haskell/pull/94) fixed a parse error with webhooktoken + + +rename fields `messageText` -> `messageContent`, `messageChannel` -> `messageChannelId` ## 1.10.0 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.10.0 +version: 1.11.0 description: Functions and data types to write discord bots. Official discord docs . . @@ -34,6 +34,7 @@ , text , unliftio , discord-haskell + -- , req {- needed for slash commands -} library ghc-options: -Wall @@ -44,6 +45,7 @@ exposed-modules: Discord , Discord.Types , Discord.Handle + , Discord.Interactions , Discord.Requests , Discord.Internal.Gateway , Discord.Internal.Gateway.Cache @@ -58,6 +60,8 @@ , Discord.Internal.Rest.Channel , Discord.Internal.Rest.Voice , Discord.Internal.Rest.Webhook + , Discord.Internal.Rest.ApplicationCommands + , Discord.Internal.Rest.Interactions , Discord.Internal.Types , Discord.Internal.Types.Prelude , Discord.Internal.Types.Channel @@ -66,6 +70,9 @@ , Discord.Internal.Types.Guild , Discord.Internal.Types.User , Discord.Internal.Types.Embed + , Discord.Internal.Types.ApplicationCommands + , Discord.Internal.Types.Interactions + , Discord.Internal.Types.Components build-depends: base >= 4 && <5 , aeson @@ -89,3 +96,4 @@ , wuss , mtl , unliftio + , scientific diff --git a/examples/ping-pong.hs b/examples/ping-pong.hs --- a/examples/ping-pong.hs +++ b/examples/ping-pong.hs @@ -13,28 +13,39 @@ -- Allows this code to be an executable. See discord-haskell.cabal main :: IO () -main = pingpongExample +main = if testserverid == -1 + then TIO.putStrLn "ERROR: modify the source and set testserverid to your serverid" + else pingpongExample + + +-- check the url in a discord server +-- +-- https://discord.com/channels/2385235298674262408/4286572469284672046 +testserverid :: Snowflake +testserverid = 453207241294610442 + -- | Replies "pong" to every message that starts with "ping" pingpongExample :: IO () pingpongExample = do tok <- TIO.readFile "./examples/auth-token.secret" -- open ghci and run [[ :info RunDiscordOpts ]] to see available fields - t <- runDiscord $ def { discordToken = tok - , discordOnStart = startHandler - , discordOnEnd = liftIO $ putStrLn "Ended" - , discordOnEvent = eventHandler - , discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "" - } - TIO.putStrLn t + err <- runDiscord $ def { discordToken = tok + , discordOnStart = startHandler + , discordOnEnd = liftIO $ putStrLn "Ended" + , discordOnEvent = eventHandler + , discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "" + } + -- only reached on an unrecoverable error + -- put normal 'cleanup' code in discordOnEnd + TIO.putStrLn err + -- If the start handler throws an exception, discord-haskell will gracefully shutdown -- Use place to execute commands you know you want to complete startHandler :: DiscordHandler () startHandler = do - Right partialGuilds <- restCall R.GetCurrentUserGuilds - let activity = Activity { activityName = "ping-pong" , activityType = ActivityTypeGame , activityUrl = Nothing @@ -46,23 +57,21 @@ } sendCommand (UpdateStatus opts) - forM_ partialGuilds $ \pg -> do - Right guild <- restCall $ R.GetGuild (partialGuildId pg) - Right chans <- restCall $ R.GetGuildChannels (guildId guild) - forM_ (take 1 (filter isTextChannel chans)) - (\channel -> restCall $ R.CreateMessage (channelId channel) - "Hello! I will reply to pings with pongs") + Right chans <- restCall $ R.GetGuildChannels testserverid + forM_ (take 1 (filter isTextChannel chans)) + (\channel -> restCall $ R.CreateMessage (channelId channel) + "Hello! I will reply to pings with pongs") -- If an event handler throws an exception, discord-haskell will continue to run eventHandler :: Event -> DiscordHandler () eventHandler event = case event of MessageCreate m -> when (not (fromBot m) && isPing m) $ do - void $ restCall (R.CreateReaction (messageChannel m, messageId m) "eyes") - threadDelay (2 * 10^(6 :: Int)) + void $ restCall (R.CreateReaction (messageChannelId m, messageId m) "eyes") + threadDelay (2 * 10 ^ (6 :: Int)) -- A very simple message. - void $ restCall (R.CreateMessage (messageChannel m) "Pong!") + void $ restCall (R.CreateMessage (messageChannelId m) "Pong!") -- A more complex message. Text-to-speech, does not mention everyone nor -- the user, and uses Discord native replies. @@ -77,7 +86,7 @@ , R.messageDetailedReference = Just $ def { referenceMessageId = Just $ messageId m } } - void $ restCall (R.CreateMessageDetailed (messageChannel m) opts) + void $ restCall (R.CreateMessageDetailed (messageChannelId m) opts) _ -> return () isTextChannel :: Channel -> Bool @@ -88,4 +97,4 @@ fromBot = userIsBot . messageAuthor isPing :: Message -> Bool -isPing = ("ping" `T.isPrefixOf`) . T.toLower . messageText +isPing = ("ping" `T.isPrefixOf`) . T.toLower . messageContent diff --git a/src/Discord.hs b/src/Discord.hs --- a/src/Discord.hs +++ b/src/Discord.hs @@ -131,7 +131,7 @@ resp <- liftIO $ writeRestCall (discordHandleRestChan h) r case resp of Right x -> pure (Right x) - Left (RestCallInternalErrorCode c e1 e2) -> + Left (RestCallInternalErrorCode c e1 e2) -> do pure (Left (RestCallErrorCode c (TE.decodeUtf8 e1) (TE.decodeUtf8 e2))) Left (RestCallInternalHttpException _) -> threadDelay (10 * 10^(6 :: Int)) >> restCall r diff --git a/src/Discord/Interactions.hs b/src/Discord/Interactions.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Interactions.hs @@ -0,0 +1,7 @@ +module Discord.Interactions + ( 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 @@ -18,6 +18,7 @@ , cacheDMChannels :: M.Map ChannelId Channel , cacheGuilds :: M.Map GuildId (Guild, GuildInfo) , cacheChannels :: M.Map ChannelId Channel + , cacheApplication :: PartialApplication } deriving (Show) data CacheHandle = CacheHandle @@ -29,9 +30,9 @@ cacheLoop cacheHandle log = do ready <- readChan eventChan case ready of - Right (InternalReady _ user dmChannels _unavailableGuilds _) -> do + Right (InternalReady _ user dmChannels _unavailableGuilds _ _ pApp) -> do let dmChans = M.fromList (zip (map channelId dmChannels) dmChannels) - putMVar cache (Right (Cache user dmChans M.empty M.empty)) + putMVar cache (Right (Cache user dmChans M.empty M.empty pApp)) loop Right r -> writeChan log ("cache - stopping cache - expected Ready event, but got " <> T.pack (show r)) @@ -72,6 +73,7 @@ -- c = M.filterWithKey (\(keyGuildId,_) _ -> keyGuildId /= guildId guild) (cacheChannels minfo) -- m2 = minfo { cacheGuilds = g, cacheChannels = c } -- putMVar cache m2 + InternalReady _ _ _ _ _ _ pa -> minfo { cacheApplication = pa } _ -> minfo setChanGuildID :: GuildId -> Channel -> Channel diff --git a/src/Discord/Internal/Gateway/EventLoop.hs b/src/Discord/Internal/Gateway/EventLoop.hs --- a/src/Discord/Internal/Gateway/EventLoop.hs +++ b/src/Discord/Internal/Gateway/EventLoop.hs @@ -102,7 +102,7 @@ LoopClosed -> pure Nothing startconnectionpls :: GatewaySendableInternal -> IO LoopState - startconnectionpls first = runSecureClient "gateway.discord.gg" 443 "/?v=6&encoding=json" $ \conn -> do + startconnectionpls first = runSecureClient "gateway.discord.gg" 443 "/?v=8&encoding=json" $ \conn -> do msg <- getPayload conn log case msg of Right (Hello interval) -> do @@ -141,7 +141,7 @@ Right (Dispatch event sq) -> do writeIORef (gatewayHandleLastSequenceId thehandle) sq writeChan eventChan (Right event) case event of - (InternalReady _ _ _ _ seshID) -> + (InternalReady _ _ _ _ seshID _ _) -> writeIORef (gatewayHandleSessionId thehandle) seshID _ -> writeIORef (startsendingUsers sendablesData) True loop 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} -- | Provides a higher level interface to the rest functions. @@ -43,8 +44,9 @@ r <- readMVar m pure $ case eitherDecode <$> r of Right (Right o) -> Right o - Right (Left er) -> Left (RestCallInternalNoParse er (case r of Right x -> x - Left _ -> "")) + (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 new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Rest/ApplicationCommands.hs @@ -0,0 +1,103 @@ +{-# 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 Discord.Internal.Rest.Prelude +import Discord.Internal.Types +import Discord.Internal.Types.ApplicationCommands + + +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 + 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 + DeleteGuildApplicationCommand :: ApplicationId -> GuildId -> ApplicationCommandId -> ApplicationCommandRequest () + BulkOverWriteGuildApplicationCommand :: ApplicationId -> GuildId -> [CreateApplicationCommand] -> ApplicationCommandRequest () + GetGuildApplicationCommandPermissions :: ApplicationId -> GuildId -> ApplicationCommandRequest GuildApplicationCommandPermissions + GetApplicationCommandPermissions :: ApplicationId -> GuildId -> ApplicationCommandId -> ApplicationCommandRequest GuildApplicationCommandPermissions + EditApplicationCommandPermissions :: ApplicationId -> GuildId -> ApplicationCommandId -> [ApplicationCommandPermissions] -> ApplicationCommandRequest GuildApplicationCommandPermissions + -- | 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 + +applicationCommandMajorRoute :: ApplicationCommandRequest a -> String +applicationCommandMajorRoute a = case a of + (GetGlobalApplicationCommands aid) -> "get_glob_appcomm" <> show aid + (CreateGlobalApplicationCommand aid _) -> "write_glob_appcomm" <> show aid + (GetGlobalApplicationCommand aid _) -> "get_glob_appcomm" <> show aid + (EditGlobalApplicationCommand aid _ _) -> "write_glob_appcomm" <> show aid + (DeleteGlobalApplicationCommand aid _) -> "write_glob_appcomm" <> show aid + (BulkOverWriteGlobalApplicationCommand aid _) -> "write_glob_appcomm" <> show aid + (GetGuildApplicationCommands aid _) -> "get_appcomm" <> show aid + (CreateGuildApplicationCommand aid _ _) -> "write_appcomm" <> show aid + (GetGuildApplicationCommand aid _ _) -> "get_appcomm" <> show aid + (EditGuildApplicationCommand aid _ _ _) -> "write_appcomm" <> show aid + (DeleteGuildApplicationCommand aid _ _) -> "write_appcomm" <> show aid + (BulkOverWriteGuildApplicationCommand aid _ _) -> "write_appcomm" <> show aid + (GetGuildApplicationCommandPermissions aid _) -> "appcom_perm " <> show aid + (GetApplicationCommandPermissions aid _ _) -> "appcom_perm " <> show aid + (EditApplicationCommandPermissions aid _ _ _) -> "appcom_perm " <> show aid + (BatchEditApplicationCommandPermissions aid _ _) -> "appcom_perm " <> show aid + +applicationCommandJsonRequest :: ApplicationCommandRequest a -> JsonRequest +applicationCommandJsonRequest a = case a of + (GetGlobalApplicationCommands aid) -> + Get (applications aid /: "commands") mempty + (CreateGlobalApplicationCommand aid cac) -> + Post (applications aid /: "commands") (convert cac) mempty + (GetGlobalApplicationCommand aid aci) -> + Get (applications aid /: "commands" // aci) mempty + (EditGlobalApplicationCommand aid aci eac) -> + Patch (applications aid /: "commands" // aci) (convert eac) mempty + (DeleteGlobalApplicationCommand aid aci) -> + Delete (applications aid /: "commands" // aci) mempty + (BulkOverWriteGlobalApplicationCommand aid cacs) -> + Put (applications aid /: "commands") (R.ReqBodyJson $ toJSON cacs) mempty + (GetGuildApplicationCommands aid gid) -> + Get (applications aid /: "guilds" // gid /: "commands") mempty + (CreateGuildApplicationCommand aid gid cac) -> + Post (applications aid /: "guilds" // gid /: "commands") (convert cac) mempty + (GetGuildApplicationCommand aid gid aci) -> + Get (applications aid /: "guilds" // gid /: "commands" // aci) mempty + (EditGuildApplicationCommand aid gid aci eac) -> + Patch (applications aid /: "guilds" // gid /: "commands" // aci) (convert eac) mempty + (DeleteGuildApplicationCommand aid gid aci) -> + Delete (applications aid /: "guilds" // gid /: "commands" // aci) mempty + (BulkOverWriteGuildApplicationCommand aid gid cacs) -> + Put (applications aid /: "guilds" // gid /: "commands") (R.ReqBodyJson $ toJSON cacs) mempty + (GetGuildApplicationCommandPermissions aid gid) -> + Get (applications aid /: "guilds" // gid /: "commands" /: "permissions") mempty + (GetApplicationCommandPermissions aid gid cid) -> + Get (applications aid /: "guilds" // gid /: "commands" // cid /: "permissions") mempty + (EditApplicationCommandPermissions aid gid cid ps) -> + Put (applications aid /: "guilds" // gid /: "commands" // cid /: "permissions") (R.ReqBodyJson $ toJSON (GuildApplicationCommandPermissions aid cid gid ps)) mempty + (BatchEditApplicationCommandPermissions aid gid ps) -> + Put (applications aid /: "guilds" // gid /: "commands" /: "permissions") (R.ReqBodyJson $ toJSON ps) mempty + where + convert :: (ToJSON a) => a -> RestIO (ReqBodyJson Value) + convert = (pure @RestIO) . R.ReqBodyJson . toJSON 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 @@ -106,6 +106,8 @@ , messageDetailedFile :: Maybe (T.Text, B.ByteString) , messageDetailedAllowedMentions :: Maybe AllowedMentions , messageDetailedReference :: Maybe MessageReference + , messageDetailedComponents :: Maybe [Component] + , messageDetailedStickerIds :: Maybe [StickerId] } deriving (Show, Read, Eq, Ord) instance Default MessageDetailedOpts where @@ -115,39 +117,10 @@ , messageDetailedFile = Nothing , messageDetailedAllowedMentions = Nothing , messageDetailedReference = Nothing + , messageDetailedComponents = Nothing + , messageDetailedStickerIds = Nothing } --- | Data constructor for a part of MessageDetailedOpts. -data AllowedMentions = AllowedMentions - { mentionEveryone :: Bool - , mentionUsers :: Bool - , mentionRoles :: Bool - , mentionUserIds :: [UserId] - , mentionRoleIds :: [RoleId] - , mentionRepliedUser :: Bool - } deriving (Show, Read, Eq, Ord) - -instance Default AllowedMentions where - def = AllowedMentions { mentionEveryone = False - , mentionUsers = True - , mentionRoles = True - , mentionUserIds = [] - , mentionRoleIds = [] - , mentionRepliedUser = True - } - -instance ToJSON AllowedMentions where - toJSON AllowedMentions{..} = object [ - ("parse" .= [name :: T.Text | (name, True) <- - [ ("everyone", mentionEveryone), - ("users", mentionUsers && mentionUserIds == []), - ("roles", mentionRoles && mentionRoleIds == []) ] ]), - -- https://discord.com/developers/docs/resources/channel#allowed-mentions-object - -- parse.users and users list cannot both be active, prioritize id list - ("roles" .= mentionRoleIds), - ("users" .= mentionUserIds), - ("replied_user" .= mentionRepliedUser) ] - -- | Data constructor for GetReaction requests data ReactionTiming = BeforeReaction MessageId | AfterReaction MessageId @@ -330,12 +303,14 @@ Just f -> [partFileRequestBody "file" (T.unpack $ fst f) $ RequestBodyBS $ snd f] - payloadData = object $ [ "content" .= messageDetailedContent msgOpts + payloadData = object $ [ "content" .= messageDetailedContent msgOpts , "tts" .= messageDetailedTTS msgOpts ] ++ [ name .= value | (name, Just value) <- - [ ("embed", toJSON <$> createEmbed <$> messageDetailedEmbed msgOpts) + [ ("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 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 @@ -131,12 +131,12 @@ DeleteGuildIntegration :: GuildId -> IntegrationId -> GuildRequest () -- | Sync an 'Integration'. Requires the 'MANAGE_GUILD' permission. SyncGuildIntegration :: GuildId -> IntegrationId -> GuildRequest () - -- | Returns the 'GuildEmbed' object. Requires the 'MANAGE_GUILD' permission. - GetGuildEmbed :: GuildId -> GuildRequest GuildEmbed - -- | Modify a 'GuildEmbed' object for the guild. All attributes may be passed in with + -- | Returns the 'GuildWidget' object. Requires the 'MANAGE_GUILD' permission. + 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 - -- 'GuildEmbed' object. - ModifyGuildEmbed :: GuildId -> GuildEmbed -> GuildRequest GuildEmbed + -- 'GuildWidget' object. + ModifyGuildWidget :: GuildId -> GuildWidget -> GuildRequest GuildWidget -- | Vanity URL GetGuildVanityURL :: GuildId -> GuildRequest T.Text @@ -167,13 +167,13 @@ instance ToJSON CreateGuildBanOpts where toJSON CreateGuildBanOpts{..} = object [(name, val) | (name, Just val) <- - [("delete-message-days", + [("delete_message_days", toJSON <$> createGuildBanOptsDeleteLastNMessages ), ("reason", toJSON <$> createGuildBanOptsReason )]] data ModifyGuildRoleOpts = ModifyGuildRoleOpts { modifyGuildRoleOptsName :: Maybe T.Text - , modifyGuildRoleOptsPermissions :: Maybe Integer + , modifyGuildRoleOptsPermissions :: Maybe T.Text , modifyGuildRoleOptsColor :: Maybe ColorInteger , modifyGuildRoleOptsSeparateSidebar :: Maybe Bool , modifyGuildRoleOptsMentionable :: Maybe Bool @@ -324,8 +324,8 @@ (ModifyGuildIntegration g _ _) -> "guild_intgr " <> show g (DeleteGuildIntegration g _) -> "guild_intgr " <> show g (SyncGuildIntegration g _) -> "guild_sync " <> show g - (GetGuildEmbed g) -> "guild_embed " <> show g - (ModifyGuildEmbed g _) -> "guild_embed " <> show g + (GetGuildWidget g) -> "guild_widget " <> show g + (ModifyGuildWidget g _) -> "guild_widget " <> show g (GetGuildVanityURL g) -> "guild " <> show g @@ -436,11 +436,11 @@ (SyncGuildIntegration guild integ) -> Post (guilds // guild /: "integrations" // integ) (pure R.NoReqBody) mempty - (GetGuildEmbed guild) -> + (GetGuildWidget guild) -> Get (guilds // guild /: "integrations") mempty - (ModifyGuildEmbed guild patch) -> - Patch (guilds // guild /: "embed") (pure (R.ReqBodyJson patch)) mempty + (ModifyGuildWidget guild patch) -> + Patch (guilds // guild /: "widget") (pure (R.ReqBodyJson patch)) mempty (GetGuildVanityURL guild) -> Get (guilds // guild /: "vanity-url") mempty diff --git a/src/Discord/Internal/Rest/Interactions.hs b/src/Discord/Internal/Rest/Interactions.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Rest/Interactions.hs @@ -0,0 +1,65 @@ +{-# 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 Discord.Internal.Rest.Prelude +import Discord.Internal.Types +import Discord.Internal.Types.Interactions + +data InteractionResponseRequest a where + CreateInteractionResponse :: InteractionId -> InteractionToken -> InteractionResponse -> InteractionResponseRequest () + GetOriginalInteractionResponse :: ApplicationId -> InteractionToken -> InteractionResponseRequest Message + EditOriginalInteractionResponse :: ApplicationId -> InteractionToken -> InteractionCallbackMessages -> InteractionResponseRequest Message + DeleteOriginalInteractionResponse :: ApplicationId -> InteractionToken -> InteractionResponseRequest () + CreateFollowupInteractionMessage :: ApplicationId -> InteractionToken -> InteractionCallbackMessages -> InteractionResponseRequest Message + GetFollowupInteractionMessage :: ApplicationId -> InteractionToken -> MessageId -> InteractionResponseRequest Message + EditFollowupInteractionMessage :: ApplicationId -> InteractionToken -> MessageId -> InteractionResponse -> InteractionResponseRequest Message + DeleteFollowupInteractionMessage :: ApplicationId -> InteractionToken -> MessageId -> InteractionResponseRequest () + +instance Request (InteractionResponseRequest a) where + jsonRequest = interactionResponseJsonRequest + majorRoute = interactionResponseMajorRoute + +interactionResponseMajorRoute :: InteractionResponseRequest a -> String +interactionResponseMajorRoute a = case a of + (CreateInteractionResponse iid _ _) -> "intresp " <> show iid + (GetOriginalInteractionResponse aid _) -> "intresp " <> show aid + (EditOriginalInteractionResponse aid _ _) -> "intresp " <> show aid + (DeleteOriginalInteractionResponse aid _) -> "intresp " <> show aid + (CreateFollowupInteractionMessage iid _ _) -> "intrespf " <> show iid + (GetFollowupInteractionMessage aid _ _) -> "intrespf " <> show aid + (EditFollowupInteractionMessage aid _ _ _) -> "intrespf " <> show aid + (DeleteFollowupInteractionMessage aid _ _) -> "intrespf " <> show aid + +interaction :: ApplicationId -> InteractionToken -> R.Url 'R.Https +interaction aid it = baseUrl /: "webhooks" // aid /: it /: "messages" + +interactionResponseJsonRequest :: InteractionResponseRequest a -> JsonRequest +interactionResponseJsonRequest a = case a of + (CreateInteractionResponse iid it i) -> + Post (baseUrl /: "interactions" // iid /: it /: "callback") (convert i) mempty + (GetOriginalInteractionResponse aid it) -> + Get (interaction aid it /: "@original") mempty + (EditOriginalInteractionResponse aid it i) -> + Patch (interaction aid it /: "@original") (convert i) mempty + (DeleteOriginalInteractionResponse aid it) -> + Delete (interaction aid it /: "@original") mempty + (CreateFollowupInteractionMessage aid it i) -> + Post (baseUrl /: "webhooks" // aid /: it) (convert i) mempty + (GetFollowupInteractionMessage aid it mid) -> + Get (interaction aid it // mid) mempty + (EditFollowupInteractionMessage aid it mid i) -> + Patch (interaction aid it // mid) (convert i) mempty + (DeleteFollowupInteractionMessage aid it mid) -> + Delete (interaction aid it // mid) mempty + where + convert :: (ToJSON a) => a -> RestIO (ReqBodyJson Value) + convert = (pure @RestIO) . R.ReqBodyJson . toJSON 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 @@ -19,7 +19,7 @@ -- | The base url (Req) for API requests baseUrl :: R.Url 'R.Https baseUrl = R.https "discord.com" R./: "api" R./: apiVersion - where apiVersion = "v6" + where apiVersion = "v8" -- | Discord requires HTTP headers for authentication. authHeader :: Auth -> R.Option 'R.Https @@ -29,7 +29,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.10.0)" + agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 1.11.0)" -- Append to an URL infixl 5 // @@ -37,7 +37,7 @@ (//) url part = url R./: T.pack (show part) --- | Represtents a HTTP request made to an API that supplies a Json response +-- | A compiled HTTP request ready to execute data JsonRequest where Delete :: R.Url 'R.Https -> R.Option 'R.Https -> JsonRequest Get :: R.Url 'R.Https -> R.Option 'R.Https -> JsonRequest @@ -46,7 +46,11 @@ Post :: R.HttpBody a => R.Url 'R.Https -> RestIO a -> R.Option 'R.Https -> JsonRequest class Request a where + -- | used for putting a request into a rate limit bucket + -- https://discord.com/developers/docs/topics/rate-limits#rate-limits majorRoute :: a -> String + + -- | build a JSON http request jsonRequest :: a -> JsonRequest -- | Same Monad as IO. Overwrite Req settings 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 @@ -8,6 +8,9 @@ , 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 @@ -20,14 +23,20 @@ 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) userFacingEvent :: EventInternalParse -> Event userFacingEvent event = case event of - InternalReady a b c d e -> Ready a b c d e + InternalReady a b c d e f g -> Ready a b c d e f g InternalResumed a -> Resumed a InternalChannelCreate a -> ChannelCreate a InternalChannelUpdate a -> ChannelUpdate a @@ -58,4 +67,5 @@ InternalPresenceUpdate a -> PresenceUpdate a InternalTypingStart a -> TypingStart a InternalUserUpdate a -> UserUpdate a + InternalInteractionCreate a -> InteractionCreate (fromMaybe (InteractionUnknown a) (fromInternal a)) InternalUnknownEvent a b -> UnknownEvent a b diff --git a/src/Discord/Internal/Types/ApplicationCommands.hs b/src/Discord/Internal/Types/ApplicationCommands.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Types/ApplicationCommands.hs @@ -0,0 +1,693 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Discord.Internal.Types.ApplicationCommands + ( ApplicationCommand (..), + ApplicationCommandOptionSubcommandOrGroup (..), + ApplicationCommandOptionSubcommand (..), + ApplicationCommandOptionValue (..), + InternalApplicationCommand (..), + CreateApplicationCommand (..), + createApplicationCommandChatInput, + createApplicationCommandUser, + createApplicationCommandMessage, + EditApplicationCommand (..), + ApplicationCommandType (..), + InternalApplicationCommandOption (..), + ApplicationCommandOptionType (..), + InternalApplicationCommandOptionChoice, + Choice (..), + ApplicationCommandChannelType (..), + GuildApplicationCommandPermissions (..), + ApplicationCommandPermissions (..), + ApplicationCommandPermissionType (..), + StringNumberValue (..), + ) +where + +import Control.Applicative +import Data.Aeson +import Data.Char (isLower) +import Data.Data (Data) +import Data.Default (Default (..)) +import Data.Maybe (fromJust, fromMaybe) +import Data.Scientific (Scientific) +import qualified Data.Text as T +import Discord.Internal.Types.Prelude (ApplicationCommandId, ApplicationId, GuildId, Internals (..), Snowflake, makeTable, toMaybeJSON) + +data ApplicationCommand + = ApplicationCommandUser + { applicationCommandId :: ApplicationCommandId, + applicationCommandApplicationId :: ApplicationId, + applicationCommandGuildId :: Maybe GuildId, + applicationCommandName :: T.Text, + applicationCommandDefaultPermission :: Maybe Bool, + applicationCommandVersion :: Snowflake + } + | ApplicationCommandMessage + { applicationCommandId :: ApplicationCommandId, + applicationCommandApplicationId :: ApplicationId, + applicationCommandGuildId :: Maybe GuildId, + applicationCommandName :: T.Text, + applicationCommandDefaultPermission :: Maybe Bool, + applicationCommandVersion :: Snowflake + } + | ApplicationCommandChatInput + { applicationCommandId :: ApplicationCommandId, + applicationCommandApplicationId :: ApplicationId, + applicationCommandGuildId :: Maybe GuildId, + applicationCommandName :: T.Text, + applicationCommandDescription :: T.Text, + applicationCommandOptions :: Maybe ApplicationCommandOptions, + applicationCommandDefaultPermission :: Maybe Bool, + applicationCommandVersion :: Snowflake + } + | ApplicationCommandUnknown InternalApplicationCommand + deriving (Show, Eq, Read) + +data ApplicationCommandOptions + = ApplicationCommandOptionsSubcommands [ApplicationCommandOptionSubcommandOrGroup] + | ApplicationCommandOptionsValues [ApplicationCommandOptionValue] + deriving (Show, Eq, Read) + +data ApplicationCommandOptionSubcommandOrGroup + = ApplicationCommandOptionSubcommandGroup + { applicationCommandOptionSubcommandGroupName :: T.Text, + applicationCommandOptionSubcommandGroupDescription :: T.Text, + applicationCommandOptionSubcommandGroupOptions :: [ApplicationCommandOptionSubcommand] + } + | ApplicationCommandOptionSubcommandOrGroupSubcommand ApplicationCommandOptionSubcommand + deriving (Show, Eq, Read) + +data ApplicationCommandOptionSubcommand = ApplicationCommandOptionSubcommand + { applicationCommandOptionSubcommandName :: T.Text, + applicationCommandOptionSubcommandDescription :: T.Text, + applicationCommandOptionSubcommandOptions :: [ApplicationCommandOptionValue] + } + deriving (Show, Eq, Read) + +data ApplicationCommandOptionValue + = ApplicationCommandOptionValueString + { applicationCommandOptionValueName :: T.Text, + applicationCommandOptionValueDescription :: T.Text, + applicationCommandOptionValueRequired :: Maybe Bool, + applicationCommandOptionValueStringChoices :: Maybe [Choice T.Text], + applicationCommandOptionValueAutocomplete :: Maybe Bool + } + | ApplicationCommandOptionValueInteger + { applicationCommandOptionValueName :: T.Text, + applicationCommandOptionValueDescription :: T.Text, + applicationCommandOptionValueRequired :: Maybe Bool, + applicationCommandOptionValueIntegerChoices :: Maybe [Choice Integer], + applicationCommandOptionValueIntegerMinVal :: Maybe Integer, + applicationCommandOptionValueIntegerMaxVal :: Maybe Integer, + applicationCommandOptionValueAutocomplete :: Maybe Bool + } + | ApplicationCommandOptionValueBoolean + { applicationCommandOptionValueName :: T.Text, + applicationCommandOptionValueDescription :: T.Text, + applicationCommandOptionValueRequired :: Maybe Bool + } + | ApplicationCommandOptionValueUser + { applicationCommandOptionValueName :: T.Text, + applicationCommandOptionValueDescription :: T.Text, + applicationCommandOptionValueRequired :: Maybe Bool + } + | ApplicationCommandOptionValueChannel + { applicationCommandOptionValueName :: T.Text, + applicationCommandOptionValueDescription :: T.Text, + applicationCommandOptionValueRequired :: Maybe Bool, + applicationCommandOptionValueChannelTypes :: Maybe [ApplicationCommandChannelType] + } + | ApplicationCommandOptionValueRole + { applicationCommandOptionValueName :: T.Text, + applicationCommandOptionValueDescription :: T.Text, + applicationCommandOptionValueRequired :: Maybe Bool + } + | ApplicationCommandOptionValueMentionable + { applicationCommandOptionValueName :: T.Text, + applicationCommandOptionValueDescription :: T.Text, + applicationCommandOptionValueRequired :: Maybe Bool + } + | ApplicationCommandOptionValueNumber + { applicationCommandOptionValueName :: T.Text, + applicationCommandOptionValueDescription :: T.Text, + applicationCommandOptionValueRequired :: Maybe Bool, + applicationCommandOptionValueNumberChoices :: Maybe [Choice Scientific], + applicationCommandOptionValueNumberMinVal :: Maybe Scientific, + applicationCommandOptionValueNumberMaxVal :: Maybe Scientific, + applicationCommandOptionValueAutocomplete :: Maybe Bool + } + 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 Enum ApplicationCommandType where + fromEnum ApplicationCommandTypeChatInput = 1 + fromEnum ApplicationCommandTypeUser = 2 + fromEnum ApplicationCommandTypeMessage = 3 + toEnum a = fromJust $ lookup a table + where + table = makeTable ApplicationCommandTypeChatInput + +instance ToJSON ApplicationCommandType where + toJSON = toJSON . fromEnum + +instance FromJSON ApplicationCommandType where + parseJSON = withScientific "ApplicationCommandType" (return . toEnum . round) + +-- | Data type to be used when creating application commands. The specification +-- is below. +-- +-- If a command of the same type and and name is sent to the server, it will +-- overwrite any command that already exists in the same scope (guild vs +-- global). +-- +-- The description has to be empty for non-slash command application +-- commands, as do the options. The options need to be `Nothing` for non-slash +-- commands, too. If one of the options is a subcommand or subcommand group, +-- the base command will no longer be usable. +-- +-- A subcommand group can have subcommands within it. This is the maximum amount +-- 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 + } + deriving (Show, Eq, Read) + +instance ToJSON CreateApplicationCommand where + toJSON CreateApplicationCommand {..} = + object + [ (name, value) + | (name, Just value) <- + [ ("name", toMaybeJSON createApplicationCommandName), + ("description", toMaybeJSON createApplicationCommandDescription), + ("options", toJSON <$> createApplicationCommandOptions), + ("default_permission", toJSON <$> createApplicationCommandDefaultPermission), + ("type", toJSON <$> createApplicationCommandType) + ] + ] + +-- | 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) + | 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) + | 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) + | 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 + } + +instance Default EditApplicationCommand where + def = EditApplicationCommand Nothing Nothing Nothing Nothing Nothing + +instance ToJSON EditApplicationCommand where + toJSON EditApplicationCommand {..} = + object + [ (name, value) + | (name, Just value) <- + [ ("name", toJSON <$> editApplicationCommandName), + ("description", toJSON <$> editApplicationCommandDescription), + ("options", toJSON <$> editApplicationCommandOptions), + ("default_permission", toJSON <$> editApplicationCommandDefaultPermission), + ("type", toJSON <$> editApplicationCommandType) + ] + ] + +-- | 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 {..} = + 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) + ] + ] + +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) + +data Choice a = Choice {choiceName :: T.Text, choiceValue :: a} + deriving (Show, Read, Eq) + +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)] + +instance (FromJSON a) => FromJSON (Choice a) where + parseJSON = + withObject + "Choice" + ( \v -> + Choice + <$> v .: "name" + <*> v .: "value" + ) + +-- | The different channel types. +-- +-- https://discord.com/developers/docs/resources/channel#channel-object-channel-types +data ApplicationCommandChannelType + = -- | A text channel in a server. + ApplicationCommandChannelTypeGuildText + | -- | A direct message between users. + ApplicationCommandChannelTypeDM + | -- | A voice channel in a server. + ApplicationCommandChannelTypeGuildVoice + | -- | A direct message between multiple users. + ApplicationCommandChannelTypeGroupDM + | -- | An organizational category that contains up to 50 channels. + ApplicationCommandChannelTypeGuildCategory + | -- | A channel that users can follow and crosspost into their own server. + ApplicationCommandChannelTypeGuildNews + | -- | A channel in which game developers can sell their game on discord. + ApplicationCommandChannelTypeGuildStore + | -- | A temporary sub-channel within a guild_news channel. + ApplicationCommandChannelTypeGuildNewsThread + | -- | 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 + ApplicationCommandChannelTypeGuildPrivateThread + | -- | A voice channel for hosting events with an audience. + 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 ToJSON ApplicationCommandChannelType where + toJSON = toJSON . fromEnum + +instance FromJSON ApplicationCommandChannelType where + parseJSON = withScientific "ApplicationCommandChannelType" (return . toEnum . round) + +data GuildApplicationCommandPermissions = GuildApplicationCommandPermissions + { -- | The id of the command + guildApplicationCommandPermissionsId :: ApplicationCommandId, + -- | The id of the application + guildApplicationCommandPermissionsApplicationId :: ApplicationId, + -- | The id of the guild + guildApplicationCommandPermissionsGuildId :: GuildId, + -- | The permissions for the command in the guild + guildApplicationCommandPermissionsPermissions :: [ApplicationCommandPermissions] + } + deriving (Show, Eq, Ord, Read) + +instance FromJSON GuildApplicationCommandPermissions where + parseJSON = + withObject + "GuildApplicationCommandPermissions" + ( \v -> + GuildApplicationCommandPermissions + <$> v .: "id" + <*> v .: "application_id" + <*> v .: "guild_id" + <*> v .: "permissions" + ) + +instance ToJSON GuildApplicationCommandPermissions where + toJSON GuildApplicationCommandPermissions {..} = + object + [ (name, value) + | (name, Just value) <- + [ ("id", toMaybeJSON guildApplicationCommandPermissionsId), + ("application_id", toMaybeJSON guildApplicationCommandPermissionsApplicationId), + ("guild_id", toMaybeJSON guildApplicationCommandPermissionsGuildId), + ("permissions", toMaybeJSON guildApplicationCommandPermissionsPermissions) + ] + ] + +data ApplicationCommandPermissions = ApplicationCommandPermissions + { -- | The id of the role or user + applicationCommandPermissionsId :: Snowflake, + -- | Choose either role or user + applicationCommandPermissionsType :: ApplicationCommandPermissionType, + -- | Whether to allow or not + applicationCommandPermissionsPermission :: Bool + } + deriving (Show, Eq, Ord, Read) + +instance FromJSON ApplicationCommandPermissions where + parseJSON = + withObject + "ApplicationCommandPermissions" + ( \v -> + ApplicationCommandPermissions + <$> v .: "id" + <*> v .: "type" + <*> v .: "permission" + ) + +instance ToJSON ApplicationCommandPermissions where + toJSON ApplicationCommandPermissions {..} = + object + [ (name, value) + | (name, Just value) <- + [ ("id", toMaybeJSON applicationCommandPermissionsId), + ("type", toMaybeJSON applicationCommandPermissionsType), + ("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,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} -- | Data structures pertaining to Discord Channels module Discord.Internal.Types.Channel where @@ -13,8 +14,12 @@ import qualified Data.Text as T import Discord.Internal.Types.Prelude -import Discord.Internal.Types.User (User(..)) +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) -- | Guild channels represent an isolated set of users and messages in a Guild (Server) data Channel @@ -158,6 +163,73 @@ _ -> ChannelUnknownType <$> o .: "id" <*> pure (T.pack (show o)) +instance ToJSON Channel where + toJSON ChannelText{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure channelId) + , ("guild_id", toJSON <$> pure channelGuild) + , ("name", toJSON <$> pure channelName) + , ("position", toJSON <$> pure channelPosition) + , ("rate_limit_per_user", toJSON <$> pure channelUserRateLimit) + , ("nsfw", toJSON <$> pure channelNSFW) + , ("permission_overwrites", toJSON <$> pure channelPermissions) + , ("topic", toJSON <$> pure channelTopic) + , ("last_message_id", toJSON <$> channelLastMessage) + , ("parent_id", toJSON <$> pure channelParentId) + ] ] + toJSON ChannelNews{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure channelId) + , ("guild_id", toJSON <$> pure channelGuild) + , ("name", toJSON <$> pure channelName) + , ("position", toJSON <$> pure channelPosition) + , ("permission_overwrites", toJSON <$> pure channelPermissions) + , ("nsfw", toJSON <$> pure channelNSFW) + , ("topic", toJSON <$> pure channelTopic) + , ("last_message_id", toJSON <$> channelLastMessage) + ] ] + toJSON ChannelStorePage{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure channelId) + , ("guild_id", toJSON <$> pure channelGuild) + , ("name", toJSON <$> pure channelName) + , ("nsfw", toJSON <$> pure channelNSFW) + , ("position", toJSON <$> pure channelPosition) + , ("permission_overwrites", toJSON <$> pure channelPermissions) + ] ] + toJSON ChannelDirectMessage{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure channelId) + , ("recipients", toJSON <$> pure channelRecipients) + , ("last_message_id", toJSON <$> channelLastMessage) + ] ] + toJSON ChannelVoice{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure channelId) + , ("guild_id", toJSON <$> pure channelGuild) + , ("name", toJSON <$> pure channelName) + , ("position", toJSON <$> pure channelPosition) + , ("nsfw", toJSON <$> pure channelNSFW) + , ("permission_overwrites", toJSON <$> pure channelPermissions) + , ("bitrate", toJSON <$> pure channelBitRate) + , ("user_limit", toJSON <$> pure channelUserLimit) + ] ] + toJSON ChannelGroupDM{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure channelId) + , ("recipients", toJSON <$> pure channelRecipients) + , ("last_message_id", toJSON <$> channelLastMessage) + ] ] + toJSON ChannelGuildCategory{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure channelId) + , ("name", toJSON <$> pure channelName) + , ("guild_id", toJSON <$> pure channelGuild) + ] ] + toJSON ChannelStage{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure channelId) + , ("guild_id", toJSON <$> pure channelGuild) + , ("channel_id", toJSON <$> pure channelStageId) + , ("topic", toJSON <$> pure channelStageTopic) + ] ] + toJSON ChannelUnknownType{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure channelId) + , ("json", toJSON <$> pure channelJSON) + ] ] + -- | If the channel is part of a guild (has a guild id field) channelIsInGuild :: Channel -> Bool channelIsInGuild c = case c of @@ -171,9 +243,9 @@ -- | Permission overwrites for a channel. data Overwrite = Overwrite { overwriteId :: OverwriteId -- ^ 'Role' or 'User' id - , overwriteType :: T.Text -- ^ Either "role" or "member - , overwriteAllow :: Integer -- ^ Allowed permission bit set - , overwriteDeny :: Integer -- ^ Denied permission bit set + , overwriteType :: Integer -- ^ Either role (0) or member (1) + , overwriteAllow :: T.Text -- ^ Allowed permission bit set + , overwriteDeny :: T.Text -- ^ Denied permission bit set } deriving (Show, Read, Eq, Ord) instance FromJSON Overwrite where @@ -193,42 +265,55 @@ -- | Represents information about a message in a Discord channel. data Message = Message - { messageId :: MessageId -- ^ The id of the message - , messageChannel :: ChannelId -- ^ Id of the channel the message - -- was sent in - , messageAuthor :: User -- ^ The 'User' the message was sent - -- by - , messageText :: Text -- ^ Contents of the message - , messageTimestamp :: UTCTime -- ^ When the message was sent - , messageEdited :: Maybe UTCTime -- ^ When/if the message was edited - , messageTts :: Bool -- ^ Whether this message was a TTS - -- message - , messageEveryone :: Bool -- ^ Whether this message mentions - -- everyone - , messageMentions :: [User] -- ^ 'User's specifically mentioned in - -- the message - , messageMentionRoles :: [RoleId] -- ^ 'Role's specifically mentioned in - -- the message - , messageAttachments :: [Attachment] -- ^ Any attached files - , messageEmbeds :: [Embed] -- ^ Any embedded content - , messageReactions :: [MessageReaction] -- ^ Any reactions to message - , messageNonce :: Maybe Nonce -- ^ Used for validating if a message - -- was sent - , messagePinned :: Bool -- ^ Whether this message is pinned - , messageGuild :: Maybe GuildId -- ^ The guild the message went to - , messageReference :: Maybe MessageReference -- ^ Reference IDs of the original message - , referencedMessage :: Maybe Message -- ^ The full original message + { messageId :: MessageId -- ^ The id of the message + , messageChannelId :: ChannelId -- ^ Id of the channel the message + -- was sent in + , messageGuildId :: Maybe GuildId -- ^ The guild the message went to + , messageAuthor :: User -- ^ The 'User' the message was sent + -- by + , messageMember :: Maybe GuildMember -- ^ A partial guild member object + , messageContent :: Text -- ^ Contents of the message + , messageTimestamp :: UTCTime -- ^ When the message was sent + , messageEdited :: Maybe UTCTime -- ^ When/if the message was edited + , messageTts :: Bool -- ^ Whether this message was a TTS + -- message + , messageEveryone :: Bool -- ^ Whether this message mentions + -- everyone + , messageMentions :: [User] -- ^ 'User's specifically mentioned in + -- the message + , messageMentionRoles :: [RoleId] -- ^ 'Role's specifically mentioned in + -- the message + , messageAttachments :: [Attachment] -- ^ Any attached files + , messageEmbeds :: [Embed] -- ^ Any embedded content + , messageReactions :: [MessageReaction] -- ^ Any reactions to message + , messageNonce :: Maybe Nonce -- ^ Used for validating if a message + -- was sent + , messagePinned :: Bool -- ^ Whether this message is pinned + , 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) instance FromJSON Message where parseJSON = withObject "Message" $ \o -> Message <$> o .: "id" <*> o .: "channel_id" + <*> o .:? "guild_id" .!= Nothing <*> (do isW <- o .:? "webhook_id" a <- o .: "author" case isW :: Maybe WebhookId of Nothing -> pure a Just _ -> pure $ a { userIsWebhook = True }) + <*> o .:? "member" <*> o .:? "content" .!= "" <*> o .:? "timestamp" .!= epochTime <*> o .:? "edited_timestamp" @@ -241,11 +326,84 @@ <*> o .:? "reactions" .!= [] <*> o .:? "nonce" <*> o .:? "pinned" .!= False - <*> o .:? "guild_id" .!= Nothing + <*> o .:? "webhook_id" + <*> o .: "type" + <*> o .:? "activity" + -- <*> o .:? "application" + <*> o .:? "application_id" <*> o .:? "message_reference" .!= Nothing + <*> o .:? "flags" <*> o .:? "referenced_message" .!= Nothing + <*> o .:? "interaction" + <*> o .:? "thread" + <*> o .:? "components" + <*> o .:? "sticker_items" +instance ToJSON Message where + toJSON Message {..} = object [(name, value) | (name, Just value) <- + [ ("id", toJSON <$> pure messageId) + , ("channel_id", toJSON <$> pure messageChannelId) + , ("guild_id", toJSON <$> messageGuildId) + , ("author", toJSON <$> pure messageAuthor) + , ("member", toJSON <$> messageMember) + , ("content", toJSON <$> pure messageContent) + , ("timestamp", toJSON <$> pure messageTimestamp) + , ("edited_timestamp", toJSON <$> messageEdited) + , ("tts", toJSON <$> pure messageTts) + , ("mention_everyone", toJSON <$> pure messageEveryone) + , ("mentions", toJSON <$> pure messageMentions) + , ("mention_roles", toJSON <$> pure messageMentionRoles) + , ("attachments", toJSON <$> pure messageAttachments) + , ("embeds", toJSON <$> pure messageEmbeds) + , ("reactions", toJSON <$> pure messageReactions) + , ("nonce", toJSON <$> messageNonce) + , ("pinned", toJSON <$> pure messagePinned) + , ("webhook_id", toJSON <$> messageWebhookId) + , ("type", toJSON <$> pure messageType) + , ("activity", toJSON <$> messageActivity) + -- , ("application", toJSON <$> messageApplication) + , ("application_id", toJSON <$> messageApplicationId) + , ("message_reference", toJSON <$> messageReference) + , ("flags", toJSON <$> messageFlags) + , ("referenced_message", toJSON <$> messageReferencedMessage) + , ("interaction", toJSON <$> messageInteraction) + , ("thread", toJSON <$> messageThread) + , ("components", toJSON <$> messageComponents) + , ("sticker_items", toJSON <$> messageStickerItems) + ] ] + +-- | Data constructor for a part of MessageDetailedOpts. +data AllowedMentions = AllowedMentions + { mentionEveryone :: Bool + , mentionUsers :: Bool + , mentionRoles :: Bool + , mentionUserIds :: [UserId] + , mentionRoleIds :: [RoleId] + , mentionRepliedUser :: Bool + } deriving (Show, Read, Eq, Ord) + +instance Default AllowedMentions where + def = AllowedMentions { mentionEveryone = False + , mentionUsers = True + , mentionRoles = True + , mentionUserIds = [] + , mentionRoleIds = [] + , mentionRepliedUser = True + } + +instance ToJSON AllowedMentions where + toJSON AllowedMentions{..} = object [ + ("parse" .= [name :: T.Text | (name, True) <- + [ ("everyone", mentionEveryone), + ("users", mentionUsers && mentionUserIds == []), + ("roles", mentionRoles && mentionRoleIds == []) ] ]), + -- https://discord.com/developers/docs/resources/channel#allowed-mentions-object + -- parse.users and users list cannot both be active, prioritize id list + ("roles" .= mentionRoleIds), + ("users" .= mentionUserIds), + ("replied_user" .= mentionRepliedUser) ] + data MessageReaction = MessageReaction { messageReactionCount :: Int , messageReactionMeIncluded :: Bool @@ -258,29 +416,56 @@ <*> o .: "me" <*> o .: "emoji" --- | Represents an emoticon (emoji) -data Emoji = Emoji - { emojiId :: Maybe EmojiId -- ^ The emoji id - , emojiName :: T.Text -- ^ The emoji name - , emojiRoles :: Maybe [RoleId] -- ^ Roles the emoji is active for - , emojiUser :: Maybe User -- ^ User that created this emoji - , emojiManaged :: Maybe Bool -- ^ Whether this emoji is managed - , emojiAnimated :: Maybe Bool -- ^ Whether this emoji is animated - } deriving (Show, Read, Eq, Ord) +instance ToJSON MessageReaction where + toJSON MessageReaction{..} = object [(name, value) | (name, Just value) <- + [ ("count", toJSON <$> pure messageReactionCount) + , ("me", toJSON <$> pure messageReactionMeIncluded) + , ("emoji", toJSON <$> pure messageReactionEmoji) + ]] -instance FromJSON Emoji where - parseJSON = withObject "Emoji" $ \o -> - Emoji <$> o .: "id" - <*> o .: "name" - <*> o .:? "roles" - <*> o .:? "user" - <*> o .:? "managed" - <*> o .:? "animated" +-- TODO: expand stickers and have full objects +data StickerItem = StickerItem + { stickerItemId :: StickerId + , stickerItemName :: T.Text + , stickerItemFormatType :: StickerFormatType + } deriving (Show, Read, Eq, Ord) +instance FromJSON StickerItem where + parseJSON = withObject "StickerItem" $ \o -> + StickerItem <$> o .: "id" + <*> o .: "name" + <*> o .: "format_type" +instance ToJSON StickerItem where + toJSON StickerItem{..} = object [(name, value) | (name, Just value) <- + [ ("id", toJSON <$> pure stickerItemId) + , ("name", toJSON <$> pure stickerItemName) + , ("format_type", toJSON <$> pure stickerItemFormatType) + ]] + +data StickerFormatType = + StickerFormatTypePNG + | StickerFormatTypeAPNG + | 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 ToJSON StickerFormatType where + toJSON = toJSON . fromEnum + +instance FromJSON StickerFormatType where + parseJSON = withScientific "StickerFormatType" (return . toEnum . round) + -- | Represents an attached to a message file. data Attachment = Attachment - { attachmentId :: Snowflake -- ^ Attachment id + { attachmentId :: AttachmentId -- ^ Attachment id , attachmentFilename :: T.Text -- ^ Name of attached file , attachmentSize :: Integer -- ^ Size of file (in bytes) , attachmentUrl :: T.Text -- ^ Source of file @@ -299,7 +484,16 @@ <*> o .:? "height" <*> o .:? "width" - +instance ToJSON Attachment where + toJSON Attachment {..} = object [(name, value) | (name, Just value) <- + [ ("id", toJSON <$> pure attachmentId) + , ("filename", toJSON <$> pure attachmentFilename) + , ("size", toJSON <$> pure attachmentSize) + , ("url", toJSON <$> pure attachmentUrl) + , ("proxy_url", toJSON <$> pure attachmentProxy) + , ("height", toJSON <$> attachmentHeight) + , ("width", toJSON <$> attachmentWidth) + ] ] newtype Nonce = Nonce T.Text deriving (Show, Read, Eq, Ord) @@ -309,7 +503,10 @@ parseJSON (Number nonce) = pure . Nonce . T.pack . show $ nonce parseJSON _ = empty +instance ToJSON Nonce where + toJSON (Nonce t) = String t + -- | Represents a Message Reference data MessageReference = MessageReference { referenceMessageId :: Maybe MessageId -- ^ id of the originating message @@ -339,3 +536,166 @@ , referenceGuildId = Nothing , failIfNotExists = False } + + +data MessageType + = MessageTypeDefault + | MessageTypeRecipientAdd + | MessageTypeRecipientRemove + | MessageTypeCall + | MessageTypeChannelNameChange + | MessageTypeChannelIconChange + | MessageTypeChannelPinnedMessage + | MessageTypeGuildMemberJoin + | MessageTypeUserPremiumGuildSubscription + | MessageTypeUserPremiumGuildSubscriptionTier1 + | MessageTypeUserPremiumGuildSubscriptionTier2 + | MessageTypeUserPremiumGuildSubscriptionTier3 + | MessageTypeChannelFollowAdd + | MessageTypeGuildDiscoveryDisqualified + | MessageTypeGuildDiscoveryRequalified + | MessageTypeGuildDiscoveryGracePeriodInitialWarning + | MessageTypeGuildDiscoveryGracePeriodFinalWarning + | MessageTypeThreadCreated + | MessageTypeReply + | MessageTypeChatInputCommand + | MessageTypeThreadStarterMessage + | MessageTypeGuildInviteReminder + | 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 ToJSON MessageType where + toJSON = toJSON . fromEnum + +instance FromJSON MessageType where + parseJSON = withScientific "MessageType" (return . toEnum . round) + +data MessageActivity = MessageActivity + { messageActivityType :: MessageActivityType + , messageActivityPartyId :: Maybe T.Text + } + deriving (Show, Read, Data, Eq, Ord) + +instance FromJSON MessageActivity where + parseJSON = withObject "MessageActivity" $ \o -> + MessageActivity <$> o .: "type" + <*> o .:? "party_id" + +instance ToJSON MessageActivity where + toJSON MessageActivity{..} = object [(name,value) | (name, Just value) <- + [ ("type", toJSON <$> pure messageActivityType) + , ("party_id", toJSON <$> messageActivityPartyId) + ] ] + +data MessageActivityType + = MessageActivityTypeJoin -- ^ Join a Rich Presence event + | MessageActivityTypeSpectate -- ^ Spectate a Rich Presence event + | MessageActivityTypeListen -- ^ Listen to a Rich Presence event + | 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 ToJSON MessageActivityType where + toJSON = toJSON . fromEnum + +instance FromJSON MessageActivityType where + parseJSON = withScientific "MessageActivityType" (return . toEnum . round) + +-- | Types of flags to attach to the message. +data MessageFlag = + MessageFlagCrossposted + | MessageFlagIsCrosspost + | MessageFlagSupressEmbeds + | MessageFlagSourceMessageDeleted + | MessageFlagUrgent + | MessageFlagHasThread + | MessageFlagEphemeral + | MessageFlagLoading + deriving (Show, Read, Eq, Data, Ord) + +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 ToJSON MessageFlags where + toJSON (MessageFlags fs) = Number $ fromInteger $ fromIntegral $ foldr (.|.) 0 (fromEnum <$> 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 + +data MessageInteraction = MessageInteraction + { messageInteractionId :: InteractionId + , messageInteractionType :: InteractionType + , messageInteractionName :: T.Text + , messageInteractionUser :: User + } deriving (Show, Eq, Ord, Read) + +instance ToJSON MessageInteraction where + toJSON MessageInteraction{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure messageInteractionId) + , ("type", toJSON <$> pure messageInteractionType) + , ("name", toJSON <$> pure messageInteractionName) + , ("user", toJSON <$> pure messageInteractionUser) + ] ] + + +instance FromJSON MessageInteraction where + parseJSON = withObject "MessageInteraction" $ \o -> + MessageInteraction <$> o .: "id" + <*> o .: "type" + <*> o .: "name" + <*> o .: "user" + diff --git a/src/Discord/Internal/Types/Components.hs b/src/Discord/Internal/Types/Components.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Types/Components.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Discord.Internal.Types.Components where + +import Data.Aeson +import Data.Data (Data) +import Data.Maybe (fromJust, fromMaybe) +import qualified Data.Text as T +import Data.Tuple (swap) +import Discord.Internal.Types.Prelude (EmojiId, Internals (..), RoleId, makeTable, toMaybeJSON) +import Discord.Internal.Types.User (User) +import qualified Network.HTTP.Req as R + +-- | 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, + componentButtonDisabled :: Bool, + componentButtonStyle :: ButtonStyle, + componentButtonLabel :: T.Text, + componentButtonEmoji :: Maybe Emoji + } + | ComponentButtonUrl + { componentButtonUrl :: R.Url 'R.Https, + componentButtonDisabled :: Bool, + componentButtonLabel :: T.Text, + componentButtonEmoji :: Maybe Emoji + } + deriving (Show, Eq) + +data ButtonStyle = ButtonStylePrimary | ButtonStyleSecondary | ButtonStyleSuccess | ButtonStyleDanger + deriving (Show, Eq, Read) + +buttonStyles :: [(ButtonStyle, InternalButtonStyle)] +buttonStyles = + [ (ButtonStylePrimary, InternalButtonStylePrimary), + (ButtonStyleSecondary, InternalButtonStyleSecondary), + (ButtonStyleSuccess, InternalButtonStyleSuccess), + (ButtonStyleDanger, InternalButtonStyleDanger) + ] + +instance Internals ButtonStyle InternalButtonStyle where + toInternal a = fromJust (lookup a buttonStyles) + fromInternal b = lookup b (swap <$> buttonStyles) + +-- | 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, + componentSelectMenuDisabled :: Bool, + componentSelectMenuOptions :: [SelectOption], + componentSelectMenuPlaceholder :: Maybe T.Text, + componentSelectMenuMinValues :: Maybe Integer, + componentSelectMenuMaxValues :: Maybe Integer + } + deriving (Show, Eq, Read) + +data ComponentActionRow = ComponentActionRowButton [ComponentButton] | ComponentActionRowSelectMenu ComponentSelectMenu + deriving (Show, Eq) + +validPartialEmoji :: Emoji -> Maybe Emoji +validPartialEmoji Emoji {..} = do + eid <- emojiId + ean <- emojiAnimated + return $ Emoji (Just eid) emojiName Nothing Nothing Nothing (Just ean) + +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]) + + 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 + +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] + } + 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" + <*> o .:? "emoji" + <*> o .:? "url" + <*> o .:? "options" + <*> o .:? "placeholder" + <*> o .:? "min_values" + <*> o .:? "max_values" + <*> o .:? "components" + +instance ToJSON Component where + toJSON Component {..} = + 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) + ] + ] + +-- | 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 + emojiId :: Maybe EmojiId, + -- | The emoji name + emojiName :: T.Text, + -- | Roles the emoji is active for + emojiRoles :: Maybe [RoleId], + -- | User that created this emoji + emojiUser :: Maybe User, + -- | Whether this emoji is managed + emojiManaged :: Maybe Bool, + -- | Whether this emoji is animated + emojiAnimated :: Maybe Bool + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON Emoji where + parseJSON = withObject "Emoji" $ \o -> + Emoji <$> o .:? "id" + <*> o .: "name" + <*> o .:? "roles" + <*> o .:? "user" + <*> o .:? "managed" + <*> o .:? "animated" + +instance ToJSON Emoji where + toJSON Emoji {..} = + object + [ (name, value) + | (name, Just value) <- + [ ("id", toJSON <$> emojiId), + ("name", toMaybeJSON emojiName), + ("roles", toJSON <$> emojiRoles), + ("user", toJSON <$> emojiUser), + ("managed", toJSON <$> emojiManaged), + ("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/Events.hs b/src/Discord/Internal/Types/Events.hs --- a/src/Discord/Internal/Types/Events.hs +++ b/src/Discord/Internal/Types/Events.hs @@ -15,13 +15,15 @@ import Discord.Internal.Types.Prelude import Discord.Internal.Types.Channel -import Discord.Internal.Types.Guild -import Discord.Internal.Types.User (User) +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.Components (Emoji) -- | Represents possible events sent by discord. Detailed information can be found at https://discord.com/developers/docs/topics/gateway. data Event = - Ready Int User [Channel] [GuildUnavailable] T.Text + Ready Int User [Channel] [GuildUnavailable] T.Text (Maybe Shard) PartialApplication | Resumed [T.Text] | ChannelCreate Channel | ChannelUpdate Channel @@ -52,13 +54,14 @@ | PresenceUpdate PresenceInfo | TypingStart TypingInfo | UserUpdate User + | InteractionCreate Interaction -- | VoiceStateUpdate -- | VoiceServerUpdate | UnknownEvent T.Text Object deriving (Show, Read, Eq) data EventInternalParse = - InternalReady Int User [Channel] [GuildUnavailable] T.Text + InternalReady Int User [Channel] [GuildUnavailable] T.Text (Maybe Shard) PartialApplication | InternalResumed [T.Text] | InternalChannelCreate Channel | InternalChannelUpdate Channel @@ -89,11 +92,20 @@ | InternalPresenceUpdate PresenceInfo | InternalTypingStart TypingInfo | InternalUserUpdate User + | InternalInteractionCreate InternalInteraction -- | InternalVoiceStateUpdate -- | InternalVoiceServerUpdate | InternalUnknownEvent T.Text Object deriving (Show, Read, Eq) +data PartialApplication = PartialApplication + { partialApplicationID :: ApplicationId + , partialApplicationFlags :: Int + } deriving (Show, Eq, Read) + +instance FromJSON PartialApplication where + parseJSON = withObject "PartialApplication" (\v -> PartialApplication <$> v .: "id" <*> v .: "flags") + data ReactionInfo = ReactionInfo { reactionUserId :: UserId , reactionGuildId :: Maybe GuildId @@ -169,6 +181,8 @@ <*> o .: "private_channels" <*> o .: "guilds" <*> o .: "session_id" + <*> o .: "shard" + <*> o .: "application" "RESUMED" -> InternalResumed <$> o .: "_trace" "CHANNEL_CREATE" -> InternalChannelCreate <$> reparse o "CHANNEL_UPDATE" -> InternalChannelUpdate <$> reparse o @@ -202,10 +216,11 @@ "MESSAGE_REACTION_REMOVE" -> InternalMessageReactionRemove <$> reparse o "MESSAGE_REACTION_REMOVE_ALL" -> InternalMessageReactionRemoveAll <$> o .: "channel_id" <*> o .: "message_id" - "MESSAGE_REACTION_REMOVE_EMOJI"-> InternalMessageReactionRemoveEmoji <$> reparse o + "MESSAGE_REACTION_REMOVE_EMOJI" -> InternalMessageReactionRemoveEmoji <$> reparse o "PRESENCE_UPDATE" -> InternalPresenceUpdate <$> reparse o "TYPING_START" -> InternalTypingStart <$> reparse o "USER_UPDATE" -> InternalUserUpdate <$> reparse o -- "VOICE_STATE_UPDATE" -> InternalVoiceStateUpdate <$> reparse o -- "VOICE_SERVER_UPDATE" -> InternalVoiceServerUpdate <$> reparse o + "INTERACTION_CREATE" -> InternalInteractionCreate <$> reparse o _other_event -> InternalUnknownEvent t <$> reparse o 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 @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | Types relating to Discord Guilds (servers) module Discord.Internal.Types.Guild where @@ -9,45 +10,28 @@ import qualified Data.Text as T import Discord.Internal.Types.Prelude -import Discord.Internal.Types.Channel (Channel, Emoji) -import Discord.Internal.Types.User (User) +import Discord.Internal.Types.Channel (Channel) +import Discord.Internal.Types.User (User, GuildMember) +import Discord.Internal.Types.Components (Emoji) --- | Representation of a guild member. -data GuildMember = GuildMember - { memberUser :: User - , memberNick :: Maybe T.Text - , memberRoles :: [Snowflake] - , memberJoinedAt :: UTCTime - , memberDeaf :: Bool - , memberMute :: Bool - } deriving (Show, Read, Eq, Ord) -instance FromJSON GuildMember where - parseJSON = withObject "GuildMember" $ \o -> - GuildMember <$> o .: "user" - <*> o .:? "nick" - <*> o .: "roles" - <*> o .: "joined_at" - <*> o .: "deaf" - <*> o .: "mute" - --- https://discord.com/developers/docs/resources/guild#guild-object - -- | Guilds in Discord represent a collection of users and channels into an isolated -- "Server" +-- +-- https://discord.com/developers/docs/resources/guild#guild-object data Guild = Guild { guildId :: GuildId -- ^ Gulid id , guildName :: T.Text -- ^ Guild name (2 - 100 chars) , guildIcon :: Maybe T.Text -- ^ Icon hash , guildSplash :: Maybe T.Text -- ^ Splash hash , guildOwnerId :: UserId -- ^ Guild owner id - , guildPermissions :: Maybe Integer + , guildPermissions :: Maybe T.Text , guildRegion :: Maybe T.Text -- ^ Guild voice region , guildAfkId :: Maybe ChannelId -- ^ Id of afk channel , guildAfkTimeout :: Integer -- ^ Afk timeout in seconds - , guildEmbedEnabled :: Maybe Bool -- ^ Id of embedded channel - , guildEmbedChannel :: Maybe ChannelId -- ^ Id of embedded channel + , guildWidgetEnabled :: Maybe Bool -- ^ Id of embedded channel + , guildWidgetChannelId :: Maybe ChannelId -- ^ Id of embedded channel , guildVerificationLevel :: Integer -- ^ Level of verification , guildNotification :: Integer -- ^ Level of default notifications , guildExplicitFilterLevel :: Integer @@ -69,8 +53,8 @@ <*> o .:? "region" <*> o .:? "afk_channel_id" <*> o .: "afk_timeout" - <*> o .:? "embed_enabled" - <*> o .:? "embed_channel_id" + <*> o .:? "widget_enabled" + <*> o .:? "widget_channel_id" <*> o .: "verification_level" <*> o .: "default_message_notifications" <*> o .: "explicit_content_filter" @@ -112,7 +96,7 @@ , partialGuildName :: T.Text , partialGuildIcon :: Maybe T.Text , partialGuildOwner :: Bool - , partialGuildPermissions :: Integer + , partialGuildPermissions :: T.Text } deriving (Show, Read, Eq, Ord) instance FromJSON PartialGuild where @@ -135,7 +119,7 @@ , roleColor :: ColorInteger -- ^ Integer representation of color code , roleHoist :: Bool -- ^ If the role is pinned in the user listing , rolePos :: Integer -- ^ Position of this role - , rolePerms :: Integer -- ^ 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) @@ -261,17 +245,17 @@ IntegrationAccount <$> o .: "id" <*> o .: "name" -- | Represents an image to be used in third party sites to link to a discord channel -data GuildEmbed = GuildEmbed - { embedEnabled :: Bool -- ^ Whether the embed is enabled - , embedChannel :: ChannelId -- ^ The embed channel id +data GuildWidget = GuildWidget + { widgetEnabled :: Bool -- ^ Whether the widget is enabled + , widgetChannelId :: ChannelId -- ^ The widget channel id } deriving (Show, Read, Eq, Ord) -instance FromJSON GuildEmbed where - parseJSON = withObject "GuildEmbed" $ \o -> - GuildEmbed <$> o .: "enabled" <*> o .: "snowflake" +instance FromJSON GuildWidget where + parseJSON = withObject "GuildWidget" $ \o -> + GuildWidget <$> o .: "enabled" <*> o .: "channel_id" -instance ToJSON GuildEmbed where - toJSON (GuildEmbed enabled snowflake) = object +instance ToJSON GuildWidget where + toJSON (GuildWidget enabled snowflake) = object [ "enabled" .= enabled - , "snowflake" .= snowflake + , "channel_id" .= snowflake ] diff --git a/src/Discord/Internal/Types/Interactions.hs b/src/Discord/Internal/Types/Interactions.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Types/Interactions.hs @@ -0,0 +1,614 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Discord.Internal.Types.Interactions + ( Interaction (..), + InteractionDataComponent (..), + InteractionDataApplicationCommand (..), + InteractionDataApplicationCommandOptions (..), + InteractionDataApplicationCommandOptionSubcommandOrGroup (..), + InteractionDataApplicationCommandOptionSubcommand (..), + InteractionDataApplicationCommandOptionValue (..), + ApplicationCommandInteractionDataValue (..), + InternalInteraction (..), + InteractionToken, + InteractionType, + InternalInteractionData (..), + ResolvedData (..), + InternalInteractionDataApplicationCommandOption (..), + InteractionResponse (..), + interactionResponseBasic, + InteractionCallbackType (..), + InteractionCallbackData (..), + InteractionCallbackAutocomplete, + InteractionCallbackMessages (..), + interactionCallbackMessagesBasic, + InteractionCallbackDataFlags (..), + InteractionCallbackDataFlag (..), + ) +where + +import Control.Applicative (Alternative ((<|>))) +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.Bits (Bits (shift, (.|.))) +import Data.Data (Data) +import Data.Maybe (fromJust, fromMaybe) +import Data.Scientific (Scientific) +import qualified Data.Text as T +import Discord.Internal.Types.ApplicationCommands + ( + InternalApplicationCommandOptionChoice, + ApplicationCommandOptionType (..), + ApplicationCommandType (..), + ) +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.User (GuildMember, User) + +import Debug.Trace + +data Interaction + = InteractionComponent + { interactionId :: InteractionId, + interactionApplicationId :: ApplicationId, + interactionDataComponent :: Maybe InteractionDataComponent, -- referenced as Data in API + interactionGuildId :: Maybe GuildId, + interactionChannelId :: Maybe ChannelId, + interactionMember :: Maybe GuildMember, + interactionUser :: Maybe User, + interactionToken :: InteractionToken, + interactionVersion :: Int, + interactionMessage :: Message + } + | InteractionPing + { interactionId :: InteractionId, + interactionApplicationId :: ApplicationId, + interactionToken :: InteractionToken, + interactionVersion :: Int + } + | InteractionApplicationCommand + { interactionId :: InteractionId, + interactionApplicationId :: ApplicationId, + interactionDataApplicationCommand :: Maybe InteractionDataApplicationCommand, -- referenced as Data in API + interactionGuildId :: Maybe GuildId, + interactionChannelId :: Maybe ChannelId, + interactionMember :: Maybe GuildMember, + interactionUser :: Maybe User, + interactionToken :: InteractionToken, + interactionVersion :: Int + } + | InteractionApplicationCommandAutocomplete + { interactionId :: InteractionId, + interactionApplicationId :: ApplicationId, + interactionDataApplicationCommand :: Maybe InteractionDataApplicationCommand, -- referenced as Data in API + interactionGuildId :: Maybe GuildId, + interactionChannelId :: Maybe ChannelId, + interactionMember :: Maybe GuildMember, + interactionUser :: Maybe User, + interactionToken :: InteractionToken, + interactionVersion :: Int + } + | InteractionUnknown InternalInteraction + deriving (Show, Read, Eq) + +data InteractionDataComponent + = InteractionDataComponentButton + { -- | Component only, the unique id + interactionDataComponentCustomId :: T.Text + } + | InteractionDataComponentSelectMenu + { interactionDataComponentCustomId :: T.Text, + interactionDataComponentValues :: [T.Text] + } + deriving (Show, Read, Eq) + +data InteractionDataApplicationCommand + = InteractionDataApplicationCommandUser + { -- | id of the invoked command + interactionDataApplicationCommandId :: ApplicationCommandId, + -- | name of the invoked command + interactionDataApplicationCommandName :: T.Text, + -- | the resolved data in the command + interactionDataApplicationCommandResolvedData :: Maybe ResolvedData, + -- | the target of the command + interactionDataApplicationCommandTargetId :: UserId + } + | InteractionDataApplicationCommandMessage + { -- | Application command only, id of the invoked command + interactionDataApplicationCommandId :: ApplicationCommandId, + -- | Application command only, name of the invoked command + interactionDataApplicationCommandName :: T.Text, + interactionDataApplicationCommandResolvedData :: Maybe ResolvedData, + interactionDataApplicationCommandTargetId :: MessageId + } + | InteractionDataApplicationCommandChatInput + { -- | Application command only, id of the invoked command + interactionDataApplicationCommandId :: ApplicationCommandId, + -- | Application command only, name of the invoked command + interactionDataApplicationCommandName :: T.Text, + interactionDataApplicationCommandResolvedData :: Maybe ResolvedData, + interactionDataApplicationCommandOptions :: Maybe InteractionDataApplicationCommandOptions + } + deriving (Show, Read, Eq) + +data InteractionDataApplicationCommandOptions + = InteractionDataApplicationCommandOptionsSubcommands [InteractionDataApplicationCommandOptionSubcommandOrGroup] + | InteractionDataApplicationCommandOptionsValues [InteractionDataApplicationCommandOptionValue] + deriving (Show, Read, Eq) + +data InteractionDataApplicationCommandOptionSubcommandOrGroup + = InteractionDataApplicationCommandOptionSubcommandGroup + { interactionDataApplicationCommandOptionSubcommandGroupName :: T.Text, + interactionDataApplicationCommandOptionSubcommandGroupOptions :: [InteractionDataApplicationCommandOptionSubcommand], + interactionDataApplicationCommandOptionSubcommandGroupFocused :: Maybe Bool + } + | InteractionDataApplicationCommandOptionSubcommandOrGroupSubcommand InteractionDataApplicationCommandOptionSubcommand + deriving (Show, Read, Eq) + +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 + } + 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 + 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" + ) + +-- | 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 + } + 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 + 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" + ) + +-- | 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. +-- If you need to extract from these values, check out the link below. +-- +-- https://discord.com/developers/docs/interactions/receiving-and-responding#interaction-object-resolved-data-structure +data ResolvedData = ResolvedData + { resolvedDataUsers :: Maybe Value, + resolvedDataMembers :: Maybe Value, + resolvedDataRoles :: Maybe Value, + resolvedDataChannels :: Maybe Value + } + deriving (Show, Read, Eq) + +instance ToJSON ResolvedData where + toJSON ResolvedData {..} = + object + [ (name, value) + | (name, Just value) <- + [ ("users", resolvedDataUsers), + ("members", resolvedDataMembers), + ("roles", resolvedDataRoles), + ("channels", resolvedDataChannels) + ] + ] + +instance FromJSON ResolvedData where + parseJSON = + withObject + "ResolvedData" + ( \v -> + ResolvedData + <$> v .:? "users" + <*> v .:? "members" + <*> v .:? "roles" + <*> 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) + +interactionResponseBasic :: T.Text -> InteractionResponse +interactionResponseBasic t = InteractionResponse InteractionCallbackTypeChannelMessageWithSource (Just . InteractionCallbackDataMessages $ interactionCallbackMessagesBasic 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) + +instance ToJSON InteractionCallbackData where + toJSON (InteractionCallbackDataMessages icdm) = toJSON icdm + toJSON (InteractionCallbackDataAutocomplete icda) = toJSON icda + +type InteractionCallbackAutocomplete = [InternalApplicationCommandOptionChoice] + +-- | 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] + } + deriving (Show, Read, Eq) + +interactionCallbackMessagesBasic :: T.Text -> InteractionCallbackMessages +interactionCallbackMessagesBasic t = InteractionCallbackMessages Nothing (Just t) Nothing Nothing Nothing Nothing Nothing + +instance ToJSON InteractionCallbackMessages where + toJSON InteractionCallbackMessages {..} = + 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) + ] + ] + +-- | Types of flags to attach to the interaction message. +-- +-- Currently the only flag is EPHERMERAL, which means only the user can see the +-- message. +data InteractionCallbackDataFlag = InteractionCallbackDataFlagEphermeral + deriving (Show, Read, Eq) + +newtype InteractionCallbackDataFlags = InteractionCallbackDataFlags [InteractionCallbackDataFlag] + deriving (Show, Read, Eq) + +instance Enum InteractionCallbackDataFlag where + fromEnum InteractionCallbackDataFlagEphermeral = 1 `shift` 6 + toEnum i + | i == 1 `shift` 6 = InteractionCallbackDataFlagEphermeral + | 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 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,5 +1,8 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} -- | Provides base types and utility functions needed for modules in Discord.Internal.Types module Discord.Internal.Types.Prelude where @@ -15,6 +18,9 @@ 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 @@ -41,20 +47,29 @@ toJSON (Snowflake snowflake) = String . T.pack $ show snowflake instance FromJSON Snowflake where - parseJSON (String snowflake) = pure . read $ T.unpack snowflake + parseJSON (String snowflake) = case readMaybe (T.unpack snowflake) of + Nothing -> fail "null snowflake" + (Just i) -> pure i parseJSON _ = mzero type ChannelId = Snowflake type StageId = Snowflake type GuildId = Snowflake type MessageId = Snowflake +type AttachmentId = Snowflake type EmojiId = Snowflake +type StickerId = Snowflake type UserId = Snowflake type OverwriteId = Snowflake type RoleId = Snowflake type IntegrationId = Snowflake type WebhookId = Snowflake type ParentId = Snowflake +type ApplicationId = Snowflake +type ApplicationCommandId = Snowflake +type InteractionId = Snowflake +type InteractionToken = T.Text +type Shard = (Int, Int) -- | Gets a creation date from a snowflake. snowflakeCreationDate :: Snowflake -> UTCTime @@ -66,3 +81,41 @@ 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 + +-- | 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) + +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 + +instance ToJSON InteractionType where + toJSON = toJSON . fromEnum + +instance FromJSON InteractionType where + parseJSON = withScientific "InteractionType" (return . toEnum . round) + +class Internals a b where + toInternal :: a -> b + fromInternal :: b -> Maybe a + +instance Internals a a where + toInternal = id + fromInternal = Just diff --git a/src/Discord/Internal/Types/User.hs b/src/Discord/Internal/Types/User.hs --- a/src/Discord/Internal/Types/User.hs +++ b/src/Discord/Internal/Types/User.hs @@ -8,55 +8,79 @@ import Data.Text (Text) import qualified Data.Text as T import Discord.Internal.Types.Prelude +import Data.Time (UTCTime) -- | Represents information about a user. data User = User - { userId :: UserId -- ^ The user's id. - , userName :: T.Text -- ^ The user's username (not unique) - , userDiscrim :: T.Text -- ^ The user's 4-digit discord-tag. - , userAvatar :: Maybe T.Text -- ^ The user's avatar hash. - , userIsBot :: Bool -- ^ User is an OAuth2 application. - , userIsWebhook:: Bool -- ^ User is a webhook - , userMfa :: Maybe Bool -- ^ User has two factor authentication enabled on the account. - , userVerified :: Maybe Bool -- ^ Whether the email has been verified. - , userEmail :: Maybe T.Text -- ^ The user's email. + { userId :: UserId -- ^ The user's id. + , userName :: T.Text -- ^ The user's username (not unique) + , userDiscrim :: Maybe T.Text -- ^ The user's 4-digit discord-tag. + , userAvatar :: Maybe T.Text -- ^ The user's avatar hash. + , userIsBot :: Bool -- ^ User is an OAuth2 application. + , userIsWebhook :: Bool -- ^ User is a webhook. + , userIsSystem :: Maybe Bool -- ^ User is an official discord system user. + , userMfa :: Maybe Bool -- ^ User has two factor authentication enabled on the account. + , userBanner :: Maybe T.Text -- ^ User's banner hash + , userAccentColor :: Maybe Int -- ^ User's banner color + , userLocale :: Maybe T.Text -- ^ User's chosen language + , userVerified :: Maybe Bool -- ^ Whether the email has been verified. + , userEmail :: Maybe T.Text -- ^ The user's email. + , userFlags :: Maybe Integer -- ^ The user's flags. + , userPremiumType :: Maybe Integer -- ^ The user's premium type. + , userPublicFlags :: Maybe Integer -- ^ The user's public flags. + , userMember :: Maybe GuildMember -- ^ Some guild member info (message create/update) } deriving (Show, Read, Eq, Ord) instance FromJSON User where parseJSON = withObject "User" $ \o -> User <$> o .: "id" <*> o .: "username" - <*> o .: "discriminator" + <*> o .:? "discriminator" -- possibly not there in the case of webhooks <*> o .:? "avatar" <*> o .:? "bot" .!= False <*> pure False -- webhook + <*> o .:? "system" <*> o .:? "mfa_enabled" + <*> o .:? "banner" + <*> o .:? "accent_color" + <*> o .:? "locale" <*> o .:? "verified" <*> o .:? "email" + <*> o .:? "flags" + <*> o .:? "premium_type" + <*> o .:? "public_flags" + <*> o .:? "member" instance ToJSON User where toJSON User{..} = object [(name,value) | (name, Just value) <- [ ("id", toJSON <$> pure userId) , ("username", toJSON <$> pure userName) - , ("discriminator", toJSON <$> pure userDiscrim) + , ("discriminator", toJSON <$> userDiscrim) , ("avatar", toJSON <$> userAvatar) , ("bot", toJSON <$> pure userIsBot) - , ("webhook", toJSON <$> pure userIsWebhook) + , ("system", toJSON <$> userIsSystem) , ("mfa_enabled", toJSON <$> userMfa) + , ("banner", toJSON <$> userBanner) + , ("accent_color", toJSON <$> userAccentColor) , ("verified", toJSON <$> userVerified) , ("email", toJSON <$> userEmail) + , ("flags", toJSON <$> userFlags) + , ("premium_type", toJSON <$> userPremiumType) + , ("public_flags", toJSON <$> userPublicFlags) + , ("member", toJSON <$> userPublicFlags) ] ] +-- TODO: fully update webhook structure data Webhook = Webhook { webhookId :: WebhookId - , webhookToken :: Text + , webhookToken :: Maybe Text , webhookChannelId :: ChannelId } deriving (Show, Read, Eq, Ord) instance FromJSON Webhook where parseJSON = withObject "Webhook" $ \o -> Webhook <$> o .: "id" - <*> o .: "token" + <*> o .:? "token" <*> o .: "channel_id" data ConnectionObject = ConnectionObject @@ -83,3 +107,45 @@ <*> o .: "friend_sync" <*> o .: "show_activity" <*> ( (==) (1::Int) <$> o .: "visibility") + + +-- | Representation of a guild member. +data GuildMember = GuildMember + { memberUser :: Maybe User -- ^ User object - not included in message_create or update + , memberNick :: Maybe T.Text -- ^ User's guild nickname + , memberAvatar :: Maybe T.Text -- ^ User's guild avatar hash + , memberRoles :: [RoleId] -- ^ Array of role ids + , memberJoinedAt :: UTCTime -- ^ When the user joined the guild + , memberPremiumSince :: Maybe UTCTime -- ^ When the user started boosting the guild + , memberDeaf :: Bool -- ^ Whether the user is deafened + , memberMute :: Bool -- ^ Whether the user is muted + , memberPending :: Bool -- ^ Whether the user has passed the guild's membership screening + , memberPermissions :: Maybe T.Text -- ^ total permissions of the member + } deriving (Show, Read, Eq, Ord) + +instance FromJSON GuildMember where + parseJSON = withObject "GuildMember" $ \o -> + GuildMember <$> o .:? "user" + <*> o .:? "nick" + <*> o .:? "avatar" + <*> o .: "roles" + <*> o .: "joined_at" + <*> o .:? "premium_since" + <*> o .: "deaf" + <*> o .: "mute" + <*> o .:? "pending" .!= False + <*> o .:? "permissions" + +instance ToJSON GuildMember where + toJSON GuildMember {..} = object [(name, value) | (name, Just value) <- + [ ("user", toJSON <$> memberUser) + , ("nick", toJSON <$> memberNick) + , ("avatar", toJSON <$> memberAvatar) + , ("roles", toJSON <$> pure memberRoles) + , ("joined_at", toJSON <$> pure memberJoinedAt) + , ("premium_since", toJSON <$> memberPremiumSince) + , ("deaf", toJSON <$> pure memberDeaf) + , ("mute", toJSON <$> pure memberMute) + , ("pending", toJSON <$> pure memberPending) + , ("permissions", toJSON <$> memberPermissions) + ] ] diff --git a/src/Discord/Requests.hs b/src/Discord/Requests.hs --- a/src/Discord/Requests.hs +++ b/src/Discord/Requests.hs @@ -6,6 +6,8 @@ , module Discord.Internal.Rest.User , module Discord.Internal.Rest.Voice , module Discord.Internal.Rest.Webhook + , module Discord.Internal.Rest.ApplicationCommands + , module Discord.Internal.Rest.Interactions ) where import Discord.Internal.Rest.Channel @@ -15,3 +17,5 @@ import Discord.Internal.Rest.User import Discord.Internal.Rest.Voice import Discord.Internal.Rest.Webhook +import Discord.Internal.Rest.ApplicationCommands +import Discord.Internal.Rest.Interactions