From 4da3ad1f569832845b58c3ce35149633a2bb665c Mon Sep 17 00:00:00 2001 From: Uko Kokņevičs Date: Thu, 9 Oct 2025 21:58:43 +0300 Subject: Initial commit --- src/bot.lisp | 6 + src/bot/impl.lisp | 96 +++++++++ src/bot/methods.lisp | 88 ++++++++ src/config.lisp | 28 +++ src/db.lisp | 82 +++++++ src/hash-tables.lisp | 27 +++ src/inline-bots.lisp | 42 ++++ src/log.lisp | 85 ++++++++ src/main.lisp | 354 +++++++++++++++++++++++++++++++ src/strings.lisp | 59 ++++++ src/tg-types.lisp | 18 ++ src/tg-types/bot-name.lisp | 14 ++ src/tg-types/callback-query.lisp | 24 +++ src/tg-types/chat.lisp | 31 +++ src/tg-types/force-reply.lisp | 21 ++ src/tg-types/inline-keyboard-button.lisp | 32 +++ src/tg-types/inline-keyboard-markup.lisp | 17 ++ src/tg-types/link-preview-options.lisp | 25 +++ src/tg-types/macros.lisp | 134 ++++++++++++ src/tg-types/message-entity.lisp | 61 ++++++ src/tg-types/message.lisp | 168 +++++++++++++++ src/tg-types/parsers.lisp | 9 + src/tg-types/reply-parameters.lisp | 32 +++ src/tg-types/update.lisp | 47 ++++ src/tg-types/user.lisp | 48 +++++ 25 files changed, 1548 insertions(+) create mode 100644 src/bot.lisp create mode 100644 src/bot/impl.lisp create mode 100644 src/bot/methods.lisp create mode 100644 src/config.lisp create mode 100644 src/db.lisp create mode 100644 src/hash-tables.lisp create mode 100644 src/inline-bots.lisp create mode 100644 src/log.lisp create mode 100644 src/main.lisp create mode 100644 src/strings.lisp create mode 100644 src/tg-types.lisp create mode 100644 src/tg-types/bot-name.lisp create mode 100644 src/tg-types/callback-query.lisp create mode 100644 src/tg-types/chat.lisp create mode 100644 src/tg-types/force-reply.lisp create mode 100644 src/tg-types/inline-keyboard-button.lisp create mode 100644 src/tg-types/inline-keyboard-markup.lisp create mode 100644 src/tg-types/link-preview-options.lisp create mode 100644 src/tg-types/macros.lisp create mode 100644 src/tg-types/message-entity.lisp create mode 100644 src/tg-types/message.lisp create mode 100644 src/tg-types/parsers.lisp create mode 100644 src/tg-types/reply-parameters.lisp create mode 100644 src/tg-types/update.lisp create mode 100644 src/tg-types/user.lisp (limited to 'src') diff --git a/src/bot.lisp b/src/bot.lisp new file mode 100644 index 0000000..a51402d --- /dev/null +++ b/src/bot.lisp @@ -0,0 +1,6 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(uiop:define-package :ukkoclot/bot + (:use) + ;; Maybe should somehow hide BOT-USERNAME% and BOT-ID% but whatever + (:use-reexport :ukkoclot/bot/impl :ukkoclot/bot/methods)) diff --git a/src/bot/impl.lisp b/src/bot/impl.lisp new file mode 100644 index 0000000..b57e2d3 --- /dev/null +++ b/src/bot/impl.lisp @@ -0,0 +1,96 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/bot/impl + (:use :c2cl :iterate :ukkoclot/config :ukkoclot/log) + (:import-from :anaphora :aand :acond :it) + (:import-from :dex) + (:import-from :ukkoclot/strings :lisp->snake-case) + (:local-nicknames + (:jzon :com.inuoe.jzon)) + (:export + :arg-encode :bot :bot-p :make-bot :do-call + + :bot-config :bot-db :bot-base-uri :bot-power-on :bot-username% :bot-id%)) +(in-package :ukkoclot/bot/impl) + +(defgeneric will-arg-encode (object) + (:documentation "Whether the OBJECT has any transformation done to it by arg-encode") + (:method (obj) + nil) + (:method ((obj cons)) + (or (will-arg-encode (car obj)) + (will-arg-encode (cdr obj))))) + +(defgeneric arg-encode (object) + (:documentation "Encode the OBJECT to a form that our HTTP code is happy about.") + (:method (obj) + obj) + (:method ((obj cons)) + (if (not (will-arg-encode obj)) + obj + (cons (arg-encode (car obj)) + (arg-encode (cdr obj)))))) + +(defgeneric fixup-arg (value) + (:documentation "Make sure Telegram & QURI & whatever like the arg") + (:method (value) + (error "Unsupported argument type ~S (~S)" (class-name (class-of value)) value)) + (:method ((value null)) + value) + (:method ((value number)) + value) + (:method ((value string)) + value) + (:method ((value hash-table)) + (jzon:stringify value))) + +(defstruct (bot (:constructor make-bot%)) + (config (error "No value given for config") :read-only t) + (db (error "No value given for DB") :read-only t) + (base-uri (error "No value given for base-uri") :read-only t) + (power-on t :type boolean) + (username% nil :type (or string null)) + (id% nil :type (or integer null))) + +(defun make-bot (config db) + (let ((base-uri (concatenate 'string + "https://api.telegram.org/bot" + (config-bot-token config) "/"))) + (make-bot% :config config :db db :base-uri base-uri))) + +(defun args-plist->alist (args-plist) + (iter (for (old-key value) on args-plist by #'cddr) + (collect + (let ((new-key (string-downcase (lisp->snake-case (symbol-name old-key))))) + (cons new-key value))))) + +(defun fixup-args (args-alist) + (iter (for (name . value) in args-alist) + (collecting (cons name (fixup-arg (arg-encode value)))))) + +(defun req (uri method content) + ;; We deal with this manually + (handler-bind ((dex:http-request-too-many-requests #'dex:ignore-and-continue)) + (dex:request uri :method method :content content))) + +(defun do-call% (bot method uri mapfn args-encoded) + (let ((body (req uri method args-encoded))) + (let ((hash (jzon:parse body))) + (acond + ((gethash "ok" hash) (funcall mapfn (gethash "result" hash))) + ((aand (gethash "parameters" hash) + (gethash "retry_after" it)) + (log-info "Should sleep for ~A seconds" it) + (sleep it) + (log-info "Good morning!") + (do-call% bot method uri mapfn args-encoded)) + (t (error "TG error ~A: ~A ~:A" + (gethash "error_code" hash) + (gethash "description" hash) + (gethash "parameters" hash))))))) + +(defun do-call (bot method path mapfn args-plist) + (let ((uri (concatenate 'string (bot-base-uri bot) path)) + (args-encoded (fixup-args (args-plist->alist args-plist)))) + (log-debug "~A .../~A ~S" method path args-encoded) + (do-call% bot method uri mapfn args-encoded))) diff --git a/src/bot/methods.lisp b/src/bot/methods.lisp new file mode 100644 index 0000000..b0eca5c --- /dev/null +++ b/src/bot/methods.lisp @@ -0,0 +1,88 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/bot/methods + (:use :c2cl :ukkoclot/bot/impl :ukkoclot/tg-types :ukkoclot/tg-types/macros) + (:export :answer-callback-query :bot-id :bot-username :delete-message :edit-message-text :get-me :get-updates :send-message :set-my-name)) +(in-package :ukkoclot/bot/methods) + +(define-tg-method (answer-callback-query boolean "answerCallbackQuery" #'identity) + (callback-query-id string) + (text (or string null) nil) + (show-alert boolean nil) + (url (or string null) nil) + (cache-time (or integer null) nil)) + +(defun bot-id (bot) + (or (bot-id% bot) + (progn + (get-me bot) + (bot-id% bot)))) + +(defun bot-username (bot) + (or (bot-username% bot) + (progn + (get-me bot) + (bot-username% bot)))) + +(define-tg-method (delete-message boolean "deleteMessage" #'identity) + (chat-id (or integer string)) + (message-id integer)) + +(define-tg-method (edit-message-text message "editMessageText" #'hash->message) + (business-connection-id (or string null) nil) + (chat-id (or integer string null) nil) + (message-id (or integer null) nil) + (inline-message-id (or string null) nil) + (text string) + (parse-mode (or string null) nil) + (entities (or (array message-entity) null) nil) + (link-preview-options (or link-preview-options null) nil) + (reply-markup (or inline-keyboard-markup null) nil)) + +(define-tg-method (get-me% user "getMe" #'hash->user :GET)) + +(defun get-me (bot) + (let ((res (get-me% bot))) + (setf (bot-id% bot) (user-id res)) + (setf (bot-username% bot) (user-username res)) + res)) + +(define-tg-method (get-my-name bot-name "getMyName" #'hash->bot-name :GET) + (language-code (or string null) nil)) + +(define-tg-method (get-updates (array update) "getUpdates" #'parse-update-array) + (offset (or integer null) nil) + (limit (or integer null) nil) + (timeout (or integer null) nil) + (allowed-updates (or string null) nil)) + +(define-tg-method (send-message message "sendMessage" #'hash->message) + (business-connection-id (or string null) nil) + (chat-id (or integer string)) + (message-thread-id (or integer null) nil) + (text string) + ;; TODO: parse-mode should maybe be keywords? + (parse-mode (or string null) nil) + (entities (or (array message-entity) null) nil) + (link-preview-options (or link-preview-options null) nil) + (disable-notification (or boolean null) nil) + (protect-content (or boolean null) nil) + (message-effect-id (or string null) nil) + (reply-parameters (or reply-parameters null) nil) + (reply-markup (or inline-keyboard-markup + ;; TODO: reply-keyboard-markup + ;; TODO: reply-keyboard-remove + force-reply null) nil)) + +(define-tg-method (set-my-name% boolean "setMyName" #'identity) + (name (or string null) nil) + (language-code (or string null) nil)) + +(defun set-my-name (bot &key (name nil) (language-code nil)) + (block nil + (when name + (let ((curr-name (get-my-name bot :language-code language-code))) + (when (string= name (bot-name-name curr-name)) + (return)))) + (unless (set-my-name% bot :name name :language-code language-code) + (error "Failed to set name")))) diff --git a/src/config.lisp b/src/config.lisp new file mode 100644 index 0000000..86a0f33 --- /dev/null +++ b/src/config.lisp @@ -0,0 +1,28 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/config + (:use :c2cl :ukkoclot/hash-tables :ukkoclot/log) + (:export + :config-load :config-merge + :config-p + :config-bot-name :config-bot-token :config-db-path :config-dev-group :config-owner)) +(in-package :ukkoclot/config) + +(defmacro defconfig (&rest slots-and-types) + `(defstruct config + ,@(loop for (name type) on slots-and-types by #'cddr + collect `(,(intern (symbol-name name)) (error "No value given for ~A" ,name) :type ,type :read-only t)))) + +(defconfig + :bot-name string + :bot-token string + :db-path string + :dev-group integer + :owner integer) + +(defun config-load (filename) + (apply #'make-config (with-open-file (f filename) (read f)))) + +(defun config-merge (config filename) + (loop for (name value) on (with-open-file (f filename) (read f)) by #'cddr do + (setf (slot-value config (intern (symbol-name name) :ukkoclot/config)) value))) diff --git a/src/db.lisp b/src/db.lisp new file mode 100644 index 0000000..9b646d2 --- /dev/null +++ b/src/db.lisp @@ -0,0 +1,82 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/db + (:use :c2cl :sqlite :ukkoclot/log) + (:export :get-inline-bot-type :set-inline-bot-type :with-db)) +(in-package :ukkoclot/db) + +(defparameter +target-version+ 1 + "Intended DB version") + +(defmacro with-db ((name path) &body body) + `(let ((,name (connect ,path))) + (unwind-protect (progn (upgrade ,name) ,@body) + (disconnect ,name)))) + +(defun get-inline-bot-type (db id) + (let ((type-int (execute-single db "SELECT type FROM inline_bots WHERE id = ?" id))) + (when type-int + (integer->inline-bot-type type-int)))) + +(defun set-inline-bot-type (db id type) + (execute-non-query db "INSERT OR REPLACE INTO inline_bots (id, type) VALUES (?, ?)" id (inline-bot-type->integer type))) + +(defun inline-bot-type->integer (type) + (case type + (:blacklisted 0) + (:whitelisted 1) + (t (error "Unknown inline bot type ~S" type)))) + +(defun integer->inline-bot-type (num) + (case num + (0 :blacklisted) + (1 :whitelisted) + (t (error "Unknown inline bot type value ~S" num)))) + +(defun upgrade (db) + (execute-non-query db "CREATE TABLE IF NOT EXISTS version(id INTEGER PRIMARY KEY, version INTEGER)") + (let ((current-ver (execute-single db "SELECT version FROM version WHERE id = 0"))) + (unless current-ver + (setf current-ver 0)) + (cond + ((= current-ver +target-version+) (log-info "Database is up to date")) + + ((> current-ver +target-version+) + (log-error "Database has a higher version than supported?") + (error "Corrupted Database")) + + (t + (log-info "Updating database from version ~A to ~A" current-ver +target-version+) + (loop while (< current-ver +target-version+) + do (with-transaction db + (log-info "Updating database step from ~A" current-ver) + (incf current-ver) + (upgrade-step db current-ver) + (execute-non-query + db + "INSERT OR REPLACE INTO version(id, version) VALUES (0, ?)" + current-ver))) + (log-info "Database updating complete :)"))))) + +(defun upgrade-step (db new-version) + (case new-version + (1 + (execute-non-query db "DROP TABLE IF EXISTS inline_bots_enum") + (execute-non-query db " +CREATE TABLE inline_bots_enum ( + id INTEGER PRIMARY KEY, + value TEXT UNIQUE +)") + (execute-non-query db " +INSERT INTO inline_bots_enum(id, value) +VALUES (?, 'blacklisted'), (?, 'whitelisted')" + (inline-bot-type->integer :blacklisted) + (inline-bot-type->integer :whitelisted)) + + (execute-non-query db "DROP TABLE IF EXISTS inline_bots") + (execute-non-query db " +CREATE TABLE inline_bots ( + id INTEGER PRIMARY KEY, + type INTEGER REFERENCES inline_bots_enum(id) +)")) + (t (error "Unreachable upgrade step reached ~A" new-version)))) diff --git a/src/hash-tables.lisp b/src/hash-tables.lisp new file mode 100644 index 0000000..9e41b26 --- /dev/null +++ b/src/hash-tables.lisp @@ -0,0 +1,27 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/hash-tables + (:use :c2cl) + (:export :alist->hash-table :gethash-lazy :plist->hash-table)) +(in-package :ukkoclot/hash-tables) + +(defun alist->hash-table (alist &rest args &key &allow-other-keys) + (let ((ht (apply #'make-hash-table args))) + (loop for (key . value) in alist do + (setf (gethash key ht) value)) + ht)) + +(defmacro gethash-lazy (key hash-table default-lazy) + (let ((unique (gensym "UNIQUE-")) + (res (gensym "RES-"))) + `(let* ((,unique ',unique) + (,res (gethash ,key ,hash-table ,unique))) + (if (eq ,res ,unique) + ,default-lazy + ,res)))) + +(defun plist->hash-table (plist &rest args &key &allow-other-keys) + (let ((ht (apply #'make-hash-table args))) + (loop for (key value) on plist by #'cddr do + (setf (gethash key ht) value)) + ht)) diff --git a/src/inline-bots.lisp b/src/inline-bots.lisp new file mode 100644 index 0000000..5945084 --- /dev/null +++ b/src/inline-bots.lisp @@ -0,0 +1,42 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/inline-bots + (:use :c2cl :ukkoclot/bot :ukkoclot/config :ukkoclot/log :ukkoclot/tg-types) + (:local-nicknames (:db :ukkoclot/db)) + (:export :blacklist-inline-bot :on-inline-bot :whitelist-inline-bot)) +(in-package :ukkoclot/inline-bots) + +(defun blacklist-inline-bot (bot inline-bot-id) + (db:set-inline-bot-type (bot-db bot) inline-bot-id :blacklisted)) + +(defun whitelist-inline-bot (bot inline-bot-id) + (db:set-inline-bot-type (bot-db bot) inline-bot-id :whitelisted)) + +(defun on-inline-bot (bot msg via) + (let ((ty (db:get-inline-bot-type (bot-db bot) (user-id via)))) + (if (eq ty :whitelisted) + t + (progn + (log-info "Deleting an unallowed inline bot message from ~A ~A" + (user-username via) + (user-id via)) + (delete-message bot + :chat-id (message-chat-id msg) + :message-id (message-id msg)) + (unless (eq ty :blacklisted) + ;; Not explicitly blacklisted, notify dev group + (send-message bot + :chat-id (config-dev-group (bot-config bot)) + :text (format nil "Deleted a message sent via inline bot @~A ~A" + (user-username via) + (user-id via)) + :parse-mode "HTML" + :reply-markup (make-inline-keyboard-markup + :inline-keyboard + #(#((make-inline-keyboard-button + :text "Whitelist" + :callback-data (format nil "bwl:~A" (user-id via))) + (make-inline-keyboard-button + :text "Blacklist" + :callback-data (format nil "bbl:~A" (user-id via)))))))) + nil)))) diff --git a/src/log.lisp b/src/log.lisp new file mode 100644 index 0000000..e6e8661 --- /dev/null +++ b/src/log.lisp @@ -0,0 +1,85 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/log + (:use :c2cl) + (:export :*output* :deflevel :log-error :log-warn :log-info :log-debug)) +(in-package :ukkoclot/log) + +(defparameter *output* *error-output*) + +(defvar *max-name-length* 8) +(defvar *max-level-length* 4) + +(defvar *levels* nil) + +(defun get-levels () + (unless *levels* + (setf *levels* (make-hash-table :test #'eq))) + *levels*) + +(defun register-level (level value) + (setf (gethash level (get-levels)) value) + (let ((l (length (symbol-name level)))) + (when (> l *max-level-length*) + (setf *max-level-length* l)))) + +(defun level-value (level) + (let ((value (gethash level (get-levels)))) + (if value + value + (progn + (format *output* "UKKOLOG INTERNAL WARN: UNKNOWN LEVEL ~A" level) + 1000)))) + +(defun level< (lhs rhs) + (< (level-value lhs) (level-value rhs))) + +(defstruct (logger (:constructor make-logger%)) + (name (error "No value given for NAME") :type keyword :read-only t) + (min-level :debug :type keyword)) ;TODO: Make this :info and make it configurable + +(defun make-logger (name) + (let ((l (length (symbol-name name)))) + (when (> l *max-name-length*) + (setf *max-name-length* l))) + (make-logger% :name name)) + +(defvar *package-loggers* nil) + +(defun get-package-loggers () + (unless *package-loggers* + (setf *package-loggers* (make-hash-table :test #'eq))) + *package-loggers*) + +(defun get-package-logger (package) + (let* ((name (package-name package)) + (name-sym (intern name :keyword)) + (loggers (get-package-loggers)) + (logger (gethash name-sym loggers))) + (unless logger + (setf logger (make-logger name-sym)) + (setf (gethash name-sym loggers) logger)) + logger)) + +(defun perform-log (package level fmt-str &rest args) + (let ((logger (get-package-logger package))) + (unless (level< level (logger-min-level logger)) + (apply #'format *output* + (concatenate 'string "~&~v@A: ~v@A: " fmt-str "~%") + *max-name-length* (logger-name logger) + *max-level-length* level + args)))) + +(defmacro p (level fmt-str &rest args) + `(perform-log ,*package* ,level ,fmt-str ,@args)) + +(defmacro deflevel (name value) + `(progn + (register-level ,name ,value) + (defmacro ,(intern (concatenate 'string "LOG-" (symbol-name name))) (fmt-str &rest args) + `(p ,,name ,fmt-str ,@args)))) + +(deflevel :error 700) +(deflevel :warn 600) +(deflevel :info 500) +(deflevel :debug 400) 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 +(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 ">:3" + :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 + "" + (escape-xml (string-upcase the-text)) + "") + :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 "Randomly selected reminder that h > H." + :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 "~A" (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 "~A while handling ~&
~A
" + (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"))) diff --git a/src/strings.lisp b/src/strings.lisp new file mode 100644 index 0000000..68289aa --- /dev/null +++ b/src/strings.lisp @@ -0,0 +1,59 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/strings + (:use :c2cl :iterate) + (:import-from :cl-unicode :general-category) + (:export :escape-xml :is-tg-whitespace-str :lisp->snake-case :snake->lisp-case :starts-with :starts-with-ignore-case)) +(in-package :ukkoclot/strings) + +;; These are very inefficient but I don't care until I profile + +(defun escape-xml (str &optional out) + (if out + (escape-xml% str out) + (with-output-to-string (out) + (escape-xml% str out)))) + +(defun escape-xml% (str out) + (loop for ch across str do + (case ch + (#\< (write-string "<" out)) + (#\> (write-string ">" out)) + (#\& (write-string "&" out)) + (#\" (write-string """ out)) + (t (write-char ch out))))) + +(defun is-tg-whitespace (ch) + (let ((gc (general-category ch))) + (or (string= gc "Zs") ; Separator, space + (string= gc "Zl") ; Separator, line + (string= gc "Zp") ; Separator, paragraph + (string= gc "Cc") ; Other, control + (= (char-code ch) #x2800) ; BRAILLE PATTERN BLANK + ))) + +(defun is-tg-whitespace-str (str) + (iter (for ch in-string str) + (always (is-tg-whitespace ch)))) + +(defun lisp->snake-case (str) + (with-output-to-string (out) + (loop for ch across str do + (case ch + (#\- (write-char #\_ out)) + (t (write-char ch out)))))) + +(defun snake->lisp-case (str) + (with-output-to-string (out) + (loop for ch across str do + (case ch + (#\_ (write-char #\- out)) + (t (write-char ch out)))))) + +(defun starts-with (str prefix) + (and (> (length str) (length prefix)) + (string= str prefix :end1 (length prefix)))) + +(defun starts-with-ignore-case (str prefix) + (and (> (length str) (length prefix)) + (string-equal str prefix :end1 (length prefix)))) diff --git a/src/tg-types.lisp b/src/tg-types.lisp new file mode 100644 index 0000000..1243773 --- /dev/null +++ b/src/tg-types.lisp @@ -0,0 +1,18 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(uiop:define-package :ukkoclot/tg-types + (:use) + (:use-reexport + :ukkoclot/tg-types/bot-name + :ukkoclot/tg-types/callback-query + :ukkoclot/tg-types/chat + :ukkoclot/tg-types/force-reply + :ukkoclot/tg-types/inline-keyboard-button + :ukkoclot/tg-types/inline-keyboard-markup + :ukkoclot/tg-types/link-preview-options + :ukkoclot/tg-types/message + :ukkoclot/tg-types/message-entity + :ukkoclot/tg-types/reply-parameters + :ukkoclot/tg-types/update + :ukkoclot/tg-types/user + )) diff --git a/src/tg-types/bot-name.lisp b/src/tg-types/bot-name.lisp new file mode 100644 index 0000000..385b91c --- /dev/null +++ b/src/tg-types/bot-name.lisp @@ -0,0 +1,14 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/tg-types/bot-name + (:use :c2cl :ukkoclot/tg-types/macros) + (:export + bot-name bot-name-p + + hash->bot-name make-bot-name parse-bot-name-array + + bot-name-name)) +(in-package :ukkoclot/tg-types/bot-name) + +(define-tg-type bot-name + (name string)) diff --git a/src/tg-types/callback-query.lisp b/src/tg-types/callback-query.lisp new file mode 100644 index 0000000..bb1b4e7 --- /dev/null +++ b/src/tg-types/callback-query.lisp @@ -0,0 +1,24 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/tg-types/callback-query + (:use :c2cl :ukkoclot/tg-types/macros) + (:use + :ukkoclot/tg-types/message + :ukkoclot/tg-types/user) + (:export + callback-query callback-query-p + + hash->callback-query make-callback-query parse-callback-query-array + + callback-query-id callback-query-from callback-query-message callback-query-inline-message-id + callback-query-chat-instance callback-query-data callback-query-game-short-name)) +(in-package :ukkoclot/tg-types/callback-query) + +(define-tg-type callback-query + (id string) + (from user) + (message (or message null) nil) + (inline-message-id (or string null) nil) + (chat-instance string) + (data (or string null) nil) + (game-short-name (or string null) nil)) diff --git a/src/tg-types/chat.lisp b/src/tg-types/chat.lisp new file mode 100644 index 0000000..4010f7b --- /dev/null +++ b/src/tg-types/chat.lisp @@ -0,0 +1,31 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/tg-types/chat + (:use :c2cl :ukkoclot/tg-types/macros :ukkoclot/tg-types/parsers) + (:export + chat + make-chat + chat-p + copy-chat + chat-id + chat-type + chat-title + chat-username + chat-first-name + chat-last-name + chat-is-forum + chat-is-direct-messages + + hash->chat + parse-chat-array)) +(in-package :ukkoclot/tg-types/chat) + +(define-tg-type chat + (id integer) + (type keyword nil :parser tg-string->keyword) + (title (or string null) nil) + (username (or string null) nil) + (first-name (or string null) nil) + (last-name (or string null) nil) + (is-forum boolean nil) + (is-direct-messages boolean nil)) diff --git a/src/tg-types/force-reply.lisp b/src/tg-types/force-reply.lisp new file mode 100644 index 0000000..ad9d2a0 --- /dev/null +++ b/src/tg-types/force-reply.lisp @@ -0,0 +1,21 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/tg-types/force-reply + (:use :c2cl :ukkoclot/tg-types/macros) + (:export + force-reply + make-force-reply + force-reply-p + copy-force-reply + force-reply-force-reply + force-reply-input-field-placeholder + force-reply-selective + + hash->force-reply + parse-force-reply-array)) +(in-package :ukkoclot/tg-types/force-reply) + +(define-tg-type force-reply + (force-reply boolean t :skip-if-default nil) + (input-field-placeholder (or string null) nil) + (selective boolean nil)) diff --git a/src/tg-types/inline-keyboard-button.lisp b/src/tg-types/inline-keyboard-button.lisp new file mode 100644 index 0000000..3b76ade --- /dev/null +++ b/src/tg-types/inline-keyboard-button.lisp @@ -0,0 +1,32 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/tg-types/inline-keyboard-button + (:use :c2cl :ukkoclot/tg-types/macros) + (:export + inline-keyboard-button + make-inline-keyboard-button + inline-keyboard-button-p + copy-inline-keyboard-button + inline-keyboard-button-text + inline-keyboard-button-url + inline-keyboard-button-callback-data + inline-keyboard-button-switch-inline-query + inline-keyboard-button-switch-inline-query-current-chat + inline-keyboard-button-pay + + hash->inline-keyboard-button + parse-inline-keyboard-button-array)) +(in-package :ukkoclot/tg-types/inline-keyboard-button) + +(define-tg-type inline-keyboard-button + (text string) + (url (or string null) nil) + (callback-data string) + ;; TODO: (web-app (or web-app-info null) nil) + ;; TODO: (login-url (or login-url null) nil) + (switch-inline-query (or string null) nil) + (switch-inline-query-current-chat (or string null) nil) + ;; TODO: (switch-inline-query-chosen-chat (or switch-inline-query-chosen-chat null) nil) + ;; TODO: (copy-text (or copy-text-button null) nil) + ;; TODO: (callback-game (or callback-game null) nil) + (pay boolean nil)) diff --git a/src/tg-types/inline-keyboard-markup.lisp b/src/tg-types/inline-keyboard-markup.lisp new file mode 100644 index 0000000..1f17f6c --- /dev/null +++ b/src/tg-types/inline-keyboard-markup.lisp @@ -0,0 +1,17 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/tg-types/inline-keyboard-markup + (:use :c2cl :ukkoclot/tg-types/inline-keyboard-button :ukkoclot/tg-types/macros) + (:export + inline-keyboard-markup + make-inline-keyboard-markup + inline-keyboard-markup-p + copy-inline-keyboard-markup + inline-keyboard-markup-inline-keyboard + + hash->inline-keyboard-markup + parse-inline-keyboard-markup-array)) +(in-package :ukkoclot/tg-types/inline-keyboard-markup) + +(define-tg-type inline-keyboard-markup + (inline-keyboard (array (array inline-keyboard-button)))) diff --git a/src/tg-types/link-preview-options.lisp b/src/tg-types/link-preview-options.lisp new file mode 100644 index 0000000..66b7d83 --- /dev/null +++ b/src/tg-types/link-preview-options.lisp @@ -0,0 +1,25 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/tg-types/link-preview-options + (:use :c2cl :ukkoclot/tg-types/macros) + (:export + link-preview-options + make-link-preview-options + link-preview-options-p + copy-link-preview-options + link-preview-options-is-disabled + link-preview-options-url + link-preview-options-prefer-small-media + link-preview-options-prefer-large-media + link-preview-options-show-above-text + + hash->link-preview-options + parse-link-preview-options-array)) +(in-package :ukkoclot/tg-types/link-preview-options) + +(define-tg-type link-preview-options + (is-disabled boolean nil) + (url (or string null) nil) + (prefer-small-media boolean nil) + (prefer-large-media boolean nil) + (show-above-text boolean nil)) diff --git a/src/tg-types/macros.lisp b/src/tg-types/macros.lisp new file mode 100644 index 0000000..668df17 --- /dev/null +++ b/src/tg-types/macros.lisp @@ -0,0 +1,134 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/tg-types/macros + (:use :c2cl) + (:import-from :ukkoclot/bot/impl :arg-encode :bot :do-call :will-arg-encode) + (:import-from :ukkoclot/hash-tables :gethash-lazy) + (:import-from :ukkoclot/strings :lisp->snake-case) + (:export :define-tg-method :define-tg-type)) +(in-package :ukkoclot/tg-types/macros) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defstruct (field (:constructor make-field%)) name type default skip-if-default (parser 'identity)) + + (defparameter +unique+ (gensym)) + + (defun make-field (name type &optional (default +unique+) &key (parser 'identity) (skip-if-default (not (eq default +unique+)))) + (let ((default (if (eq default +unique+) + (list 'error (format nil "No value given for ~A" name)) + default))) + (make-field% :name name + :type type + :default default + :skip-if-default skip-if-default + :parser parser))) + + (defun parse-field-specs (field-specs) + (loop for field-spec in field-specs + collect (apply #'make-field field-spec))) + + (defun field-hash-key (field) + (string-downcase (lisp->snake-case (symbol-name (field-name field))))) + + (defun field-accessor (struc-name field) + (intern (concatenate 'string (symbol-name struc-name) "-" (symbol-name (field-name field))))) + + (defun field->defun-spec (field) + (list (field-name field) (field-default field))) + + (defun field->format-arg (field name struc) + `(',(field-name field) (,(field-accessor name field) ,struc))) + + (defun field->ftype-spec (field) + (list (intern (symbol-name (field-name field)) :keyword) (field-type field))) + + (defun field->gethash-spec (field hash-table-sym) + (let ((hash-key (field-hash-key field))) + (list 'gethash-lazy hash-key hash-table-sym (field-default field)))) + + (defun field->sethash-spec (field name struc hash-table-sym) + (let ((hash-key (field-hash-key field)) + (skip-if-default (field-skip-if-default field)) + (default (field-default field))) + (if skip-if-default + (let ((tmpsym (gensym "TMP"))) + `(let ((,tmpsym (,(field-accessor name field) ,struc))) + (unless (equal ,tmpsym ,default) + (setf (gethash ,hash-key ,hash-table-sym) ,tmpsym)))) + `(setf (gethash ,hash-key ,hash-table-sym) (,(field-accessor name field) ,struc))))) + + (defun field->let-gethash-spec (field hash-table-sym) + (list (field-name field) + (list 'funcall + (list 'function (field-parser field)) + (field->gethash-spec field hash-table-sym)))) + + (defun field->make-spec (field) + (list (intern (symbol-name (field-name field)) :keyword) + (field-name field))) + + (defun field->struct-spec (field) + (list (field-name field) (field-default field) :type (field-type field)))) + +;; TODO: Automatically derive path from name +;; TODO: Automatically derive mapfn from type +;; TODO: Skip values that are already their defaults +(defmacro define-tg-method ( + (name type path mapfn &optional (method :POST)) + &body field-specs) + (let ((fields (parse-field-specs field-specs)) + (args-plist (gensym "ARGS-PLIST-")) + (bot (gensym "BOT-"))) + `(progn + (declaim (ftype (function (bot &key ,@(loop for field in fields + collect (field->ftype-spec field))) + ,type) + ,name)) + (defun ,name (,bot &rest ,args-plist &key ,@(loop for field in fields collect (field->defun-spec field))) + (declare ,@(loop for field in fields collect (list 'ignore (field-name field)))) + (do-call ,bot ,method ,path ,mapfn ,args-plist))))) + +(defmacro define-tg-type (name &body field-specs) + (let* ((fields (parse-field-specs field-specs)) + (revfields (reverse fields)) + (make-name (intern (concatenate 'string "MAKE-" (symbol-name name)))) + (hash->name (intern (concatenate 'string "HASH->" (symbol-name name)))) + (parse-name-array (intern (concatenate 'string "PARSE-" (symbol-name name) "-ARRAY"))) + (printer (gensym (concatenate 'string "PRINT-" (symbol-name name)))) + (hash (gensym "HASH-")) + (array (gensym "ARRAY-")) + (struc (gensym (symbol-name name))) + (stream (gensym "STREAM")) + (depth (gensym "DEPTH")) + (pprint-args (gensym "PPRINT-ARGS"))) + `(progn + (defstruct (,name (:print-function ,printer)) + ,@(loop for field in fields + collect (field->struct-spec field))) + (defun ,printer (,struc ,stream ,depth) + (declare (ignore ,depth)) + (let (,pprint-args) + ,@(loop for field in revfields + collecting + (if (field-skip-if-default field) + `(let ((value (,(field-accessor name field) ,struc))) + (unless (equal value ,(field-default field)) + (setf ,pprint-args (list* ',(field-name field) value ,pprint-args)))) + `(setf ,pprint-args (list* ',(field-name field) (,(field-accessor name field) ,struc) ,pprint-args)))) + (format ,stream "~A~<[~;~@{~_~1I~W = ~W~^, ~}~;]~:>" ',name ,pprint-args))) + (defun ,hash->name (,hash) + (when ,hash + (let ,(loop for field in fields + collect (field->let-gethash-spec field hash)) + (,make-name ,@(loop for field in fields + append (field->make-spec field)))))) + (defmethod arg-encode ((,struc ,name)) + (let ((,hash (make-hash-table))) + ,@(loop for field in fields + collect (field->sethash-spec field name struc hash)) + ,hash)) + (defmethod will-arg-encode ((,struc ,name)) + t) + (defun ,parse-name-array (,array) + (when ,array + (map 'vector #',hash->name ,array)))))) diff --git a/src/tg-types/message-entity.lisp b/src/tg-types/message-entity.lisp new file mode 100644 index 0000000..fcabcce --- /dev/null +++ b/src/tg-types/message-entity.lisp @@ -0,0 +1,61 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/tg-types/message-entity + (:use :c2cl :iterate :ukkoclot/tg-types/macros :ukkoclot/tg-types/parsers :ukkoclot/tg-types/user) + (:export + message-entity + make-message-entity + message-entity-p + copy-message-entity + message-entity-type + message-entity-offset + message-entity-length + message-entity-url + message-entity-user + message-entity-language + message-entity-custom-emoji-id + + hash->message-entity + message-entity-extract + parse-message-entity-array)) +(in-package :ukkoclot/tg-types/message-entity) + +(define-tg-type message-entity + (type keyword nil :parser tg-string->keyword) + (offset integer) + (length integer) + (url (or string null) nil) + (user (or user null) nil) + (language (or string null) nil) + (custom-emoji-id (or string null) nil)) + +(unless (= char-code-limit #x110000) + (error "Some UTF-16 fuckery assumes that system chars are UTF-32")) + +(defun utf16-width (ch) + (if (< (char-code ch) #x10000) + 1 + 2)) + +(defun message-entity-extract (entity text) + (with-slots (length offset) entity + (if (= length 0) + "" + (let* ((start (iterate + (with curr-idx16 = 0) + (for ch in-string text with-index curr-idx32) + (for curr-width = (utf16-width ch)) + (when (or (= curr-idx16 offset) + (> (+ curr-idx16 curr-width) offset)) + (return curr-idx32)) + (setq curr-idx16 (+ curr-idx16 curr-width)) + (finally (return (length text))))) + (end (iterate + (with curr-len16 = 0) + (for ch in-string text from start with-index curr-idx32) + (for curr-width = (utf16-width ch)) + (when (>= curr-len16 length) + (return curr-idx32)) + (setq curr-len16 (+ curr-len16 curr-width)) + (finally (return (length text)))))) + (subseq text start end))))) diff --git a/src/tg-types/message.lisp b/src/tg-types/message.lisp new file mode 100644 index 0000000..fee0734 --- /dev/null +++ b/src/tg-types/message.lisp @@ -0,0 +1,168 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/tg-types/message + (:use :c2cl :ukkoclot/tg-types/macros + + :ukkoclot/tg-types/chat + :ukkoclot/tg-types/message-entity + :ukkoclot/tg-types/user) + (:export + message + make-message + message-p + copy-message + message-message-id + message-message-thread-id + message-from + message-sender-boost-count + message-sender-business-bot + message-date + message-business-connection-id + message-chat + message-is-topic-message + message-is-automatic-forward + message-reply-to-message + message-reply-to-checklist-task-id + message-via-bot + message-edit-date + message-has-protected-content + message-is-from-offline + message-is-paid-post + message-media-group-id + message-author-signature + message-paid-star-count + message-text + message-entities + message-effect-id + message-caption + message-show-caption-above-media + message-has-media-spoiler + message-new-chat-members + message-new-chat-title + message-delete-chat-photo + message-group-chat-created + message-supergroup-chat-created + message-channel-chat-created + message-migrate-to-chat-id + message-migrate-from-chat-id + message-pinned-message + message-connected-website + + hash->message + message-id + message-chat-id + message-thread-id + parse-message-array)) +(in-package :ukkoclot/tg-types/message) + +;; If this is a MaybeInaccessibleMessage date will be 0 if this is inaccessible +(define-tg-type message + (message-id integer) + (message-thread-id (or integer null) nil) + ;; (direct-messages-topic (or direct-messages-topic null) nil) + (from (or user null) nil :parser hash->user) + ;; (sender-chat (or chat null) nil) + (sender-boost-count (or integer null) nil) + (sender-business-bot (or user null) nil :parser hash->user) + (date integer) + (business-connection-id (or string null) nil) + (chat chat nil :parser hash->chat) + ;; (forward-origin (or message-origin null) nil) + (is-topic-message boolean nil) + (is-automatic-forward boolean nil) + (reply-to-message (or message null) nil :parser hash->message) + ;; (external-reply (or external-reply-info null) nil) + ;; (quote (or text-quote null) nil) + ;; (reply-to-story (or story null) nil) + (reply-to-checklist-task-id (or integer null) nil) + (via-bot (or user null) nil :parser hash->user) + (edit-date (or integer null) nil) + (has-protected-content boolean nil) + (is-from-offline boolean nil) + (is-paid-post boolean nil) + (media-group-id (or string null) nil) + (author-signature (or string null) nil) + (paid-star-count (or string null) nil) + (text (or string null) nil) + (entities (or (array message-entity) null) nil :parser parse-message-entity-array) + ;; (link-preview-options (or link-preview-options null) nil) + ;; (suggested-post-info (or suggested-post-info null) nil) + (effect-id (or string null) nil) + ;; (animation (or animation null) nil) + ;; (audio (or audio null) nil) + ;; (document (or document null) nil) + ;; (paid-media (or paid-media-info null) nil) + ;; (photo (or (array photo-size) null) nil) + ;; (sticker (or sticker null) nil) + ;; (story (or story null) nil) + ;; (video (or video null) nil) + ;; (video-note (or video-note null) nil) + ;; (voice (or voice null) nil) + (caption (or string null) nil) + ;; (caption-entities (or (array message-entity) null) nil) + (show-caption-above-media boolean nil) + (has-media-spoiler boolean nil) + ;; (contact (or contact null) nil) + ;; (dice (or dice null) nil) + ;; (game (or game null) nil) + ;; (poll (or poll null) nil) + ;; (venue (or venue null) nil) + ;; (location (or location null) nil) + (new-chat-members (or (array user) null) nil :parser parse-user-array) + ;; (left-chat-member (or user null) nil) + (new-chat-title (or string null) nil) + ;; (new-chat-photo (or (array photo-size) null) nil) + (delete-chat-photo boolean nil) + (group-chat-created boolean nil) + (supergroup-chat-created boolean nil) + (channel-chat-created boolean nil) + ;; (message-auto-delete-timer-changed (orp message-auto-delete-timer-changed null) nil) + (migrate-to-chat-id (or integer null) nil) + (migrate-from-chat-id (or integer null) nil) + (pinned-message (or message null) nil :parser hash->message) + ;; (invoice (or invoice null) nil) + ;; (successful-payment (or successful-payment null) nil) + ;; (refunded-payment (or refunded-payment null) nil) + ;; (users-shared (or users-shared null) nil) + ;; (chat-shared (or chat-shared null) nil) + ;; (gift (or gift-info null) nil) + ;; (unique-gift (or unique-gift-info null) nil) + (connected-website (or string null) nil) + ;; (write-access-allowed (or write-access-allowed null) nil) + ;; (passport-data (or passport-data null) nil) + ;; (proximity-alert-triggered (or proximity-alert-triggered null) nil) + ;; (boost-added (or chat-boost-added null) nil) + ;; (chat-background-set (or chat-background null) nil) + ;; (checklist-tasks-added (or checklist-tasks-added null) nil) + ;; (direct-message-price-changed (or direct-message-price-changed null) nil) + ;; (forum-topic-created (or forum-topic-created null) nil) + ;; (forum-topic-edited (or forum-topic-edited null) nil) + ;; (forum-topic-closed (or forum-topic-closed null) nil) + ;; (forum-topic-reopened (or forum-topic-reopened null) nil) + ;; (general-forum-topic-hidden (or general-forum-topic-hidden null) nil) + ;; (general-forum-topic-unhidden (or general-forum-topic-unhidden null) nil) + ;; (giveaway-created (or giveaway-created null) nil) + ;; (giveaway-winners (or giveaway-winners null) nil) + ;; (giveaway-completed (or giveaway-completed null) nil) + ;; (paid-message-price-changed (or paid-message-price-changed null) nil) + ;; (suggested-post-approved (or suggested-post-approved null) nil) + ;; (suggested-post-approval-failed (or suggested-post-approval-failed null) nil) + ;; (suggested-post-declined (or suggested-post-declined null) nil) + ;; (suggested-post-paid (or suggested-post-paid null) nil) + ;; (suggested-post-refunded (or suggested-post-refunded null) nil) + ;; (video-chat-scheduled (or video-chat-scheduled null) nil) + ;; (video-chat-started (or video-chat-started null) nil) + ;; (video-chat-ended (or video-chat-ended null) nil) + ;; (video-chat-participants-invited (or video-chat-participants-invited null) nil) + ;; (web-app-data (or web-app-data null) nil) + ;; (reply-markup (or inline-keyboard-markup null) nil) + ) + +(defun message-id (msg) + (message-message-id msg)) + +(defun message-chat-id (msg) + (chat-id (message-chat msg))) + +(defun message-thread-id (msg) + (message-message-thread-id msg)) diff --git a/src/tg-types/parsers.lisp b/src/tg-types/parsers.lisp new file mode 100644 index 0000000..0b6c4ae --- /dev/null +++ b/src/tg-types/parsers.lisp @@ -0,0 +1,9 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/tg-types/parsers + (:use :c2cl :ukkoclot/strings) + (:export tg-string->keyword)) +(in-package :ukkoclot/tg-types/parsers) + +(defun tg-string->keyword (str) + (intern (string-upcase (snake->lisp-case str)) :keyword)) diff --git a/src/tg-types/reply-parameters.lisp b/src/tg-types/reply-parameters.lisp new file mode 100644 index 0000000..5f0595d --- /dev/null +++ b/src/tg-types/reply-parameters.lisp @@ -0,0 +1,32 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/tg-types/reply-parameters + (:use :c2cl :ukkoclot/tg-types/macros :ukkoclot/tg-types/message-entity) + (:export + reply-parameters + make-reply-parameters + reply-parameters-p + copy-reply-parameters + reply-parameters-message-id + reply-parameters-chat-id + reply-parameters-allow-sending-without-reply + reply-parameters-quote + reply-parameters-quote-parse-mode + reply-parameters-quote-entities + reply-parameters-quote-position + reply-parameters-checklist-task-id + + hash->reply-parameters + parse-reply-parameters-array)) +(in-package :ukkoclot/tg-types/reply-parameters) + +(define-tg-type reply-parameters + (message-id integer) + (chat-id (or integer string null) nil) + ;; Technically true if on a business account but yeah right lmao + (allow-sending-without-reply boolean nil) + (quote (or string null) nil) + (quote-parse-mode (or string null) nil) + (quote-entities (or (array message-entity) null) nil) + (quote-position (or integer null) nil) + (checklist-task-id (or integer null) nil)) diff --git a/src/tg-types/update.lisp b/src/tg-types/update.lisp new file mode 100644 index 0000000..9043d54 --- /dev/null +++ b/src/tg-types/update.lisp @@ -0,0 +1,47 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/tg-types/update + (:use :c2cl :ukkoclot/tg-types/macros + :ukkoclot/tg-types/callback-query + :ukkoclot/tg-types/message) + (:export + update update-p + + hash->update make-update parse-update-array + + update-update-id update-message update-edited-message update-channel-post update-edited-channel-post + ;; update-business-connection + update-business-message update-edited-business-message + ;; update-deleted-business-messages update-message-reaction update-message-reaction-count update-inline-query + ;; update-chosen-inline-result + update-callback-query + ;; update-shipping-query update-pre-checkout-query update-poll update-poll-answer update-my-chat-member + ;; update-chat-member update-chat-join-request update-chat-boost update-removed-chat-boost + )) +(in-package :ukkoclot/tg-types/update) + +(define-tg-type update + (update-id integer) + (message (or message null) nil :parser hash->message) + (edited-message (or message null) nil :parser hash->message) + (channel-post (or message null) nil :parser hash->message) + (edited-channel-post (or message null) nil :parser hash->message) + ;; (business-connection (or business-connection null) nil) + (business-message (or message null) nil :parser hash->message) + (edited-business-message (or message null) nil :parser hash->message) + ;; (deleted-business-messages (or business-messages-deleted null) nil) + ;; (message-reaction (or message-reaction-updated null) nil) + ;; (message-reaction-count (or message-reaction-count-updated null) nil) + ;; (inline-query (or inline-query null) nil) + ;; (chosen-inline-result (or chosen-inline-result null) nil) + (callback-query (or callback-query null) nil :parser hash->callback-query) + ;; (shipping-query (or shipping-query null) nil) + ;; (pre-checkout-query (or pre-checkout-query null) nil) + ;; (poll (or poll null) nil) + ;; (poll-answer (or poll-answer null) nil) + ;; (my-chat-member (or chat-member-updated null) nil) + ;; (chat-member (or chat-member-updated null) nil) + ;; (chat-join-request (or chat-join-request null) nil) + ;; (chat-boost (or chat-boost-updated null) nil) + ;; (removed-chat-boost (or chat-boost-removed) nil) + ) diff --git a/src/tg-types/user.lisp b/src/tg-types/user.lisp new file mode 100644 index 0000000..c5ed499 --- /dev/null +++ b/src/tg-types/user.lisp @@ -0,0 +1,48 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/tg-types/user + (:use :c2cl :ukkoclot/tg-types/macros) + (:import-from :ukkoclot/strings :escape-xml) + (:export + user user-p + + hash->user make-user parse-user-array user-format-name + + user-id user-is-bot user-first-name user-last-name user-username user-language-code user-is-premium + user-added-to-attachment-menu user-can-join-groups user-can-read-all-group-messages user-supports-inline-queries + user-can-connect-to-business)) +(in-package :ukkoclot/tg-types/user) + +(define-tg-type user + (id integer) + (is-bot boolean) + (first-name string) + (last-name (or string null) nil) + (username (or string null) nil) + (language-code (or string null) nil) + (is-premium boolean nil) + (added-to-attachment-menu boolean nil) + (can-join-groups boolean nil) + (can-read-all-group-messages boolean nil) + (supports-inline-queries boolean nil) + (can-connect-to-business boolean nil)) + +(defun user-format-name% (user out) + (format out "" (user-id user)) + (escape-xml (user-first-name user) out) + (when (user-last-name user) + (write-char #\Space out) + (escape-xml (user-last-name user) out)) + (write-string "" out) + + (when (user-username user) + (write-string " @" out) + (escape-xml (user-username user) out)) + + (format out " [~A]" (user-id user))) + +(defun user-format-name (user &optional out) + (if out + (user-format-name% user out) + (with-output-to-string (stream) + (user-format-name% user stream)))) -- cgit v1.2.3