summaryrefslogtreecommitdiff
path: root/src/main.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'src/main.lisp')
-rw-r--r--src/main.lisp41
1 files changed, 29 insertions, 12 deletions
diff --git a/src/main.lisp b/src/main.lisp
index e68ca40..4cb8c19 100644
--- a/src/main.lisp
+++ b/src/main.lisp
@@ -7,7 +7,7 @@
7 (:import-from :com.dieggsy.f-string :enable-f-strings) 7 (:import-from :com.dieggsy.f-string :enable-f-strings)
8 (:import-from :conf) 8 (:import-from :conf)
9 (:import-from :log) 9 (:import-from :log)
10 (:import-from :serapeum :drop) 10 (:import-from :serapeum :-> :drop)
11 (:import-from :state :*state* :make-state) 11 (:import-from :state :*state* :make-state)
12 (:import-from :str) 12 (:import-from :str)
13 (:import-from :ukkoclot/src/db :with-db) 13 (:import-from :ukkoclot/src/db :with-db)
@@ -22,13 +22,13 @@
22 22
23(defvar *in-prod* nil) 23(defvar *in-prod* nil)
24 24
25(-> main () (values &optional))
25(defun main () 26(defun main ()
26 (unwind-protect 27 (unwind-protect
27 (progn 28 (progn
28 (conf:load-config #P"config.lisp") 29 (conf:load-config #P"config.lisp")
29 (log:info "Starting up ~A" (conf:bot-name)) 30 (log:info "Starting up ~A" (conf:bot-name))
30 (main-with-config) 31 (main-with-config))
31 nil)
32 (log:info "Quitting!"))) 32 (log:info "Quitting!")))
33 33
34(defmacro reporty ((evt) &body body) 34(defmacro reporty ((evt) &body body)
@@ -38,6 +38,7 @@
38 (error (err) (report-error ,evt err)))) 38 (error (err) (report-error ,evt err))))
39 (t ,@body))) 39 (t ,@body)))
40 40
41(-> main-with-config () (values &optional))
41(defun main-with-config () 42(defun main-with-config ()
42 (unwind-protect 43 (unwind-protect
43 (with-db (db (conf:db-path)) 44 (with-db (db (conf:db-path))
@@ -46,6 +47,7 @@
46 (wrapped-main)) 47 (wrapped-main))
47 (log:info "We're done!"))) 48 (log:info "We're done!")))
48 49
50(-> wrapped-main () (values &optional))
49(defun wrapped-main () 51(defun wrapped-main ()
50 (when *in-prod* 52 (when *in-prod*
51 (send-message :chat-id (conf:dev-group) :text "Initializing...")) 53 (send-message :chat-id (conf:dev-group) :text "Initializing..."))
@@ -65,8 +67,10 @@
65 (setf gup-offset (1+ (update-update-id update))))))) 67 (setf gup-offset (1+ (update-update-id update)))))))
66 ;; One last getUpdates to make sure offset is stored on server 68 ;; One last getUpdates to make sure offset is stored on server
67 (get-updates :timeout 0 :limit 1 :offset gup-offset)) 69 (get-updates :timeout 0 :limit 1 :offset gup-offset))
68 (send-message :chat-id (conf:dev-group) :text "Shutting down...")) 70 (send-message :chat-id (conf:dev-group) :text "Shutting down...")
71 (values))
69 72
73(-> on-callback-query (callback-query) (values &optional))
70(defun on-callback-query (cb) 74(defun on-callback-query (cb)
71 (let ((data (callback-query-data cb))) 75 (let ((data (callback-query-data cb)))
72 (cond ((and data 76 (cond ((and data
@@ -95,9 +99,10 @@
95 (log:info "Unrecognised callback query data: ~A" data) 99 (log:info "Unrecognised callback query data: ~A" data)
96 (answer-callback-query :callback-query-id (callback-query-id cb) 100 (answer-callback-query :callback-query-id (callback-query-id cb)
97 :text "Unallowed callback query, don't press the button again" 101 :text "Unallowed callback query, don't press the button again"
98 :show-alert t))))) 102 :show-alert t))))
99 103 (values))
100 104
105(-> on-message (message) (values &optional))
101(defun on-message (msg) 106(defun on-message (msg)
102 (block nil 107 (block nil
103 (when-let (inline-bot (message-via-bot msg)) 108 (when-let (inline-bot (message-via-bot msg))
@@ -110,8 +115,10 @@
110 (when-let (new-chat-members (message-new-chat-members msg)) 115 (when-let (new-chat-members (message-new-chat-members msg))
111 (iter 116 (iter
112 (for new-chat-member in-vector new-chat-members) 117 (for new-chat-member in-vector new-chat-members)
113 (on-new-member msg new-chat-member))))) 118 (on-new-member msg new-chat-member))))
119 (values))
114 120
121(-> on-new-member (message user) (values &optional))
115(defun on-new-member (msg new-member) 122(defun on-new-member (msg new-member)
116 (if (= (user-id new-member) (bot-id)) 123 (if (= (user-id new-member) (bot-id))
117 (reply-animation msg #P"blob/rule-11.mp4" 124 (reply-animation msg #P"blob/rule-11.mp4"
@@ -122,13 +129,16 @@
122 "! Be on your bestest behaviour now!!") 129 "! Be on your bestest behaviour now!!")
123 :parse-mode html 130 :parse-mode html
124 :caption-above t 131 :caption-above t
125 :allow-sending-without-reply t))) 132 :allow-sending-without-reply t))
133 (values))
126 134
135(-> is-bad-text (string) boolean)
127(defun is-bad-text (text) 136(defun is-bad-text (text)
128 (declare (ignore text)) 137 (declare (ignore text))
129 ;; TODO: 138 ;; TODO:
130 nil) 139 nil)
131 140
141(-> on-text-message (message string) (values &optional))
132(defun on-text-message (msg text) 142(defun on-text-message (msg text)
133 (block nil 143 (block nil
134 (when (is-bad-text text) 144 (when (is-bad-text text)
@@ -141,7 +151,7 @@
141 ;; 5 current warns: Ban 151 ;; 5 current warns: Ban
142 ;; 152 ;;
143 ;; warn gets removed after a month of no warns 153 ;; warn gets removed after a month of no warns
144 (return)) 154 (return (values)))
145 155
146 (when-let (entities (message-entities msg)) 156 (when-let (entities (message-entities msg))
147 (iter 157 (iter
@@ -223,8 +233,10 @@
223 (write-char #\l s) 233 (write-char #\l s)
224 (write-char #\L s))))) 234 (write-char #\L s)))))
225 235
226 (t nil)))) 236 (t nil)))
237 (values))
227 238
239(-> simplify-cmd (string) (or string null))
228(defun simplify-cmd (cmd) 240(defun simplify-cmd (cmd)
229 (let ((at-idx (position #\@ cmd))) 241 (let ((at-idx (position #\@ cmd)))
230 (if (null at-idx) 242 (if (null at-idx)
@@ -235,6 +247,7 @@
235 (subseq cmd 1 at-idx) 247 (subseq cmd 1 at-idx)
236 nil))))) 248 nil)))))
237 249
250(-> on-text-command (message string string) (values &optional))
238(defun on-text-command (msg text cmd) 251(defun on-text-command (msg text cmd)
239 (declare (ignore text)) 252 (declare (ignore text))
240 (let ((simple-cmd (simplify-cmd cmd))) 253 (let ((simple-cmd (simplify-cmd cmd)))
@@ -264,14 +277,18 @@
264 (message-from msg) 277 (message-from msg)
265 (= (user-id (message-from msg)) (conf:owner))) 278 (= (user-id (message-from msg)) (conf:owner)))
266 (setf (state:power-on) nil) 279 (setf (state:power-on) nil)
267 (reply-message msg "Initialising shutdown..." :allow-sending-without-reply t))))) 280 (reply-message msg "Initialising shutdown..." :allow-sending-without-reply t))))
281 (values))
268 282
283(-> escape-xml-obj (t) string)
269(defun escape-xml-obj (obj) 284(defun escape-xml-obj (obj)
270 (escape-xml #f"{obj}")) 285 (escape-xml #f"{obj}"))
271 286
287(-> report-error (t t) (values &optional))
272(defun report-error (evt err) 288(defun report-error (evt err)
273 (log:error "While handling ~A: ~A" evt err) 289 (log:error "While handling ~A: ~A" evt err)
274 (let ((msg #f"<code>{(escape-xml-obj err)}</code> while handling{;~%}<pre>{(escape-xml-obj evt)}</pre>")) 290 (let ((msg #f"<code>{(escape-xml-obj err)}</code> while handling{;~%}<pre>{(escape-xml-obj evt)}</pre>"))
275 (send-message :chat-id (conf:dev-group) 291 (send-message :chat-id (conf:dev-group)
276 :text msg 292 :text msg
277 :parse-mode html))) 293 :parse-mode html))
294 (values))