1 files changed, 354 insertions, 0 deletions

diff --git a/src/main.lisp b/src/main.lisp
new file mode 100644
index 0000000..af88fe6
--- /dev/null
+++ b/src/main.lisp
@@ -0,0 +1,354 @@
+;; SPDX-License-Identifier: EUPL-1.2
+;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
+(defpackage :ukkoclot/main
+  (:nicknames :ukkoclot)
+  (:use :c2cl :ukkoclot/bot :ukkoclot/config :ukkoclot/inline-bots :ukkoclot/log :ukkoclot/tg-types)
+  (:import-from :anaphora :aand :awhen :it)
+  (:import-from :ukkoclot/bot :make-bot :bot-power-on)
+  (:import-from :ukkoclot/db :with-db)
+  (:import-from :ukkoclot/strings :escape-xml :is-tg-whitespace-str :starts-with :starts-with-ignore-case)
+  (:local-nicknames
+   (:jzon :com.inuoe.jzon))
+  (:export :main))
+(in-package :ukkoclot/main)
+
+(defvar *in-prod* t)
+
+(defmacro reporty ((evt) &body body)
+  `(if *in-prod*
+       (handler-case (progn ,@body)
+         (error (err) (report-error bot ,evt err)))
+       (progn ,@body)))
+
+(defun main ()
+  (unwind-protect
+       (let ((config (config-load #P"config.default.lisp")))
+         (config-merge config #P"config.lisp")
+         (log-info "Starting up ~A" (config-bot-name config))
+         (with-db (db (config-db-path config))
+           (let ((bot (make-bot config db)))
+             ;; TODO: Catch fatal errors & report them
+             (wrapped-main bot config))))
+    (log-info "We're done!")))
+
+(defun wrapped-main (bot config)
+  (send-message bot :chat-id (config-dev-group config) :text "Initializing...")
+  (set-my-name bot :name (config-bot-name config))
+  (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
+                 (awhen (update-message update)
+                   (reporty (it)
+                     (on-message bot it)))
+                 (awhen (update-callback-query update)
+                   (reporty (it)
+                     (on-callback-query bot it))))
+            (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 (config-dev-group config) :text "Shutting down..."))
+
+(defun on-callback-query (bot cb)
+  (let ((data (callback-query-data cb)))
+    (cond ((and data
+                (starts-with data "bbl:")
+                (= (user-id (callback-query-from cb))
+                   (config-owner (bot-config bot))))
+           (let ((bot-id (read-from-string data t nil :start 4)))
+             (blacklist-inline-bot bot bot-id))
+           (awhen (callback-query-message cb)
+             (delete-message bot
+                                 :chat-id (message-chat-id it)
+                                 :message-id (message-id it)))
+           (answer-callback-query bot
+                                  :callback-query-id (callback-query-id cb)
+                                  :text "OK"))
+          ((and data
+                (starts-with data "bwl:")
+                (= (user-id (callback-query-from cb))
+                   (config-owner (bot-config bot))))
+           (let ((bot-id (read-from-string data t nil :start 4)))
+             (whitelist-inline-bot bot bot-id))
+           (awhen (callback-query-message cb)
+             (delete-message bot
+                             :chat-id (message-chat-id it)
+                             :message-id (message-id it)))
+           (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
+    (awhen (message-via-bot msg)
+      (unless (on-inline-bot bot msg it)
+        (return)))
+
+    (awhen (message-text msg)
+      (on-text-message bot msg it))
+
+    (awhen (message-new-chat-members msg)
+      (loop for new-chat-member across it do
+        (on-new-member bot msg new-chat-member)))))
+
+(defun on-new-member (bot msg new-member)
+  ;; TODO: Rule 11 no hating on cats on bot entry
+  ;; TODO: Rule 10 have fun and enjoy your time on user entry
+  (if (= (user-id new-member) (bot-id bot))
+      nil
+      (send-message bot
+                    :chat-id (message-chat-id msg)
+                    :text (concatenate 'string "Hello there, " (user-format-name new-member) "!  Be on your bestest behaviour now!!")
+                    :parse-mode "HTML"
+                    :reply-parameters
+                    (make-reply-parameters
+                     :allow-sending-without-reply t
+                     :message-id (message-id msg)
+                     :chat-id (message-chat-id msg)))))
+
+(defun is-bad-text (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))
+
+    (awhen (message-entities msg)
+      (loop for entity across it
+            when (and (eq (message-entity-type entity) :bot-command)
+                      (= (message-entity-offset entity) 0))
+              do (on-text-command bot msg text (message-entity-extract entity text))))
+
+    (cond ((equal text ":3")
+           (send-message bot :chat-id (message-chat-id msg)
+                             :text ">:3"
+                             :reply-parameters (make-reply-parameters :message-id (message-id msg)
+                                                                      :chat-id (message-chat-id msg))))
+
+          ((equal text ">:3")
+           (send-message bot :chat-id (message-chat-id msg)
+                             :text "<b>&gt;:3</b>"
+                             :parse-mode "HTML"
+                             :reply-parameters (make-reply-parameters
+                                                :message-id (message-id msg)
+                                                :chat-id (message-chat-id msg))))
+
+          ((starts-with-ignore-case text "big ")
+           (let ((the-text (subseq text 4)))
+             (unless (is-tg-whitespace-str the-text)
+               (send-message bot
+                             :chat-id (message-chat-id msg)
+                             :text (concatenate 'string
+                                                "<b>"
+                                                (escape-xml (string-upcase the-text))
+                                                "</b>")
+                             :parse-mode "HTML"
+                             :reply-parameters
+                             (make-reply-parameters
+                              :message-id (message-id msg)
+                              :chat-id (message-chat-id msg))))))
+
+          ((string-equal text "dio cane")
+           (let ((reply-msg-id (message-id msg))
+                 (reply-chat-id (message-chat-id msg)))
+             (awhen (message-reply-to-message msg)
+               (setf reply-msg-id (message-id it))
+               (setf reply-chat-id (message-chat-id it)))
+             (send-message bot
+                           :chat-id (message-chat-id msg)
+                           :text "porco dio"
+                           :reply-parameters
+                           (make-reply-parameters
+                            :message-id reply-msg-id
+                            :chat-id reply-chat-id))))
+
+          ((string-equal text "forgor")
+           (send-message bot
+                         :chat-id (message-chat-id msg)
+                         :text "💀"
+                         :reply-parameters
+                         (make-reply-parameters
+                          :message-id (message-id msg)
+                          :chat-id (message-chat-id msg))))
+
+          ((string-equal text "huh")
+           (send-message bot
+                         :chat-id (message-chat-id msg)
+                         :text "idgi"
+                         :reply-parameters
+                         (make-reply-parameters
+                          :message-id (message-id msg)
+                          :chat-id (message-chat-id msg))))
+
+          ((string= text "H")
+           (send-message bot
+                         :chat-id (message-chat-id msg)
+                         :text "<code>Randomly selected reminder that h &gt; H.</code>"
+                         :parse-mode "HTML"
+                         :reply-parameters
+                         (make-reply-parameters
+                          :message-id (message-id msg)
+                          :chat-id (message-chat-id msg))))
+
+          ((string-equal text "porco dio")
+           (let ((reply-msg-id (message-id msg))
+                 (reply-chat-id (message-chat-id msg)))
+             (awhen (message-reply-to-message msg)
+               (setf reply-msg-id (message-id it))
+               (setf reply-chat-id (message-chat-id it)))
+             (send-message bot
+                           :chat-id (message-chat-id msg)
+                           :text "dio cane"
+                           :reply-parameters
+                           (make-reply-parameters
+                            :message-id reply-msg-id
+                            :chat-id reply-chat-id))))
+
+          ((starts-with-ignore-case text "say ")
+           (let ((the-text (subseq text 4)))
+             (unless (is-tg-whitespace-str the-text)
+               (send-message bot
+                             :chat-id (message-chat-id msg)
+                             :text the-text
+                             :reply-parameters
+                             (make-reply-parameters
+                              :message-id (message-id msg)
+                              :chat-id (message-chat-id msg))))))
+
+          ((string-equal text "uwu")
+           (send-message bot
+                         :chat-id (message-chat-id msg)
+                         :text "OwO"
+                         :reply-parameters
+                         (make-reply-parameters
+                          :message-id (message-id msg)
+                          :chat-id (message-chat-id msg))))
+
+          ((string-equal text "waow")
+           (let ((reply-msg-id (message-id msg))
+                 (reply-chat-id (message-chat-id msg)))
+             (awhen (message-reply-to-message msg)
+               (setf reply-msg-id (message-id it))
+               (setf reply-chat-id (message-chat-id it)))
+             (send-message bot
+                           :chat-id (message-chat-id msg)
+                           :text "BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED"
+                           :reply-parameters
+                           (make-reply-parameters
+                            :message-id reply-msg-id
+                            :chat-id reply-chat-id))))
+
+          ((string-equal text "what")
+           (send-message bot
+                         :chat-id (message-chat-id msg)
+                         :text (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)))
+                         :reply-parameters
+                         (make-reply-parameters
+                          :message-id (message-id msg)
+                          :chat-id (message-chat-id msg))))
+          )))
+
+(defun simplify-cmd (bot cmd)
+  (let ((at-idx (position #\@ cmd)))
+    (if (null at-idx)
+        (subseq cmd 1)
+        (let ((username (subseq cmd (1+ at-idx)))
+              (my-username (bot-username bot)))
+          (if (equal username my-username)
+              (subseq cmd 1 at-idx)
+              nil)))))
+
+(defun on-text-command (bot msg text cmd)
+  (let ((simple-cmd (simplify-cmd bot cmd)))
+    (log-debug "text-command: ~A AKA ~A" cmd simple-cmd)
+    (cond ((equal simple-cmd "chatid")
+           (send-message bot :chat-id (message-chat-id msg)
+                             :text (format nil "<code>~A</code>" (message-chat-id msg))
+                             :parse-mode "HTML"
+                             :reply-parameters (make-reply-parameters :message-id (message-id msg)
+                                                                      :chat-id (message-chat-id msg))))
+
+          ((equal simple-cmd "msginfo")
+           (aand (message-reply-to-message msg)
+                 (send-message bot :chat-id (message-chat-id msg)
+                               ;; TODO: Text needs lot more massaging
+                                   :text (jzon:stringify (arg-encode it))
+                                   :reply-parameters
+                                   (make-reply-parameters
+                                    :message-id (message-id msg)
+                                    :chat-id (message-chat-id msg)))))
+
+          ((equal simple-cmd "ping")
+           (let* ((start-time (get-internal-real-time))
+                  (reply (send-message bot
+                                       :chat-id (message-chat-id msg)
+                                       :text "Pong!
+Send time: ..."
+                                       :reply-parameters
+                                       (make-reply-parameters
+                                        :message-id (message-id msg)
+                                        :chat-id (message-chat-id msg))))
+                  (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 msg)
+                                :message-id (message-id reply)
+                                :text (format nil "Pong!~2%Send time: ~Gms" time-elapsed))))
+
+          ((and (equal simple-cmd "shutdown")
+                 (message-from msg)
+                 (= (user-id (message-from msg)) (config-owner (bot-config bot))))
+           (setf (bot-power-on bot) nil)
+           (send-message bot
+                         :chat-id (message-chat-id msg)
+                         :text "Initialising shutdown..."
+                         :reply-parameters
+                         (make-reply-parameters
+                          :allow-sending-without-reply t
+                          :message-id (message-id msg)
+                          :chat-id (message-chat-id msg))))
+
+          )))
+
+(defun report-error (bot evt err)
+  (log-error "While handling ~A: ~A" evt err)
+  (let ((msg (format nil "<code>~A</code> while handling ~&<pre>~A</pre>"
+                     (escape-xml (format nil "~A" err))
+                     (escape-xml (format nil "~A" evt)))))
+    (send-message bot
+                      :chat-id (config-dev-group (bot-config bot))
+                      :text msg
+                      :parse-mode "HTML")))