1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- | Provides actions for Channel API interactions
module Discord.Internal.Rest.Emoji
( EmojiRequest (..),
ModifyGuildEmojiOpts (..),
parseEmojiImage,
parseStickerImage,
StickerRequest (..),
CreateGuildStickerOpts (..),
EditGuildStickerOpts (..)
)
where
import Data.Aeson
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as B64
import qualified Data.Text as T
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 <https://discord.com/developers/docs/resources/ API>
data EmojiRequest a where
-- | List of emoji objects for the given guild. Requires MANAGE_EMOJIS permission.
ListGuildEmojis :: GuildId -> EmojiRequest [Emoji]
-- | Emoji object for the given guild and emoji ID
GetGuildEmoji :: GuildId -> EmojiId -> EmojiRequest Emoji
-- | Create a new guild emoji (static&animated). Requires MANAGE_EMOJIS permission.
CreateGuildEmoji :: GuildId -> T.Text -> Base64Image Emoji -> EmojiRequest Emoji
-- | Requires MANAGE_EMOJIS permission
ModifyGuildEmoji :: GuildId -> EmojiId -> ModifyGuildEmojiOpts -> EmojiRequest Emoji
-- | Requires MANAGE_EMOJIS permission
DeleteGuildEmoji :: GuildId -> EmojiId -> EmojiRequest ()
data ModifyGuildEmojiOpts = ModifyGuildEmojiOpts
{ modifyGuildEmojiName :: T.Text,
modifyGuildEmojiRoles :: [RoleId]
}
deriving (Show, Read, Eq, Ord)
instance ToJSON ModifyGuildEmojiOpts where
toJSON (ModifyGuildEmojiOpts name roles) =
object ["name" .= name, "roles" .= roles]
-- | @parseEmojiImage bs@ will attempt to convert the given image bytestring @bs@
-- to the base64 format expected by the Discord API. It may return Left with an
-- error reason if either the bytestring is too large, or if the image format
-- could not be predetermined from the opening few bytes. This function does
-- /not/ validate the rest of the image, nor check that its dimensions are
-- 128x128 as required by Discord. This is up to the library user to check.
--
-- This function accepts all file types accepted by 'getMimeType'.
parseEmojiImage :: B.ByteString -> Either T.Text (Base64Image Emoji)
parseEmojiImage bs
| B.length bs > 256000 = Left "Cannot create emoji - File is larger than 256kb"
| Just mime <- getMimeType bs = Right (Base64Image mime (B64.encode bs))
| otherwise = Left "Unsupported image format provided"
emojiMajorRoute :: EmojiRequest a -> String
emojiMajorRoute c = case c of
(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
guilds :: R.Url 'R.Https
guilds = baseUrl /: "guilds"
emojiJsonRequest :: EmojiRequest r -> JsonRequest
emojiJsonRequest c = case c of
(ListGuildEmojis g) -> Get (guilds /~ g /: "emojis") mempty
(GetGuildEmoji g e) -> Get (guilds /~ g /: "emojis" /~ e) mempty
(CreateGuildEmoji g name b64im) ->
Post
(guilds /~ g /: "emojis")
( pure
( R.ReqBodyJson
( object
[ "name" .= name,
"image" .= b64im
-- 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
-- | @parseStickerImage bs@ accepts PNG, APNG, or Lottie JSON bytestring @bs@ and
-- will attempt to convert it to the base64 format expected by the Discord API.
-- It may return Left with an error reason if the image format is unexpected.
-- This function does /not/ validate the contents of the image, this is up to
-- the library user to check.
parseStickerImage :: B.ByteString -> Either T.Text (Base64Image Sticker)
parseStickerImage bs
| B.length bs > 512000
= Left "Cannot create sticker - File is larger than 512kb"
| Just "image/png" <- getMimeType bs
= Right (Base64Image "image/png" (B64.encode bs))
| not (B.null bs) && B.head bs == 0x7b -- '{'
= Right (Base64Image "application/json" (B64.encode bs))
| otherwise
= Left "Unsupported image format provided"
-- | Options for `CreateGuildSticker`
data CreateGuildStickerOpts = CreateGuildStickerOpts
{ guildStickerName :: T.Text,
guildStickerDescription :: T.Text,
guildStickerTags :: [T.Text],
guildStickerFile :: Base64Image Sticker
}
deriving (Show, Read, Eq, Ord)
instance ToJSON CreateGuildStickerOpts where
toJSON (CreateGuildStickerOpts name desc tags b64im) =
object
[ ("name", toJSON name),
("description", toJSON desc),
("tags", toJSON $ T.intercalate "," tags),
("file", toJSON b64im)
]
-- | Options for `ModifyGuildSticker`
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 {..} =
objectFromMaybes
[ "name" .=? editGuildStickerName,
"description" .=? editGuildStickerDescription,
"tags" .=? fmap (T.intercalate ",") editGuildStickerTags
]
instance Request (StickerRequest a) where
majorRoute = stickerMajorRoute
jsonRequest = stickerJsonRequest
-- | Data constructor for requests. See <https://discord.com/developers/docs/resources/ API>
--
-- 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"
|
