Emoji.hs

{-# 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"