{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module Discord.Rest.User
( UserRequest(..)
) where
import Data.Aeson
import Data.Monoid (mempty, (<>))
import Network.HTTP.Req ((/:))
import qualified Network.HTTP.Req as R
import Discord.Rest.Prelude
import Discord.Types
instance Request (UserRequest a) where
majorRoute = userMajorRoute
jsonRequest = userJsonRequest
data UserRequest a where
GetCurrentUser :: UserRequest User
GetUser :: Snowflake -> UserRequest User
GetCurrentUserGuilds :: UserRequest [PartialGuild]
LeaveGuild :: Snowflake -> UserRequest ()
GetUserDMs :: UserRequest [Channel]
CreateDM :: Snowflake -> UserRequest Channel
userMajorRoute :: UserRequest a -> String
userMajorRoute c = case c of
(GetCurrentUser) -> "me "
(GetUser _) -> "user "
(GetCurrentUserGuilds) -> "get_user_guilds "
(LeaveGuild g) -> "leave_guild " <> show g
(GetUserDMs) -> "get_dms "
(CreateDM _) -> "make_dm "
baseUrl :: R.Url 'R.Https
baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion
where apiVersion = "v6"
users :: R.Url 'R.Https
users = baseUrl /: "users"
userJsonRequest :: UserRequest r -> JsonRequest
userJsonRequest c = case c of
(GetCurrentUser) -> Get (users /: "@me") mempty
(GetUser user) -> Get (users // user ) mempty
(GetCurrentUserGuilds) -> Get (users /: "@me" /: "guilds") mempty
(LeaveGuild guild) -> Delete (users /: "@me" /: "guilds" // guild) mempty
(GetUserDMs) -> Get (users /: "@me" /: "channels") mempty
(CreateDM user) ->
let body = R.ReqBodyJson $ object ["recipient_id" .= user]
in Post (users /: "@me" /: "channels") (pure body) mempty