path: root/src/main.lisp

;; SPDX-License-Identifier: EUPL-1.2
;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
(defpackage :ukkoclot/src/main
  (:documentation "Main package of Ukkoclot")
  (:nicknames :ukkoclot)
  (:use :c2cl :iterate :ukkoclot/src/inline-bots :ukkoclot/src/tg)
  (:import-from :alexandria :when-let)
  (:import-from :conf)
  (:import-from :log)
  (:import-from :named-readtables :in-readtable)
  (:import-from :serapeum :-> :drop)
  (:import-from :state :*state* :make-state)
  (:import-from :str)
  (:import-from :ukkoclot/src/readtable :readtable)
  (:import-from :ukkoclot/src/db :with-db)
  (:import-from :ukkoclot/src/serializing :fixup-value)
  (: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)
(in-readtable readtable)

(defvar *in-prod* nil)

(-> main () (values &optional))
(defun main ()
  "Entry point in ukkoclot."
  (unwind-protect
       (progn
         (conf:load-config #P"config.lisp")
         (log:info "Starting up ~A" (conf:bot-name))
         (main-with-config))
    (log:info "Quitting!")))

(defmacro reporty ((evt) &body body)
  "Catches all errors and reports them to developer group if `*in-prod*' is true."
  `(cond
     (*in-prod*
      (handler-case (progn ,@body) ; lint:suppress redundant-progn
        (error (err) (report-error ,evt err))))
     (t ,@body)))

(-> main-with-config () (values &optional))
(defun main-with-config ()
  "Call after `conf:*config*' has been initialised."
  (unwind-protect
       (with-db (db (conf:db-path))
         (setf *state* (make-state db))
         ;; TODO: Catch fatal errors & report them
         (wrapped-main))
    (log:info "We're done!")))

(-> wrapped-main () (values &optional))
(defun wrapped-main ()
  "Call after `*state*' has been initalised."
  (when *in-prod*
    (send-message :chat-id (conf:dev-group) :text "Initializing..."))
  (set-my-name :name (conf:bot-name))
  (let ((gup-offset 0))
    (loop while (state:power-on) do
      (let ((updates (get-updates :timeout 60 :offset gup-offset)))
        (loop for update across updates do
          (unwind-protect
               (progn
                 (when-let (msg (update-message update))
                   (reporty (msg)
                     (on-message msg)))
                 (when-let (cbq (update-callback-query update))
                   (reporty (cbq)
                     (on-callback-query cbq))))
            (setf gup-offset (1+ (update-update-id update)))))))
    ;; One last getUpdates to make sure offset is stored on server
    (get-updates :timeout 0 :limit 1 :offset gup-offset))
  (send-message :chat-id (conf:dev-group) :text "Shutting down...")
  (values))

(-> on-callback-query (callback-query) (values &optional))
(defun on-callback-query (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-id))
           (when-let (msg (callback-query-message cb))
             (handler-case
                 (delete-message :chat-id (message-chat-id msg)
                                 :message-id (message-id msg))
               (error (e)
                 (reply-message msg #f"BTW couldn't delete this jsyk {e}"))))
           (answer-callback-query :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-id))
           (when-let (msg (callback-query-message cb))
             (handler-case
                 (delete-message :chat-id (message-chat-id msg)
                                 :message-id (message-id msg))
               (error (e)
                 (reply-message msg #f"BTW couldn't delete this jsyk {e}"))))
           (answer-callback-query :callback-query-id (callback-query-id cb)
                                  :text "OK"))
          (t
           (log:info "Unrecognised callback query data: ~A" data)
           (answer-callback-query :callback-query-id (callback-query-id cb)
                                  :text "Unallowed callback query, don't press the button again"
                                  :show-alert t))))
  (values))

(-> on-message (message) (values &optional))
(defun on-message (msg)
  (block nil
    (when-let (inline-bot (message-via-bot msg))
      (unless (on-inline-bot msg inline-bot)
        (return)))

    (when-let (text (message-text msg))
      (on-text-message 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 msg new-chat-member))))
  (values))

(-> on-new-member (message user) (values &optional))
(defun on-new-member (msg new-member)
  (if (= (user-id new-member) (bot-id))
      (reply-animation msg #P"blob/rule-11.mp4"
                       :allow-sending-without-reply t)
      (reply-animation 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))
  (values))

(-> is-bad-text (string) boolean)
(defun is-bad-text (text)
  (declare (ignore text))
  ;; TODO:
  nil)

(-> on-text-message (message string) (values &optional))
(defun on-text-message (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 (values)))

    (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 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 msg ">:3"))

          ((equal text ">:3")
           (reply-message msg "<b>&gt;:3</b>" :parse-mode html))

          ((str:starts-with-p "big " text)
           (let ((the-text (drop 4 text)))
             (unless (is-tg-whitespace-str the-text)
               (reply-message msg
                              (concatenate 'string
                                           "<b>"
                                           (escape-xml (string-upcase the-text))
                                           "</b>")
                              :parse-mode html))))

          ((string-equal text "dio cane")
           (reply-message (or (message-reply-to-message msg) msg)
                          "porco dio"))

          ((string-equal text "forgor")
           (reply-message msg "💀"))

          ((string-equal text "huh")
           (reply-message msg "idgi"))

          ((string= text "H")
           (reply-message msg "<code>Randomly selected reminder that h &gt; H.</code>" :parse-mode html))

          ((string-equal text "porco dio")
           (reply-message (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 msg the-text))))

          ((str:starts-with-p "tiny " text)
           (let ((the-text (drop 5 text)))
             (unless (is-tg-whitespace-str the-text)
               (reply-message msg
                              (map 'string #'(lambda (ch)
                                               (if (is-tg-whitespace ch)
                                                   ch
                                                   #\.))
                                   the-text)))))

          ((string-equal text "uwu")
           (reply-message msg "OwO"))

          ((string-equal text "waow")
           (reply-message
            (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 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)))
  (values))

(-> simplify-cmd (string) (or string null))
(defun simplify-cmd (cmd)
  (let ((at-idx (position #\@ cmd)))
    (if (null at-idx)
        (drop 1 cmd)
        (let ((username (drop (1+ at-idx) cmd))
              (my-username (bot-username)))
          (if (equal username my-username)
              (subseq cmd 1 at-idx)
              nil)))))

(-> on-text-command (message string string) (values &optional))
(defun on-text-command (msg text cmd)
  (declare (ignore text))
  (let ((simple-cmd (simplify-cmd 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 msg
                      #f"<code>{(message-chat-id msg)}</code>"
                      :parse-mode html))

      ((equal simple-cmd "msginfo")
       (when-let (replied (message-reply-to-message msg))
         (reply-message replied (let ((*print-pretty* t)) (fixup-value replied)))))

      ((equal simple-cmd "ping")
       (let* ((start-time (get-internal-real-time))
              (reply (reply-message 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 :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 (state:power-on) nil)
       (reply-message msg "Initialising shutdown..." :allow-sending-without-reply t))))
  (values))

(-> escape-xml-obj (t) string)
(defun escape-xml-obj (obj)
  (escape-xml #f"{obj}"))

(-> report-error (t t) (values &optional))
(defun report-error (evt err)
  (log:error "While handling ~A: ~A" evt err)
  (let ((msg #f"<code>{(escape-xml-obj err)}</code> while handling{;~%}<pre>{(escape-xml-obj evt)}</pre>"))
    (send-message :chat-id (conf:dev-group)
                  :text msg
                  :parse-mode html))
  (values))