aboutsummaryrefslogtreecommitdiff
path: root/telebot.scm
blob: eda1a0eb0f34b0a8043a5cd0fd3f7de68a96b6f7 (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
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
(module telebot (;;; basic API wrappers
                 getMe
                 getUpdates
                 sendMessage
                 forwardMessage
		 resolve-query
                 sendPhoto
                 sendAudio
                 sendDocument
                 sendSticker
                 sendVideo
                 sendVoice
                 sendLocation
                 sendVenue
                 sendContact
                 sendChatAction
                 getUserProfilePhotos
                 getFile
                 kickChatMember
                 unbanChatMember
                 answerCallbackQuery
                 editMessageText
                 editMessageCaption
                 editMessageReplyMarkup
                 answerInlineQuery
                 ;;; framework
                 is-message?
		 is-edited_message?
                 is-inline_query?
                 is-chosen_inline_result?
		 is-text?
		 is-location?
                 poll-updates
                 make-conversation-manager)
  (import chicken scheme)
  (use srfi-1
       srfi-69)
  (use openssl
       http-client)
  (use medea
       vector-lib
       data-structures)
  (use loops)

  (define-constant api-base "https://api.telegram.org/bot")

  ;;; helper functions

  (define (get-query-url token method)
    (string-append api-base token "/" method))

  (define (clean-query-parameters parameters)
    (let ((cleaned-parameters (remove (lambda (p) (equal? #f (cdr p)))
                                      parameters)))
      (if (null-list? cleaned-parameters)
        #f
        cleaned-parameters)))

  (define (resolve-query query tree)
    (fold (lambda (x y) (alist-ref x y eqv? '()))
          tree
          query))

  ;;; plain API wrappers, returning deserialized JSON

  (define-syntax wrap-api-method
    (syntax-rules (required optional)
    ((wrap-api-method method
                      (required required_params ...)
                      (optional optional_params ...))
     (define (method token
                     #!key required_params ...
                           optional_params ...)
       (if (any (lambda (x) (equal? #f x))
                (list required_params ...))
         (abort 'required-parameter-missing)
         (with-input-from-request
           (get-query-url token (symbol->string 'method))
           (clean-query-parameters
             (map (lambda (l) (cons (first l) (second l)))
                  (zip '(required_params ... optional_params ...)
                       (list required_params ... optional_params ...))))
           read-json))))))

  (wrap-api-method getMe (required) (optional))

  (wrap-api-method getUpdates
                   (required)
                   (optional offset
                             limit
                             timeout))

  (wrap-api-method sendMessage
                   (required chat_id
                             text)
                   (optional parse_mode
                             disable_web_page_preview
                             disable_notification
                             reply_to_message_id
                             reply_markup))

  (wrap-api-method forwardMessage
                   (required chat_id
                             from_chat_id
                             message_id)
                   (optional disable_notification))

  (wrap-api-method sendPhoto
                   (required chat_id
                             photo)
                   (optional caption
                             disable_notification
                             reply_to_message_id
                             reply_markup))

  (wrap-api-method sendAudio
                   (required chat_id
                             audio)
                   (optional duration
                             performer
                             title
                             disable_notification
                             reply_to_message_id
                             reply_markup))

  (wrap-api-method sendDocument
                   (required chat_id
                             document)
                   (optional caption
                             disable_notification
                             reply_to_message_id
                             reply_markup))

  (wrap-api-method sendSticker
                   (required chat_id
                             sticker)
                   (optional disable_notification
                             reply_to_message_id
                             reply_markup))

  (wrap-api-method sendVideo
                   (required chat_id
                             video)
                   (optional duration
                             width
                             height
                             caption
                             disable_notification
                             reply_to_message_id
                             reply_markup))

  (wrap-api-method sendVoice
                   (required chat_id
                             voice)
                   (optional duration
                             disable_notification
                             reply_to_message_id
                             reply_markup))

  (wrap-api-method sendLocation
                   (required chat_id
                             latitude
                             longitude)
                   (optional disable_notification
                             reply_to_message_id
                             reply_markup))

  (wrap-api-method sendVenue
                   (required chat_id
                             latitude
                             longitude
                             title
                             address)
                   (optional foursquare_id
                             disable_notification
                             reply_to_message_id
                             reply_markup))

  (wrap-api-method sendContact
                   (required chat_id
                             phone_number
                             first_name)
                   (optional last_name
                             disable_notification
                             reply_to_message_id
                             reply_markup))

  (wrap-api-method sendChatAction
                   (required chat_id
                             action)
                   (optional))

  (wrap-api-method getUserProfilePhotos
                   (required user_id)
                   (optional offset
                             limit))

  (wrap-api-method getFile
                   (required file_id)
                   (optional))

  (wrap-api-method kickChatMember
                   (required chat_id
                             user_id)
                   (optional))

  (wrap-api-method unbanChatMember
                   (required chat_id
                             user_id)
                   (optional))

  (wrap-api-method answerCallbackQuery
                   (required callback_query_id)
                   (optional text
                             show_alert))

  (wrap-api-method editMessageText
                   (required text)
                   (optional chat_id
                             message_id
                             inline_message_id
                             parse_mode
                             disable_web_page_preview
                             reply_markup))

  (wrap-api-method editMessageCaption
                   (required)
                   (optional chat_id
                             message_id
                             inline_message_id
                             caption
                             reply_markup))

  (wrap-api-method editMessageReplyMarkup
                   (required)
                   (optional chat_id
                             message_id
                             inline_message_id
                             reply_markup))

  (wrap-api-method answerInlineQuery
                   (required inline_query_id
                             results)
                   (optional cache_time
                             is_personal
                             next_offset))

  ;;; framework
  (define (is-update-type? type update)
    (not (equal? '() (resolve-query type update))))

  (define (update-predicate types)
    (lambda (update)
      (any (lambda (type) (is-update-type? type update)) types)))

  (define is-message?              (update-predicate '((message) (edited_message)) ))
  (define is-edited_message?       (update-predicate '((edited_message)) ))
  (define is-inline_query?         (update-predicate '((inline_query)) ))
  (define is-chosen_inline_result? (update-predicate '((chosen_inline_result)) ))

  (define is-text?                 (update-predicate '((message text) (edited_message text)) ))
  (define is-location?             (update-predicate '((message location) (edited_message location)) ))

  (define (poll-updates token handler)
    (let ((offset 0))
      (do-forever
        (vector-for-each (lambda (i u)
                           (handler u)
                           (set! offset (+ 1 (alist-ref 'update_id u))))
                         (alist-ref 'result
                                    (getUpdates token
                                                offset:  offset
                                                timeout: 60))))))

  (define (make-conversation-manager token make-handler)
    (let ((token         token)
          (conversations (make-hash-table)))
      (lambda (update)
        (if (is-message? update)
          (let ((chat_id (resolve-query '(message from id) update)))
            (if (hash-table-exists? conversations chat_id)
              ((hash-table-ref conversations chat_id) update)
              (hash-table-set! conversations
                               chat_id
                               (make-handler token chat_id))))))))
)