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

-- | Provides actions for Channel API interactions
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 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 -> Base64Image User -> 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]

-- | @parseAvatarImage bs@ will attempt to convert the given image bytestring
-- @bs@ to the base64 format expected by the Discord API. It may return Left
-- with an error reason if the image format could not be predetermined from the
-- opening magic bytes. This function does /not/ validate the rest of the image,
-- and this is up to the library user to check themselves.
--
-- This function accepts all file types accepted by 'getMimeType'.
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