aboutsummaryrefslogtreecommitdiff
path: root/telebot.scm
blob: b5ca1e30f95b258400532399c02aff5ee913eade (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
(module telebot (;;; basic API wrappers
                 getMe
                 getUpdates
                 sendMessage
                 forwardMessage
                 sendPhoto
                 sendAudio
                 sendDocument
                 sendSticker
                 sendVideo
                 sendVoice
                 sendLocation
                 sendChatAction
                 getUserProfilePhotos
                 getFile
                 answerInlineQuery
                 ;;; framework
                 is-message?
                 is-inline_query?
                 is-chosen_inline_result?
                 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))
          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 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 answerInlineQuery
                   (required inline_query_id
                             results)
                   (optional cache_time
                             is_personal
                             next_offset))

  ;;; framework

  (define (update-predicate type)
    (lambda (update)
      (not (equal? #f (alist-ref type update)))))

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

  (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))))))))
)