discord-haskell 1.8.3 → 1.8.4
raw patch · 6 files changed
+132/−3 lines, 6 files
Files
- changelog.md +4/−0
- discord-haskell.cabal +1/−1
- examples/ping-pong.hs +16/−0
- src/Discord/Internal/Rest/Channel.hs +73/−0
- src/Discord/Internal/Rest/Prelude.hs +1/−1
- src/Discord/Internal/Types/Channel.hs +37/−1
changelog.md view
@@ -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
discord-haskell.cabal view
@@ -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 <https://discord.com/developers/docs/reference>. .
examples/ping-pong.hs view
@@ -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 ()
src/Discord/Internal/Rest/Channel.hs view
@@ -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) ->
src/Discord/Internal/Rest/Prelude.hs view
@@ -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 //
src/Discord/Internal/Types/Channel.hs view
@@ -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+ }