diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -6,6 +6,10 @@ ## master +## 1.8.4 + +[yutotakano](https://github.com/aquarial/discord-haskell/pull/64) Add discord replies type, and message constructor + ## 1.8.3 Bot no longer disconnects randomly (hopefully) https://github.com/aquarial/discord-haskell/issues/62 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.8.3 +version: 1.8.4 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 @@ -61,7 +61,23 @@ MessageCreate m -> when (not (fromBot m) && isPing m) $ do _ <- restCall (R.CreateReaction (messageChannel m, messageId m) "eyes") threadDelay (4 * 10^(6 :: Int)) + + -- A very simple message. _ <- restCall (R.CreateMessage (messageChannel m) "Pong!") + + -- A more complex message. Text-to-speech, does not mention everyone nor + -- the user, and uses Discord native replies. + let opts = def { messageDetailedContent = "Here's a more complex message, but doesn't ping @everyone!" + , messageDetailedTTS = True + , messageDetailedAllowedMentions = Just $ + def { mentionEveryone = False + , mentionRepliedUser = False + } + , messageDetailedReference = Just $ + def { referenceMessageId = Just $ messageId m } + } + _ <- restCall (R.CreateMessageDetailed (messageChannel m) opts) + pure () _ -> pure () 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 @@ -7,6 +7,8 @@ -- | Provides actions for Channel API interactions module Discord.Internal.Rest.Channel ( ChannelRequest(..) + , MessageDetailedOpts(..) + , AllowedMentions(..) , ReactionTiming(..) , MessageTiming(..) , ChannelInviteOpts(..) @@ -18,6 +20,7 @@ import Data.Aeson +import Data.Default (Default, def) import Data.Emoji (unicodeByName) import qualified Data.Text as T import qualified Data.ByteString as B @@ -52,6 +55,8 @@ CreateMessageEmbed :: ChannelId -> T.Text -> CreateEmbed -> ChannelRequest Message -- | Sends a message with a file to a channel. CreateMessageUploadFile :: ChannelId -> T.Text -> B.ByteString -> ChannelRequest Message + -- | Sends a message with granular controls. + 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 () -- | Remove a Reaction this bot added @@ -93,6 +98,54 @@ GroupDMRemoveRecipient :: ChannelId -> UserId -> ChannelRequest () +-- | Data constructor for CreateMessageDetailed requests. +data MessageDetailedOpts = MessageDetailedOpts + { messageDetailedContent :: T.Text + , messageDetailedTTS :: Bool + , messageDetailedEmbed :: Maybe CreateEmbed + , messageDetailedFile :: Maybe (T.Text, B.ByteString) + , messageDetailedAllowedMentions :: Maybe AllowedMentions + , messageDetailedReference :: Maybe MessageReference + } + +instance Default MessageDetailedOpts where + def = MessageDetailedOpts { messageDetailedContent = "" + , messageDetailedTTS = False + , messageDetailedEmbed = Nothing + , messageDetailedFile = Nothing + , messageDetailedAllowedMentions = Nothing + , messageDetailedReference = Nothing + } + +-- | Data constructor for a part of MessageDetailedOpts. +data AllowedMentions = AllowedMentions + { mentionEveryone :: Bool + , mentionUsers :: Bool + , mentionRoles :: Bool + , mentionUserIds :: [UserId] + , mentionRoleIds :: [RoleId] + , mentionRepliedUser :: Bool + } + +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), + ("roles", mentionRoles) ] ]), + ("roles" .= mentionRoleIds), + ("users" .= mentionUserIds), + ("replied_user" .= mentionRepliedUser) ] + -- | Data constructor for GetReaction requests data ReactionTiming = BeforeReaction MessageId | AfterReaction MessageId @@ -187,6 +240,7 @@ (CreateMessage chan _) -> "msg " <> show chan (CreateMessageEmbed chan _ _) -> "msg " <> show chan (CreateMessageUploadFile chan _ _) -> "msg " <> show chan + (CreateMessageDetailed chan _) -> "msg " <> show chan (CreateReaction (chan, _) _) -> "add_react " <> show chan (DeleteOwnReaction (chan, _) _) -> "react " <> show chan (DeleteUserReaction (chan, _) _ _) -> "react " <> show chan @@ -261,6 +315,25 @@ (CreateMessageUploadFile chan fileName file) -> let part = partFileRequestBody "file" (T.unpack fileName) $ RequestBodyBS file body = R.reqBodyMultipart [part] + in Post (channels // chan /: "messages") body mempty + + (CreateMessageDetailed chan msgOpts) -> + let fileUpload = messageDetailedFile msgOpts + filePart = case fileUpload of + Nothing -> [] + Just f -> [partFileRequestBody "file" (T.unpack $ fst f) + $ RequestBodyBS $ snd f] + + payloadData = object $ [ "content" .= messageDetailedContent msgOpts + , "tts" .= messageDetailedTTS msgOpts ] ++ + [ name .= value | (name, Just value) <- + [ ("embed", toJSON <$> createEmbed <$> messageDetailedEmbed msgOpts) + , ("allowed_mentions", toJSON <$> messageDetailedAllowedMentions msgOpts) + , ("message_reference", toJSON <$> messageDetailedReference msgOpts) + ] ] + payloadPart = partBS "payload_json" $ BL.toStrict $ encode $ toJSON payloadData + + body = R.reqBodyMultipart (payloadPart : filePart) in Post (channels // chan /: "messages") body mempty (CreateReaction (chan, msgid) emoji) -> 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 @@ -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.8.3)" + agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 1.8.4)" -- Append to an URL infixl 5 // 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 @@ -7,6 +7,7 @@ import Control.Applicative (empty) import Data.Aeson import Data.Aeson.Types (Parser) +import Data.Default (Default, def) import Data.Text (Text) import Data.Time.Clock import qualified Data.Text as T @@ -250,6 +251,8 @@ -- 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 } deriving (Show, Eq, Ord) instance FromJSON Message where @@ -274,6 +277,8 @@ <*> o .:? "nonce" <*> o .:? "pinned" .!= False <*> o .:? "guild_id" .!= Nothing + <*> o .:? "message_reference" .!= Nothing + <*> o .:? "referenced_message" .!= Nothing data MessageReaction = MessageReaction @@ -305,7 +310,7 @@ <*> o .:? "user" <*> o .:? "managed" - + -- | Represents an attached to a message file. data Attachment = Attachment { attachmentId :: Snowflake -- ^ Attachment id @@ -336,3 +341,34 @@ parseJSON (String nonce) = pure $ Nonce nonce parseJSON (Number nonce) = pure . Nonce . T.pack . show $ nonce parseJSON _ = empty + + +-- | Represents a Message Reference +data MessageReference = MessageReference + { referenceMessageId :: Maybe MessageId -- ^ id of the originating message + , referenceChannelId :: Maybe ChannelId -- ^ id of the originating message's channel + , referenceGuildId :: Maybe GuildId -- ^ id of the originating message's guild + , failIfNotExists :: Bool -- ^ Whether to not send if reference not exist + } deriving (Show, Eq, Ord) + +instance FromJSON MessageReference where + parseJSON = withObject "MessageReference" $ \o -> + MessageReference <$> o .:? "message_id" + <*> o .:? "channel_id" + <*> o .:? "guild_id" + <*> o .:? "fail_if_not_exists" .!= True + +instance ToJSON MessageReference where + toJSON MessageReference{..} = object [(name,value) | (name, Just value) <- + [ ("message_id", toJSON <$> pure referenceMessageId) + , ("channel_id", toJSON <$> pure referenceChannelId) + , ("guild_id", toJSON <$> pure referenceGuildId) + , ("fail_if_not_exists", toJSON <$> pure failIfNotExists) + ] ] + +instance Default MessageReference where + def = MessageReference { referenceMessageId = Nothing + , referenceChannelId = Nothing + , referenceGuildId = Nothing + , failIfNotExists = False + }