path: root/src/main.lisp

;; SPDX-License-Identifier: EUPL-1.2
;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
(defpackage :ukkoclot/main
  (:nicknames :ukkoclot)
  (:use :c2cl :iterate :ukkoclot/inline-bots :ukkoclot/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/db :with-db)
  (:import-from :ukkoclot/serializing :fixup-value)
  (:import-from :ukkoclot/state :make-bot :bot-power-on)
  (:import-from :ukkoclot/strings :escape-xml :is-tg-whitespace :is-tg-whitespace-str)
  (:local-nicknames
   (:jzon :com.inuoe.jzon))
  (:export :main))
(in-package :ukkoclot/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)
  ;; 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 "<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 bot msg
                              (concatenate 'string
                                           "<b>"
                                           (escape-xml (string-upcase the-text))
                                           "</b>")
                              :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 "<code>Randomly selected reminder that h &gt; H.</code>" :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)
  (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"<code>{(message-chat-id msg)}</code>"
                      :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"<code>{(escape-xml-obj err)}</code> while handling{;~%}<pre>{(escape-xml-obj evt)}</pre>"))
    (send-message bot
                      :chat-id (conf:dev-group)
                      :text msg
                      :parse-mode html)))