diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,38 +1,32 @@ -# 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) +# 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) -## 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`. +Build that discord bot in Haskell! Also checkout the +[calamity haskell library](https://github.com/nitros12/calamity) +for a more advanced interface. -### Documentation + #### Local Documentation -Find docs on features, metadata, and parts is found in [./docs/README.md#Documentation](./docs/README.md#Documentation) +Documentation on specific features and metadata is in [the local documentation folder](./docs/README.md#Documentation) #### Discord Server -Current project discord server: - -Ask questions, get updates, request features, etc +Ask questions, get updates, request features, etc in the project discord server: #### 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. +This api closley matches the [official discord documentation](https://discord.com/developers/docs/intro), +which lists the rest requests, gateway events, and gateway sendables. -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. +You can use the docs to check the name of something you want to do. For example: +the docs list a [Get Channel](https://discord.com/developers/docs/resources/channel#get-channel) API path, +which translates to discord-haskell's rest request ADT for `GetChannel` of type `ChannelId -> ChannelRequest Channel`. #### 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 +If something goes wrong: check the error message (optional: check [the debugging logs](./docs/debugging.md)), make sure you have the most recent version, ask on discord, or open a github issue. ### Quickstart @@ -40,12 +34,13 @@ ```haskell {-# LANGUAGE OverloadedStrings #-} -- allows "string literals" to be Text -import Control.Monad (when, void) -import Data.Text (isPrefixOf, toLower, Text) +import Control.Monad (when, void) +import UnliftIO.Concurrent +import Data.Text (isPrefixOf, toLower, Text) import qualified Data.Text.IO as TIO -import UnliftIO.Concurrent -import Discord -import Discord.Types + +import Discord +import Discord.Types import qualified Discord.Requests as R -- | Replies "pong" to every message that starts with "ping" @@ -53,16 +48,14 @@ pingpongExample = do userFacingError <- runDiscord $ def { discordToken = "Bot ZZZZZZZZZZZZZZZZZZZ" - , discordOnEvent = eventHandler - , discordOnLog = \s -> TIO.putStrLn s - , discordForkThreadForEvents = True } + , discordOnEvent = eventHandler } 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 + MessageCreate m -> when (isPing m && (not (fromBot m)) $ do void $ restCall (R.CreateReaction (messageChannelId m, messageId m) "eyes") threadDelay (2 * 10^6) void $ restCall (R.CreateMessage (messageChannelId m) "Pong!") @@ -75,32 +68,11 @@ isPing = ("ping" `isPrefixOf`) . toLower . messageContent ``` -```cabal --- ping-pong.cabal - -executable haskell-bot - main-is: src/Main.hs - default-language: Haskell2010 - ghc-options: -threaded - build-depends: base - , text - , unliftio - , discord-haskell -``` - -### Biggest TODOs - -- [ ] Add slash commands [issue](https://github.com/aquarial/discord-haskell/issues/59) -- [ ] APIv9 [issue](https://github.com/aquarial/discord-haskell/issues/72) -- [ ] Event type includes roles and other cached info -- [ ] higher level bot interface? easier to add state and stuff -- [x] rewrite eventloop [issue](https://github.com/aquarial/discord-haskell/issues/70) - ### Installing discord-haskell is on hosted on hackage at https://hackage.haskell.org/package/discord-haskell, -In `stack.yaml` +Add the following to your `stack.yaml` (if using stack) ```yaml extra-deps: @@ -108,7 +80,7 @@ - discord-haskell-VERSION ``` -In `project.cabal` +And add this to the `project.cabal` ```cabal executable haskell-bot @@ -117,7 +89,8 @@ ghc-options: -threaded build-depends: base , text - , discord-haskell + , discord-haskell + -- == VERSION (if using cabal) ``` For a more complete example with various options go to @@ -127,5 +100,13 @@ [Creating your first Bot](https://github.com/aquarial/discord-haskell/wiki/Creating-your-first-Bot) for some help setting up your bot token + + +### Rough Roadmap + +- [ ] Add slash commands [issue](https://github.com/aquarial/discord-haskell/issues/59) +- [ ] APIv9 [issue](https://github.com/aquarial/discord-haskell/issues/72) +- [ ] Event type includes roles and other cached info +- [ ] higher level bot interface? easier to add state and stuff diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -6,6 +6,12 @@ ## master +## 1.12.1 + +[L0neGamer](https://github.com/aquarial/discord-haskell/pull/103) Add threads, switch api to V10, Update Guild data fields + +[L0neGamer](https://github.com/aquarial/discord-haskell/pull/104) Add model interaction and components + ## 1.12.0 [L0neGamer](https://github.com/aquarial/discord-haskell/pull/96) breaking changes and fixes to application commands, interactions, and components, and updates elsewhere 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.12.0 +version: 1.12.1 description: Functions and data types to write discord bots. Official discord docs . . diff --git a/examples/ping-pong.hs b/examples/ping-pong.hs --- a/examples/ping-pong.hs +++ b/examples/ping-pong.hs @@ -36,6 +36,7 @@ , discordOnEnd = liftIO $ putStrLn "Ended" , discordOnEvent = eventHandler , discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "" + , discordGatewayIntent = def {gatewayIntentMembers = True, gatewayIntentPrecenses =True} } -- only reached on an unrecoverable error @@ -46,10 +47,9 @@ -- Use place to execute commands you know you want to complete startHandler :: DiscordHandler () startHandler = do - let activity = Activity { activityName = "ping-pong" - , activityType = ActivityTypeGame - , activityUrl = Nothing - } + let activity = def { activityName = "ping-pong" + , activityType = ActivityTypeGame + } let opts = UpdateStatusOpts { updateStatusOptsSince = Nothing , updateStatusOptsGame = Just activity , updateStatusOptsNewStatus = UpdateStatusOnline 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 @@ -16,7 +16,7 @@ data Cache = Cache { cacheCurrentUser :: User , cacheDMChannels :: M.Map ChannelId Channel - , cacheGuilds :: M.Map GuildId (Guild, GuildInfo) + , cacheGuilds :: M.Map GuildId Guild , cacheChannels :: M.Map ChannelId Channel , cacheApplication :: PartialApplication } deriving (Show) @@ -54,10 +54,10 @@ adjustCache :: Cache -> EventInternalParse -> Cache adjustCache minfo event = case event of - InternalGuildCreate guild info -> - let newChans = map (setChanGuildID (guildId guild)) $ guildChannels info - g = M.insert (guildId guild) (guild, info { guildChannels = newChans }) (cacheGuilds minfo) - c = M.unionWith (\a _ -> a) + InternalGuildCreate guild -> + let newChans = maybe [] (map (setChanGuildID (guildId guild))) (guildChannels guild) + g = M.insert (guildId guild) (guild { guildChannels = Just newChans }) (cacheGuilds minfo) + c = M.unionWith const (M.fromList [ (channelId ch, ch) | ch <- newChans ]) (cacheChannels minfo) in minfo { cacheGuilds = g, cacheChannels = c } 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 @@ -24,6 +24,7 @@ receiveData, sendTextData, sendClose) import Discord.Internal.Types +import Discord.Internal.Rest.Prelude (apiVersion) data GatewayHandle = GatewayHandle @@ -102,7 +103,7 @@ LoopClosed -> pure Nothing startconnectionpls :: GatewaySendableInternal -> IO LoopState - startconnectionpls first = runSecureClient "gateway.discord.gg" 443 "/?v=8&encoding=json" $ \conn -> do + startconnectionpls first = runSecureClient "gateway.discord.gg" 443 ("/?v=" <> T.unpack apiVersion <>"&encoding=json") $ \conn -> do msg <- getPayload conn log case msg of Right (Hello interval) -> do 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 @@ -16,6 +16,9 @@ , ChannelPermissionsOpts(..) , GroupDMAddRecipientOpts(..) , ChannelPermissionsOptsType(..) + , StartThreadOpts(..) + , StartThreadNoMessageOpts(..) + , ListThreads(..) ) where @@ -41,60 +44,91 @@ -- | Data constructor for requests. See data ChannelRequest a where -- | Gets a channel by its id. - GetChannel :: ChannelId -> ChannelRequest Channel + GetChannel :: ChannelId -> ChannelRequest Channel -- | Edits channels options. - ModifyChannel :: ChannelId -> ModifyChannelOpts -> ChannelRequest Channel + ModifyChannel :: ChannelId -> ModifyChannelOpts -> ChannelRequest Channel -- | Deletes a channel if its id doesn't equal to the id of guild. - DeleteChannel :: ChannelId -> ChannelRequest Channel + DeleteChannel :: ChannelId -> ChannelRequest Channel -- | Gets a messages from a channel with limit of 100 per request. - GetChannelMessages :: ChannelId -> (Int, MessageTiming) -> ChannelRequest [Message] + GetChannelMessages :: ChannelId -> (Int, MessageTiming) -> ChannelRequest [Message] -- | Gets a message in a channel by its id. - GetChannelMessage :: (ChannelId, MessageId) -> ChannelRequest Message + GetChannelMessage :: (ChannelId, MessageId) -> ChannelRequest Message -- | Sends a message to a channel. - CreateMessage :: ChannelId -> T.Text -> ChannelRequest Message + CreateMessage :: ChannelId -> T.Text -> ChannelRequest Message -- | Sends a message with a file to a channel. - CreateMessageUploadFile :: ChannelId -> T.Text -> B.ByteString -> ChannelRequest Message + CreateMessageUploadFile :: ChannelId -> T.Text -> B.ByteString -> ChannelRequest Message -- | Sends a message with granular controls. - CreateMessageDetailed :: ChannelId -> MessageDetailedOpts -> ChannelRequest Message + CreateMessageDetailed :: ChannelId -> MessageDetailedOpts -> ChannelRequest Message -- | Add an emoji reaction to a message. ID must be present for custom emoji - CreateReaction :: (ChannelId, MessageId) -> T.Text -> ChannelRequest () + CreateReaction :: (ChannelId, MessageId) -> T.Text -> ChannelRequest () -- | Remove a Reaction this bot added - DeleteOwnReaction :: (ChannelId, MessageId) -> T.Text -> ChannelRequest () + DeleteOwnReaction :: (ChannelId, MessageId) -> T.Text -> ChannelRequest () -- | Remove a Reaction someone else added - DeleteUserReaction :: (ChannelId, MessageId) -> UserId -> T.Text -> ChannelRequest () + DeleteUserReaction :: (ChannelId, MessageId) -> UserId -> T.Text -> ChannelRequest () -- | Deletes all reactions of a single emoji on a message - DeleteSingleReaction :: (ChannelId, MessageId) -> T.Text -> ChannelRequest () + DeleteSingleReaction :: (ChannelId, MessageId) -> T.Text -> ChannelRequest () -- | List of users that reacted with this emoji - GetReactions :: (ChannelId, MessageId) -> T.Text -> (Int, ReactionTiming) -> ChannelRequest [User] + GetReactions :: (ChannelId, MessageId) -> T.Text -> (Int, ReactionTiming) -> ChannelRequest [User] -- | Delete all reactions on a message - DeleteAllReactions :: (ChannelId, MessageId) -> ChannelRequest () + DeleteAllReactions :: (ChannelId, MessageId) -> ChannelRequest () -- | Edits a message content. - EditMessage :: (ChannelId, MessageId) -> T.Text -> Maybe CreateEmbed - -> ChannelRequest Message + EditMessage :: (ChannelId, MessageId) -> T.Text -> Maybe CreateEmbed + -> ChannelRequest Message -- | Deletes a message. - DeleteMessage :: (ChannelId, MessageId) -> ChannelRequest () + DeleteMessage :: (ChannelId, MessageId) -> ChannelRequest () -- | Deletes a group of messages. - BulkDeleteMessage :: (ChannelId, [MessageId]) -> ChannelRequest () + BulkDeleteMessage :: (ChannelId, [MessageId]) -> ChannelRequest () -- | Edits a permission overrides for a channel. - EditChannelPermissions :: ChannelId -> OverwriteId -> ChannelPermissionsOpts -> ChannelRequest () + EditChannelPermissions :: ChannelId -> OverwriteId -> ChannelPermissionsOpts -> ChannelRequest () -- | Gets all instant invites to a channel. - GetChannelInvites :: ChannelId -> ChannelRequest Object + GetChannelInvites :: ChannelId -> ChannelRequest Object -- | Creates an instant invite to a channel. - CreateChannelInvite :: ChannelId -> ChannelInviteOpts -> ChannelRequest Invite + CreateChannelInvite :: ChannelId -> ChannelInviteOpts -> ChannelRequest Invite -- | Deletes a permission override from a channel. - DeleteChannelPermission :: ChannelId -> OverwriteId -> ChannelRequest () + DeleteChannelPermission :: ChannelId -> OverwriteId -> ChannelRequest () -- | Sends a typing indicator a channel which lasts 10 seconds. - TriggerTypingIndicator :: ChannelId -> ChannelRequest () + TriggerTypingIndicator :: ChannelId -> ChannelRequest () -- | Gets all pinned messages of a channel. - GetPinnedMessages :: ChannelId -> ChannelRequest [Message] + GetPinnedMessages :: ChannelId -> ChannelRequest [Message] -- | Pins a message. - AddPinnedMessage :: (ChannelId, MessageId) -> ChannelRequest () + AddPinnedMessage :: (ChannelId, MessageId) -> ChannelRequest () -- | Unpins a message. - DeletePinnedMessage :: (ChannelId, MessageId) -> ChannelRequest () + DeletePinnedMessage :: (ChannelId, MessageId) -> ChannelRequest () -- | Adds a recipient to a Group DM using their access token - GroupDMAddRecipient :: ChannelId -> GroupDMAddRecipientOpts -> ChannelRequest () + GroupDMAddRecipient :: ChannelId -> GroupDMAddRecipientOpts -> ChannelRequest () -- | Removes a recipient from a Group DM - GroupDMRemoveRecipient :: ChannelId -> UserId -> ChannelRequest () + GroupDMRemoveRecipient :: ChannelId -> UserId -> ChannelRequest () + -- | Start a thread from a message + StartThreadFromMessage :: ChannelId -> MessageId -> StartThreadOpts -> ChannelRequest Channel + -- | Start a thread without a message + StartThreadNoMessage :: ChannelId -> StartThreadNoMessageOpts -> ChannelRequest Channel + -- | Join a thread + JoinThread :: ChannelId -> ChannelRequest () + -- | Add a thread member + AddThreadMember :: ChannelId -> UserId -> ChannelRequest () + -- | Leave a thread + LeaveThread :: ChannelId -> ChannelRequest () + -- | Remove a thread member + RemoveThreadMember :: ChannelId -> UserId -> ChannelRequest () + -- | Get a thread member + GetThreadMember :: ChannelId -> UserId -> ChannelRequest ThreadMember + -- | List the thread members + ListThreadMembers :: ChannelId -> ChannelRequest [ThreadMember] + -- | List public archived threads in the given channel. Optionally before a + -- given time, and optional maximum number of threads. Returns the threads, + -- thread members, and whether there are more to collect. + -- Requires the READ_MESSAGE_HISTORY permission. + ListPublicArchivedThreads :: ChannelId -> (Maybe UTCTime, Maybe Integer) -> ChannelRequest ListThreads + -- | List private archived threads in the given channel. Optionally before a + -- given time, and optional maximum number of threads. Returns the threads, + -- thread members, and whether there are more to collect. + -- Requires both the READ_MESSAGE_HISTORY and MANAGE_THREADS permissions. + ListPrivateArchivedThreads :: ChannelId -> (Maybe UTCTime, Maybe Integer) -> ChannelRequest ListThreads + -- | List joined private archived threads in the given channel. Optionally + -- before a given time, and optional maximum number of threads. Returns the + -- threads, thread members, and whether there are more to collect. + -- Requires both the READ_MESSAGE_HISTORY and MANAGE_THREADS permissions. + ListJoinedPrivateArchivedThreads :: ChannelId -> (Maybe UTCTime, Maybe Integer) -> ChannelRequest ListThreads -- | Data constructor for CreateMessageDetailed requests. @@ -107,7 +141,7 @@ , messageDetailedReference :: Maybe MessageReference , messageDetailedComponents :: Maybe [ComponentActionRow] , messageDetailedStickerIds :: Maybe [StickerId] - } deriving (Show, Eq, Ord, Read) + } deriving (Show, Read, Eq, Ord) instance Default MessageDetailedOpts where def = MessageDetailedOpts { messageDetailedContent = "" @@ -208,35 +242,95 @@ , groupDMAddRecipientGDMJoinAccessToken :: T.Text } deriving (Show, Read, Eq, Ord) +data StartThreadOpts = StartThreadOpts + { startThreadName :: T.Text + , startThreadAutoArchive :: Maybe Integer -- ^ can be one of 60, 1440, 4320, 10080 + , startThreadRateLimit :: Maybe Integer + } deriving (Show, Read, Eq, Ord) + +instance ToJSON StartThreadOpts where + toJSON StartThreadOpts{..} = object [ (name, value) | (name, Just value) <- + [ ("name", toJSON <$> pure startThreadName) + , ("auto_archive_duration", toJSON <$> startThreadAutoArchive) + , ("rate_limit_per_user", toJSON <$> startThreadRateLimit) + ] + ] + +data StartThreadNoMessageOpts = StartThreadNoMessageOpts + { startThreadNoMessageBaseOpts :: StartThreadOpts + , startThreadNoMessageType :: Integer -- ^ 10, 11, or 12 (https://discord.com/developers/docs/resources/channel#channel-object-channel-types) + , startThreadNoMessageInvitable :: Maybe Bool + } deriving (Show, Read, Eq, Ord) + +instance ToJSON StartThreadNoMessageOpts where + toJSON StartThreadNoMessageOpts{..} = object [ (name, value) | (name, Just value) <- + [ ("name", toJSON <$> pure (startThreadName startThreadNoMessageBaseOpts)) + , ("auto_archive_duration", toJSON <$> (startThreadAutoArchive startThreadNoMessageBaseOpts)) + , ("rate_limit_per_user", toJSON <$> (startThreadRateLimit startThreadNoMessageBaseOpts)) + , ("type", toJSON <$> pure startThreadNoMessageType) + , ("invitable", toJSON <$> startThreadNoMessageInvitable) + ] + ] + +data ListThreads = ListThreads + { listThreadsThreads :: [Channel] + , listThreadsMembers :: [ThreadMember] + , listThreadsHasMore :: Bool -- ^ whether there is more data to retrieve + } deriving (Show, Read, Eq, Ord) + +instance ToJSON ListThreads where + toJSON ListThreads{..} = object + [ ("threads", toJSON listThreadsThreads) + , ("members", toJSON listThreadsMembers) + , ("has_more", toJSON listThreadsHasMore) + ] + +instance FromJSON ListThreads where + parseJSON = withObject "ListThreads" $ \o -> + ListThreads <$> o .: "threads" + <*> o .: "members" + <*> o .: "has_more" + channelMajorRoute :: ChannelRequest a -> String channelMajorRoute c = case c of - (GetChannel chan) -> "get_chan " <> show chan - (ModifyChannel chan _) -> "mod_chan " <> show chan - (DeleteChannel chan) -> "mod_chan " <> show chan - (GetChannelMessages chan _) -> "msg " <> show chan - (GetChannelMessage (chan, _)) -> "get_msg " <> show chan - (CreateMessage chan _) -> "msg " <> show chan - (CreateMessageUploadFile chan _ _) -> "msg " <> show chan - (CreateMessageDetailed chan _) -> "msg " <> show chan - (CreateReaction (chan, _) _) -> "add_react " <> show chan - (DeleteOwnReaction (chan, _) _) -> "react " <> show chan - (DeleteUserReaction (chan, _) _ _) -> "react " <> show chan - (DeleteSingleReaction (chan, _) _) -> "react " <> show chan - (GetReactions (chan, _) _ _) -> "react " <> show chan - (DeleteAllReactions (chan, _)) -> "react " <> show chan - (EditMessage (chan, _) _ _) -> "get_msg " <> show chan - (DeleteMessage (chan, _)) -> "get_msg " <> show chan - (BulkDeleteMessage (chan, _)) -> "del_msgs " <> show chan - (EditChannelPermissions chan _ _) -> "perms " <> show chan - (GetChannelInvites chan) -> "invites " <> show chan - (CreateChannelInvite chan _) -> "invites " <> show chan - (DeleteChannelPermission chan _) -> "perms " <> show chan - (TriggerTypingIndicator chan) -> "tti " <> show chan - (GetPinnedMessages chan) -> "pins " <> show chan - (AddPinnedMessage (chan, _)) -> "pin " <> show chan - (DeletePinnedMessage (chan, _)) -> "pin " <> show chan - (GroupDMAddRecipient chan _) -> "groupdm " <> show chan - (GroupDMRemoveRecipient chan _) -> "groupdm " <> show chan + (GetChannel chan) -> "get_chan " <> show chan + (ModifyChannel chan _) -> "mod_chan " <> show chan + (DeleteChannel chan) -> "mod_chan " <> show chan + (GetChannelMessages chan _) -> "msg " <> show chan + (GetChannelMessage (chan, _)) -> "get_msg " <> show chan + (CreateMessage chan _) -> "msg " <> show chan + (CreateMessageUploadFile chan _ _) -> "msg " <> show chan + (CreateMessageDetailed chan _) -> "msg " <> show chan + (CreateReaction (chan, _) _) -> "add_react " <> show chan + (DeleteOwnReaction (chan, _) _) -> "react " <> show chan + (DeleteUserReaction (chan, _) _ _) -> "react " <> show chan + (DeleteSingleReaction (chan, _) _) -> "react " <> show chan + (GetReactions (chan, _) _ _) -> "react " <> show chan + (DeleteAllReactions (chan, _)) -> "react " <> show chan + (EditMessage (chan, _) _ _) -> "get_msg " <> show chan + (DeleteMessage (chan, _)) -> "get_msg " <> show chan + (BulkDeleteMessage (chan, _)) -> "del_msgs " <> show chan + (EditChannelPermissions chan _ _) -> "perms " <> show chan + (GetChannelInvites chan) -> "invites " <> show chan + (CreateChannelInvite chan _) -> "invites " <> show chan + (DeleteChannelPermission chan _) -> "perms " <> show chan + (TriggerTypingIndicator chan) -> "tti " <> show chan + (GetPinnedMessages chan) -> "pins " <> show chan + (AddPinnedMessage (chan, _)) -> "pin " <> show chan + (DeletePinnedMessage (chan, _)) -> "pin " <> show chan + (GroupDMAddRecipient chan _) -> "groupdm " <> show chan + (GroupDMRemoveRecipient chan _) -> "groupdm " <> show chan + (StartThreadFromMessage chan _ _) -> "thread " <> show chan + (StartThreadNoMessage chan _) -> "thread " <> show chan + (JoinThread chan) -> "thread " <> show chan + (AddThreadMember chan _) -> "thread " <> show chan + (LeaveThread chan) -> "thread " <> show chan + (RemoveThreadMember chan _) -> "thread " <> show chan + (GetThreadMember chan _) -> "thread " <> show chan + (ListThreadMembers chan) -> "thread " <> show chan + (ListPublicArchivedThreads chan _) -> "thread " <> show chan + (ListPrivateArchivedThreads chan _) -> "thread " <> show chan + (ListJoinedPrivateArchivedThreads chan _) -> "thread " <> show chan cleanupEmoji :: T.Text -> T.Text cleanupEmoji emoji = @@ -380,3 +474,48 @@ (GroupDMRemoveRecipient chan userid) -> Delete (channels // chan // chan /: "recipients" // userid) mempty + (StartThreadFromMessage chan mid sto) -> + Post (channels // chan /: "messages" // mid /: "threads") + (pure $ R.ReqBodyJson $ toJSON sto) + mempty + + (StartThreadNoMessage chan sto) -> + Post (channels // chan /: "messages" /: "threads") + (pure $ R.ReqBodyJson $ toJSON sto) + mempty + + (JoinThread chan) -> + Put (channels // chan /: "thread-members" /: "@me") + R.NoReqBody mempty + + (AddThreadMember chan uid) -> + Put (channels // chan /: "thread-members" // uid) + R.NoReqBody mempty + + (LeaveThread chan) -> + Delete (channels // chan /: "thread-members" /: "@me") + mempty + + (RemoveThreadMember chan uid) -> + Delete (channels // chan /: "thread-members" // uid) + mempty + + (GetThreadMember chan uid) -> + Get (channels // chan /: "thread-members" // uid) + mempty + + (ListThreadMembers chan) -> + Get (channels // chan /: "thread-members") + mempty + + (ListPublicArchivedThreads chan (time, lim)) -> + Get (channels // chan /: "threads" /: "archived" /: "public") + (maybe mempty ("limit" R.=:) lim <> maybe mempty ("before" R.=:) time) + + (ListPrivateArchivedThreads chan (time, lim)) -> + Get (channels // chan /: "threads" /: "archived" /: "private") + (maybe mempty ("limit" R.=:) lim <> maybe mempty ("before" R.=:) time) + + (ListJoinedPrivateArchivedThreads chan (time, lim)) -> + Get (channels // chan /: "users" /: "@me" /: "threads" /: "archived" /: "private") + (maybe mempty ("limit" R.=:) lim <> maybe mempty ("before" R.=:) time) 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 @@ -17,10 +17,14 @@ import Discord.Internal.Types +-- | The api version to use. +apiVersion :: T.Text +apiVersion = "10" + -- | The base url (Req) for API requests baseUrl :: R.Url 'R.Https -baseUrl = R.https "discord.com" R./: "api" R./: apiVersion - where apiVersion = "v8" +baseUrl = R.https "discord.com" R./: "api" R./: apiVersion' + where apiVersion' = "v" <> apiVersion -- | Discord requires HTTP headers for authentication. authHeader :: Auth -> R.Option 'R.Https @@ -30,7 +34,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.12.0)" + agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 1.12.1)" -- Append to an URL infixl 5 // diff --git a/src/Discord/Internal/Types.hs b/src/Discord/Internal/Types.hs --- a/src/Discord/Internal/Types.hs +++ b/src/Discord/Internal/Types.hs @@ -34,8 +34,13 @@ InternalChannelCreate a -> ChannelCreate a InternalChannelUpdate a -> ChannelUpdate a InternalChannelDelete a -> ChannelDelete a + InternalThreadCreate a -> ThreadCreate a + InternalThreadUpdate a -> ThreadUpdate a + InternalThreadDelete a -> ThreadDelete a + InternalThreadListSync a -> ThreadListSync a + InternalThreadMembersUpdate a -> ThreadMembersUpdate a InternalChannelPinsUpdate a b -> ChannelPinsUpdate a b - InternalGuildCreate a b -> GuildCreate a b + InternalGuildCreate a -> GuildCreate a InternalGuildUpdate a -> GuildUpdate a InternalGuildDelete a -> GuildDelete a InternalGuildBanAdd a b -> GuildBanAdd a b diff --git a/src/Discord/Internal/Types/ApplicationCommands.hs b/src/Discord/Internal/Types/ApplicationCommands.hs --- a/src/Discord/Internal/Types/ApplicationCommands.hs +++ b/src/Discord/Internal/Types/ApplicationCommands.hs @@ -538,7 +538,7 @@ ] data Choice a = Choice {choiceName :: T.Text, choiceValue :: a} - deriving (Show, Read, Eq) + deriving (Show, Read, Eq, Ord) instance Functor Choice where fmap f (Choice s a) = Choice s (f a) @@ -632,7 +632,7 @@ -- | The permissions for the command in the guild. guildApplicationCommandPermissionsPermissions :: [ApplicationCommandPermissions] } - deriving (Show, Eq, Ord, Read) + deriving (Show, Read, Eq, Ord) instance FromJSON GuildApplicationCommandPermissions where parseJSON = @@ -668,7 +668,7 @@ -- | Whether to allow or not. applicationCommandPermissionsPermission :: Bool } - deriving (Show, Eq, Ord, Read) + deriving (Show, Read, Eq, Ord) instance FromJSON ApplicationCommandPermissions where parseJSON = 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 @@ -28,7 +28,7 @@ { channelId :: ChannelId -- ^ The id of the channel (Will be equal to -- the guild if it's the "general" channel). , channelGuild :: GuildId -- ^ The id of the guild. - , channelName :: T.Text -- ^ The name of the guild (2 - 1000 characters). + , channelName :: T.Text -- ^ The name of the channel (2 - 1000 characters). , channelPosition :: Integer -- ^ The storing position of the channel. , channelPermissions :: [Overwrite] -- ^ An array of permission 'Overwrite's , channelUserRateLimit :: Integer -- ^ Seconds before a user can speak again @@ -94,6 +94,39 @@ , channelStageId :: StageId , channelStageTopic :: Text } + | ChannelNewsThread + { channelId :: ChannelId -- ^ The id of the thread + , channelGuild :: GuildId -- ^ The id of the guild. + , channelThreadName :: Maybe T.Text -- ^ The name of the channel (2 - 1000 characters). + , channelUserRateLimitThread :: Maybe Integer -- ^ Seconds before a user can speak again + , channelLastMessage :: Maybe MessageId -- ^ The id of the last message sent in the + -- channel + , channelParentId :: Maybe ParentId -- ^ The id of the parent channel (category) + , channelThreadMetadata :: Maybe ThreadMetadata -- ^ Metadata about this thread + , channelThreadMember :: Maybe ThreadMember -- ^ Used to indicate if the user has joined the thread + } + | ChannelPublicThread + { channelId :: ChannelId -- ^ The id of the thread + , channelGuild :: GuildId -- ^ The id of the guild. + , channelThreadName :: Maybe T.Text -- ^ The name of the channel (2 - 1000 characters). + , channelUserRateLimitThread :: Maybe Integer -- ^ Seconds before a user can speak again + , channelLastMessage :: Maybe MessageId -- ^ The id of the last message sent in the + -- channel + , channelParentId :: Maybe ParentId -- ^ The id of the parent channel (category) + , channelThreadMetadata :: Maybe ThreadMetadata -- ^ Metadata about this thread + , channelThreadMember :: Maybe ThreadMember -- ^ Used to indicate if the user has joined the thread + } + | ChannelPrivateThread + { channelId :: ChannelId -- ^ The id of the thread + , channelGuild :: GuildId -- ^ The id of the guild. + , channelThreadName :: Maybe T.Text -- ^ The name of the channel (2 - 1000 characters). + , channelUserRateLimitThread :: Maybe Integer -- ^ Seconds before a user can speak again + , channelLastMessage :: Maybe MessageId -- ^ The id of the last message sent in the + -- channel + , channelParentId :: Maybe ParentId -- ^ The id of the parent channel (category) + , channelThreadMetadata :: Maybe ThreadMetadata -- ^ Metadata about this thread + , channelThreadMember :: Maybe ThreadMember -- ^ Used to indicate if the user has joined the thread + } | ChannelUnknownType { channelId :: ChannelId , channelJSON :: Text @@ -155,6 +188,30 @@ <*> o .:? "nsfw" .!= False <*> o .: "permission_overwrites" <*> o .:? "parent_id" + 10 -> ChannelNewsThread <$> o.: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .:? "name" + <*> o .:? "rate_limit_per_user" + <*> o .:? "last_message_id" + <*> o .:? "parent_id" + <*> o .:? "thread_metadata" + <*> o .:? "member" + 11 -> ChannelPublicThread <$> o.: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .:? "name" + <*> o .:? "rate_limit_per_user" + <*> o .:? "last_message_id" + <*> o .:? "parent_id" + <*> o .:? "thread_metadata" + <*> o .:? "member" + 12 -> ChannelPrivateThread <$> o.: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .:? "name" + <*> o .:? "rate_limit_per_user" + <*> o .:? "last_message_id" + <*> o .:? "parent_id" + <*> o .:? "thread_metadata" + <*> o .:? "member" 13 -> ChannelStage <$> o .: "id" <*> o .:? "guild_id" .!= 0 @@ -225,6 +282,36 @@ , ("channel_id", toJSON <$> pure channelStageId) , ("topic", toJSON <$> pure channelStageTopic) ] ] + toJSON ChannelNewsThread{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure channelId) + , ("guild_id", toJSON <$> pure channelGuild) + , ("name", toJSON <$> channelThreadName) + , ("rate_limit_per_user", toJSON <$> channelUserRateLimitThread) + , ("last_message_id", toJSON <$> channelLastMessage) + , ("parent_id", toJSON <$> pure channelParentId) + , ("thread_metadata", toJSON <$> channelThreadMetadata) + , ("member", toJSON <$> channelThreadMember) + ] ] + toJSON ChannelPublicThread{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure channelId) + , ("guild_id", toJSON <$> pure channelGuild) + , ("name", toJSON <$> channelThreadName) + , ("rate_limit_per_user", toJSON <$> channelUserRateLimitThread) + , ("last_message_id", toJSON <$> channelLastMessage) + , ("parent_id", toJSON <$> pure channelParentId) + , ("thread_metadata", toJSON <$> channelThreadMetadata) + , ("member", toJSON <$> channelThreadMember) + ] ] + toJSON ChannelPrivateThread{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure channelId) + , ("guild_id", toJSON <$> pure channelGuild) + , ("name", toJSON <$> channelThreadName) + , ("rate_limit_per_user", toJSON <$> channelUserRateLimitThread) + , ("last_message_id", toJSON <$> channelLastMessage) + , ("parent_id", toJSON <$> pure channelParentId) + , ("thread_metadata", toJSON <$> channelThreadMetadata) + , ("member", toJSON <$> channelThreadMember) + ] ] toJSON ChannelUnknownType{..} = object [(name,value) | (name, Just value) <- [ ("id", toJSON <$> pure channelId) , ("json", toJSON <$> pure channelJSON) @@ -233,11 +320,14 @@ -- | If the channel is part of a guild (has a guild id field) channelIsInGuild :: Channel -> Bool channelIsInGuild c = case c of - ChannelGuildCategory{..} -> True - ChannelText{..} -> True - ChannelVoice{..} -> True - ChannelNews{..} -> True - ChannelStorePage{..} -> True + ChannelGuildCategory{} -> True + ChannelText{} -> True + ChannelVoice{} -> True + ChannelNews{} -> True + ChannelStorePage{} -> True + ChannelNewsThread{} -> True + ChannelPublicThread{} -> True + ChannelPrivateThread{} -> True _ -> False -- | Permission overwrites for a channel. @@ -263,6 +353,87 @@ , ("deny", toJSON overwriteDeny) ] +-- | Metadata for threads. +data ThreadMetadata = ThreadMetadata + { threadMetadataArchived :: Bool -- ^ Is the thread archived? + , threadMetadataAutoArchive :: Integer -- ^ How long after activity should the thread auto archive + , threadMetadataArchiveTime :: UTCTime -- ^ When was the last time the archive status changed? + , threadMetadataLocked :: Bool -- ^ Is the thread locked? (only MANAGE_THREADS users can unarchive) + , threadMetadataInvitable :: Maybe Bool -- ^ Can non-mods add other non-mods? (private threads only) + , threadMetadataCreateTime :: Maybe UTCTime -- ^ When was the thread created? + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ThreadMetadata where + parseJSON = withObject "ThreadMetadata" $ \o -> + ThreadMetadata <$> o .: "archived" + <*> o .: "auto_archive_duration" + <*> o .: "archive_timestamp" + <*> o .: "locked" + <*> o .:? "invitable" + <*> o .:? "create_timestamp" + +instance ToJSON ThreadMetadata where + toJSON ThreadMetadata{..} = object [(name,value) | (name, Just value) <- + [ ("archived", toJSON <$> pure threadMetadataArchived) + , ("auto_archive_duration", toJSON <$> pure threadMetadataAutoArchive) + , ("archive_timestamp", toJSON <$> pure threadMetadataArchiveTime) + , ("locked", toJSON <$> pure threadMetadataLocked) + , ("invitable", toJSON <$> threadMetadataInvitable) + , ("create_timestamp", toJSON <$> pure threadMetadataCreateTime) + ] ] + +data ThreadMember = ThreadMember + { threadMemberThreadId :: Maybe ChannelId -- ^ id of the thread + , threadMemberUserId :: Maybe UserId -- ^ id of the user + , threadMemberJoinTime :: UTCTime -- ^ time the current user last joined the thread + , threadMemberFlags :: Integer -- ^ user-thread settings + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ThreadMember where + parseJSON = withObject "ThreadMember" $ \o -> + ThreadMember <$> o .:? "id" + <*> o .:? "user_id" + <*> o .: "join_timestamp" + <*> o .: "flags" + +instance ToJSON ThreadMember where + toJSON ThreadMember{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> threadMemberThreadId) + , ("user_id", toJSON <$> threadMemberUserId) + , ("join_timestamp", toJSON <$> pure threadMemberJoinTime) + , ("flags", toJSON <$> pure threadMemberFlags) + ] ] + +data ThreadListSyncFields = ThreadListSyncFields + { threadListSyncFieldsGuildId :: GuildId + , threadListSyncFieldsChannelIds :: Maybe [ChannelId] + , threadListSyncFieldsThreads :: [Channel] + , threadListSyncFieldsThreadMembers :: [ThreadMember] + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ThreadListSyncFields where + parseJSON = withObject "ThreadListSyncFields" $ \o -> + ThreadListSyncFields <$> o .: "guild_id" + <*> o .:? "channel_ids" + <*> o .: "threads" + <*> o .: "members" + +data ThreadMembersUpdateFields = ThreadMembersUpdateFields + { threadMembersUpdateFieldsThreadId :: ChannelId + , threadMembersUpdateFieldsGuildId :: GuildId + , threadMembersUpdateFieldsMemberCount :: Integer + , threadMembersUpdateFieldsAddedMembers :: Maybe [ThreadMember] + , threadMembersUpdateFieldsRemovedMembers :: Maybe [UserId] + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ThreadMembersUpdateFields where + parseJSON = withObject "ThreadMembersUpdateFields" $ \o -> + ThreadMembersUpdateFields <$> o .: "id" + <*> o .: "guild_id" + <*> o .: "member_count" + <*> o .:? "added_members" + <*> o .:? "removed_member_ids" + -- | Represents information about a message in a Discord channel. data Message = Message { messageId :: MessageId -- ^ The id of the message @@ -300,7 +471,7 @@ , messageThread :: Maybe Channel -- ^ the thread that was started from this message, includes thread member object , messageComponents :: Maybe [ComponentActionRow] -- ^ sent if the message contains components like buttons, action rows, or other interactive components , messageStickerItems :: Maybe [StickerItem] -- ^ sent if the message contains stickers - } deriving (Show, Eq, Ord, Read) + } deriving (Show, Read, Eq, Ord) instance FromJSON Message where parseJSON = withObject "Message" $ \o -> @@ -675,7 +846,7 @@ , messageInteractionType :: Integer -- ^ Type of the interaction (liekly always application command) , messageInteractionName :: T.Text -- ^ Name of the interaction , messageInteractionUser :: User -- ^ User who invoked the interaction - } deriving (Show, Eq, Ord, Read) + } deriving (Show, Read, Eq, Ord) instance ToJSON MessageInteraction where toJSON MessageInteraction{..} = object [(name,value) | (name, Just value) <- diff --git a/src/Discord/Internal/Types/Components.hs b/src/Discord/Internal/Types/Components.hs --- a/src/Discord/Internal/Types/Components.hs +++ b/src/Discord/Internal/Types/Components.hs @@ -15,6 +15,8 @@ mkSelectMenu, SelectOption (..), mkSelectOption, + ComponentTextInput (..), + mkComponentTextInput, Emoji (..), mkEmoji, ) @@ -29,28 +31,32 @@ import Discord.Internal.Types.User (User) data ComponentActionRow = ComponentActionRowButton [ComponentButton] | ComponentActionRowSelectMenu ComponentSelectMenu - deriving (Show, Eq, Ord, Read) + deriving (Show, Read, Eq, Ord) instance FromJSON ComponentActionRow where parseJSON = withObject "ComponentActionRow" ( \cs -> do - a <- cs .: "components" :: Parser Array - let a' = toList a - case a' of - [] -> return $ ComponentActionRowButton [] - (c : _) -> - withObject - "ComponentActionRow item" - ( \v -> do - t <- v .: "type" :: Parser Int - case t of - 2 -> ComponentActionRowButton <$> mapM parseJSON a' - 3 -> ComponentActionRowSelectMenu <$> parseJSON c - _ -> fail $ "unknown component type: " ++ show t - ) - c + t <- cs .: "type" :: Parser Int + case t of + 1 -> do + a <- cs .: "components" :: Parser Array + let a' = toList a + case a' of + [] -> return $ ComponentActionRowButton [] + (c : _) -> + withObject + "ComponentActionRow item" + ( \v -> do + t' <- v .: "type" :: Parser Int + case t' of + 2 -> ComponentActionRowButton <$> mapM parseJSON a' + 3 -> ComponentActionRowSelectMenu <$> parseJSON c + _ -> fail $ "unknown component type: " ++ show t + ) + c + _ -> fail $ "expected action row type (1), got: " ++ show t ) instance ToJSON ComponentActionRow where @@ -69,7 +75,7 @@ -- | What is the style of the button componentButtonStyle :: ButtonStyle, -- | What is the user-facing label of the button - componentButtonLabel :: T.Text, + componentButtonLabel :: Maybe T.Text, -- | What emoji is displayed on the button componentButtonEmoji :: Maybe Emoji } @@ -80,15 +86,15 @@ -- | Whether the button is disabled componentButtonDisabled :: Bool, -- | What is the user-facing label of the button - componentButtonLabel :: T.Text, + componentButtonLabel :: Maybe T.Text, -- | What emoji is displayed on the button componentButtonEmoji :: Maybe Emoji } - deriving (Show, Eq, Ord, Read) + deriving (Show, Read, Eq, Ord) -- | Takes the label and the custom id of the button that is to be generated. mkButton :: T.Text -> T.Text -> ComponentButton -mkButton label customId = ComponentButton customId False ButtonStyleSecondary label Nothing +mkButton label customId = ComponentButton customId False ButtonStyleSecondary (Just label) Nothing instance FromJSON ComponentButton where parseJSON = @@ -99,7 +105,7 @@ case t of 2 -> do disabled <- v .:? "disabled" .!= False - label <- v .: "label" + label <- v .:? "label" partialEmoji <- v .:? "emoji" style <- v .: "style" :: Parser Scientific case style of @@ -126,7 +132,7 @@ | (name, Just value) <- [ ("type", Just $ Number 2), ("style", Just $ Number 5), - ("label", toMaybeJSON componentButtonLabel), + ("label", toJSON <$> componentButtonLabel), ("disabled", toMaybeJSON componentButtonDisabled), ("url", toMaybeJSON componentButtonUrl), ("emoji", toJSON <$> componentButtonEmoji) @@ -138,7 +144,7 @@ | (name, Just value) <- [ ("type", Just $ Number 2), ("style", Just $ toJSON componentButtonStyle), - ("label", toMaybeJSON componentButtonLabel), + ("label", toJSON <$> componentButtonLabel), ("disabled", toMaybeJSON componentButtonDisabled), ("custom_id", toMaybeJSON componentButtonCustomId), ("emoji", toJSON <$> componentButtonEmoji) @@ -155,7 +161,7 @@ ButtonStyleSuccess | -- | Red button ButtonStyleDanger - deriving (Show, Eq, Ord, Read) + deriving (Show, Read, Eq, Ord) instance FromJSON ButtonStyle where parseJSON = @@ -192,7 +198,7 @@ -- | Maximum number of values to select (def 1, max 25) componentSelectMenuMaxValues :: Maybe Integer } - deriving (Show, Eq, Ord, Read) + deriving (Show, Read, Eq, Ord) -- | Takes the custom id and the options of the select menu that is to be -- generated. @@ -246,7 +252,7 @@ -- | Use this value by default selectOptionDefault :: Maybe Bool } - deriving (Show, Eq, Ord, Read) + deriving (Show, Read, Eq, Ord) -- | Make a select option from the given label and value. mkSelectOption :: T.Text -> T.Text -> SelectOption @@ -272,6 +278,61 @@ ("default", toJSON <$> selectOptionDefault) ] ] + +data ComponentTextInput = ComponentTextInput + { -- | Dev identifier + componentTextInputCustomId :: T.Text, + -- | What style to use (short or paragraph) + componentTextInputIsParagraph :: Bool, + -- | The label for this component + componentTextInputLabel :: T.Text, + -- | The minimum input length for a text input (0-4000) + componentTextInputMinLength :: Maybe Integer, + -- | The maximum input length for a text input (1-4000) + componentTextInputMaxLength :: Maybe Integer, + -- | Whether this component is required to be filled + componentTextInputRequired :: Bool, + -- | The prefilled value for this component (max 4000) + componentTextInputValue :: T.Text, + -- | Placeholder text if empty (max 4000) + componentTextInputPlaceholder :: T.Text + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON ComponentTextInput where + toJSON ComponentTextInput {..} = + object + [ (name, value) + | (name, Just value) <- + [ ("type", Just $ Number 4), + ("custom_id", toMaybeJSON componentTextInputCustomId), + ("style", toMaybeJSON (1 + fromEnum componentTextInputIsParagraph)), + ("label", toMaybeJSON componentTextInputLabel), + ("min_length", toJSON <$> componentTextInputMinLength), + ("max_length", toJSON <$> componentTextInputMaxLength), + ("required", toMaybeJSON componentTextInputRequired), + ("value", toMaybeJSON componentTextInputValue), + ("placeholder", toMaybeJSON componentTextInputPlaceholder) + ] + ] + +instance FromJSON ComponentTextInput where + parseJSON = withObject "ComponentTextInput" $ \o -> do + t <- o .: "type" :: Parser Int + case t of + 4 -> + ComponentTextInput <$> o .: "custom_id" + <*> fmap (== (2 :: Int)) (o .:? "style" .!= 1) + <*> o .:? "label" .!= "" + <*> o .:? "min_length" + <*> o .:? "max_length" + <*> o .:? "required" .!= False + <*> o .:? "value" .!= "" + <*> o .:? "placeholder" .!= "" + _ -> fail "expected text input, found other type of component" + +mkComponentTextInput :: T.Text -> T.Text -> ComponentTextInput +mkComponentTextInput cid label = ComponentTextInput cid False label Nothing Nothing True "" "" -- | Represents an emoticon (emoji) data Emoji = Emoji 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,7 +15,7 @@ import Discord.Internal.Types.Prelude import Discord.Internal.Types.Channel -import Discord.Internal.Types.Guild (Role, GuildInfo, GuildUnavailable, Guild) +import Discord.Internal.Types.Guild import Discord.Internal.Types.User (User, GuildMember) import Discord.Internal.Types.Interactions (Interaction) import Discord.Internal.Types.Components (Emoji) @@ -23,79 +23,89 @@ -- | 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 (Maybe Shard) PartialApplication - | Resumed [T.Text] - | ChannelCreate Channel - | ChannelUpdate Channel - | ChannelDelete Channel - | ChannelPinsUpdate ChannelId (Maybe UTCTime) - | GuildCreate Guild GuildInfo - | GuildUpdate Guild - | GuildDelete GuildUnavailable - | GuildBanAdd GuildId User - | GuildBanRemove GuildId User - | GuildEmojiUpdate GuildId [Emoji] - | GuildIntegrationsUpdate GuildId - | GuildMemberAdd GuildId GuildMember - | GuildMemberRemove GuildId User - | GuildMemberUpdate GuildId [RoleId] User (Maybe T.Text) - | GuildMemberChunk GuildId [GuildMember] - | GuildRoleCreate GuildId Role - | GuildRoleUpdate GuildId Role - | GuildRoleDelete GuildId RoleId - | MessageCreate Message - | MessageUpdate ChannelId MessageId - | MessageDelete ChannelId MessageId - | MessageDeleteBulk ChannelId [MessageId] - | MessageReactionAdd ReactionInfo - | MessageReactionRemove ReactionInfo - | MessageReactionRemoveAll ChannelId MessageId + Ready Int User [Channel] [GuildUnavailable] T.Text (Maybe Shard) PartialApplication + | Resumed [T.Text] + | ChannelCreate Channel + | ChannelUpdate Channel + | ChannelDelete Channel + | ThreadCreate Channel + | ThreadUpdate Channel + | ThreadDelete Channel + | ThreadListSync ThreadListSyncFields + | ThreadMembersUpdate ThreadMembersUpdateFields + | ChannelPinsUpdate ChannelId (Maybe UTCTime) + | GuildCreate Guild + | GuildUpdate Guild + | GuildDelete GuildUnavailable + | GuildBanAdd GuildId User + | GuildBanRemove GuildId User + | GuildEmojiUpdate GuildId [Emoji] + | GuildIntegrationsUpdate GuildId + | GuildMemberAdd GuildId GuildMember + | GuildMemberRemove GuildId User + | GuildMemberUpdate GuildId [RoleId] User (Maybe T.Text) + | GuildMemberChunk GuildId [GuildMember] + | GuildRoleCreate GuildId Role + | GuildRoleUpdate GuildId Role + | GuildRoleDelete GuildId RoleId + | MessageCreate Message + | MessageUpdate ChannelId MessageId + | MessageDelete ChannelId MessageId + | MessageDeleteBulk ChannelId [MessageId] + | MessageReactionAdd ReactionInfo + | MessageReactionRemove ReactionInfo + | MessageReactionRemoveAll ChannelId MessageId | MessageReactionRemoveEmoji ReactionRemoveInfo - | PresenceUpdate PresenceInfo - | TypingStart TypingInfo - | UserUpdate User - | InteractionCreate Interaction + | PresenceUpdate PresenceInfo + | TypingStart TypingInfo + | UserUpdate User + | InteractionCreate Interaction -- | VoiceStateUpdate -- | VoiceServerUpdate - | UnknownEvent T.Text Object + | UnknownEvent T.Text Object deriving (Show, Eq) data EventInternalParse = - InternalReady Int User [Channel] [GuildUnavailable] T.Text (Maybe Shard) PartialApplication - | InternalResumed [T.Text] - | InternalChannelCreate Channel - | InternalChannelUpdate Channel - | InternalChannelDelete Channel - | InternalChannelPinsUpdate ChannelId (Maybe UTCTime) - | InternalGuildCreate Guild GuildInfo - | InternalGuildUpdate Guild - | InternalGuildDelete GuildUnavailable - | InternalGuildBanAdd GuildId User - | InternalGuildBanRemove GuildId User - | InternalGuildEmojiUpdate GuildId [Emoji] - | InternalGuildIntegrationsUpdate GuildId - | InternalGuildMemberAdd GuildId GuildMember - | InternalGuildMemberRemove GuildId User - | InternalGuildMemberUpdate GuildId [RoleId] User (Maybe T.Text) - | InternalGuildMemberChunk GuildId [GuildMember] - | InternalGuildRoleCreate GuildId Role - | InternalGuildRoleUpdate GuildId Role - | InternalGuildRoleDelete GuildId RoleId - | InternalMessageCreate Message - | InternalMessageUpdate ChannelId MessageId - | InternalMessageDelete ChannelId MessageId - | InternalMessageDeleteBulk ChannelId [MessageId] - | InternalMessageReactionAdd ReactionInfo - | InternalMessageReactionRemove ReactionInfo - | InternalMessageReactionRemoveAll ChannelId MessageId + InternalReady Int User [Channel] [GuildUnavailable] T.Text (Maybe Shard) PartialApplication + | InternalResumed [T.Text] + | InternalChannelCreate Channel + | InternalChannelUpdate Channel + | InternalChannelDelete Channel + | InternalThreadCreate Channel + | InternalThreadUpdate Channel + | InternalThreadDelete Channel + | InternalThreadListSync ThreadListSyncFields + | InternalThreadMembersUpdate ThreadMembersUpdateFields + | InternalChannelPinsUpdate ChannelId (Maybe UTCTime) + | InternalGuildCreate Guild + | InternalGuildUpdate Guild + | InternalGuildDelete GuildUnavailable + | InternalGuildBanAdd GuildId User + | InternalGuildBanRemove GuildId User + | InternalGuildEmojiUpdate GuildId [Emoji] + | InternalGuildIntegrationsUpdate GuildId + | InternalGuildMemberAdd GuildId GuildMember + | InternalGuildMemberRemove GuildId User + | InternalGuildMemberUpdate GuildId [RoleId] User (Maybe T.Text) + | InternalGuildMemberChunk GuildId [GuildMember] + | InternalGuildRoleCreate GuildId Role + | InternalGuildRoleUpdate GuildId Role + | InternalGuildRoleDelete GuildId RoleId + | InternalMessageCreate Message + | InternalMessageUpdate ChannelId MessageId + | InternalMessageDelete ChannelId MessageId + | InternalMessageDeleteBulk ChannelId [MessageId] + | InternalMessageReactionAdd ReactionInfo + | InternalMessageReactionRemove ReactionInfo + | InternalMessageReactionRemoveAll ChannelId MessageId | InternalMessageReactionRemoveEmoji ReactionRemoveInfo - | InternalPresenceUpdate PresenceInfo - | InternalTypingStart TypingInfo - | InternalUserUpdate User - | InternalInteractionCreate Interaction + | InternalPresenceUpdate PresenceInfo + | InternalTypingStart TypingInfo + | InternalUserUpdate User + | InternalInteractionCreate Interaction -- -- | InternalVoiceStateUpdate -- -- | InternalVoiceServerUpdate - | InternalUnknownEvent T.Text Object + | InternalUnknownEvent T.Text Object deriving (Show, Eq, Read) data PartialApplication = PartialApplication @@ -136,22 +146,6 @@ <*> o .: "message_id" <*> o .: "emoji" -data PresenceInfo = PresenceInfo - { presenceUserId :: UserId - , presenceRoles :: [RoleId] - -- , presenceGame :: Maybe Activity - , presenceGuildId :: GuildId - , presenceStatus :: T.Text - } deriving (Show, Read, Eq, Ord) - -instance FromJSON PresenceInfo where - parseJSON = withObject "PresenceInfo" $ \o -> - PresenceInfo <$> (o .: "user" >>= (.: "id")) - <*> o .: "roles" - -- <*> o .: "game" - <*> o .: "guild_id" - <*> o .: "status" - data TypingInfo = TypingInfo { typingUserId :: UserId , typingChannelId :: ChannelId @@ -187,11 +181,16 @@ "CHANNEL_CREATE" -> InternalChannelCreate <$> reparse o "CHANNEL_UPDATE" -> InternalChannelUpdate <$> reparse o "CHANNEL_DELETE" -> InternalChannelDelete <$> reparse o + "THREAD_CREATE" -> InternalThreadCreate <$> reparse o + "THREAD_UPDATE" -> InternalThreadUpdate <$> reparse o + "THREAD_DELETE" -> InternalThreadDelete <$> reparse o + "THREAD_LIST_SYNC" -> InternalThreadListSync <$> reparse o + "THREAD_MEMBERS_UPDATE" -> InternalThreadMembersUpdate <$> reparse o "CHANNEL_PINS_UPDATE" -> do id <- o .: "channel_id" stamp <- o .:? "last_pin_timestamp" let utc = stamp >>= parseISO8601 pure (InternalChannelPinsUpdate id utc) - "GUILD_CREATE" -> InternalGuildCreate <$> reparse o <*> reparse o + "GUILD_CREATE" -> InternalGuildCreate <$> reparse o "GUILD_UPDATE" -> InternalGuildUpdate <$> reparse o "GUILD_DELETE" -> InternalGuildDelete <$> reparse o "GUILD_BAN_ADD" -> InternalGuildBanAdd <$> o .: "guild_id" <*> o .: "user" diff --git a/src/Discord/Internal/Types/Gateway.hs b/src/Discord/Internal/Types/Gateway.hs --- a/src/Discord/Internal/Types/Gateway.hs +++ b/src/Discord/Internal/Types/Gateway.hs @@ -20,6 +20,7 @@ import Discord.Internal.Types.Prelude import Discord.Internal.Types.Events +import Discord.Internal.Types.Guild (Activity (..)) -- | Sent by gateway data GatewayReceivable @@ -57,6 +58,7 @@ , gatewayIntentDirectMessageChanges :: Bool , gatewayIntentDirectMessageReactions :: Bool , gatewayIntentDirectMessageTyping :: Bool + , gatewayIntentMessageContent :: Bool } deriving (Show, Read, Eq, Ord) instance Default GatewayIntent where @@ -75,6 +77,7 @@ , gatewayIntentDirectMessageChanges = True , gatewayIntentDirectMessageReactions = True , gatewayIntentDirectMessageTyping = True + , gatewayIntentMessageContent = True } compileGatewayIntent :: GatewayIntent -> Int @@ -95,6 +98,7 @@ , (2 ^ 12, gatewayIntentDirectMessageChanges) , (2 ^ 13, gatewayIntentDirectMessageReactions) , (2 ^ 14, gatewayIntentDirectMessageTyping) + , (2 ^ 15, gatewayIntentMessageContent) ] ] @@ -127,25 +131,6 @@ } deriving (Show, Read, Eq, Ord) -data Activity = Activity - { activityName :: T.Text - , activityType :: ActivityType - , activityUrl :: Maybe T.Text - } - deriving (Show, Read, Eq, Ord) - -data ActivityType = ActivityTypeGame - | ActivityTypeStreaming - | ActivityTypeListening - | ActivityTypeCompeting - deriving (Show, Read, Eq, Ord) - -activityTypeId :: ActivityType -> Int -activityTypeId a = case a of ActivityTypeGame -> 0 - ActivityTypeStreaming -> 1 - ActivityTypeListening -> 2 - ActivityTypeCompeting -> 5 - data UpdateStatusType = UpdateStatusOnline | UpdateStatusDoNotDisturb | UpdateStatusAwayFromKeyboard @@ -228,7 +213,7 @@ , "status" .= statusString status , "game" .= (game <&> \a -> object [ "name" .= activityName a - , "type" .= activityTypeId (activityType a) + , "type" .= fromDiscordType (activityType a) , "url" .= activityUrl a ]) ] 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,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveDataTypeable #-} -- | Types relating to Discord Guilds (servers) module Discord.Internal.Types.Guild where @@ -8,10 +9,12 @@ import Data.Aeson import qualified Data.Text as T +import Data.Data (Data) +import Data.Default (Default(..)) import Discord.Internal.Types.Prelude import Discord.Internal.Types.Color (DiscordColor) -import Discord.Internal.Types.Channel (Channel) +import Discord.Internal.Types.Channel (Channel, StickerItem) import Discord.Internal.Types.User (User, GuildMember) import Discord.Internal.Types.Components (Emoji) @@ -22,25 +25,57 @@ -- -- 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 T.Text - , guildRegion :: Maybe T.Text -- ^ Guild voice region - , guildAfkId :: Maybe ChannelId -- ^ Id of afk channel - , guildAfkTimeout :: Integer -- ^ Afk timeout in seconds - , 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 - , guildRoles :: [Role] -- ^ Array of 'Role' objects - , guildEmojis :: [Emoji] -- ^ Array of 'Emoji' objects - , guildFeatures :: [T.Text] - , guildMultiFactAuth :: !Integer - , guildApplicationId :: Maybe Snowflake + { guildId :: GuildId -- ^ Gulid id + , guildName :: T.Text -- ^ Guild name (2 - 100 chars) + , guildIcon :: Maybe T.Text -- ^ Icon hash + , guildIconHash :: Maybe T.Text -- ^ Icon hash, when returned in template object + , guildSplash :: Maybe T.Text -- ^ Splash hash + , guildDiscoverySplash :: Maybe T.Text -- ^ Discovery splash hash + , guildOwner :: Maybe Bool -- ^ True is user is the owner of the guild + , guildOwnerId :: UserId -- ^ Guild owner id + , guildPermissions :: Maybe T.Text -- ^ Total permissions for the user in the guild + , guildAfkId :: Maybe ChannelId -- ^ Id of afk channel + , guildAfkTimeout :: Integer -- ^ Afk timeout in seconds + , 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 -- ^ Whose media gets scanned + , guildRoles :: [Role] -- ^ Array of 'Role' objects + , guildEmojis :: [Emoji] -- ^ Array of 'Emoji' objects + , guildFeatures :: [T.Text] -- ^ Array of guild feature strings + , guildMultiFactAuth :: !Integer -- ^ MFA level for the guild + , guildApplicationId :: Maybe ApplicationId -- ^ Application id of the guild if bot created + , guildSystemChannelId :: Maybe ChannelId -- ^ Channel where guild notices such as welcome messages and boost events + , guildSystemChannelFlags :: Integer -- ^ Flags on the system channel + , guildRulesChannelId :: Maybe ChannelId -- ^ Id of channel with rules/guidelines + , guildJoinedAt :: Maybe UTCTime -- ^ When this guild was joined at + , guildLarge :: Maybe Bool -- ^ True if this guild is considered large + , guildUnavailable :: Maybe Bool -- ^ True if the guild is unavailable due to outage + , guildMemberCount :: Maybe Integer -- ^ Total number of members in the guild + -- voice_states + , guildMembers :: Maybe [GuildMember] -- ^ Users in the guild + , guildChannels :: Maybe [Channel] -- ^ Channels in the guild + , guildThreads :: Maybe [Channel] -- ^ All active threads in the guild that the current user has permission to view + , guildPresences :: Maybe [PresenceInfo] -- ^ Presences of the members in the guild + , guildMaxPresences :: Maybe Integer -- ^ Maximum number of prescences in the guild + , guildMaxMembers :: Maybe Integer -- ^ Maximum number of members in the guild + , guildVanityURL :: Maybe T.Text -- ^ Vanity url code for the guild + , guildDescription :: Maybe T.Text -- ^ Description of a commmunity guild + , guildBanner :: Maybe T.Text -- ^ Banner hash + , guildPremiumTier :: Integer -- ^ Premium tier (boost level) + , guildSubscriptionCount :: Maybe Integer -- ^ Number of boosts the guild has + , guildPreferredLocale :: T.Text -- ^ Preferred locale of a community server + , guildPublicUpdatesChannel :: Maybe ChannelId -- ^ Id of channel where admins and mods get updates + , guildMaxVideoUsers :: Maybe Integer -- ^ Maximum number of users in video channel + , guildApproxMemberCount :: Maybe Integer -- ^ Approximate number of members in the guild + , guildApproxPresenceCount :: Maybe Integer -- ^ Approximate number of non-offline members in the guild + -- welcome_screen + , guildNSFWLevel :: Integer -- ^ Guild NSFW level + -- stage_instances + , guildStickers :: Maybe [StickerItem] -- ^ Custom guild stickers + -- guild_scheduled_events + , guildPremiumBar :: Bool -- ^ Whether the guild has the boost progress bar enabled } deriving (Show, Read, Eq, Ord) instance FromJSON Guild where @@ -48,10 +83,12 @@ Guild <$> o .: "id" <*> o .: "name" <*> o .:? "icon" + <*> o .:? "icon_hash" <*> o .:? "splash" + <*> o .:? "discovery_splash" + <*> o .:? "owner" <*> o .: "owner_id" <*> o .:? "permissions" - <*> o .:? "region" <*> o .:? "afk_channel_id" <*> o .: "afk_timeout" <*> o .:? "widget_enabled" @@ -64,8 +101,37 @@ <*> o .: "features" <*> o .: "mfa_level" <*> o .:? "application_id" + <*> o .:? "system_channel_id" + <*> o .: "system_channel_flags" + <*> o .:? "rules_channel_id" + <*> o .:? "joined_at" + <*> o .:? "large" + <*> o .:? "unavailable" + <*> o .:? "member_count" + -- voice_states + <*> o .:? "members" + <*> o .:? "channels" + <*> o .:? "threads" + <*> o .:? "presences" + <*> o .:? "max_presences" + <*> o .:? "max_members" + <*> o .:? "vanity_url_code" + <*> o .:? "description" + <*> o .:? "banner" + <*> o .: "premium_tier" + <*> o .:? "premium_subscription_count" + <*> o .: "preferred_locale" + <*> o .:? "public_updates_channel_id" + <*> o .:? "max_video_channel_users" + <*> o .:? "approximate_member_count" + <*> o .:? "approximate_presence_count" + -- welcome_screen + <*> o .: "nsfw_level" + -- stage_instances + <*> o .:? "stickers" + <*> o .: "premium_progress_bar_enabled" -data GuildUnavailable = GuildUnavailable +newtype GuildUnavailable = GuildUnavailable { idOnceAvailable :: GuildId } deriving (Show, Read, Eq, Ord) @@ -73,24 +139,120 @@ parseJSON = withObject "GuildUnavailable" $ \o -> GuildUnavailable <$> o .: "id" -data GuildInfo = GuildInfo - { guildJoinedAt :: UTCTime - , guildLarge :: Bool - , guildMemberCount :: Integer - -- , guildVoiceStates :: [VoiceState] -- (without guildid) todo have to add voice state data type - , guildMembers :: [GuildMember] - , guildChannels :: [Channel] -- ^ Channels in the guild (sent in GuildCreate) - -- , guildPresences :: [Presence] - } deriving (Show, Read, Eq, Ord) +data PresenceInfo = PresenceInfo + { presenceUserId :: UserId + -- , presenceRoles :: [RoleId] + , presenceActivities :: Maybe [Activity] + , presenceGuildId :: Maybe GuildId + , presenceStatus :: T.Text + } deriving (Show, Read, Eq, Ord) -instance FromJSON GuildInfo where - parseJSON = withObject "GuildInfo" $ \o -> - GuildInfo <$> o .: "joined_at" - <*> o .: "large" - <*> o .: "member_count" - -- <*> o .: "voice_states" - <*> o .: "members" - <*> o .: "channels" +instance FromJSON PresenceInfo where + parseJSON = withObject "PresenceInfo" $ \o -> + PresenceInfo <$> (o .: "user" >>= (.: "id")) + <*> o .: "activities" + <*> o .:? "guild_id" + <*> o .: "status" + +-- | Object for a single activity +-- +-- https://discord.com/developers/docs/topics/gateway#activity-object +-- +-- When setting a bot's activity, only the name, url, and type are sent - and +-- it seems that not many types are permitted either. +data Activity = + Activity + { activityName :: T.Text -- ^ Name of activity + , activityType :: ActivityType -- ^ Type of activity + , activityUrl :: Maybe T.Text -- ^ URL of the activity (only verified when streaming) + , activityCreatedAt :: Integer -- ^ unix time in milliseconds + , activityTimeStamps :: Maybe ActivityTimestamps -- ^ Start and end times + , activityApplicationId :: Maybe ApplicationId -- ^ Application of the activity + , activityDetails :: Maybe T.Text -- ^ Details of Activity + , activityState :: Maybe T.Text -- ^ State of the user's party + , activityEmoji :: Maybe Emoji -- ^ Simplified emoji object + , activityParty :: Maybe ActivityParty -- ^ Info for the current player's party + -- assets + -- secrets + , activityInstance :: Maybe Bool -- ^ Whether or not the activity is an instanced game session + , activityFlags :: Maybe Integer -- ^ The flags https://discord.com/developers/docs/topics/gateway#activity-object-activity-flags + , activityButtons :: Maybe [ActivityButton] -- ^ Custom buttons shown in Rich Presence + } + deriving (Show, Read, Eq, Ord) + +instance Default Activity where + def = Activity "discord-haskell" ActivityTypeGame Nothing 0 Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +instance FromJSON Activity where + parseJSON = withObject "Activity" $ \o -> do + Activity <$> o .: "name" + <*> o .: "type" + <*> o .:? "url" + <*> o .: "created_at" + <*> o .:? "timestamps" + <*> o .:? "application_id" + <*> o .:? "details" + <*> o .:? "state" + <*> o .:? "emoji" + <*> o .:? "party" + -- assets + -- secrets + <*> o .:? "instance" + <*> o .:? "flags" + <*> o .:? "buttons" + +data ActivityTimestamps = ActivityTimestamps + { activityTimestampsStart :: Maybe Integer -- ^ unix time in milliseconds + , activityTimestampsEnd :: Maybe Integer -- ^ unix time in milliseconds + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ActivityTimestamps where + parseJSON = withObject "ActivityTimestamps" $ \o -> + ActivityTimestamps <$> o .:? "start" + <*> o .:? "end" + +data ActivityParty = ActivityParty + { activityPartyId :: Maybe T.Text + , activityPartySize :: Maybe (Integer, Integer) + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ActivityParty where + parseJSON = withObject "ActivityParty" $ \o -> + ActivityParty <$> o .:? "id" + <*> o .:? "size" + +data ActivityButton = ActivityButton + { activityButtonLabel :: T.Text + , activityButtonUrl :: T.Text + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ActivityButton where + parseJSON = withObject "ActivityButton" $ \o -> + ActivityButton <$> o .: "label" + <*> o .: "url" + +-- | To see what these look like, go to here: +-- https://discord.com/developers/docs/topics/gateway#activity-object-activity-types +data ActivityType = + ActivityTypeGame + | ActivityTypeStreaming + | ActivityTypeListening + | ActivityTypeWatching + | ActivityTypeCustom + | ActivityTypeCompeting + deriving (Show, Read, Eq, Ord, Data) + +instance InternalDiscordEnum ActivityType where + discordTypeStartValue = ActivityTypeGame + fromDiscordType ActivityTypeGame = 0 + fromDiscordType ActivityTypeStreaming = 1 + fromDiscordType ActivityTypeListening = 2 + fromDiscordType ActivityTypeWatching = 3 + fromDiscordType ActivityTypeCustom = 4 + fromDiscordType ActivityTypeCompeting = 5 + +instance FromJSON ActivityType where + parseJSON = discordTypeParseJSON "ActivityType" data PartialGuild = PartialGuild { partialGuildId :: GuildId diff --git a/src/Discord/Internal/Types/Interactions.hs b/src/Discord/Internal/Types/Interactions.hs --- a/src/Discord/Internal/Types/Interactions.hs +++ b/src/Discord/Internal/Types/Interactions.hs @@ -25,10 +25,12 @@ interactionResponseMessageBasic, InteractionResponseMessageFlags (..), InteractionResponseMessageFlag (..), + InteractionResponseModalData (..), ) where import Control.Applicative (Alternative ((<|>))) +import Control.Monad (join) import Data.Aeson import Data.Aeson.Types (Parser) import Data.Bits (Bits (shift, (.|.))) @@ -37,7 +39,7 @@ import qualified Data.Text as T import Discord.Internal.Types.ApplicationCommands (Choice) import Discord.Internal.Types.Channel (AllowedMentions, Attachment, Message) -import Discord.Internal.Types.Components (ComponentActionRow) +import Discord.Internal.Types.Components (ComponentActionRow, ComponentTextInput) import Discord.Internal.Types.Embed (CreateEmbed, createEmbed) import Discord.Internal.Types.Prelude (ApplicationCommandId, ApplicationId, ChannelId, GuildId, InteractionId, InteractionToken, MessageId, RoleId, Snowflake, UserId) import Discord.Internal.Types.User (GuildMember, User) @@ -122,7 +124,29 @@ -- | The invoking guild's preferred locale. interactionGuildLocale :: Maybe T.Text } - deriving (Show, Eq, Read) + | InteractionModalSubmit + { -- | The id of this interaction. + interactionId :: InteractionId, + -- | The id of the application that this interaction belongs to. + interactionApplicationId :: ApplicationId, + -- | The data for this interaction. + interactionDataModal :: InteractionDataModal, + -- | What guild this interaction comes from. + interactionGuildId :: Maybe GuildId, + -- | What channel this interaction comes from. + interactionChannelId :: Maybe ChannelId, + -- | What user/member this interaction comes from. + interactionUser :: MemberOrUser, + -- | The unique token that represents this interaction. + interactionToken :: InteractionToken, + -- | What version of interaction is this (always 1). + interactionVersion :: Int, + -- | The invoking user's preferred locale. + interactionLocale :: T.Text, + -- | The invoking guild's preferred locale. + interactionGuildLocale :: Maybe T.Text + } + deriving (Show, Read, Eq, Ord) instance FromJSON Interaction where parseJSON = @@ -170,10 +194,21 @@ <*> return version <*> v .: "locale" <*> return glocale + 5 -> + InteractionModalSubmit iid aid + <$> v .: "data" + <*> return gid + <*> return cid + <*> parseJSON (Object v) + <*> return tok + <*> return version + <*> v .: "locale" + <*> return glocale _ -> fail "unknown interaction type" ) -newtype MemberOrUser = MemberOrUser (Either GuildMember User) deriving (Show, Eq, Read) +newtype MemberOrUser = MemberOrUser (Either GuildMember User) + deriving (Show, Read, Eq, Ord) instance {-# OVERLAPPING #-} FromJSON MemberOrUser where parseJSON = @@ -193,7 +228,7 @@ -- | Values for the select menu. interactionDataComponentValues :: [T.Text] } - deriving (Show, Read, Eq) + deriving (Show, Read, Eq, Ord) instance FromJSON InteractionDataComponent where parseJSON = @@ -241,7 +276,7 @@ -- | The options of the application command. interactionDataApplicationCommandOptions :: Maybe InteractionDataApplicationCommandOptions } - deriving (Show, Read, Eq) + deriving (Show, Read, Eq, Ord) instance FromJSON InteractionDataApplicationCommand where parseJSON = @@ -269,7 +304,7 @@ data InteractionDataApplicationCommandOptions = InteractionDataApplicationCommandOptionsSubcommands [InteractionDataApplicationCommandOptionSubcommandOrGroup] | InteractionDataApplicationCommandOptionsValues [InteractionDataApplicationCommandOptionValue] - deriving (Show, Read, Eq) + deriving (Show, Read, Eq, Ord) instance FromJSON InteractionDataApplicationCommandOptions where parseJSON = @@ -299,7 +334,7 @@ interactionDataApplicationCommandOptionSubcommandGroupFocused :: Bool } | InteractionDataApplicationCommandOptionSubcommandOrGroupSubcommand InteractionDataApplicationCommandOptionSubcommand - deriving (Show, Read, Eq) + deriving (Show, Read, Eq, Ord) instance FromJSON InteractionDataApplicationCommandOptionSubcommandOrGroup where parseJSON = @@ -323,7 +358,7 @@ interactionDataApplicationCommandOptionSubcommandOptions :: [InteractionDataApplicationCommandOptionValue], interactionDataApplicationCommandOptionSubcommandFocused :: Bool } - deriving (Show, Read, Eq) + deriving (Show, Read, Eq, Ord) instance FromJSON InteractionDataApplicationCommandOptionSubcommand where parseJSON = @@ -374,7 +409,7 @@ { interactionDataApplicationCommandOptionValueName :: T.Text, interactionDataApplicationCommandOptionValueNumberValue :: Either T.Text Scientific } - deriving (Show, Read, Eq) + deriving (Show, Read, Eq, Ord) instance FromJSON InteractionDataApplicationCommandOptionValue where parseJSON = @@ -412,6 +447,30 @@ _ -> fail $ "unexpected interaction data application command option value type: " ++ show t ) +data InteractionDataModal = InteractionDataModal + { -- | The unique id of the component (up to 100 characters). + interactionDataModalCustomId :: T.Text, + -- | Components from the modal. + interactionDataModalComponents :: [ComponentTextInput] + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON InteractionDataModal where + parseJSON = + withObject + "InteractionDataModal" + ( \v -> + InteractionDataModal <$> v .: "custom_id" + <*> ((v .: "components") >>= (join <$>) . mapM getTextInput) + ) + where + getTextInput :: Value -> Parser [ComponentTextInput] + getTextInput = withObject "InteractionDataModal.TextInput" $ \o -> do + t <- o .: "type" :: Parser Int + case t of + 1 -> o .: "components" + _ -> fail $ "expected action row type (1), got: " ++ show t + parseValue :: (FromJSON a) => Object -> Bool -> Parser (Either T.Text a) parseValue o True = Left <$> o .: "value" parseValue o False = Right <$> o .: "value" @@ -429,9 +488,11 @@ { resolvedDataUsers :: Maybe Value, resolvedDataMembers :: Maybe Value, resolvedDataRoles :: Maybe Value, - resolvedDataChannels :: Maybe Value + resolvedDataChannels :: Maybe Value, + resolvedDataMessages :: Maybe Value, + resolvedDataAttachments :: Maybe Value } - deriving (Show, Read, Eq) + deriving (Show, Read, Eq, Ord) instance ToJSON ResolvedData where toJSON ResolvedData {..} = @@ -441,7 +502,9 @@ [ ("users", resolvedDataUsers), ("members", resolvedDataMembers), ("roles", resolvedDataRoles), - ("channels", resolvedDataChannels) + ("channels", resolvedDataChannels), + ("messages", resolvedDataMessages), + ("attachments", resolvedDataAttachments) ] ] @@ -455,6 +518,8 @@ <*> v .:? "members" <*> v .:? "roles" <*> v .:? "channels" + <*> v .:? "messages" + <*> v .:? "attachments" ) -- | The data to respond to an interaction with. Unless specified otherwise, you @@ -473,6 +538,9 @@ InteractionResponseUpdateMessage InteractionResponseMessage | -- | respond to an autocomplete interaction with suggested choices InteractionResponseAutocompleteResult InteractionResponseAutocomplete + | -- | respond with a popup modal + InteractionResponseModal InteractionResponseModalData + deriving (Show, Read, Eq, Ord) -- | A basic interaction response, sending back the given text. interactionResponseBasic :: T.Text -> InteractionResponse @@ -485,9 +553,10 @@ toJSON (InteractionResponseChannelMessage ms) = object [("type", Number 4), ("data", toJSON ms)] toJSON (InteractionResponseUpdateMessage ms) = object [("type", Number 7), ("data", toJSON ms)] toJSON (InteractionResponseAutocompleteResult ms) = object [("type", Number 8), ("data", toJSON ms)] + toJSON (InteractionResponseModal ms) = object [("type", Number 9), ("data", toJSON ms)] data InteractionResponseAutocomplete = InteractionResponseAutocompleteString [Choice T.Text] | InteractionResponseAutocompleteInteger [Choice Integer] | InteractionResponseAutocompleteNumber [Choice Scientific] - deriving (Show, Eq) + deriving (Show, Read, Eq, Ord) instance ToJSON InteractionResponseAutocomplete where toJSON (InteractionResponseAutocompleteString cs) = object [("choices", toJSON cs)] @@ -504,7 +573,7 @@ interactionResponseMessageComponents :: Maybe [ComponentActionRow], interactionResponseMessageAttachments :: Maybe [Attachment] } - deriving (Show, Eq) + deriving (Show, Read, Eq, Ord) -- | A basic interaction response, sending back the given text. This is -- effectively a helper function. @@ -531,10 +600,10 @@ -- Currently the only flag is EPHERMERAL, which means only the user can see the -- message. data InteractionResponseMessageFlag = InteractionResponseMessageFlagEphermeral - deriving (Show, Read, Eq) + deriving (Show, Read, Eq, Ord) newtype InteractionResponseMessageFlags = InteractionResponseMessageFlags [InteractionResponseMessageFlag] - deriving (Show, Read, Eq) + deriving (Show, Read, Eq, Ord) instance Enum InteractionResponseMessageFlag where fromEnum InteractionResponseMessageFlagEphermeral = 1 `shift` 6 @@ -544,3 +613,18 @@ instance ToJSON InteractionResponseMessageFlags where toJSON (InteractionResponseMessageFlags fs) = Number $ fromInteger $ fromIntegral $ foldr (.|.) 0 (fromEnum <$> fs) + +data InteractionResponseModalData = InteractionResponseModalData + { interactionResponseModalCustomId :: T.Text, + interactionResponseModalTitle :: T.Text, + interactionResponseModalComponents :: [ComponentTextInput] + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON InteractionResponseModalData where + toJSON InteractionResponseModalData {..} = + object + [ ("custom_id", toJSON interactionResponseModalCustomId), + ("title", toJSON interactionResponseModalTitle), + ("components", toJSON $ map (\ti -> object [("type", Number 1), ("components", toJSON [ti])]) interactionResponseModalComponents) + ]