diff options
| author | 2025-10-23 10:17:00 +0300 | |
|---|---|---|
| committer | 2025-10-23 10:32:36 +0300 | |
| commit | fec434a4e2d0ff65510581e461d87a945d25759a (patch) | |
| tree | 676891233e6121f8801f4751d3e2d1ca7ad4e09c /src/main.lisp | |
| parent | Use alexandria's make-keyword & symbolicate (diff) | |
| download | ukkoclot-fec434a4e2d0ff65510581e461d87a945d25759a.tar.gz ukkoclot-fec434a4e2d0ff65510581e461d87a945d25759a.tar.xz ukkoclot-fec434a4e2d0ff65510581e461d87a945d25759a.zip | |
Use serapeum's -> & defsubst
Diffstat (limited to 'src/main.lisp')
| -rw-r--r-- | src/main.lisp | 41 |
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)) | ||