aboutsummaryrefslogtreecommitdiff
path: root/telebot.scm
blob: 5e95e1d32223ff641bac42de51057c96d91b28a6 (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
(module telebot (getMe
                 getUpdates
                 sendMessage
                 forwardMessage
                 sendPhoto
                 sendAudio
                 sendDocument
                 sendSticker
                 sendVideo
                 sendVoice
                 sendLocation
                 sendChatAction
                 getUserProfilePhotos
                 getFile
                 pollUpdates)
  (import chicken scheme)
  (use srfi-1)
  (use openssl)
  (use http-client)
  (use medea)
  (use loops)
  (use vector-lib)
  (use data-structures)

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

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

  ;;; framework

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