{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Provides actions for Channel API interactions
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 constructor for requests. See <https://discord.com/developers/docs/resources/ API>
data UserRequest a where
  -- | Returns the 'User' object of the requester's account. For OAuth2, this requires
  --   the identify scope, which will return the object without an email, and optionally
  --   the email scope, which returns the object with an email.
  GetCurrentUser       :: UserRequest User
  -- | Returns a 'User' for a given user ID
  GetUser              :: UserId -> UserRequest User
  -- | Modify user's username & avatar pic
  ModifyCurrentUser    :: T.Text -> CurrentUserAvatar -> UserRequest User
  -- | Returns a list of user 'Guild' objects the current user is a member of.
  --   Requires the guilds OAuth2 scope.
  GetCurrentUserGuilds :: UserRequest [PartialGuild]
  -- | Leave a guild.
  LeaveGuild           :: GuildId -> UserRequest ()
  -- | Returns a list of DM 'Channel' objects
  GetUserDMs           :: UserRequest [Channel]
  -- | Create a new DM channel with a user. Returns a DM 'Channel' object.
  CreateDM             :: UserId -> UserRequest Channel

  GetUserConnections   :: UserRequest [ConnectionObject]

-- | Formatted avatar data https://discord.com/developers/docs/resources/user#avatar-data
data CurrentUserAvatar = CurrentUserAvatar T.Text
  deriving (Int -> CurrentUserAvatar -> ShowS
[CurrentUserAvatar] -> ShowS
CurrentUserAvatar -> String
(Int -> CurrentUserAvatar -> ShowS)
-> (CurrentUserAvatar -> String)
-> ([CurrentUserAvatar] -> ShowS)
-> Show CurrentUserAvatar
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CurrentUserAvatar] -> ShowS
$cshowList :: [CurrentUserAvatar] -> ShowS
show :: CurrentUserAvatar -> String
$cshow :: CurrentUserAvatar -> String
showsPrec :: Int -> CurrentUserAvatar -> ShowS
$cshowsPrec :: Int -> CurrentUserAvatar -> ShowS
Show, CurrentUserAvatar -> CurrentUserAvatar -> Bool
(CurrentUserAvatar -> CurrentUserAvatar -> Bool)
-> (CurrentUserAvatar -> CurrentUserAvatar -> Bool)
-> Eq CurrentUserAvatar
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CurrentUserAvatar -> CurrentUserAvatar -> Bool
$c/= :: CurrentUserAvatar -> CurrentUserAvatar -> Bool
== :: CurrentUserAvatar -> CurrentUserAvatar -> Bool
$c== :: CurrentUserAvatar -> CurrentUserAvatar -> Bool
Eq, Eq CurrentUserAvatar
Eq CurrentUserAvatar
-> (CurrentUserAvatar -> CurrentUserAvatar -> Ordering)
-> (CurrentUserAvatar -> CurrentUserAvatar -> Bool)
-> (CurrentUserAvatar -> CurrentUserAvatar -> Bool)
-> (CurrentUserAvatar -> CurrentUserAvatar -> Bool)
-> (CurrentUserAvatar -> CurrentUserAvatar -> Bool)
-> (CurrentUserAvatar -> CurrentUserAvatar -> CurrentUserAvatar)
-> (CurrentUserAvatar -> CurrentUserAvatar -> CurrentUserAvatar)
-> Ord CurrentUserAvatar
CurrentUserAvatar -> CurrentUserAvatar -> Bool
CurrentUserAvatar -> CurrentUserAvatar -> Ordering
CurrentUserAvatar -> CurrentUserAvatar -> CurrentUserAvatar
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CurrentUserAvatar -> CurrentUserAvatar -> CurrentUserAvatar
$cmin :: CurrentUserAvatar -> CurrentUserAvatar -> CurrentUserAvatar
max :: CurrentUserAvatar -> CurrentUserAvatar -> CurrentUserAvatar
$cmax :: CurrentUserAvatar -> CurrentUserAvatar -> CurrentUserAvatar
>= :: CurrentUserAvatar -> CurrentUserAvatar -> Bool
$c>= :: CurrentUserAvatar -> CurrentUserAvatar -> Bool
> :: CurrentUserAvatar -> CurrentUserAvatar -> Bool
$c> :: CurrentUserAvatar -> CurrentUserAvatar -> Bool
<= :: CurrentUserAvatar -> CurrentUserAvatar -> Bool
$c<= :: CurrentUserAvatar -> CurrentUserAvatar -> Bool
< :: CurrentUserAvatar -> CurrentUserAvatar -> Bool
$c< :: CurrentUserAvatar -> CurrentUserAvatar -> Bool
compare :: CurrentUserAvatar -> CurrentUserAvatar -> Ordering
$ccompare :: CurrentUserAvatar -> CurrentUserAvatar -> Ordering
$cp1Ord :: Eq CurrentUserAvatar
Ord)

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 -> ShowS
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 [ Key
"username" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
name
                                                           , Key
"avatar" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> 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 [Key
"recipient_id" Key -> UserId -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> 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