{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module Discord.Rest.Channel
( ChannelRequest(..)
, ReactionTiming(..)
, MessageTiming(..)
, ModifyChannelOptions(..)
) where
import Data.Aeson
import qualified Data.ByteString.Lazy as BL
import Data.Monoid (mempty, (<>))
import qualified Data.Text as T
import Network.HTTP.Client (RequestBody (RequestBodyLBS))
import Network.HTTP.Client.MultipartFormData (partFileRequestBody)
import Network.HTTP.Req ((/:))
import qualified Network.HTTP.Req as R
import Discord.Rest.Prelude
import Discord.Types
instance Request (ChannelRequest a) where
majorRoute = channelMajorRoute
jsonRequest = channelJsonRequest
data ChannelRequest a where
GetChannel :: Snowflake -> ChannelRequest Channel
ModifyChannel :: Snowflake -> ModifyChannelOptions -> ChannelRequest Channel
DeleteChannel :: Snowflake -> ChannelRequest Channel
GetChannelMessages :: Snowflake -> (Int, MessageTiming) -> ChannelRequest [Message]
GetChannelMessage :: (Snowflake, Snowflake) -> ChannelRequest Message
CreateMessage :: Snowflake -> T.Text -> Maybe Embed -> ChannelRequest Message
UploadFile :: Snowflake -> FilePath -> BL.ByteString -> ChannelRequest Message
CreateReaction :: (Snowflake, Snowflake) -> (T.Text, Maybe Snowflake)
-> ChannelRequest ()
DeleteOwnReaction :: (Snowflake, Snowflake) -> (T.Text, Maybe Snowflake)
-> ChannelRequest ()
DeleteUserReaction :: (Snowflake, Snowflake) -> (T.Text, Maybe Snowflake)
-> Snowflake -> ChannelRequest ()
GetReactions :: (Snowflake, Snowflake) -> (T.Text, Maybe Snowflake)
-> (Int, ReactionTiming) -> ChannelRequest ()
DeleteAllReactions :: (Snowflake, Snowflake) -> ChannelRequest ()
EditMessage :: (Snowflake, Snowflake) -> T.Text -> Maybe Embed
-> ChannelRequest Message
DeleteMessage :: (Snowflake, Snowflake) -> ChannelRequest ()
BulkDeleteMessage :: (Snowflake, [Snowflake]) -> ChannelRequest ()
GetChannelInvites :: Snowflake -> ChannelRequest Object
DeleteChannelPermission :: Snowflake -> Snowflake -> ChannelRequest ()
TriggerTypingIndicator :: Snowflake -> ChannelRequest ()
GetPinnedMessages :: Snowflake -> ChannelRequest [Message]
AddPinnedMessage :: (Snowflake, Snowflake) -> ChannelRequest ()
DeletePinnedMessage :: (Snowflake, Snowflake) -> ChannelRequest ()
data ReactionTiming = BeforeReaction Snowflake
| AfterReaction Snowflake
reactionTimingToQuery :: ReactionTiming -> R.Option 'R.Https
reactionTimingToQuery t = case t of
(BeforeReaction snow) -> "before" R.=: show snow
(AfterReaction snow) -> "after" R.=: show snow
data MessageTiming = AroundMessage Snowflake
| BeforeMessage Snowflake
| AfterMessage Snowflake
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
data ModifyChannelOptions = ModifyChannelOptions
{ modifyChannelName :: Maybe String
, modifyChannelPosition :: Maybe Integer
, modifyChannelTopic :: Maybe String
, modifyChannelNSFW :: Maybe Bool
, modifyChannelBitrate :: Maybe Integer
, modifyChannelUserRateLimit :: Maybe Integer
, modifyChannelPermissionOverwrites :: Maybe [Overwrite]
, modifyChannelParentId :: Maybe Snowflake
}
instance ToJSON ModifyChannelOptions where
toJSON ModifyChannelOptions{..} = object [(name, val) | (name, Just val) <-
[("name", toJSON <$> modifyChannelName),
("position", toJSON <$> modifyChannelPosition),
("topic", toJSON <$> modifyChannelTopic),
("nsfw", toJSON <$> modifyChannelNSFW),
("bitrate", toJSON <$> modifyChannelBitrate),
("user_limit", toJSON <$> modifyChannelUserRateLimit),
("permission_overwrites", toJSON <$> modifyChannelPermissionOverwrites),
("parent_id", toJSON <$> modifyChannelParentId) ] ]
channelMajorRoute :: ChannelRequest a -> String
channelMajorRoute c = case c of
(GetChannel chan) -> "get_chan " <> show chan
(ModifyChannel chan _) -> "mod_chan " <> show chan
(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
(CreateReaction (chan, _) _) -> "react" <> show chan
(DeleteOwnReaction (chan, _) _) -> "react" <> show chan
(DeleteUserReaction (chan, _) _ _) -> "react" <> show chan
(GetReactions (chan, _) _ _) -> "react" <> show chan
(DeleteAllReactions (chan, _)) -> "react" <> show chan
(EditMessage (chan, _) _ _) -> "get_msg " <> show chan
(DeleteMessage (chan, _)) -> "get_msg " <> show chan
(BulkDeleteMessage (chan, _)) -> "del_msgs " <> show chan
(GetChannelInvites chan) -> "invites " <> show chan
(DeleteChannelPermission chan _) -> "perms " <> show chan
(TriggerTypingIndicator chan) -> "tti " <> show chan
(GetPinnedMessages chan) -> "pins " <> show chan
(AddPinnedMessage (chan, _)) -> "pin " <> show chan
(DeletePinnedMessage (chan, _)) -> "pin " <> show chan
maybeEmbed :: Maybe Embed -> [(T.Text, Value)]
maybeEmbed = maybe [] $ \embed -> ["embed" .= embed]
baseUrl :: R.Url 'R.Https
baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion
where apiVersion = "v6"
channels :: R.Url 'R.Https
channels = baseUrl /: "channels"
channelJsonRequest :: ChannelRequest r -> JsonRequest
channelJsonRequest c = case c of
(GetChannel chan) ->
Get (channels // chan) mempty
(ModifyChannel chan patch) ->
Patch (channels // chan) (R.ReqBodyJson patch) mempty
(DeleteChannel chan) ->
Delete (channels // chan) mempty
(GetChannelMessages chan (n,timing)) ->
let n' = if n < 1 then 1 else (if n > 100 then 100 else n)
options = "limit" R.=: n' <> messageTimingToQuery timing
in Get (channels // chan /: "messages") options
(GetChannelMessage (chan, msg)) ->
Get (channels // chan /: "messages" // msg) mempty
(CreateMessage chan msg embed) ->
let content = ["content" .= msg] <> maybeEmbed embed
body = pure $ R.ReqBodyJson $ object content
in Post (channels // chan /: "messages") body mempty
(UploadFile chan fileName file) ->
let part = partFileRequestBody "file" 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" )
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
(DeleteUserReaction (chan, msgid) (name, rID) uID) ->
let emoji = "" <> name <> maybe "" ((<>) ":" . T.pack . show) rID
in Delete (channels // chan /: "messages" // msgid /: "reactions" /: emoji // uID ) mempty
(GetReactions (chan, msgid) (name, rID) (n, timing)) ->
let emoji = "" <> name <> maybe "" ((<>) ":" . T.pack . show) rID
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
(DeleteAllReactions (chan, msgid)) ->
Delete (channels // chan /: "messages" // msgid /: "reactions" ) mempty
(EditMessage (chan, msg) new embed) ->
let content = ["content" .= new] <> maybeEmbed embed
body = R.ReqBodyJson $ object content
in Patch (channels // chan /: "messages" // msg) body mempty
(DeleteMessage (chan, msg)) ->
Delete (channels // chan /: "messages" // msg) mempty
(BulkDeleteMessage (chan, msgs)) ->
let body = pure . R.ReqBodyJson $ object ["messages" .= msgs]
in Post (channels // chan /: "messages" /: "bulk-delete") body mempty
(GetChannelInvites chan) ->
Get (channels // chan /: "invites") mempty
(DeleteChannelPermission chan perm) ->
Delete (channels // chan /: "permissions" // perm) mempty
(TriggerTypingIndicator chan) ->
Post (channels // chan /: "typing") (pure R.NoReqBody) mempty
(GetPinnedMessages chan) ->
Get (channels // chan /: "pins") mempty
(AddPinnedMessage (chan, msg)) ->
Put (channels // chan /: "pins" // msg) R.NoReqBody mempty
(DeletePinnedMessage (chan, msg)) ->
Delete (channels // chan /: "pins" // msg) mempty