;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/src/main (:nicknames :ukkoclot) (:use :c2cl :iterate :ukkoclot/src/inline-bots :ukkoclot/src/tg) (:import-from :alexandria :when-let) (:import-from :com.dieggsy.f-string :enable-f-strings) (:import-from :conf) (:import-from :log) (:import-from :serapeum :drop) (:import-from :str) (:import-from :ukkoclot/src/db :with-db) (:import-from :ukkoclot/src/serializing :fixup-value) (:import-from :ukkoclot/src/state :make-bot :bot-power-on) (:import-from :ukkoclot/src/strings :escape-xml :is-tg-whitespace :is-tg-whitespace-str) (:local-nicknames (:jzon :com.inuoe.jzon)) (:export :main)) (in-package :ukkoclot/src/main) (enable-f-strings) (defvar *in-prod* t) (defmacro reporty ((evt) &body body) `(cond (*in-prod* (handler-case (progn ,@body) ; lint:suppress redundant-progn (error (err) (report-error bot ,evt err)))) (t ,@body))) (defun main () (log:config :debug) (unwind-protect (progn (conf:print-default #P"config.default.lisp") (conf:load-config #P"config.lisp") (log:info "Starting up ~A" (conf:bot-name)) (main-with-config) nil) (log:info "Quitting!"))) (defun main-with-config () (unwind-protect (with-db (db (conf:db-path)) (let ((bot (make-bot db))) ;; TODO: Catch fatal errors & report them (wrapped-main bot))) (log:info "We're done!"))) (defun wrapped-main (bot) (when *in-prod* (send-message bot :chat-id (conf:dev-group) :text "Initializing...")) (set-my-name bot :name (conf:bot-name)) (let ((gup-offset 0)) (loop while (bot-power-on bot) do (let ((updates (get-updates bot :timeout 60 :offset gup-offset))) (loop for update across updates do (unwind-protect (progn (when-let (msg (update-message update)) (reporty (msg) (on-message bot msg))) (when-let (cbq (update-callback-query update)) (reporty (cbq) (on-callback-query bot cbq)))) (setf gup-offset (1+ (update-update-id update))))))) ;; One last getUpdates to make sure offset is stored on server (get-updates bot :timeout 0 :limit 1 :offset gup-offset)) (send-message bot :chat-id (conf:dev-group) :text "Shutting down...")) (defun on-callback-query (bot cb) (let ((data (callback-query-data cb))) (cond ((and data (str:starts-with-p "bbl:" data :ignore-case nil) (= (user-id (callback-query-from cb)) (conf:owner))) (let ((bot-id (read-from-string data t nil :start 4))) (blacklist-inline-bot bot bot-id)) (when-let (msg (callback-query-message cb)) (delete-message bot :chat-id (message-chat-id msg) :message-id (message-id msg))) (answer-callback-query bot :callback-query-id (callback-query-id cb) :text "OK")) ((and data (str:starts-with-p "bwl:" data :ignore-case nil) (= (user-id (callback-query-from cb)) (conf:owner))) (let ((bot-id (read-from-string data t nil :start 4))) (whitelist-inline-bot bot bot-id)) (when-let (msg (callback-query-message cb)) (delete-message bot :chat-id (message-chat-id msg) :message-id (message-id msg))) (answer-callback-query bot :callback-query-id (callback-query-id cb) :text "OK")) (t (log:info "Unrecognised callback query data: ~A" data) (answer-callback-query bot :callback-query-id (callback-query-id cb) :text "Unallowed callback query, don't press the button again" :show-alert t))))) (defun on-message (bot msg) (block nil (when-let (inline-bot (message-via-bot msg)) (unless (on-inline-bot bot msg inline-bot) (return))) (when-let (text (message-text msg)) (on-text-message bot msg text)) (when-let (new-chat-members (message-new-chat-members msg)) (iter (for new-chat-member in-vector new-chat-members) (on-new-member bot msg new-chat-member))))) (defun on-new-member (bot msg new-member) (if (= (user-id new-member) (bot-id bot)) (reply-animation bot msg #P"blob/rule-11.mp4" :allow-sending-without-reply t) (reply-animation bot msg #P"blob/rule-10.mp4" :text (concatenate 'string "Hello there, " (user-format-name new-member) "! Be on your bestest behaviour now!!") :parse-mode html :caption-above t :allow-sending-without-reply t))) (defun is-bad-text (text) (declare (ignore text)) ;; TODO: nil) (defun on-text-message (bot msg text) (block nil (when (is-bad-text text) ;; TODO: Delete message, mute & warn user ;; 0 current warns: 5 minute mute, +1 warn ;; 1 current warn : 10 minute mute, +1 warn ;; 2 current warns: 30 minute mute, +1 warn ;; 3 current warns: 1 hour mute, +1 warn ;; 4 current warns: 1 day mute, +1 warn ;; 5 current warns: Ban ;; ;; warn gets removed after a month of no warns (return)) (when-let (entities (message-entities msg)) (iter (for entity in-vector entities) (when (and (eql (message-entity-type entity) bot-command) (zerop (message-entity-offset entity))) (on-text-command bot msg text (message-entity-extract entity text))))) ;; TODO: Replace this cond with a nicer dispatch. Something like string-case? (cond ((equal text ":3") (reply-message bot msg ">:3")) ((equal text ">:3") (reply-message bot msg ">:3" :parse-mode html)) ((str:starts-with-p "big " text) (let ((the-text (drop 4 text))) (unless (is-tg-whitespace-str the-text) (reply-message bot msg (concatenate 'string "" (escape-xml (string-upcase the-text)) "") :parse-mode html)))) ((string-equal text "dio cane") (reply-message bot (or (message-reply-to-message msg) msg) "porco dio")) ((string-equal text "forgor") (reply-message bot msg "💀")) ((string-equal text "huh") (reply-message bot msg "idgi")) ((string= text "H") (reply-message bot msg "Randomly selected reminder that h > H." :parse-mode html)) ((string-equal text "porco dio") (reply-message bot (or (message-reply-to-message msg) msg) "dio cane")) ((str:starts-with-p "say " text) (let ((the-text (drop 4 text))) (unless (is-tg-whitespace-str the-text) (reply-message bot msg the-text)))) ((str:starts-with-p "tiny " text) (let ((the-text (drop 5 text))) (unless (is-tg-whitespace-str the-text) (reply-message bot msg (map 'string #'(lambda (ch) (if (is-tg-whitespace ch) ch #\.)) the-text))))) ((string-equal text "uwu") (reply-message bot msg "OwO")) ((string-equal text "waow") (reply-message bot (or (message-reply-to-message msg) msg) "BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED")) ((string-equal text "what") (reply-message bot msg (with-output-to-string (s) (if (char= (elt text 0) #\w) (write-char #\g s) (write-char #\G s)) (if (char= (elt text 1) #\h) (write-string "ood " s) (write-string "OOD " s)) (if (char= (elt text 2) #\a) (write-string "gir" s) (write-string "GIR" s)) (if (char= (elt text 3) #\t) (write-char #\l s) (write-char #\L s))))) (t nil)))) (defun simplify-cmd (bot cmd) (let ((at-idx (position #\@ cmd))) (if (null at-idx) (drop 1 cmd) (let ((username (drop (1+ at-idx) cmd)) (my-username (bot-username bot))) (if (equal username my-username) (subseq cmd 1 at-idx) nil))))) (defun on-text-command (bot msg text cmd) (declare (ignore text)) (let ((simple-cmd (simplify-cmd bot cmd))) (log:debug "text-command: ~A AKA ~A" cmd simple-cmd) ;; TODO: Replace this cond with a nicer dispatch. Something like string-case? (cond ((equal simple-cmd "chatid") (reply-message bot msg #f"{(message-chat-id msg)}" :parse-mode html)) ((equal simple-cmd "msginfo") (when-let (replied (message-reply-to-message msg)) (reply-message bot replied (let ((*print-pretty* t)) (fixup-value replied))))) ((equal simple-cmd "ping") (let* ((start-time (get-internal-real-time)) (reply (reply-message bot msg #f"Pong!{;~2%}Send time: ...")) (end-time (get-internal-real-time)) (time-elapsed (* (/ (- end-time start-time) internal-time-units-per-second) 1000))) (edit-message-text bot :chat-id (message-chat-id reply) :message-id (message-id reply) :text #f"Pong!{;~2%}Send time: {time-elapsed;~G}ms"))) ((and (equal simple-cmd "shutdown") (message-from msg) (= (user-id (message-from msg)) (conf:owner))) (setf (bot-power-on bot) nil) (reply-message bot msg "Initialising shutdown..." :allow-sending-without-reply t))))) (defun escape-xml-obj (obj) (escape-xml #f"{obj}")) (defun report-error (bot evt err) (log:error "While handling ~A: ~A" evt err) (let ((msg #f"{(escape-xml-obj err)} while handling{;~%}
{(escape-xml-obj evt)}
")) (send-message bot :chat-id (conf:dev-group) :text msg :parse-mode html)))