blob: 162938ef546b44576f0b1794789f9ed74fa81ad9 (
plain) (
blame)
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
|
;; SPDX-License-Identifier: EUPL-1.2
;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
(defpackage :ukkoclot/bot/impl
(:use :c2cl :iterate :ukkoclot/config :ukkoclot/log)
(:import-from :anaphora :aand :acond :it)
(:import-from :cl+ssl)
(:import-from :dex)
(:import-from :ukkoclot/strings :lisp->snake-case)
(:local-nicknames
(:jzon :com.inuoe.jzon))
(:export
:bot :bot-p :make-bot :fixup-value :do-call :parse-value
:bot-config :bot-db :bot-base-uri :bot-power-on :bot-username% :bot-id%))
(in-package :ukkoclot/bot/impl)
(defgeneric parse-value (type json)
(:documentation "Parse value of TYPE from the parsed JSON")
(:method (type json)
(log-error "I don't know how to parse simple type ~A!" type)
(error "I don't know how to parse simple type ~A!" type))
(:method ((type (eql 'boolean)) json)
(check-type json boolean)
json)
(:method ((type (eql 'integer)) json)
(check-type json integer)
json)
(:method ((type (eql 'null)) json)
(check-type json null)
json)
(:method ((type (eql 'string)) json)
(check-type json string)
json))
(defun try-parse-value (type json)
(handler-case (values t (parse-value type json))
(error () (values nil nil))))
(defmethod parse-value ((type cons) json)
(cond ((and (eq (car type) 'array)
(null (cddr type)))
(when json
(let ((element-type (cadr type)))
(iter (for element in-vector json)
(collect (parse-value element-type element) result-type vector)))))
((eq (car type) 'or)
(iter (for el-type in (cdr type))
(multiple-value-bind (success res) (try-parse-value el-type json)
(when success
(return res)))
(finally
(error "Failed to parse ~S as ~A!" json type))))
(t
(error "I don't know how to parse complex type ~A!" type))))
(defgeneric fixup-value (value)
(:documentation "Fixup top-level VALUE before passing it onto telegram")
(:method (value)
(jzon:stringify value))
(:method ((value null))
value)
(:method ((value number))
value)
(:method ((value pathname))
value)
(:method ((value string))
value))
(defstruct (bot (:constructor make-bot%))
(config (error "No value given for config") :read-only t)
(db (error "No value given for DB") :read-only t)
(base-uri (error "No value given for base-uri") :read-only t)
(power-on t :type boolean)
(username% nil :type (or string null))
(id% nil :type (or integer null)))
(defun make-bot (config db)
(let ((base-uri (concatenate 'string
"https://api.telegram.org/bot"
(config-bot-token config) "/")))
(make-bot% :config config :db db :base-uri base-uri)))
(defun fixup-args (args)
(iter (for (key . value) in args)
(collect
(cons (string-downcase (lisp->snake-case (symbol-name key)))
(fixup-value value)))))
(defun req (uri method content)
(let ((retrier (dex:retry-request 5 :interval 1)))
(handler-case (dex:request uri :method method :content content)
(dex:http-request-too-many-requests (e) (dex:ignore-and-continue e)) ; We deal with too many reqs manually
(dex:http-request-failed (e) (funcall retrier e))
(cl+ssl::ssl-error (e) (funcall retrier e)))))
(defun do-call% (bot method uri type args-encoded)
(let ((body (req uri method args-encoded)))
(let ((hash (jzon:parse body)))
(acond
((gethash "ok" hash) (parse-value type (gethash "result" hash)))
((aand (gethash "parameters" hash)
(gethash "retry_after" it))
(log-info "Should sleep for ~A seconds" it)
(sleep it)
(log-info "Good morning!")
(do-call% bot method uri type args-encoded))
(t (error "TG error ~A: ~A ~:A"
(gethash "error_code" hash)
(gethash "description" hash)
(gethash "parameters" hash)))))))
(defun do-call (bot method path type args)
(let ((uri (concatenate 'string (bot-base-uri bot) path))
(args-encoded (fixup-args args)))
(log-debug "~A .../~A ~S" method path args-encoded)
(do-call% bot method uri type args-encoded)))
|
