{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-partial-type-signatures #-} -- | Channel endpoints module Calamity.HTTP.Channel ( ChannelRequest (..), CreateMessageAttachment (..), CreateMessageOptions (..), EditMessageData (..), editMessageContent, editMessageEmbeds, editMessageFlags, editMessageAllowedMentions, editMessageComponents, ChannelUpdate (..), AllowedMentionType (..), AllowedMentions (..), ChannelMessagesFilter (..), ChannelMessagesLimit (..), GetReactionsOptions (..), CreateChannelInviteOptions (..), GroupDMAddRecipientOptions (..), ) where import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild.Emoji (RawEmoji (..)) import Calamity.Types.Model.Guild.Invite (Invite) import Calamity.Types.Model.Guild.Overwrite (Overwrite) import Calamity.Types.Model.Guild.Role (Role) import Calamity.Types.Model.User import Calamity.Types.Snowflake import Data.Aeson qualified as Aeson import Data.Aeson.KeyMap qualified as K import Data.Default.Class import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T import Data.Word import Network.HTTP.Client (RequestBody) import Network.HTTP.Client.MultipartFormData import Network.HTTP.Req import Network.Mime import Optics import TextShow data CreateMessageAttachment = CreateMessageAttachment { filename :: Text , description :: Maybe Text , content :: RequestBody } instance Show CreateMessageAttachment where show (CreateMessageAttachment filename description _) = mconcat [ "CreateMessageAttachment {filename = " , show filename , ", description = " , show description , ", content = }" ] data CreateMessageOptions = CreateMessageOptions { content :: Maybe Text , nonce :: Maybe Text , tts :: Maybe Bool , attachments :: Maybe [CreateMessageAttachment] , embeds :: Maybe [Embed] , allowedMentions :: Maybe AllowedMentions , messageReference :: Maybe MessageReference , components :: Maybe [Component] } deriving (Show) instance Default CreateMessageOptions where def = CreateMessageOptions Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing data CreateMessageAttachmentJson = CreateMessageAttachmentJson { id :: Int , filename :: Text , description :: Maybe Text } deriving (Show) deriving (Aeson.ToJSON) via CalamityToJSON CreateMessageAttachmentJson instance CalamityToJSON' CreateMessageAttachmentJson where toPairs CreateMessageAttachmentJson {..} = [ "filename" .= filename , "description" .?= description , "id" .= id ] data CreateMessageJson = CreateMessageJson { content :: Maybe Text , nonce :: Maybe Text , tts :: Maybe Bool , embeds :: Maybe [Embed] , allowedMentions :: Maybe AllowedMentions , messageReference :: Maybe MessageReference , components :: Maybe [Component] , attachments :: Maybe [CreateMessageAttachmentJson] } deriving (Show) deriving (Aeson.ToJSON) via CalamityToJSON CreateMessageJson instance CalamityToJSON' CreateMessageJson where toPairs CreateMessageJson {..} = [ "content" .?= content , "nonce" .?= nonce , "tts" .?= tts , "embeds" .?= embeds , "allowed_mentions" .?= allowedMentions , "message_reference" .?= messageReference , "components" .?= components , "attachments" .?= attachments ] data AllowedMentionType = AllowedMentionRoles | AllowedMentionUsers | AllowedMentionEveryone deriving (Show) instance Aeson.ToJSON AllowedMentionType where toJSON AllowedMentionRoles = Aeson.String "roles" toJSON AllowedMentionUsers = Aeson.String "users" toJSON AllowedMentionEveryone = Aeson.String "everyone" data AllowedMentions = AllowedMentions { parse :: [AllowedMentionType] , roles :: [Snowflake Role] , users :: [Snowflake User] , repliedUser :: Bool } deriving (Show) deriving (Aeson.ToJSON) via CalamityToJSON AllowedMentions instance CalamityToJSON' AllowedMentions where toPairs AllowedMentions {..} = [ "parse" .= parse , "roles" .= roles , "users" .= users , "replied_user" .= repliedUser ] instance Default AllowedMentions where def = AllowedMentions def def def False instance Semigroup AllowedMentions where AllowedMentions p0 r0 u0 ru0 <> AllowedMentions p1 r1 u1 ru1 = AllowedMentions (p0 <> p1) (r0 <> r1) (u0 <> u1) (ru0 || ru1) instance Monoid AllowedMentions where mempty = def {- | Parameters to the Edit Message endpoint. Use the provided methods (@editMessageX@) to create a value with the field set, use the Semigroup instance to union the values. ==== Examples >>> encode $ editMessageContent (Just "test") <> editMessageFlags Nothing "{\"nick\":\"test\",\"deaf\":null}" -} newtype EditMessageData = EditMessageData Aeson.Object deriving stock (Show) deriving newtype (Aeson.ToJSON, Semigroup, Monoid) editMessageContent :: Maybe Text -> EditMessageData editMessageContent v = EditMessageData $ K.fromList [("content", Aeson.toJSON v)] editMessageEmbeds :: [Embed] -> EditMessageData editMessageEmbeds v = EditMessageData $ K.fromList [("embeds", Aeson.toJSON v)] editMessageFlags :: Maybe Word64 -> EditMessageData editMessageFlags v = EditMessageData $ K.fromList [("flags", Aeson.toJSON v)] editMessageAllowedMentions :: Maybe AllowedMentions -> EditMessageData editMessageAllowedMentions v = EditMessageData $ K.fromList [("allowed_mentions", Aeson.toJSON v)] editMessageComponents :: [Component] -> EditMessageData editMessageComponents v = EditMessageData $ K.fromList [("components", Aeson.toJSON v)] data ChannelUpdate = ChannelUpdate { name :: Maybe Text , position :: Maybe Int , topic :: Maybe Text , nsfw :: Maybe Bool , rateLimitPerUser :: Maybe Int , bitrate :: Maybe Int , userLimit :: Maybe Int , permissionOverwrites :: Maybe [Overwrite] , parentID :: Maybe (Snowflake Channel) } deriving (Show) deriving (Aeson.ToJSON) via CalamityToJSON ChannelUpdate instance Default ChannelUpdate where def = ChannelUpdate Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing instance CalamityToJSON' ChannelUpdate where toPairs ChannelUpdate {..} = [ "name" .?= name , "position" .?= position , "topic" .?= topic , "nsfw" .?= nsfw , "rate_limit_per_user" .?= rateLimitPerUser , "bitrate" .?= bitrate , "user_limit" .?= userLimit , "permission_overwrites" .?= permissionOverwrites , "parent_id" .?= parentID ] data ChannelMessagesFilter = ChannelMessagesAround { around :: Snowflake Message } | ChannelMessagesBefore { before :: Snowflake Message } | ChannelMessagesAfter { after :: Snowflake Message } deriving (Show) deriving (Aeson.ToJSON) via CalamityToJSON ChannelMessagesFilter instance CalamityToJSON' ChannelMessagesFilter where toPairs ChannelMessagesAround {around} = ["around" .= around] toPairs ChannelMessagesBefore {before} = ["before" .= before] toPairs ChannelMessagesAfter {after} = ["after" .= after] newtype ChannelMessagesLimit = ChannelMessagesLimit { limit :: Integer } deriving stock (Show) data GetReactionsOptions = GetReactionsOptions { before :: Maybe (Snowflake User) , after :: Maybe (Snowflake User) , limit :: Maybe Integer } deriving (Show) instance Default GetReactionsOptions where def = GetReactionsOptions Nothing Nothing Nothing data CreateChannelInviteOptions = CreateChannelInviteOptions { maxAge :: Maybe Int , maxUses :: Maybe Int , temporary :: Maybe Bool , unique :: Maybe Bool } deriving (Show) deriving (Aeson.ToJSON) via CalamityToJSON CreateChannelInviteOptions instance Default CreateChannelInviteOptions where def = CreateChannelInviteOptions Nothing Nothing Nothing Nothing instance CalamityToJSON' CreateChannelInviteOptions where toPairs CreateChannelInviteOptions {..} = [ "max_age" .?= maxAge , "max_uses" .?= maxUses , "temporary" .?= temporary , "unique" .?= unique ] data GroupDMAddRecipientOptions = GroupDMAddRecipientOptions { accessToken :: Text , nick :: Text } deriving (Show) deriving (Aeson.ToJSON) via CalamityToJSON GroupDMAddRecipientOptions instance CalamityToJSON' GroupDMAddRecipientOptions where toPairs GroupDMAddRecipientOptions {..} = [ "access_token" .= accessToken , "nick" .= nick ] $(makeFieldLabelsNoPrefix ''CreateMessageAttachment) $(makeFieldLabelsNoPrefix ''CreateMessageOptions) $(makeFieldLabelsNoPrefix ''CreateMessageAttachmentJson) $(makeFieldLabelsNoPrefix ''AllowedMentions) $(makeFieldLabelsNoPrefix ''ChannelUpdate) $(makeFieldLabelsNoPrefix ''ChannelMessagesFilter) $(makeFieldLabelsNoPrefix ''ChannelMessagesLimit) $(makeFieldLabelsNoPrefix ''GetReactionsOptions) $(makeFieldLabelsNoPrefix ''CreateChannelInviteOptions) $(makeFieldLabelsNoPrefix ''GroupDMAddRecipientOptions) data ChannelRequest a where CreateMessage :: (HasID Channel c) => c -> CreateMessageOptions -> ChannelRequest Message CrosspostMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest Message GetMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest Message EditMessage :: (HasID Channel c, HasID Message m) => c -> m -> EditMessageData -> ChannelRequest Message DeleteMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () BulkDeleteMessages :: (HasID Channel c, HasID Message m) => c -> [m] -> ChannelRequest () GetChannel :: (HasID Channel c) => c -> ChannelRequest Channel ModifyChannel :: (HasID Channel c) => c -> ChannelUpdate -> ChannelRequest Channel DeleteChannel :: (HasID Channel c) => c -> ChannelRequest () GetChannelMessages :: (HasID Channel c) => c -> Maybe ChannelMessagesFilter -> Maybe ChannelMessagesLimit -> ChannelRequest [Message] CreateReaction :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> ChannelRequest () DeleteOwnReaction :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> ChannelRequest () DeleteUserReaction :: (HasID Channel c, HasID Message m, HasID User u) => c -> m -> RawEmoji -> u -> ChannelRequest () GetReactions :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> GetReactionsOptions -> ChannelRequest [User] DeleteAllReactions :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () GetChannelInvites :: (HasID Channel c) => c -> ChannelRequest [Invite] CreateChannelInvite :: (HasID Channel c) => c -> CreateChannelInviteOptions -> ChannelRequest Invite EditChannelPermissions :: (HasID Channel c) => c -> Overwrite -> ChannelRequest () DeleteChannelPermission :: (HasID Channel c, HasID Overwrite o) => c -> o -> ChannelRequest () TriggerTyping :: (HasID Channel c) => c -> ChannelRequest () GetPinnedMessages :: (HasID Channel c) => c -> ChannelRequest [Message] AddPinnedMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () DeletePinnedMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () GroupDMAddRecipient :: (HasID Channel c, HasID User u) => c -> u -> GroupDMAddRecipientOptions -> ChannelRequest () GroupDMRemoveRecipient :: (HasID Channel c, HasID User u) => c -> u -> ChannelRequest () baseRoute :: Snowflake Channel -> RouteBuilder _ baseRoute id = mkRouteBuilder // S "channels" // ID @Channel & giveID id renderEmoji :: RawEmoji -> Text renderEmoji (UnicodeEmoji e) = e renderEmoji (CustomEmoji e) = e ^. #name <> ":" <> showt (e ^. #id) instance Request (ChannelRequest a) where type Result (ChannelRequest a) = a route (CreateMessage (getID -> id) _) = baseRoute id // S "messages" & buildRoute route (CrosspostMessage (getID -> id) (getID @Message -> mid)) = baseRoute id // S "messages" // ID @Message & giveID mid & buildRoute route (GetChannel (getID -> id)) = baseRoute id & buildRoute route (ModifyChannel (getID -> id) _) = baseRoute id & buildRoute route (DeleteChannel (getID -> id)) = baseRoute id & buildRoute route (GetChannelMessages (getID -> id) _ _) = baseRoute id // S "messages" & buildRoute route (GetMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "messages" // ID @Message & giveID mid & buildRoute route (CreateReaction (getID -> cid) (getID @Message -> mid) emoji) = baseRoute cid // S "messages" // ID @Message // S "reactions" // PS @"emoji" // S "@me" & giveID mid & giveParam @"emoji" (renderEmoji emoji) & buildRoute route (DeleteOwnReaction (getID -> cid) (getID @Message -> mid) emoji) = baseRoute cid // S "messages" // ID @Message // S "reactions" // PS @"emoji" // S "@me" & giveID mid & giveParam @"emoji" (renderEmoji emoji) & buildRoute route (DeleteUserReaction (getID -> cid) (getID @Message -> mid) emoji (getID @User -> uid)) = baseRoute cid // S "messages" // ID @Message // S "reactions" // PS @"emoji" // ID @User & giveID mid & giveID uid & giveParam @"emoji" (renderEmoji emoji) & buildRoute route (GetReactions (getID -> cid) (getID @Message -> mid) emoji _) = baseRoute cid // S "messages" // ID @Message // S "reactions" // PS @"emoji" & giveID mid & giveParam @"emoji" (renderEmoji emoji) & buildRoute route (DeleteAllReactions (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "messages" // ID @Message // S "reactions" & giveID mid & buildRoute route (EditMessage (getID -> cid) (getID @Message -> mid) _) = baseRoute cid // S "messages" // ID @Message & giveID mid & buildRoute route (DeleteMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "messages" // ID @Message & giveID mid & buildRoute route (BulkDeleteMessages (getID -> cid) _) = baseRoute cid // S "messages" // S "bulk-delete" & buildRoute route (GetChannelInvites (getID -> cid)) = baseRoute cid // S "invites" & buildRoute route (CreateChannelInvite (getID -> cid) _) = baseRoute cid // S "invites" & buildRoute route (EditChannelPermissions (getID -> cid) (getID @Overwrite -> oid)) = baseRoute cid // S "permissions" // ID @Overwrite & giveID oid & buildRoute route (DeleteChannelPermission (getID -> cid) (getID @Overwrite -> oid)) = baseRoute cid // S "permissions" // ID @Overwrite & giveID oid & buildRoute route (TriggerTyping (getID -> cid)) = baseRoute cid // S "typing" & buildRoute route (GetPinnedMessages (getID -> cid)) = baseRoute cid // S "pins" & buildRoute route (AddPinnedMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "pins" // ID @Message & giveID mid & buildRoute route (DeletePinnedMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "pins" // ID @Message & giveID mid & buildRoute route (GroupDMAddRecipient (getID -> cid) (getID @User -> uid) _) = baseRoute cid // S "recipients" // ID @User & giveID uid & buildRoute route (GroupDMRemoveRecipient (getID -> cid) (getID @User -> uid)) = baseRoute cid // S "recipients" // ID @User & giveID uid & buildRoute action (CreateMessage _ cm) = \u o -> do let filePart CreateMessageAttachment {filename, content} n = (partFileRequestBody @IO (T.pack $ "files[" <> show n <> "]") "" content) { partFilename = Just (T.unpack filename) , partContentType = Just (defaultMimeLookup filename) } attachmentPart CreateMessageAttachment {filename, description} n = CreateMessageAttachmentJson n filename description files = zipWith filePart (fromMaybe [] $ cm ^. #attachments) [(0 :: Int) ..] attachments = (\a -> zipWith attachmentPart a [0 ..]) <$> cm ^. #attachments jsonBody = CreateMessageJson { content = cm ^. #content , nonce = cm ^. #nonce , tts = cm ^. #tts , embeds = cm ^. #embeds , allowedMentions = cm ^. #allowedMentions , messageReference = cm ^. #messageReference , components = cm ^. #components , attachments = attachments } body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonBody) : files) postWith' body u o action (CrosspostMessage _ _) = postEmpty action (GetChannel _) = getWith action (ModifyChannel _ p) = patchWith' (ReqBodyJson p) action (DeleteChannel _) = deleteWith action (GetChannelMessages _ (Just (ChannelMessagesAround (fromSnowflake -> a))) l) = getWithP ("around" =: a <> "limit" =:? (l ^? _Just % #limit)) action (GetChannelMessages _ (Just (ChannelMessagesBefore (fromSnowflake -> a))) l) = getWithP ("before" =: a <> "limit" =:? (l ^? _Just % #limit)) action (GetChannelMessages _ (Just (ChannelMessagesAfter (fromSnowflake -> a))) l) = getWithP ("after" =: a <> "limit" =:? (l ^? _Just % #limit)) action (GetChannelMessages _ Nothing l) = getWithP ("limit" =:? (l ^? _Just % #limit)) action (GetMessage _ _) = getWith action CreateReaction {} = putEmpty action DeleteOwnReaction {} = deleteWith action DeleteUserReaction {} = deleteWith action (GetReactions _ _ _ GetReactionsOptions {before, after, limit}) = getWithP ( "before" =:? (fromSnowflake <$> before) <> "after" =:? (fromSnowflake <$> after) <> "limit" =:? limit ) action (DeleteAllReactions _ _) = deleteWith action (EditMessage _ _ o) = patchWith' (ReqBodyJson o) action (DeleteMessage _ _) = deleteWith action (BulkDeleteMessages _ (map (getID @Message) -> ids)) = postWith' (ReqBodyJson $ Aeson.object ["messages" Aeson..= ids]) action (GetChannelInvites _) = getWith action (CreateChannelInvite _ o) = postWith' (ReqBodyJson o) action (EditChannelPermissions _ o) = putWith' (ReqBodyJson o) action (DeleteChannelPermission _ _) = deleteWith action (TriggerTyping _) = postEmpty action (GetPinnedMessages _) = getWith action (AddPinnedMessage _ _) = putEmpty action (DeletePinnedMessage _ _) = deleteWith action (GroupDMAddRecipient _ _ o) = putWith' (ReqBodyJson o) action (GroupDMRemoveRecipient _ _) = deleteWith