Persistable.hs

module Network.Telegram.API.Bot.Property.Persistable (Persistable (..), Payload, PL (..), Capacity (..)) where

import "aeson" Data.Aeson (FromJSON, Value, decode, object, (.=))
import "base" Control.Exception (try)
import "base" Control.Monad (Monad ((>>=)), join)
import "base" Data.Function (flip, (.), ($))
import "base" Data.Functor (Functor (fmap), (<$>))
import "base" Data.Int (Int, Int64)
import "base" Data.Maybe (fromJust)
import "base" Data.Semigroup (Semigroup ((<>)))
import "base" Data.String (String)
import "base" Data.Tuple (snd)
import "http-client" Network.HTTP.Client (Response (responseBody))
import "text" Data.Text (Text, unpack)
import "transformers" Control.Monad.Trans.Class (lift)
import "transformers" Control.Monad.Trans.Except (ExceptT (ExceptT))
import "transformers" Control.Monad.Trans.Reader (ask)
import "wreq" Network.Wreq.Session (post)

import Network.Telegram.API.Bot.Core (Telegram, Token (Token), Ok, result)
import Network.Telegram.API.Bot.Object (Object, Keyboard, Notification, Member, Sender)
import Network.Telegram.API.Bot.Object.Update.Message (Message, Messaging (Directly, Forwarding, Replying))

data Capacity = Fetch | Post | Edit | Purge

newtype PL c o a = PL a

type family Payload (c :: k) o = r | r -> o c

type instance Payload 'Post Keyboard = PL 'Post Keyboard (Int64, Text, Keyboard)
type instance Payload 'Edit Keyboard = PL 'Edit Keyboard (Int64, Int, Keyboard)
type instance Payload 'Fetch Member = PL 'Fetch Member (Int64, Int)
type instance Payload 'Purge Message = PL 'Purge Message (Int64, Int)
type instance Payload 'Post Notification = PL 'Post Notification (Text, Text)
type instance Payload 'Fetch Sender = PL 'Fetch Sender ()

type instance Payload 'Directly Message = PL 'Directly Message (Int64, Text)
type instance Payload 'Forwarding Message = PL 'Forwarding Message (Int64, Int64, Int)
type instance Payload 'Replying Message = PL 'Replying Message (Int64, Int, Text)

class Object o => Persistable c o where
	{-# MINIMAL payload, endpoint #-}
	payload :: Payload c o -> Value
	endpoint :: Payload c o -> String
	request :: FromJSON r => Payload c o -> Telegram e r
	request x = request' (endpoint x) (payload x) where

		request' :: forall a e . FromJSON a => String -> Value -> Telegram e a
		request' e p = snd <$> ask >>= \(session, Token token) -> lift . ExceptT . try
			. fmap (fromJust . join . fmap result . decode @(Ok a) . responseBody)
				. flip (post session) p $ "https://api.telegram.org/" <> unpack token <> "/" <> e

instance Persistable 'Edit Keyboard where
	payload (PL (chat_id, message_id, reply_markup)) = object
		["chat_id" .= chat_id, "message_id" .= message_id, "reply_markup" .= reply_markup]
	endpoint _ = "editMessageReplyMarkup"

instance Persistable 'Post Keyboard where
	payload (PL (chat_id, text, kb)) = object
		["chat_id" .= chat_id, "text" .= text, "reply_markup" .= kb]
	endpoint _ = "sendMessage"

instance Persistable 'Fetch Member where
	payload (PL (chat_id, user_id)) = object ["chat_id" .= chat_id, "user_id" .= user_id]
	endpoint _ = "getChatMember"

instance Persistable 'Directly Message where
	payload (PL (chat_id, text)) = object ["chat_id" .= chat_id, "text" .= text]
	endpoint _ = "sendMessage"

instance Persistable 'Forwarding Message where
	payload (PL (chat_id, from_chat_id, message_id)) = object
		["chat_id" .= chat_id, "from_chat_id" .= from_chat_id, "message_id" .= message_id]
	endpoint _ = "forwardMessage"

instance Persistable 'Replying Message where
	payload (PL (chat_id, reply_to_message_id, text)) = object
		["chat_id" .= chat_id, "reply_to_message_id" .= reply_to_message_id, "text" .= text]
	endpoint _ = "sendMessage"

instance Persistable 'Purge Message where
	payload (PL (chat_id, message_id)) = object ["chat_id" .= chat_id, "message_id" .= message_id]
	endpoint _ = "deleteMessage"

instance Persistable 'Post Notification where
	payload (PL (cbq_id, text)) = object ["callback_query_id" .= cbq_id, "text" .= text]
	endpoint _ = "answerCallbackQuery"

instance Persistable 'Fetch Sender where
	payload (PL ()) = object []
	endpoint _ = "getMe"