diff --git a/discord-haskell.cabal b/discord-haskell.cabal --- a/discord-haskell.cabal +++ b/discord-haskell.cabal @@ -1,6 +1,6 @@ name: discord-haskell -- library version is also noted at src/Discord/Rest/Prelude.hs -version: 0.6.0 +version: 0.7.0 synopsis: Write bots for Discord in Haskell description: Functions and data types to write discord bots. Official discord docs . @@ -43,8 +43,8 @@ , Discord.Types.Guild build-depends: base >=4 && <5 - , aeson >=1.2.4.0 && <1.3 - , async >=2.1.1.1 && <2.2 + , aeson >=1.3.1.1 && < 1.4 + , async >=2.2.1 && <2.3 , bytestring >=0.10.8.2 && <0.11 , base64-bytestring >= 1.0.0.1 && <1.1 , containers >=0.5.10.2 && <0.6 @@ -52,7 +52,7 @@ , http-client >=0.5.12.1 && <0.6 , iso8601-time >=0.1.4 && <0.2 , MonadRandom >=0.5.1 && <0.6 - , req >=1.0.0 && <1.1 + , req >=1.1.0 && <1.2 , JuicyPixels >= 3.2.9.0 && < 3.3 , safe-exceptions >=0.1.7.0 && <0.2 , text >=1.2.3.0 && <1.3 diff --git a/src/Discord/Gateway/Cache.hs b/src/Discord/Gateway/Cache.hs --- a/src/Discord/Gateway/Cache.hs +++ b/src/Discord/Gateway/Cache.hs @@ -76,6 +76,6 @@ _ -> minfo setChanGuildID :: Snowflake -> Channel -> Channel -setChanGuildID s c = if isGuildChannel c +setChanGuildID s c = if channelIsInGuild c then c { channelGuild = s } else c diff --git a/src/Discord/Rest/Channel.hs b/src/Discord/Rest/Channel.hs --- a/src/Discord/Rest/Channel.hs +++ b/src/Discord/Rest/Channel.hs @@ -9,6 +9,7 @@ ( ChannelRequest(..) , ReactionTiming(..) , MessageTiming(..) + , ChannelInviteOpts(..) , ModifyChannelOpts(..) , ChannelPermissionsOpts(..) , GroupDMAddRecipientOpts(..) @@ -35,65 +36,63 @@ -- | Data constructor for requests. See data ChannelRequest a where -- | Gets a channel by its id. - GetChannel :: Snowflake -> ChannelRequest Channel + GetChannel :: ChannelId -> ChannelRequest Channel -- | Edits channels options. - ModifyChannel :: Snowflake -> ModifyChannelOpts -> ChannelRequest Channel + ModifyChannel :: ChannelId -> ModifyChannelOpts -> ChannelRequest Channel -- | Deletes a channel if its id doesn't equal to the id of guild. - DeleteChannel :: Snowflake -> ChannelRequest Channel + DeleteChannel :: ChannelId -> ChannelRequest Channel -- | Gets a messages from a channel with limit of 100 per request. - GetChannelMessages :: Snowflake -> (Int, MessageTiming) -> ChannelRequest [Message] + GetChannelMessages :: ChannelId -> (Int, MessageTiming) -> ChannelRequest [Message] -- | Gets a message in a channel by its id. - GetChannelMessage :: (Snowflake, Snowflake) -> ChannelRequest Message + GetChannelMessage :: (ChannelId, MessageId) -> ChannelRequest Message -- | Sends a message to a channel. - CreateMessage :: Snowflake -> T.Text -> Maybe Embed -> ChannelRequest Message + CreateMessage :: ChannelId -> T.Text -> ChannelRequest Message + -- | Sends a message with an Embed to a channel. + CreateMessageEmbed :: ChannelId -> T.Text -> Embed -> ChannelRequest Message -- | Sends a message with a file to a channel. - UploadFile :: Snowflake -> FilePath -> BL.ByteString -> ChannelRequest Message + CreateMessageUploadFile :: ChannelId -> T.Text -> BL.ByteString -> ChannelRequest Message -- | Add an emoji reaction to a message. ID must be present for custom emoji - CreateReaction :: (Snowflake, Snowflake) -> (T.Text, Maybe Snowflake) - -> ChannelRequest () + CreateReaction :: (ChannelId, MessageId) -> T.Text -> ChannelRequest () -- | Remove a Reaction this bot added - DeleteOwnReaction :: (Snowflake, Snowflake) -> (T.Text, Maybe Snowflake) - -> ChannelRequest () + DeleteOwnReaction :: (ChannelId, MessageId) -> T.Text -> ChannelRequest () -- | Remove a Reaction someone else added - DeleteUserReaction :: (Snowflake, Snowflake) -> (T.Text, Maybe Snowflake) - -> Snowflake -> ChannelRequest () + DeleteUserReaction :: (ChannelId, MessageId) -> UserId -> T.Text -> ChannelRequest () -- | List of users that reacted with this emoji - GetReactions :: (Snowflake, Snowflake) -> (T.Text, Maybe Snowflake) - -> (Int, ReactionTiming) -> ChannelRequest () + GetReactions :: (ChannelId, MessageId) -> T.Text -> (Int, ReactionTiming) -> ChannelRequest () -- | Delete all reactions on a message - DeleteAllReactions :: (Snowflake, Snowflake) -> ChannelRequest () + DeleteAllReactions :: (ChannelId, MessageId) -> ChannelRequest () -- | Edits a message content. - EditMessage :: (Snowflake, Snowflake) -> T.Text -> Maybe Embed + EditMessage :: (ChannelId, MessageId) -> T.Text -> Maybe Embed -> ChannelRequest Message -- | Deletes a message. - DeleteMessage :: (Snowflake, Snowflake) -> ChannelRequest () + DeleteMessage :: (ChannelId, MessageId) -> ChannelRequest () -- | Deletes a group of messages. - BulkDeleteMessage :: (Snowflake, [Snowflake]) -> ChannelRequest () + BulkDeleteMessage :: (ChannelId, [MessageId]) -> ChannelRequest () -- | Edits a permission overrides for a channel. - EditChannelPermissions :: Snowflake -> Snowflake -> ChannelPermissionsOpts -> ChannelRequest () + EditChannelPermissions :: ChannelId -> OverwriteId -> ChannelPermissionsOpts -> ChannelRequest () -- | Gets all instant invites to a channel. - GetChannelInvites :: Snowflake -> ChannelRequest Object + GetChannelInvites :: ChannelId -> ChannelRequest Object -- | Creates an instant invite to a channel. - CreateChannelInvite :: Snowflake -> ChannelInviteOpts -> ChannelRequest Invite + CreateChannelInvite :: ChannelId -> ChannelInviteOpts -> ChannelRequest Invite -- | Deletes a permission override from a channel. - DeleteChannelPermission :: Snowflake -> Snowflake -> ChannelRequest () + DeleteChannelPermission :: ChannelId -> OverwriteId -> ChannelRequest () -- | Sends a typing indicator a channel which lasts 10 seconds. - TriggerTypingIndicator :: Snowflake -> ChannelRequest () + TriggerTypingIndicator :: ChannelId -> ChannelRequest () -- | Gets all pinned messages of a channel. - GetPinnedMessages :: Snowflake -> ChannelRequest [Message] + GetPinnedMessages :: ChannelId -> ChannelRequest [Message] -- | Pins a message. - AddPinnedMessage :: (Snowflake, Snowflake) -> ChannelRequest () + AddPinnedMessage :: (ChannelId, MessageId) -> ChannelRequest () -- | Unpins a message. - DeletePinnedMessage :: (Snowflake, Snowflake) -> ChannelRequest () + DeletePinnedMessage :: (ChannelId, MessageId) -> ChannelRequest () -- | Adds a recipient to a Group DM using their access token - GroupDMAddRecipient :: Snowflake -> GroupDMAddRecipientOpts -> ChannelRequest () + GroupDMAddRecipient :: ChannelId -> GroupDMAddRecipientOpts -> ChannelRequest () -- | Removes a recipient from a Group DM - GroupDMRemoveRecipient :: Snowflake -> Snowflake -> ChannelRequest () + GroupDMRemoveRecipient :: ChannelId -> UserId -> ChannelRequest () -- | Data constructor for GetReaction requests -data ReactionTiming = BeforeReaction Snowflake - | AfterReaction Snowflake +data ReactionTiming = BeforeReaction MessageId + | AfterReaction MessageId reactionTimingToQuery :: ReactionTiming -> R.Option 'R.Https reactionTimingToQuery t = case t of @@ -101,15 +100,17 @@ (AfterReaction snow) -> "after" R.=: show snow -- | Data constructor for GetChannelMessages requests. See -data MessageTiming = AroundMessage Snowflake - | BeforeMessage Snowflake - | AfterMessage Snowflake +data MessageTiming = AroundMessage MessageId + | BeforeMessage MessageId + | AfterMessage MessageId + | LatestMessages messageTimingToQuery :: MessageTiming -> R.Option 'R.Https messageTimingToQuery t = case t of (AroundMessage snow) -> "around" R.=: show snow (BeforeMessage snow) -> "before" R.=: show snow (AfterMessage snow) -> "after" R.=: show snow + (LatestMessages) -> mempty data ChannelInviteOpts = ChannelInviteOpts { channelInviteOptsMaxAgeSeconds :: Maybe Integer @@ -133,7 +134,7 @@ , modifyChannelBitrate :: Maybe Integer , modifyChannelUserRateLimit :: Maybe Integer , modifyChannelPermissionOverwrites :: Maybe [Overwrite] - , modifyChannelParentId :: Maybe Snowflake + , modifyChannelParentId :: Maybe ChannelId } instance ToJSON ModifyChannelOpts where @@ -166,7 +167,7 @@ -- | https://discordapp.com/developers/docs/resources/channel#group-dm-add-recipient data GroupDMAddRecipientOpts = GroupDMAddRecipientOpts - { groupDMAddRecipientUserToAdd :: Snowflake + { groupDMAddRecipientUserToAdd :: UserId , groupDMAddRecipientUserToAddNickName :: T.Text , groupDMAddRecipientGDMJoinAccessToken :: T.Text } @@ -178,8 +179,9 @@ (DeleteChannel chan) -> "mod_chan " <> show chan (GetChannelMessages chan _) -> "msg " <> show chan (GetChannelMessage (chan, _)) -> "get_msg " <> show chan - (CreateMessage chan _ _) -> "msg " <> show chan - (UploadFile chan _ _) -> "msg " <> show chan + (CreateMessage chan _) -> "msg " <> show chan + (CreateMessageEmbed chan _ _) -> "msg " <> show chan + (CreateMessageUploadFile chan _ _) -> "msg " <> show chan (CreateReaction (chan, _) _) -> "react " <> show chan (DeleteOwnReaction (chan, _) _) -> "react " <> show chan (DeleteUserReaction (chan, _) _ _) -> "react " <> show chan @@ -199,6 +201,11 @@ (GroupDMAddRecipient chan _) -> "groupdm " <> show chan (GroupDMRemoveRecipient chan _) -> "groupdm " <> show chan +cleanupEmoji :: T.Text -> T.Text +cleanupEmoji emoji = + let noAngles = T.replace "<" "" (T.replace ">" "" emoji) + in case T.stripPrefix ":" noAngles of Just a -> "custom:" <> a + Nothing -> noAngles maybeEmbed :: Maybe Embed -> [(T.Text, Value)] maybeEmbed = maybe [] $ \embed -> ["embed" .= embed] @@ -230,34 +237,39 @@ (GetChannelMessage (chan, msg)) -> Get (channels // chan /: "messages" // msg) mempty - (CreateMessage chan msg embed) -> - let content = ["content" .= msg] <> maybeEmbed embed + (CreateMessage chan msg) -> + let content = ["content" .= msg] body = pure $ R.ReqBodyJson $ object content in Post (channels // chan /: "messages") body mempty - (UploadFile chan fileName file) -> - let part = partFileRequestBody "file" fileName $ RequestBodyLBS file + (CreateMessageEmbed chan msg embed) -> + let content = ["content" .= msg] <> maybeEmbed (Just embed) + body = pure $ R.ReqBodyJson $ object content + in Post (channels // chan /: "messages") body mempty + + (CreateMessageUploadFile chan fileName file) -> + let part = partFileRequestBody "file" (T.unpack fileName) $ RequestBodyLBS file body = R.reqBodyMultipart [part] in Post (channels // chan /: "messages") body mempty - (CreateReaction (chan, msgid) (name, rID)) -> - let emoji = "" <> name <> maybe "" ((<>) ":" . T.pack . show) rID - in Put (channels // chan /: "messages" // msgid /: "reactions" /: emoji /: "@me" ) + (CreateReaction (chan, msgid) emoji) -> + let e = cleanupEmoji emoji + in Put (channels // chan /: "messages" // msgid /: "reactions" /: e /: "@me" ) R.NoReqBody mempty - (DeleteOwnReaction (chan, msgid) (name, rID)) -> - let emoji = "" <> name <> maybe "" ((<>) ":" . T.pack . show) rID - in Delete (channels // chan /: "messages" // msgid /: "reactions" /: emoji /: "@me" ) mempty + (DeleteOwnReaction (chan, msgid) emoji) -> + let e = cleanupEmoji emoji + in Delete (channels // chan /: "messages" // msgid /: "reactions" /: e /: "@me" ) mempty - (DeleteUserReaction (chan, msgid) (name, rID) uID) -> - let emoji = "" <> name <> maybe "" ((<>) ":" . T.pack . show) rID - in Delete (channels // chan /: "messages" // msgid /: "reactions" /: emoji // uID ) mempty + (DeleteUserReaction (chan, msgid) uID emoji) -> + let e = cleanupEmoji emoji + in Delete (channels // chan /: "messages" // msgid /: "reactions" /: e // uID ) mempty - (GetReactions (chan, msgid) (name, rID) (n, timing)) -> - let emoji = "" <> name <> maybe "" ((<>) ":" . T.pack . show) rID + (GetReactions (chan, msgid) emoji (n, timing)) -> + let e = cleanupEmoji emoji n' = if n < 1 then 1 else (if n > 100 then 100 else n) options = "limit" R.=: n' <> reactionTimingToQuery timing - in Get (channels // chan /: "messages" // msgid /: "reactions" /: emoji ) options + in Get (channels // chan /: "messages" // msgid /: "reactions" /: e) options (DeleteAllReactions (chan, msgid)) -> Delete (channels // chan /: "messages" // msgid /: "reactions" ) mempty diff --git a/src/Discord/Rest/Emoji.hs b/src/Discord/Rest/Emoji.hs --- a/src/Discord/Rest/Emoji.hs +++ b/src/Discord/Rest/Emoji.hs @@ -9,7 +9,6 @@ module Discord.Rest.Emoji ( EmojiRequest(..) , ModifyGuildEmojiOpts(..) - , EmojiImage , parseEmojiImage ) where @@ -33,19 +32,19 @@ -- | Data constructor for requests. See data EmojiRequest a where -- | List of emoji objects for the given guild. Requires MANAGE_EMOJIS permission. - ListGuildEmojis :: Snowflake -> EmojiRequest [Emoji] + ListGuildEmojis :: GuildId -> EmojiRequest [Emoji] -- | Emoji object for the given guild and emoji ID - GetGuildEmoji :: Snowflake -> Snowflake -> EmojiRequest Emoji + GetGuildEmoji :: GuildId -> EmojiId -> EmojiRequest Emoji -- | Create a new guild emoji (static&animated). Requires MANAGE_EMOJIS permission. - CreateGuildEmoji :: Snowflake -> T.Text -> EmojiImage -> EmojiRequest Emoji + CreateGuildEmoji :: GuildId -> T.Text -> EmojiImageParsed -> EmojiRequest Emoji -- | Requires MANAGE_EMOJIS permission - ModifyGuildEmoji :: Snowflake -> Snowflake -> ModifyGuildEmojiOpts -> EmojiRequest Emoji + ModifyGuildEmoji :: GuildId -> EmojiId -> ModifyGuildEmojiOpts -> EmojiRequest Emoji -- | Requires MANAGE_EMOJIS permission - DeleteGuildEmoji :: Snowflake -> Snowflake -> EmojiRequest () + DeleteGuildEmoji :: GuildId -> EmojiId -> EmojiRequest () data ModifyGuildEmojiOpts = ModifyGuildEmojiOpts { modifyGuildEmojiName :: T.Text - , modifyGuildEmojiRoles :: [Snowflake] + , modifyGuildEmojiRoles :: [RoleId] } instance ToJSON ModifyGuildEmojiOpts where @@ -53,9 +52,9 @@ object [ "name" .= name, "roles" .= roles ] -data EmojiImage = EmojiImage [Char] +data EmojiImageParsed = EmojiImageParsed String -parseEmojiImage :: Q.ByteString -> Either String EmojiImage +parseEmojiImage :: Q.ByteString -> Either String EmojiImageParsed parseEmojiImage bs = if Q.length bs > 256000 then Left "Cannot create emoji - File is larger than 256kb" @@ -63,12 +62,12 @@ (Left e1, Left e2) -> Left ("Could not parse image or gif: " <> e1 <> " and " <> e2) (Right ims, _) -> if all is128 ims - then Right (EmojiImage ("data:text/plain;" - <> "base64," - <> Q.unpack (B64.encode bs))) + then Right (EmojiImageParsed ("data:text/plain;" + <> "base64," + <> Q.unpack (B64.encode bs))) else Left ("The frames are not all 128x128") (_, Right im) -> if is128 im - then Right (EmojiImage ("data:text/plain;" + then Right (EmojiImageParsed ("data:text/plain;" <> "base64," <> Q.unpack (B64.encode bs))) else Left ("Image is not 128x128") @@ -97,7 +96,7 @@ emojiJsonRequest c = case c of (ListGuildEmojis g) -> Get (guilds // g) mempty (GetGuildEmoji g e) -> Get (guilds // g /: "emojis" // e) mempty - (CreateGuildEmoji g name (EmojiImage im)) -> + (CreateGuildEmoji g name (EmojiImageParsed im)) -> Post (guilds // g /: "emojis") (pure (R.ReqBodyJson (object [ "name" .= name , "image" .= im diff --git a/src/Discord/Rest/Guild.hs b/src/Discord/Rest/Guild.hs --- a/src/Discord/Rest/Guild.hs +++ b/src/Discord/Rest/Guild.hs @@ -7,6 +7,7 @@ -- | Provides actions for Channel API interactions module Discord.Rest.Guild ( GuildRequest(..) + , CreateGuildChannelOpts(..) , ModifyGuildOpts(..) , GuildMembersTiming(..) ) where @@ -29,110 +30,148 @@ data GuildRequest a where -- todo CreateGuild :: So many parameters -- | Returns the new 'Guild' object for the given id - GetGuild :: Snowflake -> GuildRequest Guild + GetGuild :: GuildId -> GuildRequest Guild -- | Modify a guild's settings. Returns the updated 'Guild' object on success. Fires a -- Guild Update 'Event'. - ModifyGuild :: Snowflake -> ModifyGuildOpts -> GuildRequest Guild + ModifyGuild :: GuildId -> ModifyGuildOpts -> GuildRequest Guild -- | Delete a guild permanently. User must be owner. Fires a Guild Delete 'Event'. - DeleteGuild :: Snowflake -> GuildRequest Guild + DeleteGuild :: GuildId -> GuildRequest Guild -- | Returns a list of guild 'Channel' objects - GetGuildChannels :: Snowflake -> GuildRequest [Channel] + GetGuildChannels :: GuildId -> GuildRequest [Channel] -- | Create a new 'Channel' object for the guild. Requires 'MANAGE_CHANNELS' -- permission. Returns the new 'Channel' object on success. Fires a Channel Create -- 'Event' - -- todo CreateGuildChannel :: ToJSON o => Snowflake -> o -> GuildRequest Channel + CreateGuildChannel :: GuildId -> T.Text -> [Overwrite] -> CreateGuildChannelOpts -> GuildRequest Channel -- | Modify the positions of a set of channel objects for the guild. Requires -- 'MANAGE_CHANNELS' permission. Returns a list of all of the guild's 'Channel' -- objects on success. Fires multiple Channel Update 'Event's. - -- todo ModifyChanPosition :: ToJSON o => Snowflake -> o -> GuildRequest [Channel] + ModifyGuildChannelPositions :: GuildId -> [(ChannelId,Int)] -> GuildRequest [Channel] -- | Returns a guild 'Member' object for the specified user - GetGuildMember :: Snowflake -> Snowflake -> GuildRequest GuildMember + GetGuildMember :: GuildId -> UserId -> GuildRequest GuildMember -- | Returns a list of guild 'Member' objects that are members of the guild. - ListGuildMembers :: Snowflake -> GuildMembersTiming -> GuildRequest [GuildMember] + ListGuildMembers :: GuildId -> GuildMembersTiming -> GuildRequest [GuildMember] -- | Adds a user to the guild, provided you have a valid oauth2 access token -- for the user with the guilds.join scope. Returns the guild 'Member' as the body. -- Fires a Guild Member Add 'Event'. Requires the bot to have the -- CREATE_INSTANT_INVITE permission. - -- todo AddGuildMember :: ToJSON o => Snowflake -> Snowflake -> o + -- todo AddGuildMember :: ToJSON o => GuildId -> UserId -> o -- -> GuildRequest GuildMember -- | Modify attributes of a guild 'Member'. Fires a Guild Member Update 'Event'. - -- todo ModifyGuildMember :: ToJSON o => Snowflake -> Snowflake -> o + -- todo ModifyGuildMember :: ToJSON o => GuildId -> UserId -> o -- -> GuildRequest () -- | Remove a member from a guild. Requires 'KICK_MEMBER' permission. Fires a -- Guild Member Remove 'Event'. - RemoveGuildMember :: Snowflake -> Snowflake -> GuildRequest () + RemoveGuildMember :: GuildId -> UserId -> GuildRequest () -- | Returns a list of 'User' objects that are banned from this guild. Requires the -- 'BAN_MEMBERS' permission - GetGuildBans :: Snowflake -> GuildRequest [User] + GetGuildBans :: GuildId -> GuildRequest [User] -- | Create a guild ban, and optionally Delete previous messages sent by the banned -- user. Requires the 'BAN_MEMBERS' permission. Fires a Guild Ban Add 'Event'. - CreateGuildBan :: Snowflake -> Snowflake -> Integer -> GuildRequest () + CreateGuildBan :: GuildId -> UserId -> Integer -> GuildRequest () -- | Remove the ban for a user. Requires the 'BAN_MEMBERS' permissions. -- Fires a Guild Ban Remove 'Event'. - RemoveGuildBan :: Snowflake -> Snowflake -> GuildRequest () + RemoveGuildBan :: GuildId -> UserId -> GuildRequest () -- | Returns a list of 'Role' objects for the guild. Requires the 'MANAGE_ROLES' -- permission - GetGuildRoles :: Snowflake -> GuildRequest [Role] - -- | Create a new 'Role' for the guild. Requires the 'MANAGE_ROLES' permission. - -- Returns the new role object on success. Fires a Guild Role Create 'Event'. - CreateGuildRole :: Snowflake -> GuildRequest Role + GetGuildRoles :: GuildId -> GuildRequest [Role] + -- -- | Create a new 'Role' for the guild. Requires the 'MANAGE_ROLES' permission. + -- -- Returns the new role object on success. Fires a Guild Role Create 'Event'. + -- CreateGuildRole :: GuildId -> GuildRequest Role -- | Modify the positions of a set of role objects for the guild. Requires the -- 'MANAGE_ROLES' permission. Returns a list of all of the guild's 'Role' objects -- on success. Fires multiple Guild Role Update 'Event's. - -- todo ModifyGuildRolePositions :: ToJSON o => Snowflake -> [o] -> GuildRequest [Role] + -- todo ModifyGuildRolePositions :: ToJSON o => GuildId -> [o] -> GuildRequest [Role] -- | Modify a guild role. Requires the 'MANAGE_ROLES' permission. Returns the -- updated 'Role' on success. Fires a Guild Role Update 'Event's. - -- todo ModifyGuildRole :: ToJSON o => Snowflake -> Snowflake -> o + -- todo ModifyGuildRole :: ToJSON o => GuildId -> RoleId -> o -- -> GuildRequest Role -- | Delete a guild role. Requires the 'MANAGE_ROLES' permission. Fires a Guild Role -- Delete 'Event'. - DeleteGuildRole :: Snowflake -> Snowflake -> GuildRequest Role + DeleteGuildRole :: GuildId -> RoleId -> GuildRequest Role -- | Returns an object with one 'pruned' key indicating the number of members -- that would be removed in a prune operation. Requires the 'KICK_MEMBERS' -- permission. - GetGuildPruneCount :: Snowflake -> Integer -> GuildRequest Object + GetGuildPruneCount :: GuildId -> Integer -> GuildRequest Object -- | Begin a prune operation. Requires the 'KICK_MEMBERS' permission. Returns an -- object with one 'pruned' key indicating the number of members that were removed -- in the prune operation. Fires multiple Guild Member Remove 'Events'. - BeginGuildPrune :: Snowflake -> Integer -> GuildRequest Object + BeginGuildPrune :: GuildId -> Integer -> GuildRequest Object -- | Returns a list of 'VoiceRegion' objects for the guild. Unlike the similar /voice -- route, this returns VIP servers when the guild is VIP-enabled. - GetGuildVoiceRegions :: Snowflake -> GuildRequest [VoiceRegion] + GetGuildVoiceRegions :: GuildId -> GuildRequest [VoiceRegion] -- | Returns a list of 'Invite' objects for the guild. Requires the 'MANAGE_GUILD' -- permission. - GetGuildInvites :: Snowflake -> GuildRequest [Invite] + GetGuildInvites :: GuildId -> GuildRequest [Invite] -- | Return a list of 'Integration' objects for the guild. Requires the 'MANAGE_GUILD' -- permission. - GetGuildIntegrations :: Snowflake -> GuildRequest [Integration] + GetGuildIntegrations :: GuildId -> GuildRequest [Integration] -- | Attach an 'Integration' object from the current user to the guild. Requires the -- 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'. - -- todo CreateGuildIntegration :: ToJSON o => Snowflake -> o -> GuildRequest () + -- todo CreateGuildIntegration :: ToJSON o => GuildId -> o -> GuildRequest () -- | Modify the behavior and settings of a 'Integration' object for the guild. -- Requires the 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'. - -- todo ModifyGuildIntegration :: ToJSON o => Snowflake -> Snowflake -> o -> GuildRequest () + -- todo ModifyGuildIntegration :: ToJSON o => GuildId -> IntegrationId -> o -> GuildRequest () -- | Delete the attached 'Integration' object for the guild. Requires the -- 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'. - DeleteGuildIntegration :: Snowflake -> Snowflake -> GuildRequest () + DeleteGuildIntegration :: GuildId -> IntegrationId -> GuildRequest () -- | Sync an 'Integration'. Requires the 'MANAGE_GUILD' permission. - SyncGuildIntegration :: Snowflake -> Snowflake -> GuildRequest () + SyncGuildIntegration :: GuildId -> IntegrationId -> GuildRequest () -- | Returns the 'GuildEmbed' object. Requires the 'MANAGE_GUILD' permission. - GetGuildEmbed :: Snowflake -> GuildRequest GuildEmbed + GetGuildEmbed :: GuildId -> GuildRequest GuildEmbed -- | Modify a 'GuildEmbed' object for the guild. All attributes may be passed in with -- JSON and modified. Requires the 'MANAGE_GUILD' permission. Returns the updated -- 'GuildEmbed' object. - ModifyGuildEmbed :: Snowflake -> GuildEmbed -> GuildRequest GuildEmbed + ModifyGuildEmbed :: GuildId -> GuildEmbed -> GuildRequest GuildEmbed +data CreateGuildChannelOpts + = CreateGuildChannelOptsText { + createGuildChannelOptsTopic :: Maybe T.Text + , createGuildChannelOptsUserMessageRateDelay :: Maybe Integer + , createGuildChannelOptsIsNSFW :: Maybe Bool + , createGuildChannelOptsCategoryId :: Maybe ChannelId } + | CreateGuildChannelOptsVoice { + createGuildChannelOptsBitrate :: Maybe Integer + , createGuildChannelOptsMaxUsers :: Maybe Integer + , createGuildChannelOptsCategoryId :: Maybe ChannelId } + | CreateGuildChannelOptsCategory + deriving (Show, Eq) + +createChannelOptsToJSON :: T.Text -> [Overwrite] -> CreateGuildChannelOpts -> Value +createChannelOptsToJSON name perms opts = object [(key, val) | (key, Just val) <- optsJSON] + where + optsJSON = case opts of + CreateGuildChannelOptsText{..} -> + [("name", Just (String name)) + ,("type", Just (Number 0)) + ,("permission_overwrites", toJSON <$> Just perms) + ,("topic", toJSON <$> createGuildChannelOptsTopic) + ,("rate_limit_per_user", toJSON <$> createGuildChannelOptsUserMessageRateDelay) + ,("nsfw", toJSON <$> createGuildChannelOptsIsNSFW) + ,("parent_id", toJSON <$> createGuildChannelOptsCategoryId)] + CreateGuildChannelOptsVoice{..} -> + [("name", Just (String name)) + ,("type", Just (Number 2)) + ,("permission_overwrites", toJSON <$> Just perms) + ,("bitrate", toJSON <$> createGuildChannelOptsBitrate) + ,("user_limit", toJSON <$> createGuildChannelOptsMaxUsers) + ,("parent_id", toJSON <$> createGuildChannelOptsCategoryId)] + CreateGuildChannelOptsCategory -> + [("name", Just (String name)) + ,("type", Just (Number 4)) + ,("permission_overwrites", toJSON <$> Just perms)] + + -- | https://discordapp.com/developers/docs/resources/guild#modify-guild data ModifyGuildOpts = ModifyGuildOpts - { modifyGuildOptsName :: Maybe T.Text - , modifyGuildOptsAFKChannelId :: Maybe Snowflake - , modifyGuildOptsIcon :: Maybe T.Text - , modifyGuildOptsOwnerId :: Maybe Snowflake + { modifyGuildOptsName :: Maybe T.Text + , modifyGuildOptsAFKChannelId :: Maybe ChannelId + , modifyGuildOptsIcon :: Maybe T.Text + , modifyGuildOptsOwnerId :: Maybe UserId -- Region -- VerificationLevel -- DefaultMessageNotification -- ExplicitContentFilter - } + } deriving (Show, Eq, Ord) instance ToJSON ModifyGuildOpts where toJSON ModifyGuildOpts{..} = object [(name, val) | (name, Just val) <- @@ -143,7 +182,7 @@ data GuildMembersTiming = GuildMembersTiming { guildMembersTimingLimit :: Maybe Int - , guildMembersTimingAfter :: Maybe Snowflake + , guildMembersTimingAfter :: Maybe UserId } guildMembersTimingToQuery :: GuildMembersTiming -> R.Option 'R.Https @@ -162,8 +201,8 @@ (ModifyGuild g _) -> "guild " <> show g (DeleteGuild g) -> "guild " <> show g (GetGuildChannels g) -> "guild_chan " <> show g - -- (CreateGuildChannel g _) -> "guild_chan " <> show g - -- (ModifyChanPosition g _) -> "guild_chan " <> show g + (CreateGuildChannel g _ _ _) -> "guild_chan " <> show g + (ModifyGuildChannelPositions g _) -> "guild_chan " <> show g (GetGuildMember g _) -> "guild_memb " <> show g (ListGuildMembers g _) -> "guild_membs " <> show g -- (AddGuildMember g _ _) -> "guild_memb " <> show g @@ -172,13 +211,13 @@ (GetGuildBans g) -> "guild_bans " <> show g (CreateGuildBan g _ _) -> "guild_ban " <> show g (RemoveGuildBan g _) -> "guild_ban " <> show g - (GetGuildRoles g) -> "guild_roles " <> show g - (CreateGuildRole g) -> "guild_roles " <> show g + (GetGuildRoles g) -> "guild_roles " <> show g + -- (CreateGuildRole g) -> "guild_roles " <> show g -- (ModifyGuildRolePositions g _) -> "guild_roles " <> show g -- (ModifyGuildRole g _ _) -> "guild_role " <> show g (DeleteGuildRole g _ ) -> "guild_role " <> show g (GetGuildPruneCount g _) -> "guild_prune " <> show g - (BeginGuildPrune g _) -> "guild_prune " <> show g + (BeginGuildPrune g _) -> "guild_prune " <> show g (GetGuildVoiceRegions g) -> "guild_voice " <> show g (GetGuildInvites g) -> "guild_invit " <> show g (GetGuildIntegrations g) -> "guild_integ " <> show g @@ -212,11 +251,14 @@ (GetGuildChannels guild) -> Get (guilds // guild /: "channels") mempty - -- (CreateGuildChannel guild patch) -> - -- Post (guilds // guild /: "channels") (pure (R.ReqBodyJson patch)) mempty + (CreateGuildChannel guild name perms patch) -> + Post (guilds // guild /: "channels") + (pure (R.ReqBodyJson (createChannelOptsToJSON name perms patch))) mempty - -- (ModifyChanPosition guild patch) -> - -- Post (guilds // guild /: "channels") (pure (R.ReqBodyJson patch)) mempty + (ModifyGuildChannelPositions guild newlocs) -> + let patch = map (\(a, b) -> object [("id", toJSON a) + ,("position", toJSON b)]) newlocs + in Patch (guilds // guild /: "channels") (R.ReqBodyJson patch) mempty (GetGuildMember guild member) -> Get (guilds // guild /: "members" // member) mempty @@ -247,8 +289,8 @@ (GetGuildRoles guild) -> Get (guilds // guild /: "roles") mempty - (CreateGuildRole guild) -> - Post (guilds // guild /: "roles") (pure R.NoReqBody) mempty + -- (CreateGuildRole guild) -> + -- Post (guilds // guild /: "roles") (pure R.NoReqBody) mempty -- (ModifyGuildRolePositions guild patch) -> -- Post (guilds // guild /: "roles") (pure (R.ReqBodyJson patch)) mempty diff --git a/src/Discord/Rest/HTTP.hs b/src/Discord/Rest/HTTP.hs --- a/src/Discord/Rest/HTTP.hs +++ b/src/Discord/Rest/HTTP.hs @@ -30,7 +30,7 @@ import Discord.Types import Discord.Rest.Prelude -data RestCallException = RestCallErrorCode Int Q.ByteString +data RestCallException = RestCallErrorCode Int Q.ByteString Q.ByteString | RestCallNoParse String QL.ByteString | RestCallHttpException R.HttpException deriving (Show) @@ -59,7 +59,8 @@ -- decode "[]" == () for expected empty calls ResponseByteString "" -> putMVar thread (Right "[]") ResponseByteString bs -> putMVar thread (Right bs) - ResponseErrorCode e s -> putMVar thread (Left (RestCallErrorCode e s)) + ResponseErrorCode e s b -> + putMVar thread (Left (RestCallErrorCode e s b)) ResponseTryAgain -> writeChan urls (route, request, thread) case retry of GlobalWait i -> do @@ -81,7 +82,7 @@ data RequestResponse = ResponseTryAgain | ResponseByteString QL.ByteString - | ResponseErrorCode Int Q.ByteString + | ResponseErrorCode Int Q.ByteString Q.ByteString deriving (Show) data Timeout = GlobalWait POSIXTime @@ -92,7 +93,8 @@ tryRequest action log = do resp <- action next10 <- liftIO (round . (+10) <$> getPOSIXTime) - let code = R.responseStatusCode resp + let body = R.responseBody resp + code = R.responseStatusCode resp status = R.responseStatusMessage resp remain = fromMaybe 1 $ readMaybeBS =<< R.responseHeader resp "X-Ratelimit-Remaining" global = fromMaybe False $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Global" @@ -103,11 +105,11 @@ pure (ResponseTryAgain, if global then GlobalWait reset else PathWait reset) | code `elem` [500,502] -> pure (ResponseTryAgain, NoLimit) - | inRange (200,299) code -> pure ( ResponseByteString (R.responseBody resp) + | inRange (200,299) code -> pure ( ResponseByteString body , if remain > 0 then NoLimit else PathWait reset ) - | inRange (400,499) code -> pure (ResponseErrorCode code status + | inRange (400,499) code -> pure (ResponseErrorCode code status (QL.toStrict body) , if remain > 0 then NoLimit else PathWait reset ) - | otherwise -> pure (ResponseErrorCode code status, NoLimit) + | otherwise -> pure (ResponseErrorCode code status (QL.toStrict body), NoLimit) readMaybeBS :: Read a => Q.ByteString -> Maybe a readMaybeBS = readMaybe . Q.unpack diff --git a/src/Discord/Rest/Prelude.hs b/src/Discord/Rest/Prelude.hs --- a/src/Discord/Rest/Prelude.hs +++ b/src/Discord/Rest/Prelude.hs @@ -24,7 +24,7 @@ where -- | https://discordapp.com/developers/docs/reference#user-agent -- Second place where the library version is noted - agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 0.6.0)" + agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 0.7.0)" -- Append to an URL infixl 5 // diff --git a/src/Discord/Rest/User.hs b/src/Discord/Rest/User.hs --- a/src/Discord/Rest/User.hs +++ b/src/Discord/Rest/User.hs @@ -37,18 +37,18 @@ -- the email scope, which returns the object with an email. GetCurrentUser :: UserRequest User -- | Returns a 'User' for a given user ID - GetUser :: Snowflake -> UserRequest User + GetUser :: UserId -> UserRequest User -- | Modify user's username & avatar pic ModifyCurrentUser :: T.Text -> CurrentUserAvatar -> UserRequest User -- | Returns a list of user 'Guild' objects the current user is a member of. -- Requires the guilds OAuth2 scope. GetCurrentUserGuilds :: UserRequest [PartialGuild] -- | Leave a guild. - LeaveGuild :: Snowflake -> UserRequest () + LeaveGuild :: GuildId -> UserRequest () -- | Returns a list of DM 'Channel' objects GetUserDMs :: UserRequest [Channel] -- | Create a new DM channel with a user. Returns a DM 'Channel' object. - CreateDM :: Snowflake -> UserRequest Channel + CreateDM :: UserId -> UserRequest Channel -- | Formatted avatar data https://discordapp.com/developers/docs/resources/user#avatar-data data CurrentUserAvatar = CurrentUserAvatar String diff --git a/src/Discord/Types/Channel.hs b/src/Discord/Types/Channel.hs --- a/src/Discord/Types/Channel.hs +++ b/src/Discord/Types/Channel.hs @@ -46,7 +46,7 @@ -- | Guild channels represent an isolated set of users and messages in a Guild (Server) data Channel -- | A text channel in a guild. - = Text + = ChannelText { channelId :: Snowflake -- ^ The id of the channel (Will be equal to -- the guild if it's the "general" channel). , channelGuild :: Snowflake -- ^ The id of the guild. @@ -58,7 +58,7 @@ -- channel } -- | A voice channel in a guild. - | Voice + | ChannelVoice { channelId :: Snowflake , channelGuild :: Snowflake , channelName :: String @@ -69,17 +69,17 @@ } -- | DM Channels represent a one-to-one conversation between two users, outside the scope -- of guilds - | DirectMessage + | ChannelDirectMessage { channelId :: Snowflake , channelRecipients :: [User] -- ^ The 'User' object(s) of the DM recipient(s). , channelLastMessage :: Maybe Snowflake } - | GroupDM + | ChannelGroupDM { channelId :: Snowflake , channelRecipients :: [User] , channelLastMessage :: Maybe Snowflake } - | GuildCategory + | ChannelGuildCategory { channelId :: Snowflake , channelGuild :: Snowflake } deriving (Show, Eq) @@ -89,40 +89,40 @@ type' <- (o .: "type") :: Parser Int case type' of 0 -> - Text <$> o .: "id" - <*> o .:? "guild_id" .!= 0 - <*> o .: "name" - <*> o .: "position" - <*> o .: "permission_overwrites" - <*> o .:? "topic" .!= "" - <*> o .:? "last_message_id" + ChannelText <$> o .: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .: "name" + <*> o .: "position" + <*> o .: "permission_overwrites" + <*> o .:? "topic" .!= "" + <*> o .:? "last_message_id" 1 -> - DirectMessage <$> o .: "id" - <*> o .: "recipients" - <*> o .:? "last_message_id" + ChannelDirectMessage <$> o .: "id" + <*> o .: "recipients" + <*> o .:? "last_message_id" 2 -> - Voice <$> o .: "id" - <*> o .:? "guild_id" .!= 0 - <*> o .: "name" - <*> o .: "position" - <*> o .: "permission_overwrites" - <*> o .: "bitrate" - <*> o .: "user_limit" + ChannelVoice <$> o .: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .: "name" + <*> o .: "position" + <*> o .: "permission_overwrites" + <*> o .: "bitrate" + <*> o .: "user_limit" 3 -> - GroupDM <$> o .: "id" - <*> o .: "recipients" - <*> o .:? "last_message_id" + ChannelGroupDM <$> o .: "id" + <*> o .: "recipients" + <*> o .:? "last_message_id" 4 -> - GuildCategory <$> o .: "id" - <*> o .:? "guild_id" .!= 0 + ChannelGuildCategory <$> o .: "id" + <*> o .:? "guild_id" .!= 0 _ -> fail ("Unknown channel type:" <> show type') -- | If the channel is part of a guild (has a guild id field) -isGuildChannel :: Channel -> Bool -isGuildChannel c = case c of - GuildCategory{..} -> True - Text{..} -> True - Voice{..} -> True +channelIsInGuild :: Channel -> Bool +channelIsInGuild c = case c of + ChannelGuildCategory{..} -> True + ChannelText{..} -> True + ChannelVoice{..} -> True _ -> False -- | Permission overwrites for a channel. diff --git a/src/Discord/Types/Events.hs b/src/Discord/Types/Events.hs --- a/src/Discord/Types/Events.hs +++ b/src/Discord/Types/Events.hs @@ -36,7 +36,7 @@ | GuildIntegrationsUpdate Snowflake | GuildMemberAdd Snowflake GuildMember | GuildMemberRemove Snowflake User - | GuildMemberUpdate Snowflake [Snowflake] User String + | GuildMemberUpdate Snowflake [Snowflake] User (Maybe String) | GuildMemberChunk Snowflake [GuildMember] | GuildRoleCreate Snowflake Role | GuildRoleUpdate Snowflake Role @@ -135,7 +135,7 @@ "GUILD_MEMBER_UPDATE" -> GuildMemberUpdate <$> o .: "guild_id" <*> o .: "roles" <*> o .: "user" - <*> o .: "nick" + <*> o .:? "nick" "GUILD_MEMBER_CHUNK" -> GuildMemberChunk <$> o .: "guild_id" <*> o .: "members" "GUILD_ROLE_CREATE" -> GuildRoleCreate <$> o .: "guild_id" <*> o .: "role" "GUILD_ROLE_UPDATE" -> GuildRoleUpdate <$> o .: "guild_id" <*> o .: "role" diff --git a/src/Discord/Types/Prelude.hs b/src/Discord/Types/Prelude.hs --- a/src/Discord/Types/Prelude.hs +++ b/src/Discord/Types/Prelude.hs @@ -45,9 +45,18 @@ parseJSON (String snowflake) = Snowflake <$> (return . read $ T.unpack snowflake) parseJSON _ = mzero +type ChannelId = Snowflake +type GuildId = Snowflake +type MessageId = Snowflake +type EmojiId = Snowflake +type UserId = Snowflake +type OverwriteId = Snowflake +type RoleId = Snowflake +type IntegrationId = Snowflake + -- | Gets a creation date from a snowflake. -creationDate :: Snowflake -> UTCTime -creationDate x = posixSecondsToUTCTime . realToFrac +snowflakeCreationDate :: Snowflake -> UTCTime +snowflakeCreationDate x = posixSecondsToUTCTime . realToFrac $ 1420070400 + quot (shiftR x 22) 1000 -- | Default timestamp