summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/bot.lisp6
-rw-r--r--src/bot/impl.lisp96
-rw-r--r--src/bot/methods.lisp88
-rw-r--r--src/config.lisp28
-rw-r--r--src/db.lisp82
-rw-r--r--src/hash-tables.lisp27
-rw-r--r--src/inline-bots.lisp42
-rw-r--r--src/log.lisp85
-rw-r--r--src/main.lisp354
-rw-r--r--src/strings.lisp59
-rw-r--r--src/tg-types.lisp18
-rw-r--r--src/tg-types/bot-name.lisp14
-rw-r--r--src/tg-types/callback-query.lisp24
-rw-r--r--src/tg-types/chat.lisp31
-rw-r--r--src/tg-types/force-reply.lisp21
-rw-r--r--src/tg-types/inline-keyboard-button.lisp32
-rw-r--r--src/tg-types/inline-keyboard-markup.lisp17
-rw-r--r--src/tg-types/link-preview-options.lisp25
-rw-r--r--src/tg-types/macros.lisp134
-rw-r--r--src/tg-types/message-entity.lisp61
-rw-r--r--src/tg-types/message.lisp168
-rw-r--r--src/tg-types/parsers.lisp9
-rw-r--r--src/tg-types/reply-parameters.lisp32
-rw-r--r--src/tg-types/update.lisp47
-rw-r--r--src/tg-types/user.lisp48
25 files changed, 1548 insertions, 0 deletions
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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(uiop:define-package :ukkoclot/bot
4 (:use)
5 ;; Maybe should somehow hide BOT-USERNAME% and BOT-ID% but whatever
6 (: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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/bot/impl
4 (:use :c2cl :iterate :ukkoclot/config :ukkoclot/log)
5 (:import-from :anaphora :aand :acond :it)
6 (:import-from :dex)
7 (:import-from :ukkoclot/strings :lisp->snake-case)
8 (:local-nicknames
9 (:jzon :com.inuoe.jzon))
10 (:export
11 :arg-encode :bot :bot-p :make-bot :do-call
12
13 :bot-config :bot-db :bot-base-uri :bot-power-on :bot-username% :bot-id%))
14(in-package :ukkoclot/bot/impl)
15
16(defgeneric will-arg-encode (object)
17 (:documentation "Whether the OBJECT has any transformation done to it by arg-encode")
18 (:method (obj)
19 nil)
20 (:method ((obj cons))
21 (or (will-arg-encode (car obj))
22 (will-arg-encode (cdr obj)))))
23
24(defgeneric arg-encode (object)
25 (:documentation "Encode the OBJECT to a form that our HTTP code is happy about.")
26 (:method (obj)
27 obj)
28 (:method ((obj cons))
29 (if (not (will-arg-encode obj))
30 obj
31 (cons (arg-encode (car obj))
32 (arg-encode (cdr obj))))))
33
34(defgeneric fixup-arg (value)
35 (:documentation "Make sure Telegram & QURI & whatever like the arg")
36 (:method (value)
37 (error "Unsupported argument type ~S (~S)" (class-name (class-of value)) value))
38 (:method ((value null))
39 value)
40 (:method ((value number))
41 value)
42 (:method ((value string))
43 value)
44 (:method ((value hash-table))
45 (jzon:stringify value)))
46
47(defstruct (bot (:constructor make-bot%))
48 (config (error "No value given for config") :read-only t)
49 (db (error "No value given for DB") :read-only t)
50 (base-uri (error "No value given for base-uri") :read-only t)
51 (power-on t :type boolean)
52 (username% nil :type (or string null))
53 (id% nil :type (or integer null)))
54
55(defun make-bot (config db)
56 (let ((base-uri (concatenate 'string
57 "https://api.telegram.org/bot"
58 (config-bot-token config) "/")))
59 (make-bot% :config config :db db :base-uri base-uri)))
60
61(defun args-plist->alist (args-plist)
62 (iter (for (old-key value) on args-plist by #'cddr)
63 (collect
64 (let ((new-key (string-downcase (lisp->snake-case (symbol-name old-key)))))
65 (cons new-key value)))))
66
67(defun fixup-args (args-alist)
68 (iter (for (name . value) in args-alist)
69 (collecting (cons name (fixup-arg (arg-encode value))))))
70
71(defun req (uri method content)
72 ;; We deal with this manually
73 (handler-bind ((dex:http-request-too-many-requests #'dex:ignore-and-continue))
74 (dex:request uri :method method :content content)))
75
76(defun do-call% (bot method uri mapfn args-encoded)
77 (let ((body (req uri method args-encoded)))
78 (let ((hash (jzon:parse body)))
79 (acond
80 ((gethash "ok" hash) (funcall mapfn (gethash "result" hash)))
81 ((aand (gethash "parameters" hash)
82 (gethash "retry_after" it))
83 (log-info "Should sleep for ~A seconds" it)
84 (sleep it)
85 (log-info "Good morning!")
86 (do-call% bot method uri mapfn args-encoded))
87 (t (error "TG error ~A: ~A ~:A"
88 (gethash "error_code" hash)
89 (gethash "description" hash)
90 (gethash "parameters" hash)))))))
91
92(defun do-call (bot method path mapfn args-plist)
93 (let ((uri (concatenate 'string (bot-base-uri bot) path))
94 (args-encoded (fixup-args (args-plist->alist args-plist))))
95 (log-debug "~A .../~A ~S" method path args-encoded)
96 (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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/bot/methods
4 (:use :c2cl :ukkoclot/bot/impl :ukkoclot/tg-types :ukkoclot/tg-types/macros)
5 (:export :answer-callback-query :bot-id :bot-username :delete-message :edit-message-text :get-me :get-updates :send-message :set-my-name))
6(in-package :ukkoclot/bot/methods)
7
8(define-tg-method (answer-callback-query boolean "answerCallbackQuery" #'identity)
9 (callback-query-id string)
10 (text (or string null) nil)
11 (show-alert boolean nil)
12 (url (or string null) nil)
13 (cache-time (or integer null) nil))
14
15(defun bot-id (bot)
16 (or (bot-id% bot)
17 (progn
18 (get-me bot)
19 (bot-id% bot))))
20
21(defun bot-username (bot)
22 (or (bot-username% bot)
23 (progn
24 (get-me bot)
25 (bot-username% bot))))
26
27(define-tg-method (delete-message boolean "deleteMessage" #'identity)
28 (chat-id (or integer string))
29 (message-id integer))
30
31(define-tg-method (edit-message-text message "editMessageText" #'hash->message)
32 (business-connection-id (or string null) nil)
33 (chat-id (or integer string null) nil)
34 (message-id (or integer null) nil)
35 (inline-message-id (or string null) nil)
36 (text string)
37 (parse-mode (or string null) nil)
38 (entities (or (array message-entity) null) nil)
39 (link-preview-options (or link-preview-options null) nil)
40 (reply-markup (or inline-keyboard-markup null) nil))
41
42(define-tg-method (get-me% user "getMe" #'hash->user :GET))
43
44(defun get-me (bot)
45 (let ((res (get-me% bot)))
46 (setf (bot-id% bot) (user-id res))
47 (setf (bot-username% bot) (user-username res))
48 res))
49
50(define-tg-method (get-my-name bot-name "getMyName" #'hash->bot-name :GET)
51 (language-code (or string null) nil))
52
53(define-tg-method (get-updates (array update) "getUpdates" #'parse-update-array)
54 (offset (or integer null) nil)
55 (limit (or integer null) nil)
56 (timeout (or integer null) nil)
57 (allowed-updates (or string null) nil))
58
59(define-tg-method (send-message message "sendMessage" #'hash->message)
60 (business-connection-id (or string null) nil)
61 (chat-id (or integer string))
62 (message-thread-id (or integer null) nil)
63 (text string)
64 ;; TODO: parse-mode should maybe be keywords?
65 (parse-mode (or string null) nil)
66 (entities (or (array message-entity) null) nil)
67 (link-preview-options (or link-preview-options null) nil)
68 (disable-notification (or boolean null) nil)
69 (protect-content (or boolean null) nil)
70 (message-effect-id (or string null) nil)
71 (reply-parameters (or reply-parameters null) nil)
72 (reply-markup (or inline-keyboard-markup
73 ;; TODO: reply-keyboard-markup
74 ;; TODO: reply-keyboard-remove
75 force-reply null) nil))
76
77(define-tg-method (set-my-name% boolean "setMyName" #'identity)
78 (name (or string null) nil)
79 (language-code (or string null) nil))
80
81(defun set-my-name (bot &key (name nil) (language-code nil))
82 (block nil
83 (when name
84 (let ((curr-name (get-my-name bot :language-code language-code)))
85 (when (string= name (bot-name-name curr-name))
86 (return))))
87 (unless (set-my-name% bot :name name :language-code language-code)
88 (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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/config
4 (:use :c2cl :ukkoclot/hash-tables :ukkoclot/log)
5 (:export
6 :config-load :config-merge
7 :config-p
8 :config-bot-name :config-bot-token :config-db-path :config-dev-group :config-owner))
9(in-package :ukkoclot/config)
10
11(defmacro defconfig (&rest slots-and-types)
12 `(defstruct config
13 ,@(loop for (name type) on slots-and-types by #'cddr
14 collect `(,(intern (symbol-name name)) (error "No value given for ~A" ,name) :type ,type :read-only t))))
15
16(defconfig
17 :bot-name string
18 :bot-token string
19 :db-path string
20 :dev-group integer
21 :owner integer)
22
23(defun config-load (filename)
24 (apply #'make-config (with-open-file (f filename) (read f))))
25
26(defun config-merge (config filename)
27 (loop for (name value) on (with-open-file (f filename) (read f)) by #'cddr do
28 (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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/db
4 (:use :c2cl :sqlite :ukkoclot/log)
5 (:export :get-inline-bot-type :set-inline-bot-type :with-db))
6(in-package :ukkoclot/db)
7
8(defparameter +target-version+ 1
9 "Intended DB version")
10
11(defmacro with-db ((name path) &body body)
12 `(let ((,name (connect ,path)))
13 (unwind-protect (progn (upgrade ,name) ,@body)
14 (disconnect ,name))))
15
16(defun get-inline-bot-type (db id)
17 (let ((type-int (execute-single db "SELECT type FROM inline_bots WHERE id = ?" id)))
18 (when type-int
19 (integer->inline-bot-type type-int))))
20
21(defun set-inline-bot-type (db id type)
22 (execute-non-query db "INSERT OR REPLACE INTO inline_bots (id, type) VALUES (?, ?)" id (inline-bot-type->integer type)))
23
24(defun inline-bot-type->integer (type)
25 (case type
26 (:blacklisted 0)
27 (:whitelisted 1)
28 (t (error "Unknown inline bot type ~S" type))))
29
30(defun integer->inline-bot-type (num)
31 (case num
32 (0 :blacklisted)
33 (1 :whitelisted)
34 (t (error "Unknown inline bot type value ~S" num))))
35
36(defun upgrade (db)
37 (execute-non-query db "CREATE TABLE IF NOT EXISTS version(id INTEGER PRIMARY KEY, version INTEGER)")
38 (let ((current-ver (execute-single db "SELECT version FROM version WHERE id = 0")))
39 (unless current-ver
40 (setf current-ver 0))
41 (cond
42 ((= current-ver +target-version+) (log-info "Database is up to date"))
43
44 ((> current-ver +target-version+)
45 (log-error "Database has a higher version than supported?")
46 (error "Corrupted Database"))
47
48 (t
49 (log-info "Updating database from version ~A to ~A" current-ver +target-version+)
50 (loop while (< current-ver +target-version+)
51 do (with-transaction db
52 (log-info "Updating database step from ~A" current-ver)
53 (incf current-ver)
54 (upgrade-step db current-ver)
55 (execute-non-query
56 db
57 "INSERT OR REPLACE INTO version(id, version) VALUES (0, ?)"
58 current-ver)))
59 (log-info "Database updating complete :)")))))
60
61(defun upgrade-step (db new-version)
62 (case new-version
63 (1
64 (execute-non-query db "DROP TABLE IF EXISTS inline_bots_enum")
65 (execute-non-query db "
66CREATE TABLE inline_bots_enum (
67 id INTEGER PRIMARY KEY,
68 value TEXT UNIQUE
69)")
70 (execute-non-query db "
71INSERT INTO inline_bots_enum(id, value)
72VALUES (?, 'blacklisted'), (?, 'whitelisted')"
73 (inline-bot-type->integer :blacklisted)
74 (inline-bot-type->integer :whitelisted))
75
76 (execute-non-query db "DROP TABLE IF EXISTS inline_bots")
77 (execute-non-query db "
78CREATE TABLE inline_bots (
79 id INTEGER PRIMARY KEY,
80 type INTEGER REFERENCES inline_bots_enum(id)
81)"))
82 (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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/hash-tables
4 (:use :c2cl)
5 (:export :alist->hash-table :gethash-lazy :plist->hash-table))
6(in-package :ukkoclot/hash-tables)
7
8(defun alist->hash-table (alist &rest args &key &allow-other-keys)
9 (let ((ht (apply #'make-hash-table args)))
10 (loop for (key . value) in alist do
11 (setf (gethash key ht) value))
12 ht))
13
14(defmacro gethash-lazy (key hash-table default-lazy)
15 (let ((unique (gensym "UNIQUE-"))
16 (res (gensym "RES-")))
17 `(let* ((,unique ',unique)
18 (,res (gethash ,key ,hash-table ,unique)))
19 (if (eq ,res ,unique)
20 ,default-lazy
21 ,res))))
22
23(defun plist->hash-table (plist &rest args &key &allow-other-keys)
24 (let ((ht (apply #'make-hash-table args)))
25 (loop for (key value) on plist by #'cddr do
26 (setf (gethash key ht) value))
27 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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/inline-bots
4 (:use :c2cl :ukkoclot/bot :ukkoclot/config :ukkoclot/log :ukkoclot/tg-types)
5 (:local-nicknames (:db :ukkoclot/db))
6 (:export :blacklist-inline-bot :on-inline-bot :whitelist-inline-bot))
7(in-package :ukkoclot/inline-bots)
8
9(defun blacklist-inline-bot (bot inline-bot-id)
10 (db:set-inline-bot-type (bot-db bot) inline-bot-id :blacklisted))
11
12(defun whitelist-inline-bot (bot inline-bot-id)
13 (db:set-inline-bot-type (bot-db bot) inline-bot-id :whitelisted))
14
15(defun on-inline-bot (bot msg via)
16 (let ((ty (db:get-inline-bot-type (bot-db bot) (user-id via))))
17 (if (eq ty :whitelisted)
18 t
19 (progn
20 (log-info "Deleting an unallowed inline bot message from ~A ~A"
21 (user-username via)
22 (user-id via))
23 (delete-message bot
24 :chat-id (message-chat-id msg)
25 :message-id (message-id msg))
26 (unless (eq ty :blacklisted)
27 ;; Not explicitly blacklisted, notify dev group
28 (send-message bot
29 :chat-id (config-dev-group (bot-config bot))
30 :text (format nil "Deleted a message sent via inline bot @~A <code>~A</code>"
31 (user-username via)
32 (user-id via))
33 :parse-mode "HTML"
34 :reply-markup (make-inline-keyboard-markup
35 :inline-keyboard
36 #(#((make-inline-keyboard-button
37 :text "Whitelist"
38 :callback-data (format nil "bwl:~A" (user-id via)))
39 (make-inline-keyboard-button
40 :text "Blacklist"
41 :callback-data (format nil "bbl:~A" (user-id via))))))))
42 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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/log
4 (:use :c2cl)
5 (:export :*output* :deflevel :log-error :log-warn :log-info :log-debug))
6(in-package :ukkoclot/log)
7
8(defparameter *output* *error-output*)
9
10(defvar *max-name-length* 8)
11(defvar *max-level-length* 4)
12
13(defvar *levels* nil)
14
15(defun get-levels ()
16 (unless *levels*
17 (setf *levels* (make-hash-table :test #'eq)))
18 *levels*)
19
20(defun register-level (level value)
21 (setf (gethash level (get-levels)) value)
22 (let ((l (length (symbol-name level))))
23 (when (> l *max-level-length*)
24 (setf *max-level-length* l))))
25
26(defun level-value (level)
27 (let ((value (gethash level (get-levels))))
28 (if value
29 value
30 (progn
31 (format *output* "UKKOLOG INTERNAL WARN: UNKNOWN LEVEL ~A" level)
32 1000))))
33
34(defun level< (lhs rhs)
35 (< (level-value lhs) (level-value rhs)))
36
37(defstruct (logger (:constructor make-logger%))
38 (name (error "No value given for NAME") :type keyword :read-only t)
39 (min-level :debug :type keyword)) ;TODO: Make this :info and make it configurable
40
41(defun make-logger (name)
42 (let ((l (length (symbol-name name))))
43 (when (> l *max-name-length*)
44 (setf *max-name-length* l)))
45 (make-logger% :name name))
46
47(defvar *package-loggers* nil)
48
49(defun get-package-loggers ()
50 (unless *package-loggers*
51 (setf *package-loggers* (make-hash-table :test #'eq)))
52 *package-loggers*)
53
54(defun get-package-logger (package)
55 (let* ((name (package-name package))
56 (name-sym (intern name :keyword))
57 (loggers (get-package-loggers))
58 (logger (gethash name-sym loggers)))
59 (unless logger
60 (setf logger (make-logger name-sym))
61 (setf (gethash name-sym loggers) logger))
62 logger))
63
64(defun perform-log (package level fmt-str &rest args)
65 (let ((logger (get-package-logger package)))
66 (unless (level< level (logger-min-level logger))
67 (apply #'format *output*
68 (concatenate 'string "~&~v@A: ~v@A: " fmt-str "~%")
69 *max-name-length* (logger-name logger)
70 *max-level-length* level
71 args))))
72
73(defmacro p (level fmt-str &rest args)
74 `(perform-log ,*package* ,level ,fmt-str ,@args))
75
76(defmacro deflevel (name value)
77 `(progn
78 (register-level ,name ,value)
79 (defmacro ,(intern (concatenate 'string "LOG-" (symbol-name name))) (fmt-str &rest args)
80 `(p ,,name ,fmt-str ,@args))))
81
82(deflevel :error 700)
83(deflevel :warn 600)
84(deflevel :info 500)
85(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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/main
4 (:nicknames :ukkoclot)
5 (:use :c2cl :ukkoclot/bot :ukkoclot/config :ukkoclot/inline-bots :ukkoclot/log :ukkoclot/tg-types)
6 (:import-from :anaphora :aand :awhen :it)
7 (:import-from :ukkoclot/bot :make-bot :bot-power-on)
8 (:import-from :ukkoclot/db :with-db)
9 (:import-from :ukkoclot/strings :escape-xml :is-tg-whitespace-str :starts-with :starts-with-ignore-case)
10 (:local-nicknames
11 (:jzon :com.inuoe.jzon))
12 (:export :main))
13(in-package :ukkoclot/main)
14
15(defvar *in-prod* t)
16
17(defmacro reporty ((evt) &body body)
18 `(if *in-prod*
19 (handler-case (progn ,@body)
20 (error (err) (report-error bot ,evt err)))
21 (progn ,@body)))
22
23(defun main ()
24 (unwind-protect
25 (let ((config (config-load #P"config.default.lisp")))
26 (config-merge config #P"config.lisp")
27 (log-info "Starting up ~A" (config-bot-name config))
28 (with-db (db (config-db-path config))
29 (let ((bot (make-bot config db)))
30 ;; TODO: Catch fatal errors & report them
31 (wrapped-main bot config))))
32 (log-info "We're done!")))
33
34(defun wrapped-main (bot config)
35 (send-message bot :chat-id (config-dev-group config) :text "Initializing...")
36 (set-my-name bot :name (config-bot-name config))
37 (let ((gup-offset 0))
38 (loop while (bot-power-on bot) do
39 (let ((updates (get-updates bot :timeout 60 :offset gup-offset)))
40 (loop for update across updates do
41 (unwind-protect
42 (progn
43 (awhen (update-message update)
44 (reporty (it)
45 (on-message bot it)))
46 (awhen (update-callback-query update)
47 (reporty (it)
48 (on-callback-query bot it))))
49 (setf gup-offset (1+ (update-update-id update)))))))
50 ;; One last getUpdates to make sure offset is stored on server
51 (get-updates bot :timeout 0 :limit 1 :offset gup-offset))
52 (send-message bot :chat-id (config-dev-group config) :text "Shutting down..."))
53
54(defun on-callback-query (bot cb)
55 (let ((data (callback-query-data cb)))
56 (cond ((and data
57 (starts-with data "bbl:")
58 (= (user-id (callback-query-from cb))
59 (config-owner (bot-config bot))))
60 (let ((bot-id (read-from-string data t nil :start 4)))
61 (blacklist-inline-bot bot bot-id))
62 (awhen (callback-query-message cb)
63 (delete-message bot
64 :chat-id (message-chat-id it)
65 :message-id (message-id it)))
66 (answer-callback-query bot
67 :callback-query-id (callback-query-id cb)
68 :text "OK"))
69 ((and data
70 (starts-with data "bwl:")
71 (= (user-id (callback-query-from cb))
72 (config-owner (bot-config bot))))
73 (let ((bot-id (read-from-string data t nil :start 4)))
74 (whitelist-inline-bot bot bot-id))
75 (awhen (callback-query-message cb)
76 (delete-message bot
77 :chat-id (message-chat-id it)
78 :message-id (message-id it)))
79 (answer-callback-query bot
80 :callback-query-id (callback-query-id cb)
81 :text "OK"))
82 (t
83 (log-info "Unrecognised callback query data: ~A" data)
84 (answer-callback-query bot
85 :callback-query-id (callback-query-id cb)
86 :text "Unallowed callback query, don't press the button again"
87 :show-alert t)))))
88
89
90(defun on-message (bot msg)
91 (block nil
92 (awhen (message-via-bot msg)
93 (unless (on-inline-bot bot msg it)
94 (return)))
95
96 (awhen (message-text msg)
97 (on-text-message bot msg it))
98
99 (awhen (message-new-chat-members msg)
100 (loop for new-chat-member across it do
101 (on-new-member bot msg new-chat-member)))))
102
103(defun on-new-member (bot msg new-member)
104 ;; TODO: Rule 11 no hating on cats on bot entry
105 ;; TODO: Rule 10 have fun and enjoy your time on user entry
106 (if (= (user-id new-member) (bot-id bot))
107 nil
108 (send-message bot
109 :chat-id (message-chat-id msg)
110 :text (concatenate 'string "Hello there, " (user-format-name new-member) "! Be on your bestest behaviour now!!")
111 :parse-mode "HTML"
112 :reply-parameters
113 (make-reply-parameters
114 :allow-sending-without-reply t
115 :message-id (message-id msg)
116 :chat-id (message-chat-id msg)))))
117
118(defun is-bad-text (text)
119 ;; TODO:
120 nil)
121
122(defun on-text-message (bot msg text)
123 (block nil
124 (when (is-bad-text text)
125 ;; TODO: Delete message, mute & warn user
126 ;; 0 current warns: 5 minute mute, +1 warn
127 ;; 1 current warn : 10 minute mute, +1 warn
128 ;; 2 current warns: 30 minute mute, +1 warn
129 ;; 3 current warns: 1 hour mute, +1 warn
130 ;; 4 current warns: 1 day mute, +1 warn
131 ;; 5 current warns: Ban
132 ;;
133 ;; warn gets removed after a month of no warns
134 (return))
135
136 (awhen (message-entities msg)
137 (loop for entity across it
138 when (and (eq (message-entity-type entity) :bot-command)
139 (= (message-entity-offset entity) 0))
140 do (on-text-command bot msg text (message-entity-extract entity text))))
141
142 (cond ((equal text ":3")
143 (send-message bot :chat-id (message-chat-id msg)
144 :text ">:3"
145 :reply-parameters (make-reply-parameters :message-id (message-id msg)
146 :chat-id (message-chat-id msg))))
147
148 ((equal text ">:3")
149 (send-message bot :chat-id (message-chat-id msg)
150 :text "<b>&gt;:3</b>"
151 :parse-mode "HTML"
152 :reply-parameters (make-reply-parameters
153 :message-id (message-id msg)
154 :chat-id (message-chat-id msg))))
155
156 ((starts-with-ignore-case text "big ")
157 (let ((the-text (subseq text 4)))
158 (unless (is-tg-whitespace-str the-text)
159 (send-message bot
160 :chat-id (message-chat-id msg)
161 :text (concatenate 'string
162 "<b>"
163 (escape-xml (string-upcase the-text))
164 "</b>")
165 :parse-mode "HTML"
166 :reply-parameters
167 (make-reply-parameters
168 :message-id (message-id msg)
169 :chat-id (message-chat-id msg))))))
170
171 ((string-equal text "dio cane")
172 (let ((reply-msg-id (message-id msg))
173 (reply-chat-id (message-chat-id msg)))
174 (awhen (message-reply-to-message msg)
175 (setf reply-msg-id (message-id it))
176 (setf reply-chat-id (message-chat-id it)))
177 (send-message bot
178 :chat-id (message-chat-id msg)
179 :text "porco dio"
180 :reply-parameters
181 (make-reply-parameters
182 :message-id reply-msg-id
183 :chat-id reply-chat-id))))
184
185 ((string-equal text "forgor")
186 (send-message bot
187 :chat-id (message-chat-id msg)
188 :text "💀"
189 :reply-parameters
190 (make-reply-parameters
191 :message-id (message-id msg)
192 :chat-id (message-chat-id msg))))
193
194 ((string-equal text "huh")
195 (send-message bot
196 :chat-id (message-chat-id msg)
197 :text "idgi"
198 :reply-parameters
199 (make-reply-parameters
200 :message-id (message-id msg)
201 :chat-id (message-chat-id msg))))
202
203 ((string= text "H")
204 (send-message bot
205 :chat-id (message-chat-id msg)
206 :text "<code>Randomly selected reminder that h &gt; H.</code>"
207 :parse-mode "HTML"
208 :reply-parameters
209 (make-reply-parameters
210 :message-id (message-id msg)
211 :chat-id (message-chat-id msg))))
212
213 ((string-equal text "porco dio")
214 (let ((reply-msg-id (message-id msg))
215 (reply-chat-id (message-chat-id msg)))
216 (awhen (message-reply-to-message msg)
217 (setf reply-msg-id (message-id it))
218 (setf reply-chat-id (message-chat-id it)))
219 (send-message bot
220 :chat-id (message-chat-id msg)
221 :text "dio cane"
222 :reply-parameters
223 (make-reply-parameters
224 :message-id reply-msg-id
225 :chat-id reply-chat-id))))
226
227 ((starts-with-ignore-case text "say ")
228 (let ((the-text (subseq text 4)))
229 (unless (is-tg-whitespace-str the-text)
230 (send-message bot
231 :chat-id (message-chat-id msg)
232 :text the-text
233 :reply-parameters
234 (make-reply-parameters
235 :message-id (message-id msg)
236 :chat-id (message-chat-id msg))))))
237
238 ((string-equal text "uwu")
239 (send-message bot
240 :chat-id (message-chat-id msg)
241 :text "OwO"
242 :reply-parameters
243 (make-reply-parameters
244 :message-id (message-id msg)
245 :chat-id (message-chat-id msg))))
246
247 ((string-equal text "waow")
248 (let ((reply-msg-id (message-id msg))
249 (reply-chat-id (message-chat-id msg)))
250 (awhen (message-reply-to-message msg)
251 (setf reply-msg-id (message-id it))
252 (setf reply-chat-id (message-chat-id it)))
253 (send-message bot
254 :chat-id (message-chat-id msg)
255 :text "BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED BASED"
256 :reply-parameters
257 (make-reply-parameters
258 :message-id reply-msg-id
259 :chat-id reply-chat-id))))
260
261 ((string-equal text "what")
262 (send-message bot
263 :chat-id (message-chat-id msg)
264 :text (with-output-to-string (s)
265 (if (char= (elt text 0) #\w)
266 (write-char #\g s)
267 (write-char #\G s))
268 (if (char= (elt text 1) #\h)
269 (write-string "ood " s)
270 (write-string "OOD " s))
271 (if (char= (elt text 2) #\a)
272 (write-string "gir" s)
273 (write-string "GIR" s))
274 (if (char= (elt text 3) #\t)
275 (write-char #\l s)
276 (write-char #\L s)))
277 :reply-parameters
278 (make-reply-parameters
279 :message-id (message-id msg)
280 :chat-id (message-chat-id msg))))
281 )))
282
283(defun simplify-cmd (bot cmd)
284 (let ((at-idx (position #\@ cmd)))
285 (if (null at-idx)
286 (subseq cmd 1)
287 (let ((username (subseq cmd (1+ at-idx)))
288 (my-username (bot-username bot)))
289 (if (equal username my-username)
290 (subseq cmd 1 at-idx)
291 nil)))))
292
293(defun on-text-command (bot msg text cmd)
294 (let ((simple-cmd (simplify-cmd bot cmd)))
295 (log-debug "text-command: ~A AKA ~A" cmd simple-cmd)
296 (cond ((equal simple-cmd "chatid")
297 (send-message bot :chat-id (message-chat-id msg)
298 :text (format nil "<code>~A</code>" (message-chat-id msg))
299 :parse-mode "HTML"
300 :reply-parameters (make-reply-parameters :message-id (message-id msg)
301 :chat-id (message-chat-id msg))))
302
303 ((equal simple-cmd "msginfo")
304 (aand (message-reply-to-message msg)
305 (send-message bot :chat-id (message-chat-id msg)
306 ;; TODO: Text needs lot more massaging
307 :text (jzon:stringify (arg-encode it))
308 :reply-parameters
309 (make-reply-parameters
310 :message-id (message-id msg)
311 :chat-id (message-chat-id msg)))))
312
313 ((equal simple-cmd "ping")
314 (let* ((start-time (get-internal-real-time))
315 (reply (send-message bot
316 :chat-id (message-chat-id msg)
317 :text "Pong!
318Send time: ..."
319 :reply-parameters
320 (make-reply-parameters
321 :message-id (message-id msg)
322 :chat-id (message-chat-id msg))))
323 (end-time (get-internal-real-time))
324 (time-elapsed (* (/ (- end-time start-time) internal-time-units-per-second)
325 1000)))
326 (edit-message-text bot
327 :chat-id (message-chat-id msg)
328 :message-id (message-id reply)
329 :text (format nil "Pong!~2%Send time: ~Gms" time-elapsed))))
330
331 ((and (equal simple-cmd "shutdown")
332 (message-from msg)
333 (= (user-id (message-from msg)) (config-owner (bot-config bot))))
334 (setf (bot-power-on bot) nil)
335 (send-message bot
336 :chat-id (message-chat-id msg)
337 :text "Initialising shutdown..."
338 :reply-parameters
339 (make-reply-parameters
340 :allow-sending-without-reply t
341 :message-id (message-id msg)
342 :chat-id (message-chat-id msg))))
343
344 )))
345
346(defun report-error (bot evt err)
347 (log-error "While handling ~A: ~A" evt err)
348 (let ((msg (format nil "<code>~A</code> while handling ~&<pre>~A</pre>"
349 (escape-xml (format nil "~A" err))
350 (escape-xml (format nil "~A" evt)))))
351 (send-message bot
352 :chat-id (config-dev-group (bot-config bot))
353 :text msg
354 :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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/strings
4 (:use :c2cl :iterate)
5 (:import-from :cl-unicode :general-category)
6 (:export :escape-xml :is-tg-whitespace-str :lisp->snake-case :snake->lisp-case :starts-with :starts-with-ignore-case))
7(in-package :ukkoclot/strings)
8
9;; These are very inefficient but I don't care until I profile
10
11(defun escape-xml (str &optional out)
12 (if out
13 (escape-xml% str out)
14 (with-output-to-string (out)
15 (escape-xml% str out))))
16
17(defun escape-xml% (str out)
18 (loop for ch across str do
19 (case ch
20 (#\< (write-string "&lt;" out))
21 (#\> (write-string "&gt;" out))
22 (#\& (write-string "&amp;" out))
23 (#\" (write-string "&quot;" out))
24 (t (write-char ch out)))))
25
26(defun is-tg-whitespace (ch)
27 (let ((gc (general-category ch)))
28 (or (string= gc "Zs") ; Separator, space
29 (string= gc "Zl") ; Separator, line
30 (string= gc "Zp") ; Separator, paragraph
31 (string= gc "Cc") ; Other, control
32 (= (char-code ch) #x2800) ; BRAILLE PATTERN BLANK
33 )))
34
35(defun is-tg-whitespace-str (str)
36 (iter (for ch in-string str)
37 (always (is-tg-whitespace ch))))
38
39(defun lisp->snake-case (str)
40 (with-output-to-string (out)
41 (loop for ch across str do
42 (case ch
43 (#\- (write-char #\_ out))
44 (t (write-char ch out))))))
45
46(defun snake->lisp-case (str)
47 (with-output-to-string (out)
48 (loop for ch across str do
49 (case ch
50 (#\_ (write-char #\- out))
51 (t (write-char ch out))))))
52
53(defun starts-with (str prefix)
54 (and (> (length str) (length prefix))
55 (string= str prefix :end1 (length prefix))))
56
57(defun starts-with-ignore-case (str prefix)
58 (and (> (length str) (length prefix))
59 (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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(uiop:define-package :ukkoclot/tg-types
4 (:use)
5 (:use-reexport
6 :ukkoclot/tg-types/bot-name
7 :ukkoclot/tg-types/callback-query
8 :ukkoclot/tg-types/chat
9 :ukkoclot/tg-types/force-reply
10 :ukkoclot/tg-types/inline-keyboard-button
11 :ukkoclot/tg-types/inline-keyboard-markup
12 :ukkoclot/tg-types/link-preview-options
13 :ukkoclot/tg-types/message
14 :ukkoclot/tg-types/message-entity
15 :ukkoclot/tg-types/reply-parameters
16 :ukkoclot/tg-types/update
17 :ukkoclot/tg-types/user
18 ))
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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/tg-types/bot-name
4 (:use :c2cl :ukkoclot/tg-types/macros)
5 (:export
6 bot-name bot-name-p
7
8 hash->bot-name make-bot-name parse-bot-name-array
9
10 bot-name-name))
11(in-package :ukkoclot/tg-types/bot-name)
12
13(define-tg-type bot-name
14 (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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/tg-types/callback-query
4 (:use :c2cl :ukkoclot/tg-types/macros)
5 (:use
6 :ukkoclot/tg-types/message
7 :ukkoclot/tg-types/user)
8 (:export
9 callback-query callback-query-p
10
11 hash->callback-query make-callback-query parse-callback-query-array
12
13 callback-query-id callback-query-from callback-query-message callback-query-inline-message-id
14 callback-query-chat-instance callback-query-data callback-query-game-short-name))
15(in-package :ukkoclot/tg-types/callback-query)
16
17(define-tg-type callback-query
18 (id string)
19 (from user)
20 (message (or message null) nil)
21 (inline-message-id (or string null) nil)
22 (chat-instance string)
23 (data (or string null) nil)
24 (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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/tg-types/chat
4 (:use :c2cl :ukkoclot/tg-types/macros :ukkoclot/tg-types/parsers)
5 (:export
6 chat
7 make-chat
8 chat-p
9 copy-chat
10 chat-id
11 chat-type
12 chat-title
13 chat-username
14 chat-first-name
15 chat-last-name
16 chat-is-forum
17 chat-is-direct-messages
18
19 hash->chat
20 parse-chat-array))
21(in-package :ukkoclot/tg-types/chat)
22
23(define-tg-type chat
24 (id integer)
25 (type keyword nil :parser tg-string->keyword)
26 (title (or string null) nil)
27 (username (or string null) nil)
28 (first-name (or string null) nil)
29 (last-name (or string null) nil)
30 (is-forum boolean nil)
31 (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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/tg-types/force-reply
4 (:use :c2cl :ukkoclot/tg-types/macros)
5 (:export
6 force-reply
7 make-force-reply
8 force-reply-p
9 copy-force-reply
10 force-reply-force-reply
11 force-reply-input-field-placeholder
12 force-reply-selective
13
14 hash->force-reply
15 parse-force-reply-array))
16(in-package :ukkoclot/tg-types/force-reply)
17
18(define-tg-type force-reply
19 (force-reply boolean t :skip-if-default nil)
20 (input-field-placeholder (or string null) nil)
21 (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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/tg-types/inline-keyboard-button
4 (:use :c2cl :ukkoclot/tg-types/macros)
5 (:export
6 inline-keyboard-button
7 make-inline-keyboard-button
8 inline-keyboard-button-p
9 copy-inline-keyboard-button
10 inline-keyboard-button-text
11 inline-keyboard-button-url
12 inline-keyboard-button-callback-data
13 inline-keyboard-button-switch-inline-query
14 inline-keyboard-button-switch-inline-query-current-chat
15 inline-keyboard-button-pay
16
17 hash->inline-keyboard-button
18 parse-inline-keyboard-button-array))
19(in-package :ukkoclot/tg-types/inline-keyboard-button)
20
21(define-tg-type inline-keyboard-button
22 (text string)
23 (url (or string null) nil)
24 (callback-data string)
25 ;; TODO: (web-app (or web-app-info null) nil)
26 ;; TODO: (login-url (or login-url null) nil)
27 (switch-inline-query (or string null) nil)
28 (switch-inline-query-current-chat (or string null) nil)
29 ;; TODO: (switch-inline-query-chosen-chat (or switch-inline-query-chosen-chat null) nil)
30 ;; TODO: (copy-text (or copy-text-button null) nil)
31 ;; TODO: (callback-game (or callback-game null) nil)
32 (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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/tg-types/inline-keyboard-markup
4 (:use :c2cl :ukkoclot/tg-types/inline-keyboard-button :ukkoclot/tg-types/macros)
5 (:export
6 inline-keyboard-markup
7 make-inline-keyboard-markup
8 inline-keyboard-markup-p
9 copy-inline-keyboard-markup
10 inline-keyboard-markup-inline-keyboard
11
12 hash->inline-keyboard-markup
13 parse-inline-keyboard-markup-array))
14(in-package :ukkoclot/tg-types/inline-keyboard-markup)
15
16(define-tg-type inline-keyboard-markup
17 (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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/tg-types/link-preview-options
4 (:use :c2cl :ukkoclot/tg-types/macros)
5 (:export
6 link-preview-options
7 make-link-preview-options
8 link-preview-options-p
9 copy-link-preview-options
10 link-preview-options-is-disabled
11 link-preview-options-url
12 link-preview-options-prefer-small-media
13 link-preview-options-prefer-large-media
14 link-preview-options-show-above-text
15
16 hash->link-preview-options
17 parse-link-preview-options-array))
18(in-package :ukkoclot/tg-types/link-preview-options)
19
20(define-tg-type link-preview-options
21 (is-disabled boolean nil)
22 (url (or string null) nil)
23 (prefer-small-media boolean nil)
24 (prefer-large-media boolean nil)
25 (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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/tg-types/macros
4 (:use :c2cl)
5 (:import-from :ukkoclot/bot/impl :arg-encode :bot :do-call :will-arg-encode)
6 (:import-from :ukkoclot/hash-tables :gethash-lazy)
7 (:import-from :ukkoclot/strings :lisp->snake-case)
8 (:export :define-tg-method :define-tg-type))
9(in-package :ukkoclot/tg-types/macros)
10
11(eval-when (:compile-toplevel :load-toplevel :execute)
12 (defstruct (field (:constructor make-field%)) name type default skip-if-default (parser 'identity))
13
14 (defparameter +unique+ (gensym))
15
16 (defun make-field (name type &optional (default +unique+) &key (parser 'identity) (skip-if-default (not (eq default +unique+))))
17 (let ((default (if (eq default +unique+)
18 (list 'error (format nil "No value given for ~A" name))
19 default)))
20 (make-field% :name name
21 :type type
22 :default default
23 :skip-if-default skip-if-default
24 :parser parser)))
25
26 (defun parse-field-specs (field-specs)
27 (loop for field-spec in field-specs
28 collect (apply #'make-field field-spec)))
29
30 (defun field-hash-key (field)
31 (string-downcase (lisp->snake-case (symbol-name (field-name field)))))
32
33 (defun field-accessor (struc-name field)
34 (intern (concatenate 'string (symbol-name struc-name) "-" (symbol-name (field-name field)))))
35
36 (defun field->defun-spec (field)
37 (list (field-name field) (field-default field)))
38
39 (defun field->format-arg (field name struc)
40 `(',(field-name field) (,(field-accessor name field) ,struc)))
41
42 (defun field->ftype-spec (field)
43 (list (intern (symbol-name (field-name field)) :keyword) (field-type field)))
44
45 (defun field->gethash-spec (field hash-table-sym)
46 (let ((hash-key (field-hash-key field)))
47 (list 'gethash-lazy hash-key hash-table-sym (field-default field))))
48
49 (defun field->sethash-spec (field name struc hash-table-sym)
50 (let ((hash-key (field-hash-key field))
51 (skip-if-default (field-skip-if-default field))
52 (default (field-default field)))
53 (if skip-if-default
54 (let ((tmpsym (gensym "TMP")))
55 `(let ((,tmpsym (,(field-accessor name field) ,struc)))
56 (unless (equal ,tmpsym ,default)
57 (setf (gethash ,hash-key ,hash-table-sym) ,tmpsym))))
58 `(setf (gethash ,hash-key ,hash-table-sym) (,(field-accessor name field) ,struc)))))
59
60 (defun field->let-gethash-spec (field hash-table-sym)
61 (list (field-name field)
62 (list 'funcall
63 (list 'function (field-parser field))
64 (field->gethash-spec field hash-table-sym))))
65
66 (defun field->make-spec (field)
67 (list (intern (symbol-name (field-name field)) :keyword)
68 (field-name field)))
69
70 (defun field->struct-spec (field)
71 (list (field-name field) (field-default field) :type (field-type field))))
72
73;; TODO: Automatically derive path from name
74;; TODO: Automatically derive mapfn from type
75;; TODO: Skip values that are already their defaults
76(defmacro define-tg-method (
77 (name type path mapfn &optional (method :POST))
78 &body field-specs)
79 (let ((fields (parse-field-specs field-specs))
80 (args-plist (gensym "ARGS-PLIST-"))
81 (bot (gensym "BOT-")))
82 `(progn
83 (declaim (ftype (function (bot &key ,@(loop for field in fields
84 collect (field->ftype-spec field)))
85 ,type)
86 ,name))
87 (defun ,name (,bot &rest ,args-plist &key ,@(loop for field in fields collect (field->defun-spec field)))
88 (declare ,@(loop for field in fields collect (list 'ignore (field-name field))))
89 (do-call ,bot ,method ,path ,mapfn ,args-plist)))))
90
91(defmacro define-tg-type (name &body field-specs)
92 (let* ((fields (parse-field-specs field-specs))
93 (revfields (reverse fields))
94 (make-name (intern (concatenate 'string "MAKE-" (symbol-name name))))
95 (hash->name (intern (concatenate 'string "HASH->" (symbol-name name))))
96 (parse-name-array (intern (concatenate 'string "PARSE-" (symbol-name name) "-ARRAY")))
97 (printer (gensym (concatenate 'string "PRINT-" (symbol-name name))))
98 (hash (gensym "HASH-"))
99 (array (gensym "ARRAY-"))
100 (struc (gensym (symbol-name name)))
101 (stream (gensym "STREAM"))
102 (depth (gensym "DEPTH"))
103 (pprint-args (gensym "PPRINT-ARGS")))
104 `(progn
105 (defstruct (,name (:print-function ,printer))
106 ,@(loop for field in fields
107 collect (field->struct-spec field)))
108 (defun ,printer (,struc ,stream ,depth)
109 (declare (ignore ,depth))
110 (let (,pprint-args)
111 ,@(loop for field in revfields
112 collecting
113 (if (field-skip-if-default field)
114 `(let ((value (,(field-accessor name field) ,struc)))
115 (unless (equal value ,(field-default field))
116 (setf ,pprint-args (list* ',(field-name field) value ,pprint-args))))
117 `(setf ,pprint-args (list* ',(field-name field) (,(field-accessor name field) ,struc) ,pprint-args))))
118 (format ,stream "~A~<[~;~@{~_~1I~W = ~W~^, ~}~;]~:>" ',name ,pprint-args)))
119 (defun ,hash->name (,hash)
120 (when ,hash
121 (let ,(loop for field in fields
122 collect (field->let-gethash-spec field hash))
123 (,make-name ,@(loop for field in fields
124 append (field->make-spec field))))))
125 (defmethod arg-encode ((,struc ,name))
126 (let ((,hash (make-hash-table)))
127 ,@(loop for field in fields
128 collect (field->sethash-spec field name struc hash))
129 ,hash))
130 (defmethod will-arg-encode ((,struc ,name))
131 t)
132 (defun ,parse-name-array (,array)
133 (when ,array
134 (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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/tg-types/message-entity
4 (:use :c2cl :iterate :ukkoclot/tg-types/macros :ukkoclot/tg-types/parsers :ukkoclot/tg-types/user)
5 (:export
6 message-entity
7 make-message-entity
8 message-entity-p
9 copy-message-entity
10 message-entity-type
11 message-entity-offset
12 message-entity-length
13 message-entity-url
14 message-entity-user
15 message-entity-language
16 message-entity-custom-emoji-id
17
18 hash->message-entity
19 message-entity-extract
20 parse-message-entity-array))
21(in-package :ukkoclot/tg-types/message-entity)
22
23(define-tg-type message-entity
24 (type keyword nil :parser tg-string->keyword)
25 (offset integer)
26 (length integer)
27 (url (or string null) nil)
28 (user (or user null) nil)
29 (language (or string null) nil)
30 (custom-emoji-id (or string null) nil))
31
32(unless (= char-code-limit #x110000)
33 (error "Some UTF-16 fuckery assumes that system chars are UTF-32"))
34
35(defun utf16-width (ch)
36 (if (< (char-code ch) #x10000)
37 1
38 2))
39
40(defun message-entity-extract (entity text)
41 (with-slots (length offset) entity
42 (if (= length 0)
43 ""
44 (let* ((start (iterate
45 (with curr-idx16 = 0)
46 (for ch in-string text with-index curr-idx32)
47 (for curr-width = (utf16-width ch))
48 (when (or (= curr-idx16 offset)
49 (> (+ curr-idx16 curr-width) offset))
50 (return curr-idx32))
51 (setq curr-idx16 (+ curr-idx16 curr-width))
52 (finally (return (length text)))))
53 (end (iterate
54 (with curr-len16 = 0)
55 (for ch in-string text from start with-index curr-idx32)
56 (for curr-width = (utf16-width ch))
57 (when (>= curr-len16 length)
58 (return curr-idx32))
59 (setq curr-len16 (+ curr-len16 curr-width))
60 (finally (return (length text))))))
61 (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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/tg-types/message
4 (:use :c2cl :ukkoclot/tg-types/macros
5
6 :ukkoclot/tg-types/chat
7 :ukkoclot/tg-types/message-entity
8 :ukkoclot/tg-types/user)
9 (:export
10 message
11 make-message
12 message-p
13 copy-message
14 message-message-id
15 message-message-thread-id
16 message-from
17 message-sender-boost-count
18 message-sender-business-bot
19 message-date
20 message-business-connection-id
21 message-chat
22 message-is-topic-message
23 message-is-automatic-forward
24 message-reply-to-message
25 message-reply-to-checklist-task-id
26 message-via-bot
27 message-edit-date
28 message-has-protected-content
29 message-is-from-offline
30 message-is-paid-post
31 message-media-group-id
32 message-author-signature
33 message-paid-star-count
34 message-text
35 message-entities
36 message-effect-id
37 message-caption
38 message-show-caption-above-media
39 message-has-media-spoiler
40 message-new-chat-members
41 message-new-chat-title
42 message-delete-chat-photo
43 message-group-chat-created
44 message-supergroup-chat-created
45 message-channel-chat-created
46 message-migrate-to-chat-id
47 message-migrate-from-chat-id
48 message-pinned-message
49 message-connected-website
50
51 hash->message
52 message-id
53 message-chat-id
54 message-thread-id
55 parse-message-array))
56(in-package :ukkoclot/tg-types/message)
57
58;; If this is a MaybeInaccessibleMessage date will be 0 if this is inaccessible
59(define-tg-type message
60 (message-id integer)
61 (message-thread-id (or integer null) nil)
62 ;; (direct-messages-topic (or direct-messages-topic null) nil)
63 (from (or user null) nil :parser hash->user)
64 ;; (sender-chat (or chat null) nil)
65 (sender-boost-count (or integer null) nil)
66 (sender-business-bot (or user null) nil :parser hash->user)
67 (date integer)
68 (business-connection-id (or string null) nil)
69 (chat chat nil :parser hash->chat)
70 ;; (forward-origin (or message-origin null) nil)
71 (is-topic-message boolean nil)
72 (is-automatic-forward boolean nil)
73 (reply-to-message (or message null) nil :parser hash->message)
74 ;; (external-reply (or external-reply-info null) nil)
75 ;; (quote (or text-quote null) nil)
76 ;; (reply-to-story (or story null) nil)
77 (reply-to-checklist-task-id (or integer null) nil)
78 (via-bot (or user null) nil :parser hash->user)
79 (edit-date (or integer null) nil)
80 (has-protected-content boolean nil)
81 (is-from-offline boolean nil)
82 (is-paid-post boolean nil)
83 (media-group-id (or string null) nil)
84 (author-signature (or string null) nil)
85 (paid-star-count (or string null) nil)
86 (text (or string null) nil)
87 (entities (or (array message-entity) null) nil :parser parse-message-entity-array)
88 ;; (link-preview-options (or link-preview-options null) nil)
89 ;; (suggested-post-info (or suggested-post-info null) nil)
90 (effect-id (or string null) nil)
91 ;; (animation (or animation null) nil)
92 ;; (audio (or audio null) nil)
93 ;; (document (or document null) nil)
94 ;; (paid-media (or paid-media-info null) nil)
95 ;; (photo (or (array photo-size) null) nil)
96 ;; (sticker (or sticker null) nil)
97 ;; (story (or story null) nil)
98 ;; (video (or video null) nil)
99 ;; (video-note (or video-note null) nil)
100 ;; (voice (or voice null) nil)
101 (caption (or string null) nil)
102 ;; (caption-entities (or (array message-entity) null) nil)
103 (show-caption-above-media boolean nil)
104 (has-media-spoiler boolean nil)
105 ;; (contact (or contact null) nil)
106 ;; (dice (or dice null) nil)
107 ;; (game (or game null) nil)
108 ;; (poll (or poll null) nil)
109 ;; (venue (or venue null) nil)
110 ;; (location (or location null) nil)
111 (new-chat-members (or (array user) null) nil :parser parse-user-array)
112 ;; (left-chat-member (or user null) nil)
113 (new-chat-title (or string null) nil)
114 ;; (new-chat-photo (or (array photo-size) null) nil)
115 (delete-chat-photo boolean nil)
116 (group-chat-created boolean nil)
117 (supergroup-chat-created boolean nil)
118 (channel-chat-created boolean nil)
119 ;; (message-auto-delete-timer-changed (orp message-auto-delete-timer-changed null) nil)
120 (migrate-to-chat-id (or integer null) nil)
121 (migrate-from-chat-id (or integer null) nil)
122 (pinned-message (or message null) nil :parser hash->message)
123 ;; (invoice (or invoice null) nil)
124 ;; (successful-payment (or successful-payment null) nil)
125 ;; (refunded-payment (or refunded-payment null) nil)
126 ;; (users-shared (or users-shared null) nil)
127 ;; (chat-shared (or chat-shared null) nil)
128 ;; (gift (or gift-info null) nil)
129 ;; (unique-gift (or unique-gift-info null) nil)
130 (connected-website (or string null) nil)
131 ;; (write-access-allowed (or write-access-allowed null) nil)
132 ;; (passport-data (or passport-data null) nil)
133 ;; (proximity-alert-triggered (or proximity-alert-triggered null) nil)
134 ;; (boost-added (or chat-boost-added null) nil)
135 ;; (chat-background-set (or chat-background null) nil)
136 ;; (checklist-tasks-added (or checklist-tasks-added null) nil)
137 ;; (direct-message-price-changed (or direct-message-price-changed null) nil)
138 ;; (forum-topic-created (or forum-topic-created null) nil)
139 ;; (forum-topic-edited (or forum-topic-edited null) nil)
140 ;; (forum-topic-closed (or forum-topic-closed null) nil)
141 ;; (forum-topic-reopened (or forum-topic-reopened null) nil)
142 ;; (general-forum-topic-hidden (or general-forum-topic-hidden null) nil)
143 ;; (general-forum-topic-unhidden (or general-forum-topic-unhidden null) nil)
144 ;; (giveaway-created (or giveaway-created null) nil)
145 ;; (giveaway-winners (or giveaway-winners null) nil)
146 ;; (giveaway-completed (or giveaway-completed null) nil)
147 ;; (paid-message-price-changed (or paid-message-price-changed null) nil)
148 ;; (suggested-post-approved (or suggested-post-approved null) nil)
149 ;; (suggested-post-approval-failed (or suggested-post-approval-failed null) nil)
150 ;; (suggested-post-declined (or suggested-post-declined null) nil)
151 ;; (suggested-post-paid (or suggested-post-paid null) nil)
152 ;; (suggested-post-refunded (or suggested-post-refunded null) nil)
153 ;; (video-chat-scheduled (or video-chat-scheduled null) nil)
154 ;; (video-chat-started (or video-chat-started null) nil)
155 ;; (video-chat-ended (or video-chat-ended null) nil)
156 ;; (video-chat-participants-invited (or video-chat-participants-invited null) nil)
157 ;; (web-app-data (or web-app-data null) nil)
158 ;; (reply-markup (or inline-keyboard-markup null) nil)
159 )
160
161(defun message-id (msg)
162 (message-message-id msg))
163
164(defun message-chat-id (msg)
165 (chat-id (message-chat msg)))
166
167(defun message-thread-id (msg)
168 (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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/tg-types/parsers
4 (:use :c2cl :ukkoclot/strings)
5 (:export tg-string->keyword))
6(in-package :ukkoclot/tg-types/parsers)
7
8(defun tg-string->keyword (str)
9 (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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/tg-types/reply-parameters
4 (:use :c2cl :ukkoclot/tg-types/macros :ukkoclot/tg-types/message-entity)
5 (:export
6 reply-parameters
7 make-reply-parameters
8 reply-parameters-p
9 copy-reply-parameters
10 reply-parameters-message-id
11 reply-parameters-chat-id
12 reply-parameters-allow-sending-without-reply
13 reply-parameters-quote
14 reply-parameters-quote-parse-mode
15 reply-parameters-quote-entities
16 reply-parameters-quote-position
17 reply-parameters-checklist-task-id
18
19 hash->reply-parameters
20 parse-reply-parameters-array))
21(in-package :ukkoclot/tg-types/reply-parameters)
22
23(define-tg-type reply-parameters
24 (message-id integer)
25 (chat-id (or integer string null) nil)
26 ;; Technically true if on a business account but yeah right lmao
27 (allow-sending-without-reply boolean nil)
28 (quote (or string null) nil)
29 (quote-parse-mode (or string null) nil)
30 (quote-entities (or (array message-entity) null) nil)
31 (quote-position (or integer null) nil)
32 (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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/tg-types/update
4 (:use :c2cl :ukkoclot/tg-types/macros
5 :ukkoclot/tg-types/callback-query
6 :ukkoclot/tg-types/message)
7 (:export
8 update update-p
9
10 hash->update make-update parse-update-array
11
12 update-update-id update-message update-edited-message update-channel-post update-edited-channel-post
13 ;; update-business-connection
14 update-business-message update-edited-business-message
15 ;; update-deleted-business-messages update-message-reaction update-message-reaction-count update-inline-query
16 ;; update-chosen-inline-result
17 update-callback-query
18 ;; update-shipping-query update-pre-checkout-query update-poll update-poll-answer update-my-chat-member
19 ;; update-chat-member update-chat-join-request update-chat-boost update-removed-chat-boost
20 ))
21(in-package :ukkoclot/tg-types/update)
22
23(define-tg-type update
24 (update-id integer)
25 (message (or message null) nil :parser hash->message)
26 (edited-message (or message null) nil :parser hash->message)
27 (channel-post (or message null) nil :parser hash->message)
28 (edited-channel-post (or message null) nil :parser hash->message)
29 ;; (business-connection (or business-connection null) nil)
30 (business-message (or message null) nil :parser hash->message)
31 (edited-business-message (or message null) nil :parser hash->message)
32 ;; (deleted-business-messages (or business-messages-deleted null) nil)
33 ;; (message-reaction (or message-reaction-updated null) nil)
34 ;; (message-reaction-count (or message-reaction-count-updated null) nil)
35 ;; (inline-query (or inline-query null) nil)
36 ;; (chosen-inline-result (or chosen-inline-result null) nil)
37 (callback-query (or callback-query null) nil :parser hash->callback-query)
38 ;; (shipping-query (or shipping-query null) nil)
39 ;; (pre-checkout-query (or pre-checkout-query null) nil)
40 ;; (poll (or poll null) nil)
41 ;; (poll-answer (or poll-answer null) nil)
42 ;; (my-chat-member (or chat-member-updated null) nil)
43 ;; (chat-member (or chat-member-updated null) nil)
44 ;; (chat-join-request (or chat-join-request null) nil)
45 ;; (chat-boost (or chat-boost-updated null) nil)
46 ;; (removed-chat-boost (or chat-boost-removed) nil)
47 )
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 @@
1;; SPDX-License-Identifier: EUPL-1.2
2;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
3(defpackage :ukkoclot/tg-types/user
4 (:use :c2cl :ukkoclot/tg-types/macros)
5 (:import-from :ukkoclot/strings :escape-xml)
6 (:export
7 user user-p
8
9 hash->user make-user parse-user-array user-format-name
10
11 user-id user-is-bot user-first-name user-last-name user-username user-language-code user-is-premium
12 user-added-to-attachment-menu user-can-join-groups user-can-read-all-group-messages user-supports-inline-queries
13 user-can-connect-to-business))
14(in-package :ukkoclot/tg-types/user)
15
16(define-tg-type user
17 (id integer)
18 (is-bot boolean)
19 (first-name string)
20 (last-name (or string null) nil)
21 (username (or string null) nil)
22 (language-code (or string null) nil)
23 (is-premium boolean nil)
24 (added-to-attachment-menu boolean nil)
25 (can-join-groups boolean nil)
26 (can-read-all-group-messages boolean nil)
27 (supports-inline-queries boolean nil)
28 (can-connect-to-business boolean nil))
29
30(defun user-format-name% (user out)
31 (format out "<a href=\"tg://user?id=~A\"><i>" (user-id user))
32 (escape-xml (user-first-name user) out)
33 (when (user-last-name user)
34 (write-char #\Space out)
35 (escape-xml (user-last-name user) out))
36 (write-string "</i>" out)
37
38 (when (user-username user)
39 (write-string " @" out)
40 (escape-xml (user-username user) out))
41
42 (format out "</a> [<code>~A</code>]" (user-id user)))
43
44(defun user-format-name (user &optional out)
45 (if out
46 (user-format-name% user out)
47 (with-output-to-string (stream)
48 (user-format-name% user stream))))
HIC SVNT DRACONES