{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module Discord.Internal.Rest.User
( UserRequest(..)
, parseCurrentUserAvatar
, CurrentUserAvatar
) where
import Data.Aeson
import Codec.Picture
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.Lazy as BL
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 -> CurrentUserAvatar -> UserRequest User
GetCurrentUserGuilds :: UserRequest [PartialGuild]
LeaveGuild :: GuildId -> UserRequest ()
GetUserDMs :: UserRequest [Channel]
CreateDM :: UserId -> UserRequest Channel
GetUserConnections :: UserRequest [ConnectionObject]
data CurrentUserAvatar = CurrentUserAvatar T.Text
parseCurrentUserAvatar :: B.ByteString -> Either T.Text CurrentUserAvatar
parseCurrentUserAvatar :: ByteString -> Either Text CurrentUserAvatar
parseCurrentUserAvatar ByteString
bs =
case ByteString -> Either String DynamicImage
decodeImage ByteString
bs of
Left String
e -> Text -> Either Text CurrentUserAvatar
forall a b. a -> Either a b
Left (String -> Text
T.pack String
e)
Right DynamicImage
im -> CurrentUserAvatar -> Either Text CurrentUserAvatar
forall a b. b -> Either a b
Right (CurrentUserAvatar -> Either Text CurrentUserAvatar)
-> CurrentUserAvatar -> Either Text CurrentUserAvatar
forall a b. (a -> b) -> a -> b
$ Text -> CurrentUserAvatar
CurrentUserAvatar (Text -> CurrentUserAvatar) -> Text -> CurrentUserAvatar
forall a b. (a -> b) -> a -> b
$ Text
"data:image/png;base64,"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
TE.decodeUtf8 (ByteString -> ByteString
B64.encode (ByteString -> ByteString
BL.toStrict (Image PixelRGBA8 -> ByteString
forall a. PngSavable a => Image a -> ByteString
encodePng (DynamicImage -> Image PixelRGBA8
convertRGBA8 DynamicImage
im))))
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
_ CurrentUserAvatar
_) -> String
"modify_user "
(UserRequest a
GetCurrentUserGuilds) -> String
"get_user_guilds "
(LeaveGuild UserId
g) -> String
"leave_guild " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UserId -> String
forall a. Show a => a -> String
show UserId
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).
Show a =>
Url scheme -> a -> Url scheme
// UserId
user ) Option 'Https
forall a. Monoid a => a
mempty
(ModifyCurrentUser Text
name (CurrentUserAvatar Text
im)) ->
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 -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
im ]))) 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 UserId
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 -> UserId -> Url 'Https
forall a (scheme :: Scheme).
Show a =>
Url scheme -> a -> Url scheme
// UserId
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