diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,6 +5,17 @@ [calamity haskell library](https://github.com/nitros12/calamity) for a more advanced interface. + +#### Documentation + +#### [[installing](./docs/installing.md)] [[debugging](./docs/debugging.md)] [[creating-bot](./docs/creating-bot.md)] + +#### [[design](./docs/design.md)] [[contributing](./docs/contributing.md)] [[todo](./docs/todo.md)] + +#### [[app-commands](./docs/applicationcommands.md)] [[components](./docs/components.md)] [[cache](./docs/cache.md)] [[embeds](./docs/embeds.md)] [[emoji](./docs/emoji.md)] [[intents](./docs/intents.md)] [[voice](./docs/voice.md)] + +#### Example + This is an example bot that replies "pong" to messages that start with "ping". Checkout the [other examples](./examples/) for things like state management. ```haskell @@ -33,7 +44,7 @@ eventHandler :: Event -> DiscordHandler () eventHandler event = case event of - MessageCreate m -> when (isPing m && (not (fromBot 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!") @@ -45,32 +56,6 @@ isPing :: Message -> Bool isPing = ("ping" `isPrefixOf`) . toLower . messageContent ``` - -### Documentation - -### [installing](./docs/installing.md) - -### [debugging](./docs/debugging.md) - -### [design](./docs/design.md) - -### [todo](./docs/todo.md) - -### [contributing](./docs/contributing.md) - -### [intents](./docs/intents.md) - -### [applicationcommands](./docs/applicationcommands.md) - -### [components](./docs/components.md) - -### [cache](./docs/cache.md) - -### [embeds](./docs/embeds.md) - -### [emoji](./docs/emoji.md) - -### [voice](./docs/voice.md) #### Discord Server diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -6,6 +6,14 @@ ## master +## 1.12.5 + +[Annwan](https://github.com/aquarial/discord-haskell/pull/109) Add `ScheduledEvent` rest API + +[L0neGamer](https://github.com/aquarial/discord-haskell/pull/110) Add stickers API + +[L0neGamer](https://github.com/aquarial/discord-haskell/pull/111) Add ModifyGuildMember 'timeout' option + ## 1.12.4 Library won't crash if something fails to parse. Errors are printed to the log 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.4 +version: 1.12.5 description: Functions and data types to write discord bots. Official discord docs . . @@ -85,6 +85,8 @@ , Discord.Internal.Types.Interactions , Discord.Internal.Types.Components , Discord.Internal.Types.Color + , Discord.Internal.Types.Emoji + , Discord.Internal.Types.ScheduledEvents build-depends: base >= 4 && <5 , aeson @@ -103,7 +105,6 @@ , text , time , unordered-containers - , vector , websockets , wuss , mtl diff --git a/src/Discord/Internal/Rest/Emoji.hs b/src/Discord/Internal/Rest/Emoji.hs --- a/src/Discord/Internal/Rest/Emoji.hs +++ b/src/Discord/Internal/Rest/Emoji.hs @@ -1,34 +1,35 @@ -{-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | Provides actions for Channel API interactions module Discord.Internal.Rest.Emoji - ( EmojiRequest(..) - , ModifyGuildEmojiOpts(..) - , parseEmojiImage - ) where + ( EmojiRequest (..), + ModifyGuildEmojiOpts (..), + parseEmojiImage, + StickerRequest (..), + CreateGuildStickerOpts (..), + EditGuildStickerOpts (..) + ) +where -import Data.Aeson import Codec.Picture -import Network.HTTP.Req ((/:)) -import qualified Network.HTTP.Req as R -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE +import Data.Aeson import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as B64 - +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import Discord.Internal.Rest.Prelude import Discord.Internal.Types +import Network.HTTP.Req ((/:)) +import qualified Network.HTTP.Req as R instance Request (EmojiRequest a) where majorRoute = emojiMajorRoute jsonRequest = emojiJsonRequest - -- | Data constructor for requests. See data EmojiRequest a where -- | List of emoji objects for the given guild. Requires MANAGE_EMOJIS permission. @@ -43,47 +44,63 @@ DeleteGuildEmoji :: GuildId -> EmojiId -> EmojiRequest () data ModifyGuildEmojiOpts = ModifyGuildEmojiOpts - { modifyGuildEmojiName :: T.Text - , modifyGuildEmojiRoles :: [RoleId] - } deriving (Show, Read, Eq, Ord) + { modifyGuildEmojiName :: T.Text, + modifyGuildEmojiRoles :: [RoleId] + } + deriving (Show, Read, Eq, Ord) instance ToJSON ModifyGuildEmojiOpts where toJSON (ModifyGuildEmojiOpts name roles) = - object [ "name" .= name, "roles" .= roles ] - + object ["name" .= name, "roles" .= roles] -data EmojiImageParsed = EmojiImageParsed T.Text +newtype EmojiImageParsed = EmojiImageParsed T.Text deriving (Show, Read, Eq, Ord) parseEmojiImage :: B.ByteString -> Either T.Text EmojiImageParsed parseEmojiImage bs = if B.length bs > 256000 - then Left "Cannot create emoji - File is larger than 256kb" - else case (decodeGifImages bs, decodeImage bs) of - (Left e1, Left e2) -> Left ("Could not parse image or gif: " <> T.pack e1 - <> " and " <> T.pack e2) - (Right ims, _) -> if all is128 ims - then Right (EmojiImageParsed ("data:text/plain;" - <> "base64," - <> TE.decodeUtf8 (B64.encode bs))) - else Left "The frames are not all 128x128" - (_, Right im) -> if is128 im - then Right (EmojiImageParsed ("data:text/plain;" - <> "base64," - <> TE.decodeUtf8 (B64.encode bs))) - else Left "Image is not 128x128" + then Left "Cannot create emoji - File is larger than 256kb" + else case (decodeGifImages bs, decodeImage bs) of + (Left e1, Left e2) -> + Left + ( "Could not parse image or gif: " <> T.pack e1 + <> " and " + <> T.pack e2 + ) + (Right ims, _) -> + if all is128 ims + then + Right + ( EmojiImageParsed + ( "data:text/plain;" + <> "base64," + <> TE.decodeUtf8 (B64.encode bs) + ) + ) + else Left "The frames are not all 128x128" + (_, Right im) -> + if is128 im + then + Right + ( EmojiImageParsed + ( "data:text/plain;" + <> "base64," + <> TE.decodeUtf8 (B64.encode bs) + ) + ) + else Left "Image is not 128x128" where - is128 im = let i = convertRGB8 im - in imageWidth i == 128 && imageHeight i == 128 - + is128 im = + let i = convertRGB8 im + in imageWidth i == 128 && imageHeight i == 128 emojiMajorRoute :: EmojiRequest a -> String emojiMajorRoute c = case c of - (ListGuildEmojis g) -> "emoji " <> show g - (GetGuildEmoji g _) -> "emoji " <> show g + (ListGuildEmojis g) -> "emoji " <> show g + (GetGuildEmoji g _) -> "emoji " <> show g (CreateGuildEmoji g _ _) -> "emoji " <> show g (ModifyGuildEmoji g _ _) -> "emoji " <> show g - (DeleteGuildEmoji g _) -> "emoji " <> show g + (DeleteGuildEmoji g _) -> "emoji " <> show g guilds :: R.Url 'R.Https guilds = baseUrl /: "guilds" @@ -93,13 +110,114 @@ (ListGuildEmojis g) -> Get (guilds // g /: "emojis") mempty (GetGuildEmoji g e) -> Get (guilds // g /: "emojis" // e) mempty (CreateGuildEmoji g name (EmojiImageParsed im)) -> - Post (guilds // g /: "emojis") - (pure (R.ReqBodyJson (object [ "name" .= name - , "image" .= im - -- todo , "roles" .= ... - ]))) - mempty - (ModifyGuildEmoji g e o) -> Patch (guilds // g /: "emojis" // e) - (pure (R.ReqBodyJson o)) - mempty + Post + (guilds // g /: "emojis") + ( pure + ( R.ReqBodyJson + ( object + [ "name" .= name, + "image" .= im + -- todo , "roles" .= ... + ] + ) + ) + ) + mempty + (ModifyGuildEmoji g e o) -> + Patch + (guilds // g /: "emojis" // e) + (pure (R.ReqBodyJson o)) + mempty (DeleteGuildEmoji g e) -> Delete (guilds // g /: "emojis" // e) mempty + +data StickerData = StickerDataPNG {stickerData :: B.ByteString} | StickerDataAPNG {stickerData :: B.ByteString} | StickerDataLOTTIE {stickerData :: B.ByteString} + deriving (Show, Read, Eq, Ord) + +instance ToJSON StickerData where + toJSON sd = String $ "data:image/" <> sdt <> ";base64," <> TE.decodeUtf8 (B64.encode (stickerData sd)) + where + sdt = case sd of + StickerDataPNG _ -> "png" + StickerDataAPNG _ -> "apng" + StickerDataLOTTIE _ -> "lottie" + +data CreateGuildStickerOpts = CreateGuildStickerOpts + { guildStickerName :: T.Text, + guildStickerDescription :: T.Text, + guildStickerTags :: [T.Text], + guildStickerFile :: StickerData + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON CreateGuildStickerOpts where + toJSON CreateGuildStickerOpts {..} = + object + [ ("name", toJSON guildStickerName), + ("description", toJSON guildStickerDescription), + ("tags", toJSON . T.intercalate "," $ guildStickerTags), + ("file", toJSON guildStickerFile) + ] + +data EditGuildStickerOpts = EditGuildStickerOpts + { editGuildStickerName :: Maybe T.Text, + editGuildStickerDescription :: Maybe T.Text, + editGuildStickerTags :: Maybe [T.Text] + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON EditGuildStickerOpts where + toJSON EditGuildStickerOpts {..} = + object + [ (name, value) + | (name, Just value) <- + [ ("name", toJSON <$> editGuildStickerName), + ("description", toJSON <$> editGuildStickerDescription), + ("tags", toJSON . T.intercalate "," <$> editGuildStickerTags) + ] + ] + +instance Request (StickerRequest a) where + majorRoute = stickerMajorRoute + jsonRequest = stickerJsonRequest + +-- | Data constructor for requests. See +-- +-- Be warned that these are untested due to not having a spare server with +-- boosts. Functionality is at your own risk. +data StickerRequest a where + -- | Returns a sticker object for the given sticker ID. + GetSticker :: StickerId -> StickerRequest Sticker + -- | Returns the list of sticker packs available to Nitro subscribers. + ListNitroStickerPacks :: StickerRequest [StickerPack] + -- | Returns an array of sticker objects for the given guild. + ListGuildStickers :: GuildId -> StickerRequest [Sticker] + -- | Returns a sticker object for the given guild and sticker ID. + GetGuildSticker :: GuildId -> StickerId -> StickerRequest Sticker + -- | Create a new sticker for the guild. + CreateGuildSticker :: GuildId -> CreateGuildStickerOpts -> StickerRequest Sticker + -- | Modify a sticker for a guild. + ModifyGuildSticker :: GuildId -> StickerId -> EditGuildStickerOpts -> StickerRequest Sticker + -- | Delete a guild sticker + DeleteGuildSticker :: GuildId -> StickerId -> StickerRequest () + +stickerMajorRoute :: StickerRequest a -> String +stickerMajorRoute = \case + GetSticker gid -> "sticker " <> show gid + ListNitroStickerPacks -> "sticker" + ListGuildStickers gid -> "sticker " <> show gid + GetGuildSticker gid _ -> "sticker " <> show gid + CreateGuildSticker gid _ -> "sticker " <> show gid + ModifyGuildSticker gid _ _ -> "sticker " <> show gid + DeleteGuildSticker gid _ -> "sticker " <> show gid + +stickerJsonRequest :: StickerRequest a -> JsonRequest +stickerJsonRequest = \case + GetSticker gid -> Get (baseUrl /: "stickers" // gid) mempty + ListNitroStickerPacks -> Get (baseUrl /: "sticker-packs") mempty + ListGuildStickers gid -> Get (stickersGuild gid) mempty + GetGuildSticker gid sid -> Get (stickersGuild gid // sid) mempty + CreateGuildSticker gid cgso -> Post (stickersGuild gid) (pure $ R.ReqBodyJson $ toJSON cgso) mempty + ModifyGuildSticker gid sid egso -> Patch (stickersGuild gid // sid) (pure $ R.ReqBodyJson egso) mempty + DeleteGuildSticker gid sid -> Delete (stickersGuild gid // sid) mempty + where + stickersGuild gid = baseUrl /: "guilds" // gid /: "stickers" diff --git a/src/Discord/Internal/Rest/Guild.hs b/src/Discord/Internal/Rest/Guild.hs --- a/src/Discord/Internal/Rest/Guild.hs +++ b/src/Discord/Internal/Rest/Guild.hs @@ -26,6 +26,7 @@ import Discord.Internal.Rest.Prelude import Discord.Internal.Types +import Data.Default (Default(..)) instance Request (GuildRequest a) where majorRoute = guildMajorRoute @@ -64,7 +65,7 @@ AddGuildMember :: GuildId -> UserId -> AddGuildMemberOpts -> GuildRequest () -- | Modify attributes of a guild 'Member'. Fires a Guild Member Update 'Event'. - ModifyGuildMember :: GuildId -> UserId -> ModifyGuildMemberOpts -> GuildRequest () + ModifyGuildMember :: GuildId -> UserId -> ModifyGuildMemberOpts -> GuildRequest GuildMember -- | Modify the nickname of the current user ModifyCurrentUserNick :: GuildId -> T.Text -> GuildRequest () -- | Add a member to a guild role. Requires 'MANAGE_ROLES' permission. @@ -209,15 +210,21 @@ , modifyGuildMemberOptsIsMuted :: Maybe Bool , modifyGuildMemberOptsIsDeafened :: Maybe Bool , modifyGuildMemberOptsMoveToChannel :: Maybe ChannelId + , modifyGuildMemberOptsTimeoutUntil :: Maybe (Maybe UTCTime) -- ^ If `Just Nothing`, the timeout will be removed. } deriving (Show, Read, Eq, Ord) +instance Default ModifyGuildMemberOpts where + def = ModifyGuildMemberOpts Nothing Nothing Nothing Nothing Nothing Nothing + instance ToJSON ModifyGuildMemberOpts where toJSON ModifyGuildMemberOpts{..} = object [(name, val) | (name, Just val) <- [("nick", toJSON <$> modifyGuildMemberOptsNickname ), ("roles", toJSON <$> modifyGuildMemberOptsRoles ), ("mute", toJSON <$> modifyGuildMemberOptsIsMuted ), ("deaf", toJSON <$> modifyGuildMemberOptsIsDeafened ), - ("channel_id", toJSON <$> modifyGuildMemberOptsMoveToChannel)]] + ("channel_id", toJSON <$> modifyGuildMemberOptsMoveToChannel), + ("communication_disabled_until", toJSON <$> modifyGuildMemberOptsTimeoutUntil)]] + data CreateGuildChannelOpts = CreateGuildChannelOptsText { createGuildChannelOptsTopic :: Maybe T.Text 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 @@ -34,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.4)" + agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 1.12.5)" -- 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 @@ -9,6 +9,7 @@ module Discord.Internal.Types.User, module Discord.Internal.Types.Embed, module Discord.Internal.Types.Components, + module Discord.Internal.Types.Emoji, module Data.Aeson, module Data.Time.Clock, userFacingEvent, @@ -21,6 +22,7 @@ import Discord.Internal.Types.Color import Discord.Internal.Types.Components import Discord.Internal.Types.Embed +import Discord.Internal.Types.Emoji import Discord.Internal.Types.Events import Discord.Internal.Types.Gateway import Discord.Internal.Types.Guild 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 @@ -13,13 +13,14 @@ import Data.Text (Text) import Data.Time.Clock import qualified Data.Text as T +import Data.Bits +import Data.Data (Data) import Discord.Internal.Types.Prelude import Discord.Internal.Types.User (User(..), GuildMember) import Discord.Internal.Types.Embed -import Data.Data (Data) -import Data.Bits -import Discord.Internal.Types.Components (ComponentActionRow, Emoji) +import Discord.Internal.Types.Components (ComponentActionRow) +import Discord.Internal.Types.Emoji -- | Guild channels represent an isolated set of users and messages in a Guild (Server) data Channel @@ -592,44 +593,6 @@ , ("me", toJSON <$> pure messageReactionMeIncluded) , ("emoji", toJSON <$> pure messageReactionEmoji) ]] - --- TODO: expand stickers and have full objects -data StickerItem = StickerItem - { stickerItemId :: StickerId - , stickerItemName :: T.Text - , stickerItemFormatType :: StickerFormatType - } deriving (Show, Read, Eq, Ord) - -instance FromJSON StickerItem where - parseJSON = withObject "StickerItem" $ \o -> - StickerItem <$> o .: "id" - <*> o .: "name" - <*> o .: "format_type" - -instance ToJSON StickerItem where - toJSON StickerItem{..} = object [(name, value) | (name, Just value) <- - [ ("id", toJSON <$> pure stickerItemId) - , ("name", toJSON <$> pure stickerItemName) - , ("format_type", toJSON <$> pure stickerItemFormatType) - ]] - -data StickerFormatType = - StickerFormatTypePNG - | StickerFormatTypeAPNG - | StickerFormatTypeLOTTIE - deriving (Show, Read, Eq, Ord, Data) - -instance InternalDiscordEnum StickerFormatType where - discordTypeStartValue = StickerFormatTypePNG - fromDiscordType StickerFormatTypePNG = 1 - fromDiscordType StickerFormatTypeAPNG = 2 - fromDiscordType StickerFormatTypeLOTTIE = 3 - -instance ToJSON StickerFormatType where - toJSON = toJSON . fromDiscordType - -instance FromJSON StickerFormatType where - parseJSON = discordTypeParseJSON "StickerFormatType" -- | Represents an attached to a message file. data Attachment = Attachment 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 @@ -17,8 +17,6 @@ mkSelectOption, ComponentTextInput (..), mkComponentTextInput, - Emoji (..), - mkEmoji, ) where @@ -27,8 +25,8 @@ import Data.Foldable (Foldable (toList)) import Data.Scientific (Scientific) import qualified Data.Text as T -import Discord.Internal.Types.Prelude (EmojiId, RoleId, toMaybeJSON) -import Discord.Internal.Types.User (User) +import Discord.Internal.Types.Emoji (Emoji) +import Discord.Internal.Types.Prelude (toMaybeJSON) data ComponentActionRow = ComponentActionRowButton [ComponentButton] | ComponentActionRowSelectMenu ComponentSelectMenu deriving (Show, Read, Eq, Ord) @@ -333,47 +331,3 @@ mkComponentTextInput :: T.Text -> T.Text -> ComponentTextInput mkComponentTextInput cid label = ComponentTextInput cid False label Nothing Nothing True "" "" - --- | Represents an emoticon (emoji) -data Emoji = Emoji - { -- | The emoji id - emojiId :: Maybe EmojiId, - -- | The emoji name - emojiName :: T.Text, - -- | Roles the emoji is active for - emojiRoles :: Maybe [RoleId], - -- | User that created this emoji - emojiUser :: Maybe User, - -- | Whether this emoji is managed - emojiManaged :: Maybe Bool, - -- | Whether this emoji is animated - emojiAnimated :: Maybe Bool - } - deriving (Show, Read, Eq, Ord) - --- | Make an emoji with only a name -mkEmoji :: T.Text -> Emoji -mkEmoji t = Emoji Nothing t Nothing Nothing Nothing Nothing - -instance FromJSON Emoji where - parseJSON = withObject "Emoji" $ \o -> - Emoji <$> o .:? "id" - <*> o .: "name" - <*> o .:? "roles" - <*> o .:? "user" - <*> o .:? "managed" - <*> o .:? "animated" - -instance ToJSON Emoji where - toJSON Emoji {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("id", toJSON <$> emojiId), - ("name", toMaybeJSON emojiName), - ("roles", toJSON <$> emojiRoles), - ("user", toJSON <$> emojiUser), - ("managed", toJSON <$> emojiManaged), - ("animated", toJSON <$> emojiAnimated) - ] - ] diff --git a/src/Discord/Internal/Types/Emoji.hs b/src/Discord/Internal/Types/Emoji.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Types/Emoji.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Discord.Internal.Types.Emoji where + +import Data.Aeson +import Data.Data +import Data.Functor ((<&>)) +import Data.Text as T +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.User + +-- | Represents an emoticon (emoji) +data Emoji = Emoji + { -- | The emoji id + emojiId :: Maybe EmojiId, + -- | The emoji name + emojiName :: T.Text, + -- | Roles the emoji is active for + emojiRoles :: Maybe [RoleId], + -- | User that created this emoji + emojiUser :: Maybe User, + -- | Whether this emoji is managed + emojiManaged :: Maybe Bool, + -- | Whether this emoji is animated + emojiAnimated :: Maybe Bool + } + deriving (Show, Read, Eq, Ord) + +-- | Make an emoji with only a name +mkEmoji :: T.Text -> Emoji +mkEmoji t = Emoji Nothing t Nothing Nothing Nothing Nothing + +instance FromJSON Emoji where + parseJSON = withObject "Emoji" $ \o -> + Emoji <$> o .:? "id" + <*> o .: "name" + <*> o .:? "roles" + <*> o .:? "user" + <*> o .:? "managed" + <*> o .:? "animated" + +instance ToJSON Emoji where + toJSON Emoji {..} = + object + [ (name, value) + | (name, Just value) <- + [ ("id", toJSON <$> emojiId), + ("name", toMaybeJSON emojiName), + ("roles", toJSON <$> emojiRoles), + ("user", toJSON <$> emojiUser), + ("managed", toJSON <$> emojiManaged), + ("animated", toJSON <$> emojiAnimated) + ] + ] + +-- | Represents a pack of standard stickers. +data StickerPack = StickerPack + { -- | The id of the sticker pack + stickerPackId :: Snowflake, + -- | The stickers in the pack + stickerPackStickers :: [Sticker], + -- | The name of the sticker pack + stickerPackName :: T.Text, + -- | ID of the pack's SKU + stickerPackSKUId :: Snowflake, + -- | If of the sticker which is shown as the pack's icon + stickerPackCoverStickerId :: Maybe StickerId, + -- | The description of the sticker pack + stickerPackDescription :: T.Text, + -- | Id of the sticker pack's banner image + stickerPackBannerAssetId :: Maybe Snowflake + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON StickerPack where + parseJSON = withObject "StickerPack" $ \o -> + StickerPack <$> o .: "id" + <*> o .: "stickers" + <*> o .: "name" + <*> o .: "sku_id" + <*> o .:? "cover_sticker_id" + <*> o .: "description" + <*> o .:? "banner_asset_id" + +-- | A full sticker object +data Sticker = Sticker + { -- | The sticker's id. + stickerId :: StickerId, + -- | For standard stickers, the id of the pack. + stickerStickerPackId :: Maybe Snowflake, + -- | The sticker's name. + stickerName :: T.Text, + -- | The sticker's description. + stickerDescription :: Maybe T.Text, + -- | Autocomplete/suggestion tags for the sticker (max 200 characters total). + stickerTags :: [T.Text], + -- | Whether the sticker is standard or guild type. + stickerIsStandardType :: Bool, + -- | The sticker's format type. + stickerFormatType :: StickerFormatType, + -- | Whether this guild sticker can be used. + stickerAvailable :: Maybe Bool, + -- | What guild owns this sticker. + stickerGuildId :: Maybe GuildId, + -- | What user uploaded the guild sticker. + stickerUser :: Maybe User, + -- | A standard sticker's sort order in its pack. + stickerSortValue :: Maybe Integer + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON Sticker where + parseJSON = withObject "Sticker" $ \o -> + Sticker <$> o .: "id" + <*> o .:? "pack_id" + <*> o .: "name" + <*> o .:? "description" + <*> ((o .: "tags") <&> T.splitOn "\n") + <*> ((o .: "type") <&> (== (1 :: Int))) + <*> o .: "format_type" + <*> o .:? "available" + <*> o .:? "guild_id" + <*> o .:? "user" + <*> o .:? "sort_value" + +-- | A simplified sticker object. +data StickerItem = StickerItem + { -- | The sticker's id. + stickerItemId :: StickerId, + -- | The sticker's name. + stickerItemName :: T.Text, + -- | The sticker's format type. + stickerItemFormatType :: StickerFormatType + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON StickerItem where + parseJSON = withObject "StickerItem" $ \o -> + StickerItem <$> o .: "id" + <*> o .: "name" + <*> o .: "format_type" + +instance ToJSON StickerItem where + toJSON StickerItem {..} = + object + [ ("id", toJSON stickerItemId), + ("name", toJSON stickerItemName), + ("format_type", toJSON stickerItemFormatType) + ] + +data StickerFormatType + = StickerFormatTypePNG + | StickerFormatTypeAPNG + | StickerFormatTypeLOTTIE + deriving (Show, Read, Eq, Ord, Data) + +instance InternalDiscordEnum StickerFormatType where + discordTypeStartValue = StickerFormatTypePNG + fromDiscordType StickerFormatTypePNG = 1 + fromDiscordType StickerFormatTypeAPNG = 2 + fromDiscordType StickerFormatTypeLOTTIE = 3 + +instance ToJSON StickerFormatType where + toJSON = toJSON . fromDiscordType + +instance FromJSON StickerFormatType where + parseJSON = discordTypeParseJSON "StickerFormatType" 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 @@ -18,7 +18,7 @@ import Discord.Internal.Types.Guild import Discord.Internal.Types.User (User, GuildMember) import Discord.Internal.Types.Interactions (Interaction) -import Discord.Internal.Types.Components (Emoji) +import Discord.Internal.Types.Emoji (Emoji) -- | Represents possible events sent by discord. Detailed information can be found at https://discord.com/developers/docs/topics/gateway. 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 @@ -14,9 +14,9 @@ import Discord.Internal.Types.Prelude import Discord.Internal.Types.Color (DiscordColor) -import Discord.Internal.Types.Channel (Channel, StickerItem) +import Discord.Internal.Types.Channel (Channel) import Discord.Internal.Types.User (User, GuildMember) -import Discord.Internal.Types.Components (Emoji) +import Discord.Internal.Types.Emoji (Emoji, StickerItem) diff --git a/src/Discord/Internal/Types/Prelude.hs b/src/Discord/Internal/Types/Prelude.hs --- a/src/Discord/Internal/Types/Prelude.hs +++ b/src/Discord/Internal/Types/Prelude.hs @@ -70,6 +70,8 @@ type ApplicationId = Snowflake type ApplicationCommandId = Snowflake type InteractionId = Snowflake +type ScheduledEventId = Snowflake +type ScheduledEventEntityId = Snowflake type InteractionToken = T.Text type Shard = (Int, Int) diff --git a/src/Discord/Internal/Types/ScheduledEvents.hs b/src/Discord/Internal/Types/ScheduledEvents.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Types/ScheduledEvents.hs @@ -0,0 +1,566 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Structures pertaining to Discord Scheduled Events +module Discord.Internal.Types.ScheduledEvents where + +import Data.Aeson ( (.:) + , (.:!) + , (.:?) + , (.=) + , FromJSON(parseJSON) + , ToJSON(toJSON) + , Value(Null, Number, String) + , object + , withObject + , withText + ) +import Data.Aeson.Types ( Parser ) +import qualified Data.ByteString as B +import Data.Data ( Data ) +import Data.Default ( Default(def) ) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time ( UTCTime ) +import Discord.Internal.Types.Prelude ( ChannelId + , GuildId + , InternalDiscordEnum + ( discordTypeParseJSON + , discordTypeStartValue + , fromDiscordType + ) + , ScheduledEventEntityId + , ScheduledEventId + , UserId + , toMaybeJSON + ) +import Discord.Internal.Types.User ( GuildMember + , User + ) + + + +-- | The ScheduledEvent data structure +data ScheduledEvent + = ScheduledEventStage + { scheduledEventStageId :: ScheduledEventId + , scheduledEventStageGuildId :: GuildId + , scheduledEventStageChannelId :: ChannelId + , scheduledEventStageCreatorId :: Maybe UserId + , scheduledEventStageName :: T.Text + , scheduledEventStageDescription :: Maybe T.Text + , scheduledEventStageStartTime :: UTCTime + , scheduledEventStageEndTime :: Maybe UTCTime + , scheduledEventStagePrivacyLevel :: ScheduledEventPrivacyLevel + , scheduledEventStageStatus :: ScheduledEventStatus + , scheduledEventStageEntityId :: Maybe ScheduledEventEntityId + , scheduledEventStageCreator :: Maybe User + , scheduledEventStageUserCount :: Maybe Integer + , scheduledEventStageImage :: Maybe ScheduledEventImageHash + } + | ScheduledEventVoice + { scheduledEventVoiceId :: ScheduledEventId + , scheduledEventVoiceGuildId :: GuildId + , scheduledEventVoiceChannelId :: ChannelId + , scheduledEventVoiceCreatorId :: Maybe UserId + , scheduledEventVoiceName :: T.Text + , scheduledEventVoiceDescription :: Maybe T.Text + , scheduledEventVoiceStartTime :: UTCTime + , scheduledEventVoiceEndTime :: Maybe UTCTime + , scheduledEventVoicePrivacyLevel :: ScheduledEventPrivacyLevel + , scheduledEventVoiceStatus :: ScheduledEventStatus + , scheduledEventVoiceEntityId :: Maybe ScheduledEventEntityId + , scheduledEventVoiceCreator :: Maybe User + , scheduledEventVoiceUserCount :: Maybe Integer + , scheduledEventVoiceImage :: Maybe ScheduledEventImageHash + } + | ScheduledEventExternal + { scheduledEventExternalId :: ScheduledEventId + , scheduledEventExternalGuildId :: GuildId + , scheduledEventExternalLocation :: T.Text + , scheduledEventExternalCreatorId :: Maybe UserId + , scheduledEventExternalName :: T.Text + , scheduledEventExternalDescription :: Maybe T.Text + , scheduledEventExternalStartTime :: UTCTime + , scheduledEventExternalEndTime :: UTCTime + , scheduledEventExternalPrivacyLevel :: ScheduledEventPrivacyLevel + , scheduledEventExternalStatus :: ScheduledEventStatus + , scheduledEventExternalEntityId :: Maybe ScheduledEventEntityId + , scheduledEventExternalCreator :: Maybe User + , scheduledEventExternalUserCount :: Maybe Integer + , scheduledEventExternalImage :: Maybe ScheduledEventImageHash + } + +instance ToJSON ScheduledEvent where + toJSON ScheduledEventStage {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toMaybeJSON scheduledEventStageId) + , ("guild_id" , toMaybeJSON scheduledEventStageGuildId) + , ("channel_id" , toMaybeJSON scheduledEventStageChannelId) + , ("creator_id" , toJSON <$> scheduledEventStageCreatorId) + , ("name" , toMaybeJSON scheduledEventStageName) + , ("description" , toJSON <$> scheduledEventStageDescription) + , ("scheduled_start_time", toMaybeJSON scheduledEventStageStartTime) + , ("scheduled_end_time" , toJSON <$> scheduledEventStageEndTime) + , ("privacy_level" , toMaybeJSON scheduledEventStagePrivacyLevel) + , ("entity_type" , Just $ Number 1) + , ("entity_id" , toJSON <$> scheduledEventStageEntityId) + , ("creator" , toJSON <$> scheduledEventStageCreator) + , ("user_count" , toJSON <$> scheduledEventStageUserCount) + , ("image" , toJSON <$> scheduledEventStageImage) + ] + ] + toJSON ScheduledEventVoice {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toMaybeJSON scheduledEventVoiceId) + , ("guild_id" , toMaybeJSON scheduledEventVoiceGuildId) + , ("channel_id" , toMaybeJSON scheduledEventVoiceChannelId) + , ("creator_id" , toJSON <$> scheduledEventVoiceCreatorId) + , ("name" , toMaybeJSON scheduledEventVoiceName) + , ("description" , toJSON <$> scheduledEventVoiceDescription) + , ("scheduled_start_time", toMaybeJSON scheduledEventVoiceStartTime) + , ("scheduled_end_time" , toJSON <$> scheduledEventVoiceEndTime) + , ("privacy_level" , toMaybeJSON scheduledEventVoicePrivacyLevel) + , ("entity_type" , Just $ Number 2) + , ("entity_id" , toJSON <$> scheduledEventVoiceEntityId) + , ("creator" , toJSON <$> scheduledEventVoiceCreator) + , ("user_count" , toJSON <$> scheduledEventVoiceUserCount) + , ("image" , toJSON <$> scheduledEventVoiceImage) + ] + ] + toJSON ScheduledEventExternal {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toMaybeJSON scheduledEventExternalId) + , ("guild_id" , toMaybeJSON scheduledEventExternalGuildId) + , ("creator_id" , toJSON <$> scheduledEventExternalCreatorId) + , ("name" , toMaybeJSON scheduledEventExternalName) + , ("description" , toJSON <$> scheduledEventExternalDescription) + , ("scheduled_start_time", toMaybeJSON scheduledEventExternalStartTime) + , ("scheduled_end_time" , toMaybeJSON scheduledEventExternalEndTime) + , ("privacy_level", toMaybeJSON scheduledEventExternalPrivacyLevel) + , ("entity_type" , Just $ Number 3) + , ("entity_id" , toJSON <$> scheduledEventExternalEntityId) + , ("creator" , toJSON <$> scheduledEventExternalCreator) + , ("user_count" , toJSON <$> scheduledEventExternalUserCount) + , ("image" , toJSON <$> scheduledEventExternalImage) + , ( "entity_metadata" + , Just $ object ["location" .= toJSON scheduledEventExternalLocation] + ) + ] + ] + + +instance FromJSON ScheduledEvent where + parseJSON = withObject + "ScheduledEvent" + (\v -> do + setype <- v .: "entity_type" :: Parser Int + seid <- v .: "id" + segid <- v .: "guild_id" + secrid <- v .:? "creator_id" + sename <- v .: "name" + sedesc <- v .:? "description" + sest <- v .: "scheduled_start_time" + sepl <- v .: "privacy_level" :: Parser ScheduledEventPrivacyLevel + sestat <- v .: "status" :: Parser ScheduledEventStatus + seeid <- v .:? "entity_id" + secrea <- v .:? "creator" + seuc <- v .:? "user_count" + seim <- v .:? "image" + + case setype of + 1 -> do + sechid <- v .: "channelId" + seet <- v .:? "scheduled_end_time" + return $ ScheduledEventStage seid + segid + sechid + secrid + sename + sedesc + sest + seet + sepl + sestat + seeid + secrea + seuc + seim + 2 -> do + sechid <- v .: "channelId" + seet <- v .:? "scheduled_end_time" + return $ ScheduledEventVoice seid + segid + sechid + secrid + sename + sedesc + sest + seet + sepl + sestat + seeid + secrea + seuc + seim + 3 -> do + semeta <- v .: "entity_metadata" + seloc <- withObject "entity_metadata" (.: "location") semeta + seet <- v .: "scheduled_end_time" + return $ ScheduledEventExternal seid + segid + seloc + secrid + sename + sedesc + sest + seet + sepl + sestat + seeid + secrea + seuc + seim + _ -> error "unreachable" + ) + +-- | The privacy level of a scheduled event +data ScheduledEventPrivacyLevel = ScheduledEventPrivacyLevelGuildOnly + deriving (Show, Read, Eq, Ord, Data) + +instance InternalDiscordEnum ScheduledEventPrivacyLevel where + discordTypeStartValue = ScheduledEventPrivacyLevelGuildOnly + fromDiscordType ScheduledEventPrivacyLevelGuildOnly = 2 + +instance ToJSON ScheduledEventPrivacyLevel where + toJSON = toJSON . fromDiscordType + +instance FromJSON ScheduledEventPrivacyLevel where + parseJSON = discordTypeParseJSON "ScheduledEventPrivacyLevel" + +-- | The Status of a Scheduled Event +data ScheduledEventStatus + = ScheduledEventStatusScheduled + | ScheduledEventStatusActive + | ScheduledEventStatusCompleted + | ScheduledEventStatusCancelled + deriving (Show, Read, Eq, Ord, Data) + +instance InternalDiscordEnum ScheduledEventStatus where + discordTypeStartValue = ScheduledEventStatusScheduled + fromDiscordType ScheduledEventStatusScheduled = 1 + fromDiscordType ScheduledEventStatusActive = 2 + fromDiscordType ScheduledEventStatusCompleted = 3 + fromDiscordType ScheduledEventStatusCancelled = 4 + +instance ToJSON ScheduledEventStatus where + toJSON = toJSON . fromDiscordType + +instance FromJSON ScheduledEventStatus where + parseJSON = discordTypeParseJSON "ScheduledEventStatus" + +-- | The hash of the cover image of a ScheduledEvent +type ScheduledEventImageHash = T.Text + +-- | The type of images that can be uploaded +data CreateScheduledEventImageUploadType + = CreateScheduledEventImageUploadTypeJPG + | CreateScheduledEventImageUploadTypePNG + | CreateScheduledEventImageUploadTypeGIF + deriving (Show, Read, Eq, Ord) + +-- | The required information to add a cover image to a Scheduled Event +data CreateScheduledEventImage + = CreateScheduledEventImageURL T.Text + | CreateScheduledEventImageUpload CreateScheduledEventImageUploadType B.ByteString + deriving (Show, Read, Eq, Ord) + +instance ToJSON CreateScheduledEventImage where + toJSON (CreateScheduledEventImageURL u) = String u + toJSON (CreateScheduledEventImageUpload typ bs) = + String + $ "data:" + <> (case typ of + CreateScheduledEventImageUploadTypeJPG -> "image/jpeg" + CreateScheduledEventImageUploadTypePNG -> "image/png" + CreateScheduledEventImageUploadTypeGIF -> "image/gif" + ) + <> ";base64," + <> T.decodeUtf8 bs + +instance FromJSON CreateScheduledEventImage where + parseJSON = + withText "CreateScheduledEventImage" (return . CreateScheduledEventImageURL) + +-- | Data required to create a Scheduled Event +data CreateScheduledEventData + = CreateScheduledEventDataStage + { createScheduleEventDataStageChannelId :: ChannelId + , createScheduleEventDataStageName :: T.Text + , createScheduleEventDataStagePrivacyLevel :: ScheduledEventPrivacyLevel + , createScheduleEventDataStageStartTime :: UTCTime + , createScheduleEventDataStageEndTime :: Maybe UTCTime + , createScheduleEventDataStageDescription :: Maybe T.Text + , createScheduleEventDataStageImage :: Maybe CreateScheduledEventImage + } + | CreateScheduledEventDataVoice + { createScheduleEventDataVoiceChannelId :: ChannelId + , createScheduleEventDataVoiceName :: T.Text + , createScheduleEventDataVoicePrivacyLevel :: ScheduledEventPrivacyLevel + , createScheduleEventDataVoiceStartTime :: UTCTime + , createScheduleEventDataVoiceEndTime :: Maybe UTCTime + , createScheduleEventDataVoiceDescription :: Maybe T.Text + , createScheduleEventDataVoiceImage :: Maybe CreateScheduledEventImage + } + | CreateScheduledEventDataExternal + { createScheduleEventDataExternalLocation :: T.Text + , createScheduleEventDataExternalName :: T.Text + , createScheduleEventDataExternalPrivacyLevel :: ScheduledEventPrivacyLevel + , createScheduleEventDataExternalStartTime :: UTCTime + , createScheduleEventDataExternalEndTime :: UTCTime + , createScheduleEventDataExternalDescription :: Maybe T.Text + , createScheduleEventDataExternalImage :: Maybe CreateScheduledEventImage + } + +instance ToJSON CreateScheduledEventData where + toJSON CreateScheduledEventDataStage {..} = object + [ (name, value) + | (name, Just value) <- + [ ("channel_id" , toMaybeJSON createScheduleEventDataStageChannelId) + , ("name" , toMaybeJSON createScheduleEventDataStageName) + , ("privacy_level", toMaybeJSON createScheduleEventDataStagePrivacyLevel) + , ( "scheduled_start_time" + , toMaybeJSON createScheduleEventDataStageStartTime + ) + , ("scheduled_end_time", toJSON <$> createScheduleEventDataStageEndTime) + , ("description", toJSON <$> createScheduleEventDataStageDescription) + , ("entity_type" , Just $ Number 1) + , ("image" , toJSON <$> createScheduleEventDataStageImage) + ] + ] + toJSON CreateScheduledEventDataVoice {..} = object + [ (name, value) + | (name, Just value) <- + [ ("channel_id" , toMaybeJSON createScheduleEventDataVoiceChannelId) + , ("name" , toMaybeJSON createScheduleEventDataVoiceName) + , ("privacy_level", toMaybeJSON createScheduleEventDataVoicePrivacyLevel) + , ( "scheduled_start_time" + , toMaybeJSON createScheduleEventDataVoiceStartTime + ) + , ("scheduled_end_time", toJSON <$> createScheduleEventDataVoiceEndTime) + , ("description", toJSON <$> createScheduleEventDataVoiceDescription) + , ("entity_type" , Just $ Number 2) + , ("image" , toJSON <$> createScheduleEventDataVoiceImage) + ] + ] + toJSON CreateScheduledEventDataExternal {..} = object + [ (name, value) + | (name, Just value) <- + [ ( "entity_metadata" + , Just $ object ["location" .= createScheduleEventDataExternalLocation] + ) + , ("name", toMaybeJSON createScheduleEventDataExternalName) + , ( "privacy_level" + , toMaybeJSON createScheduleEventDataExternalPrivacyLevel + ) + , ( "scheduled_start_time" + , toMaybeJSON createScheduleEventDataExternalStartTime + ) + , ( "scheduled_end_time" + , toMaybeJSON createScheduleEventDataExternalEndTime + ) + , ("description", toJSON <$> createScheduleEventDataExternalDescription) + , ("entity_type", Just $ Number 2) + , ("image", toJSON <$> createScheduleEventDataExternalImage) + ] + ] + +instance FromJSON CreateScheduledEventData where + parseJSON = withObject + "CreateScheduledEventData" + (\v -> do + t <- v .: "entity_type" :: Parser Int + csename <- v .: "name" + csepl <- v .: "privacy_level" + csest <- v .: "scheduled_start_time" + csedesc <- v .:? "description" + cseimg <- v .:? "image" + + case t of + 1 -> do + csecid <- v .: "channel_id" + cseet <- v .:? "scheduled_end_time" + return $ CreateScheduledEventDataStage csecid + csename + csepl + csest + cseet + csedesc + cseimg + 2 -> do + csecid <- v .: "channel_id" + cseet <- v .:? "scheduled_end_time" + return $ CreateScheduledEventDataVoice csecid + csename + csepl + csest + cseet + csedesc + cseimg + 3 -> do + csemeta <- v .: "entity_metadata" + cseloc <- withObject "entity_metadata" (.: "location") csemeta + cseet <- v .: "scheduled_end_time" + return $ CreateScheduledEventDataVoice cseloc + csename + csepl + csest + cseet + csedesc + cseimg + _ -> error "unreachable" + ) + + +-- | The type of ScheduledEvent, used in 'ModifyScheduledEventData' +data ScheduledEventType + = ScheduledEventTypeStage + | ScheduledEventTypeVoice + | ScheduledEventTypeExternal + deriving (Show, Read, Ord, Eq, Data) + +instance InternalDiscordEnum ScheduledEventType where + discordTypeStartValue = ScheduledEventTypeStage + fromDiscordType ScheduledEventTypeStage = 1 + fromDiscordType ScheduledEventTypeVoice = 2 + fromDiscordType ScheduledEventTypeExternal = 3 + +instance FromJSON ScheduledEventType where + parseJSON = discordTypeParseJSON "ScheduledEventType" + +instance ToJSON ScheduledEventType where + toJSON = toJSON . fromDiscordType + +-- | Data required to issue a Modify Scheduled Event request +-- This isnt fully type-safe, and can allow for boggus requests but I don't +-- know of any sane solution to this +data ModifyScheduledEventData = ModifyScheduledEventData + { modifyScheduledEventDataChannelId :: Maybe (Maybe ChannelId) + , modifyScheduledEventDataLocation :: Maybe (Maybe T.Text) + , modifyScheduledEventDataName :: Maybe T.Text + , modifyScheduledEventDataPrivacyLevel :: Maybe ScheduledEventPrivacyLevel + , modifyScheduledEventDataStartTime :: Maybe UTCTime + , modifyScheduledEventDataEndTime :: Maybe UTCTime + , modifyScheduledEventDataDescription :: Maybe (Maybe T.Text) + , modifyScheduledEventDataType :: Maybe ScheduledEventType + , modifyScheduledEventDataStatus :: Maybe ScheduledEventStatus + , modifyScheduledEventDataImage :: Maybe CreateScheduledEventImage + } + +instance Default ModifyScheduledEventData where + def = ModifyScheduledEventData Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + +instance ToJSON ModifyScheduledEventData where + toJSON ModifyScheduledEventData {..} = object + [ (name, value) + | (name, Just value) <- + [ ("channel_id", toJSON <$> modifyScheduledEventDataChannelId) + , ("entity_metadata" , loc) + , ("name", toJSON <$> modifyScheduledEventDataName) + , ("scheduled_start_time", toJSON <$> modifyScheduledEventDataStartTime) + , ("scheduled_end_time", toJSON <$> modifyScheduledEventDataEndTime) + , ("description", toJSON <$> modifyScheduledEventDataDescription) + , ("entity_type", toJSON <$> modifyScheduledEventDataType) + , ("status", toJSON <$> modifyScheduledEventDataStatus) + , ("image", toJSON <$> modifyScheduledEventDataImage) + ] + ] + where + loc = case modifyScheduledEventDataLocation of + Nothing -> Nothing + Just Nothing -> Just Null + Just loc' -> Just $ object [("location", toJSON loc')] + +instance FromJSON ModifyScheduledEventData where + parseJSON = withObject + "ModifyScheduledEventData" + (\v -> do + -- The trivial fields + msename <- v .:? "name" + msest <- v .:? "scheduled_start_time" + mseet <- v .:? "scheduled_end_time" + msetype <- v .:? "entity_type" + msepl <- v .:? "privacy_level" + msestat <- v .:? "status" + mseimg <- v .:? "image" + + -- The not so trivial ones + msecid' <- v .:! "channel_id" + mseloc' <- v .:! "entity_metadata" + msedesc' <- v .:! "description" + + -- Extract the values + msecid <- case msecid' of + Nothing -> return Nothing + Just Null -> return $ Just Nothing + Just x -> do + x' <- parseJSON x + return $ Just x' + + mseloc <- case mseloc' of + Nothing -> return Nothing + Just Null -> return $ Just Nothing + Just x -> do + x' <- withObject "entity_metadata" (.: "location") x + return $ Just x' + + msedesc <- case msedesc' of + Nothing -> return Nothing + Just Null -> return $ Just Nothing + Just x -> do + x' <- parseJSON x + return $ Just x' + + return $ ModifyScheduledEventData + { modifyScheduledEventDataChannelId = msecid + , modifyScheduledEventDataLocation = mseloc + , modifyScheduledEventDataName = msename + , modifyScheduledEventDataPrivacyLevel = msepl + , modifyScheduledEventDataStartTime = msest + , modifyScheduledEventDataEndTime = mseet + , modifyScheduledEventDataDescription = msedesc + , modifyScheduledEventDataType = msetype + , modifyScheduledEventDataStatus = msestat + , modifyScheduledEventDataImage = mseimg + } + ) + +-- | An User that subscribed to a Scheduled Event +data ScheduledEventUser = ScheduledEventUser + { scheduledEventUserEvent :: ScheduledEventId + , scheduledEventUserUser :: User + , scheduledEventUserGuildMember :: Maybe GuildMember + } + +instance FromJSON ScheduledEventUser where + parseJSON = withObject + "ScheduledEventUser" + (\v -> + ScheduledEventUser + <$> v .: "guild_scheduled_event_id" + <*> v .: "user" + <*> v .:? "member" + ) diff --git a/src/Discord/Internal/Types/User.hs b/src/Discord/Internal/Types/User.hs --- a/src/Discord/Internal/Types/User.hs +++ b/src/Discord/Internal/Types/User.hs @@ -121,6 +121,7 @@ , memberMute :: Bool -- ^ Whether the user is muted , memberPending :: Bool -- ^ Whether the user has passed the guild's membership screening , memberPermissions :: Maybe T.Text -- ^ total permissions of the member + , memberTimeoutEnd :: Maybe UTCTime -- ^ when the user's timeout will expire and they can communicate again } deriving (Show, Read, Eq, Ord) instance FromJSON GuildMember where @@ -135,6 +136,7 @@ <*> o .: "mute" <*> o .:? "pending" .!= False <*> o .:? "permissions" + <*> o .:? "communication_disabled_until" instance ToJSON GuildMember where toJSON GuildMember {..} = object [(name, value) | (name, Just value) <- @@ -148,4 +150,5 @@ , ("mute", toJSON <$> pure memberMute) , ("pending", toJSON <$> pure memberPending) , ("permissions", toJSON <$> memberPermissions) + , ("communication_disabled_until", toJSON <$> memberTimeoutEnd) ] ]