{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module Discord.Internal.Rest.User
( UserRequest(..)
, parseAvatarImage
) where
import Data.Aeson
import Network.HTTP.Req ((/:), (/~))
import qualified Network.HTTP.Req as R
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as B64
import Discord.Internal.Rest.Prelude
import Discord.Internal.Types
instance Request (UserRequest a) where
majorRoute :: UserRequest a -> String
majorRoute = UserRequest a -> String
forall a. UserRequest a -> String
userMajorRoute
jsonRequest :: UserRequest a -> JsonRequest
jsonRequest = UserRequest a -> JsonRequest
forall a. UserRequest a -> JsonRequest
userJsonRequest
data UserRequest a where
GetCurrentUser :: UserRequest User
GetUser :: UserId -> UserRequest User
ModifyCurrentUser :: T.Text -> Base64Image User -> UserRequest User
GetCurrentUserGuilds :: UserRequest [PartialGuild]
LeaveGuild :: GuildId -> UserRequest ()
GetUserDMs :: UserRequest [Channel]
CreateDM :: UserId -> UserRequest Channel
GetUserConnections :: UserRequest [ConnectionObject]
parseAvatarImage :: B.ByteString -> Either T.Text (Base64Image User)
parseAvatarImage :: ByteString -> Either Text (Base64Image User)
parseAvatarImage ByteString
bs
| Just Text
mime <- ByteString -> Maybe Text
getMimeType ByteString
bs = Base64Image User -> Either Text (Base64Image User)
forall a b. b -> Either a b
Right (Text -> Text -> Base64Image User
forall a. Text -> Text -> Base64Image a
Base64Image Text
mime (ByteString -> Text
TE.decodeUtf8 (ByteString -> ByteString
B64.encode ByteString
bs)))
| Bool
otherwise = Text -> Either Text (Base64Image User)
forall a b. a -> Either a b
Left Text
"Unsupported image format provided"
userMajorRoute :: UserRequest a -> String
userMajorRoute :: UserRequest a -> String
userMajorRoute UserRequest a
c = case UserRequest a
c of
(UserRequest a
GetCurrentUser) -> String
"me "
(GetUser UserId
_) -> String
"user "
(ModifyCurrentUser Text
_ Base64Image User
_) -> String
"modify_user "
(UserRequest a
GetCurrentUserGuilds) -> String
"get_user_guilds "
(LeaveGuild GuildId
g) -> String
"leave_guild " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> GuildId -> String
forall a. Show a => a -> String
show GuildId
g
(UserRequest a
GetUserDMs) -> String
"get_dms "
(CreateDM UserId
_) -> String
"make_dm "
(UserRequest a
GetUserConnections) -> String
"connections "
users :: R.Url 'R.Https
users :: Url 'Https
users = Url 'Https
baseUrl Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"users"
userJsonRequest :: UserRequest r -> JsonRequest
userJsonRequest :: UserRequest r -> JsonRequest
userJsonRequest UserRequest r
c = case UserRequest r
c of
(UserRequest r
GetCurrentUser) -> Url 'Https -> Option 'Https -> JsonRequest
Get (Url 'Https
users Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"@me") Option 'Https
forall a. Monoid a => a
mempty
(GetUser UserId
user) -> Url 'Https -> Option 'Https -> JsonRequest
Get (Url 'Https
users Url 'Https -> UserId -> Url 'Https
forall a (scheme :: Scheme).
ToHttpApiData a =>
Url scheme -> a -> Url scheme
/~ UserId
user ) Option 'Https
forall a. Monoid a => a
mempty
(ModifyCurrentUser Text
name Base64Image User
b64im) ->
Url 'Https
-> RestIO (ReqBodyJson Value) -> Option 'Https -> JsonRequest
forall a.
HttpBody a =>
Url 'Https -> RestIO a -> Option 'Https -> JsonRequest
Patch (Url 'Https
users Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"@me") (ReqBodyJson Value -> RestIO (ReqBodyJson Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> ReqBodyJson Value
forall a. a -> ReqBodyJson a
R.ReqBodyJson ([Pair] -> Value
object [ Text
"username" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
name
, Text
"avatar" Text -> Base64Image User -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Base64Image User
b64im ]))) Option 'Https
forall a. Monoid a => a
mempty
(UserRequest r
GetCurrentUserGuilds) -> Url 'Https -> Option 'Https -> JsonRequest
Get (Url 'Https
users Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"@me" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"guilds") Option 'Https
forall a. Monoid a => a
mempty
(LeaveGuild GuildId
guild) -> Url 'Https -> Option 'Https -> JsonRequest
Delete (Url 'Https
users Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"@me" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"guilds" Url 'Https -> GuildId -> Url 'Https
forall a (scheme :: Scheme).
ToHttpApiData a =>
Url scheme -> a -> Url scheme
/~ GuildId
guild) Option 'Https
forall a. Monoid a => a
mempty
(UserRequest r
GetUserDMs) -> Url 'Https -> Option 'Https -> JsonRequest
Get (Url 'Https
users Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"@me" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"channels") Option 'Https
forall a. Monoid a => a
mempty
(CreateDM UserId
user) ->
let body :: ReqBodyJson Value
body = Value -> ReqBodyJson Value
forall a. a -> ReqBodyJson a
R.ReqBodyJson (Value -> ReqBodyJson Value) -> Value -> ReqBodyJson Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Text
"recipient_id" Text -> UserId -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= UserId
user]
in Url 'Https
-> RestIO (ReqBodyJson Value) -> Option 'Https -> JsonRequest
forall a.
HttpBody a =>
Url 'Https -> RestIO a -> Option 'Https -> JsonRequest
Post (Url 'Https
users Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"@me" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"channels") (ReqBodyJson Value -> RestIO (ReqBodyJson Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReqBodyJson Value
body) Option 'Https
forall a. Monoid a => a
mempty
(UserRequest r
GetUserConnections) ->
Url 'Https -> Option 'Https -> JsonRequest
Get (Url 'Https
users Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"@me" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"connections") Option 'Https
forall a. Monoid a => a
mempty