Member.hs

module Network.API.Telegram.Bot.Object.Member
	( module Exports, Member (..), Until (..), Can (..), Cannot (..)
	, Kick (..), Unban (..), Restrict (..), Promote (..)) where

import Network.API.Telegram.Bot.Object.Member.Powers as Exports
import Network.API.Telegram.Bot.Object.Member.Restrictions as Exports

import "aeson" Data.Aeson (FromJSON (parseJSON), Value (Object), withObject, (.:))
import "base" Control.Applicative ((<*>))
import "base" Control.Monad (fail, (>>=))
import "base" Data.Bool (Bool (True, False))
import "base" Data.Function (($))
import "base" Data.Functor ((<$>))
import "base" Data.Int (Int, Int64)
import "base" Data.Semigroup ((<>))
import "base" Text.Show (Show)
import "data-default" Data.Default (Default (def))
import "text" Data.Text (Text)

import Network.API.Telegram.Bot.Object.Sender (Sender)
import Network.API.Telegram.Bot.Property.Accessible (Accessible (access))
import Network.API.Telegram.Bot.Property.Identifiable (Identifiable (Identificator, ident))
import Network.API.Telegram.Bot.Property.Persistable (Persistable (Payload, Returning, payload, endpoint))
import Network.API.Telegram.Bot.Utils (field)

data Member
	= Creator Sender
	| Administrator Sender Bool Powers
	| Member Sender
	| Restricted Sender Restrictions Int
	| Left Sender
	| Kicked Sender Int
	deriving Show

instance Accessible Sender Member where
	access f (Creator sender) = (\sender' -> Creator sender') <$> f sender
	access f (Administrator sender cbe powers) = (\sender' -> Administrator sender' cbe powers) <$> f sender
	access f (Member sender) = (\sender' -> Member sender') <$> f sender
	access f (Restricted sender restrictions until) = (\sender' -> Restricted sender' restrictions until) <$> f sender
	access f (Left sender) = (\sender' -> Left sender') <$> f sender
	access f (Kicked sender until) = (\sender' -> Kicked sender' until) <$> f sender

instance Identifiable Member where
	type Identificator Member = Sender
	ident (Creator sender) = sender
	ident (Administrator sender _ _) = sender
	ident (Member sender) = sender
	ident (Restricted sender _ _) = sender
	ident (Left sender) = sender
	ident (Kicked sender _) = sender

instance FromJSON Member where
	parseJSON = withObject "Member" $ \v -> v .: "status" >>= \case
		("creator" :: Text) -> Creator <$> v .: "user"
		("administrator" :: Text) -> Administrator <$> v .: "user" <*> v .: "can_be_edited" <*> parseJSON (Object v)
		("member" :: Text) -> Member <$> v .: "user"
		("restricted" :: Text) -> Restricted <$> v .: "user" <*> parseJSON (Object v) <*> v .: "until_date"
		("left" :: Text) -> Left <$> v .: "user"
		("kicked" :: Text) -> Kicked <$> v .: "user" <*> v.: "until_date"
		_ -> fail "Status of chat member is not defined"

newtype Can a = Can a

instance Default (Can Restrictions) where
	def = Can $ Restrictions True True True True

instance Default (Can Powers) where
	def = Can $ Powers True True True True True True True True

newtype Cannot a = Cannot a

instance Default (Cannot Restrictions) where
	def = Cannot $ Restrictions False False False False

instance Default (Cannot Powers) where
	def = Cannot $ Powers False False False False False False False False

-- | Ban forever or until some date (between 30 seconds and 366 days)
data Until = Forever | Until Int

data Kick a where
	Kick :: Int64 -> Int -> Until -> Kick Member

instance Persistable (Kick Member) where
	type Payload (Kick Member) = Kick Member
	type Returning (Kick Member) = ()
	payload (Kick chat_id user_id Forever) =
		field "chat_id" chat_id <> field "user_id" user_id
	payload (Kick chat_id user_id (Until until_date)) = field "chat_id" chat_id
		<> field "user_id" user_id <> field "until_date" until_date
	endpoint _ = "kickChatMember"

data Unban a where
	Unban :: Int64 -> Int -> Unban Member

instance Persistable (Unban Member) where
	type Payload (Unban Member) = Unban Member
	type Returning (Unban Member) = ()
	payload (Unban chat_id user_id) =
		field "chat_id" chat_id
		<> field "user_id" user_id
	endpoint _ = "unbanChatMember"

data Restrict a where
	Restrict :: Int64 -> Int -> Until -> Restrictions -> Restrict Member

instance Persistable (Restrict Member) where
	type Payload (Restrict Member) = Restrict Member
	type Returning (Restrict Member) = ()
	payload (Restrict chat_id user_id Forever (Restrictions send_msgs send_media_msgs send_other_msgs wp_previews)) =
		field "chat_id" chat_id <> field "user_id" user_id
		<> field "can_send_messages" send_msgs <> field "can_send_media_messages" send_media_msgs
		<> field "can_send_other_messages" send_other_msgs <> field "can_add_web_page_previews" wp_previews
	payload (Restrict chat_id user_id (Until until_date) (Restrictions send_msgs send_media_msgs send_other_msgs wp_previews)) =
		field "chat_id" chat_id <> field "user_id" user_id <> field "until_date" until_date
		<> field "can_send_messages" send_msgs <> field "can_send_media_messages" send_media_msgs
		<> field "can_send_other_messages" send_other_msgs <> field "can_add_web_page_previews" wp_previews
	endpoint _ = "restrictChatMember"

data Promote a where
	Promote :: Int64 -> Int -> Until -> Powers -> Promote Member

instance Persistable (Promote Member) where
	type Payload (Promote Member) = Promote Member
	type Returning (Promote Member) = ()
	payload (Promote chat_id user_id Forever (Powers change_info post_msgs edit_msgs delete_msgs invite_users restrict_members pin_msgs promote_members)) =
		field "chat_id" chat_id <> field "user_id" user_id
		<> field "can_change_info" change_info <> field "can_post_messages" post_msgs
		<> field "can_edit_messages" edit_msgs <> field "can_delete_messages" delete_msgs
		<> field "can_invite_users" invite_users <> field "can_restrict_members" restrict_members
		<> field "can_pin_messages" pin_msgs <> field "can_promote_members" promote_members
	payload (Promote chat_id user_id (Until until_date) (Powers change_info post_msgs edit_msgs delete_msgs invite_users restrict_members pin_msgs promote_members)) =
		field "chat_id" chat_id <> field "user_id" user_id <> field "until_date" until_date
		<> field "can_change_info" change_info <> field "can_post_messages" post_msgs
		<> field "can_edit_messages" edit_msgs <> field "can_delete_messages" delete_msgs
		<> field "can_invite_users" invite_users <> field "can_restrict_members" restrict_members
		<> field "can_pin_messages" pin_msgs <> field "can_promote_members" promote_members
	endpoint _ = "promoteChatMember"