summaryrefslogtreecommitdiff
path: root/Network/API/Telegram/Bot/Property/Persistable.hs
blob: 302d90f7d34a6fd0b01abd966475461208d3c32c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
module Network.API.Telegram.Bot.Property.Persistable
	(Persistable (..), Capacity (..), Inform (..), Way (..)) where

import "aeson" Data.Aeson (FromJSON, Value, decode, object, (.=))
import "base" Control.Exception (try)
import "base" Control.Monad (Monad ((>>=)), join)
import "base" Data.Bool (Bool (False, True))
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 "tagged" Data.Tagged (Tagged, untag)
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.API.Telegram.Bot.Core (Telegram, Token (Token), Ok, result)
import Network.API.Telegram.Bot.Object (Object, Keyboard, Notification, Member, Sender)
import Network.API.Telegram.Bot.Object.Update.Message (Message)
import Network.API.Telegram.Bot.Object.Update.Message.Content.Location (Location (Location))

data Inform = Silently | Notify

data Way = Directly | Forwarding | Replying

data Capacity object = Send Inform Way object | Post object | Fetch object | Edit object | Purge object

class Object object => Persistable capacity object where
	{-# MINIMAL payload, endpoint #-}
	type Payload (capacity :: * -> Capacity *) object = payload | payload -> capacity object
	payload :: Payload capacity object -> Value
	endpoint :: Payload capacity object -> String
	request :: FromJSON r => Payload capacity object -> 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
	type instance Payload 'Edit Keyboard
		= Tagged ('Edit Keyboard) (Int64, Int, Keyboard)
	payload (untag -> (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
	type instance Payload 'Post Keyboard
		= Tagged ('Post Keyboard) (Int64, Text, Keyboard)
	payload (untag -> (chat_id, text, kb)) = object
		["chat_id" .= chat_id, "text" .= text, "reply_markup" .= kb]
	endpoint _ = "sendMessage"

instance Persistable ('Send 'Notify 'Directly) Location where
	type instance Payload ('Send 'Notify 'Directly) Location
		= Tagged ('Send 'Notify 'Directly Location) (Int64, Location, Int)
	payload (untag -> (chat_id, Location latitude longitude, live_period)) =
		object ["chat_id" .= chat_id, "latitude" .= latitude, "longitude" .= longitude,
			"live_period" .= live_period, "disable_notification" .= False]
	endpoint _ = "sendLocation"

instance Persistable ('Send 'Silently 'Directly) Location where
	type instance Payload ('Send 'Silently 'Directly) Location
		= Tagged ('Send 'Silently 'Directly Location) (Int64, Location, Int)
	payload (untag -> (chat_id, Location latitude longitude, live_period)) =
		object ["chat_id" .= chat_id, "latitude" .= latitude, "longitude" .= longitude,
			"live_period" .= live_period, "disable_notification" .= True]
	endpoint _ = "sendLocation"

instance Persistable ('Send 'Notify 'Replying) Location where
	type instance Payload ('Send 'Notify 'Replying) Location
		= Tagged ('Send 'Notify 'Replying Location) (Int64, Location, Int, Int)
	payload (untag -> (chat_id, Location latitude longitude, live_period, reply_to_message_id)) = object
		["chat_id" .= chat_id, "latitude" .= latitude, "longitude" .= longitude, "live_period" .= live_period,
			"reply_to_message_id" .= reply_to_message_id, "disable_notification" .= False]
	endpoint _ = "sendLocation"

instance Persistable ('Send 'Silently 'Replying) Location where
	type instance Payload ('Send 'Silently 'Replying) Location
		= Tagged ('Send 'Silently 'Replying Location) (Int64, Location, Int, Int)
	payload (untag -> (chat_id, Location latitude longitude, live_period, reply_to_message_id)) = object
		["chat_id" .= chat_id, "latitude" .= latitude, "longitude" .= longitude, "live_period" .= live_period,
			"reply_to_message_id" .= reply_to_message_id, "disable_notification" .= True]
	endpoint _ = "sendLocation"

instance Persistable 'Fetch Member where
	type instance Payload 'Fetch Member = Tagged ('Fetch Member) (Int64, Int)
	payload (untag -> (chat_id, user_id)) = object ["chat_id" .= chat_id, "user_id" .= user_id]
	endpoint _ = "getChatMember"

instance Persistable ('Send 'Notify 'Directly) Message where
	type instance Payload ('Send 'Notify 'Directly) Message
		= Tagged ('Send 'Notify 'Directly Message) (Int64, Text)
	payload (untag -> (chat_id, text)) = object
		["chat_id" .= chat_id, "text" .= text, "disable_notification" .= False]
	endpoint _ = "sendMessage"

instance Persistable ('Send 'Silently 'Directly) Message where
	type instance Payload ('Send 'Silently 'Directly) Message
		= Tagged ('Send 'Silently 'Directly Message) (Int64, Text)
	payload (untag -> (chat_id, text)) = object
		["chat_id" .= chat_id, "text" .= text, "disable_notification" .= True]
	endpoint _ = "sendMessage"

instance Persistable ('Send 'Notify 'Forwarding) Message where
	type instance Payload ('Send 'Notify 'Forwarding) Message
		= Tagged ('Send 'Notify 'Forwarding Message) (Int64, Int64, Int)
	payload (untag -> (chat_id, from_chat_id, message_id)) = object
		["chat_id" .= chat_id, "from_chat_id" .= from_chat_id,
			"message_id" .= message_id, "disable_notification" .= False]
	endpoint _ = "forwardMessage"

instance Persistable ('Send 'Silently 'Forwarding) Message where
	type instance Payload ('Send 'Silently 'Forwarding) Message
		= Tagged ('Send 'Silently 'Forwarding Message) (Int64, Int64, Int)
	payload (untag -> (chat_id, from_chat_id, message_id)) = object
		["chat_id" .= chat_id, "from_chat_id" .= from_chat_id,
			"message_id" .= message_id, "disable_notification" .= True]
	endpoint _ = "forwardMessage"

instance Persistable ('Send 'Notify 'Replying) Message where
	type instance Payload ('Send 'Notify 'Replying) Message
		= Tagged ('Send 'Notify 'Replying Message) (Int64, Int, Text)
	payload (untag -> (chat_id, reply_to_message_id, text)) = object
		["chat_id" .= chat_id, "reply_to_message_id" .= reply_to_message_id,
			"text" .= text, "disable_notification" .= False]
	endpoint _ = "sendMessage"

instance Persistable ('Send 'Silently 'Replying) Message where
	type instance Payload ('Send 'Silently 'Replying) Message
		= Tagged ('Send 'Silently 'Replying Message) (Int64, Int, Text)
	payload (untag -> (chat_id, reply_to_message_id, text)) = object
		["chat_id" .= chat_id, "reply_to_message_id" .= reply_to_message_id,
			"text" .= text, "disable_notification" .= True]
	endpoint _ = "sendMessage"

instance Persistable 'Edit Message where
	type instance Payload 'Edit Message = Tagged ('Edit Message) (Int64, Int, Text)
	payload (untag -> (chat_id, message_id, text)) = object
		["chat_id" .= chat_id, "message_id" .= message_id, "text" .= text]
	endpoint _ = "editMessageText"

instance Persistable 'Purge Message where
	type instance Payload 'Purge Message = Tagged ('Purge Message) (Int64, Int)
	payload (untag -> (chat_id, message_id)) = object ["chat_id" .= chat_id, "message_id" .= message_id]
	endpoint _ = "deleteMessage"
--
instance Persistable 'Post Notification where
	type instance Payload 'Post Notification = Tagged ('Post Notification) (Text, Text)
	payload (untag -> (cbq_id, text)) = object ["callback_query_id" .= cbq_id, "text" .= text]
	endpoint _ = "answerCallbackQuery"
--
instance Persistable 'Fetch Sender where
	type instance Payload 'Fetch Sender = Tagged ('Fetch Sender) ()
	payload _ = object []
	endpoint _ = "getMe"