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 --- .gitignore | 3 + .pre-commit-config.yaml | 35 +++ LICENSES/CC0-1.0.txt | 121 +++++++++++ LICENSES/EUPL-1.2.txt | 190 +++++++++++++++++ README.md | 7 + REUSE.toml | 14 ++ config.default.lisp | 6 + 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 +++++ ukkoclot.asd | 19 ++ 33 files changed, 1943 insertions(+) create mode 100644 .gitignore create mode 100644 .pre-commit-config.yaml create mode 100644 LICENSES/CC0-1.0.txt create mode 100644 LICENSES/EUPL-1.2.txt create mode 100644 README.md create mode 100644 REUSE.toml create mode 100644 config.default.lisp 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 create mode 100644 ukkoclot.asd diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..960aab2 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +/config.lisp +/data.db +*.fasl diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml new file mode 100644 index 0000000..ea14b31 --- /dev/null +++ b/.pre-commit-config.yaml @@ -0,0 +1,35 @@ +# See https://pre-commit.com for more information +# See https://pre-commit.com/hooks.html for more hooks +repos: +- repo: https://github.com/fsfe/reuse-tool + rev: v6.1.2 + hooks: + - id: reuse +- repo: https://github.com/pre-commit/pre-commit-hooks + rev: v6.0.0 + hooks: + - id: check-added-large-files + - id: check-case-conflict + - id: check-executables-have-shebangs + - id: check-illegal-windows-names + - id: check-json + - id: check-merge-conflict + - id: check-shebang-scripts-are-executable + - id: check-symlinks + - id: check-toml + - id: check-xml + - id: check-yaml + - id: destroyed-symlinks + - id: detect-private-key + - id: end-of-file-fixer + - id: fix-byte-order-marker + - id: mixed-line-ending + args: [--fix=lf] + - id: pretty-format-json + args: [--autofix] + - id: trailing-whitespace + args: [--markdown-linebreak-ext=md] +- repo: https://github.com/stefmolin/exif-stripper + rev: 1.1.0 + hooks: + - id: strip-exif diff --git a/LICENSES/CC0-1.0.txt b/LICENSES/CC0-1.0.txt new file mode 100644 index 0000000..0e259d4 --- /dev/null +++ b/LICENSES/CC0-1.0.txt @@ -0,0 +1,121 @@ +Creative Commons Legal Code + +CC0 1.0 Universal + + CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE + LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN + ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS + INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES + REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS + PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM + THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED + HEREUNDER. + +Statement of Purpose + +The laws of most jurisdictions throughout the world automatically confer +exclusive Copyright and Related Rights (defined below) upon the creator +and subsequent owner(s) (each and all, an "owner") of an original work of +authorship and/or a database (each, a "Work"). + +Certain owners wish to permanently relinquish those rights to a Work for +the purpose of contributing to a commons of creative, cultural and +scientific works ("Commons") that the public can reliably and without fear +of later claims of infringement build upon, modify, incorporate in other +works, reuse and redistribute as freely as possible in any form whatsoever +and for any purposes, including without limitation commercial purposes. +These owners may contribute to the Commons to promote the ideal of a free +culture and the further production of creative, cultural and scientific +works, or to gain reputation or greater distribution for their Work in +part through the use and efforts of others. + +For these and/or other purposes and motivations, and without any +expectation of additional consideration or compensation, the person +associating CC0 with a Work (the "Affirmer"), to the extent that he or she +is an owner of Copyright and Related Rights in the Work, voluntarily +elects to apply CC0 to the Work and publicly distribute the Work under its +terms, with knowledge of his or her Copyright and Related Rights in the +Work and the meaning and intended legal effect of CC0 on those rights. + +1. Copyright and Related Rights. A Work made available under CC0 may be +protected by copyright and related or neighboring rights ("Copyright and +Related Rights"). Copyright and Related Rights include, but are not +limited to, the following: + + i. the right to reproduce, adapt, distribute, perform, display, + communicate, and translate a Work; + ii. moral rights retained by the original author(s) and/or performer(s); +iii. publicity and privacy rights pertaining to a person's image or + likeness depicted in a Work; + iv. rights protecting against unfair competition in regards to a Work, + subject to the limitations in paragraph 4(a), below; + v. rights protecting the extraction, dissemination, use and reuse of data + in a Work; + vi. database rights (such as those arising under Directive 96/9/EC of the + European Parliament and of the Council of 11 March 1996 on the legal + protection of databases, and under any national implementation + thereof, including any amended or successor version of such + directive); and +vii. other similar, equivalent or corresponding rights throughout the + world based on applicable law or treaty, and any national + implementations thereof. + +2. Waiver. To the greatest extent permitted by, but not in contravention +of, applicable law, Affirmer hereby overtly, fully, permanently, +irrevocably and unconditionally waives, abandons, and surrenders all of +Affirmer's Copyright and Related Rights and associated claims and causes +of action, whether now known or unknown (including existing as well as +future claims and causes of action), in the Work (i) in all territories +worldwide, (ii) for the maximum duration provided by applicable law or +treaty (including future time extensions), (iii) in any current or future +medium and for any number of copies, and (iv) for any purpose whatsoever, +including without limitation commercial, advertising or promotional +purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each +member of the public at large and to the detriment of Affirmer's heirs and +successors, fully intending that such Waiver shall not be subject to +revocation, rescission, cancellation, termination, or any other legal or +equitable action to disrupt the quiet enjoyment of the Work by the public +as contemplated by Affirmer's express Statement of Purpose. + +3. Public License Fallback. Should any part of the Waiver for any reason +be judged legally invalid or ineffective under applicable law, then the +Waiver shall be preserved to the maximum extent permitted taking into +account Affirmer's express Statement of Purpose. In addition, to the +extent the Waiver is so judged Affirmer hereby grants to each affected +person a royalty-free, non transferable, non sublicensable, non exclusive, +irrevocable and unconditional license to exercise Affirmer's Copyright and +Related Rights in the Work (i) in all territories worldwide, (ii) for the +maximum duration provided by applicable law or treaty (including future +time extensions), (iii) in any current or future medium and for any number +of copies, and (iv) for any purpose whatsoever, including without +limitation commercial, advertising or promotional purposes (the +"License"). The License shall be deemed effective as of the date CC0 was +applied by Affirmer to the Work. Should any part of the License for any +reason be judged legally invalid or ineffective under applicable law, such +partial invalidity or ineffectiveness shall not invalidate the remainder +of the License, and in such case Affirmer hereby affirms that he or she +will not (i) exercise any of his or her remaining Copyright and Related +Rights in the Work or (ii) assert any associated claims and causes of +action with respect to the Work, in either case contrary to Affirmer's +express Statement of Purpose. + +4. Limitations and Disclaimers. + + a. No trademark or patent rights held by Affirmer are waived, abandoned, + surrendered, licensed or otherwise affected by this document. + b. Affirmer offers the Work as-is and makes no representations or + warranties of any kind concerning the Work, express, implied, + statutory or otherwise, including without limitation warranties of + title, merchantability, fitness for a particular purpose, non + infringement, or the absence of latent or other defects, accuracy, or + the present or absence of errors, whether or not discoverable, all to + the greatest extent permissible under applicable law. + c. Affirmer disclaims responsibility for clearing rights of other persons + that may apply to the Work or any use thereof, including without + limitation any person's Copyright and Related Rights in the Work. + Further, Affirmer disclaims responsibility for obtaining any necessary + consents, permissions or other rights required for any use of the + Work. + d. Affirmer understands and acknowledges that Creative Commons is not a + party to this document and has no duty or obligation with respect to + this CC0 or use of the Work. diff --git a/LICENSES/EUPL-1.2.txt b/LICENSES/EUPL-1.2.txt new file mode 100644 index 0000000..6d8cea4 --- /dev/null +++ b/LICENSES/EUPL-1.2.txt @@ -0,0 +1,190 @@ +EUROPEAN UNION PUBLIC LICENCE v. 1.2 +EUPL © the European Union 2007, 2016 + +This European Union Public Licence (the ‘EUPL’) applies to the Work (as defined below) which is provided under the +terms of this Licence. Any use of the Work, other than as authorised under this Licence is prohibited (to the extent such +use is covered by a right of the copyright holder of the Work). +The Work is provided under the terms of this Licence when the Licensor (as defined below) has placed the following +notice immediately following the copyright notice for the Work: + Licensed under the EUPL +or has expressed by any other means his willingness to license under the EUPL. + +1.Definitions +In this Licence, the following terms have the following meaning: +— ‘The Licence’:this Licence. +— ‘The Original Work’:the work or software distributed or communicated by the Licensor under this Licence, available +as Source Code and also as Executable Code as the case may be. +— ‘Derivative Works’:the works or software that could be created by the Licensee, based upon the Original Work or +modifications thereof. This Licence does not define the extent of modification or dependence on the Original Work +required in order to classify a work as a Derivative Work; this extent is determined by copyright law applicable in +the country mentioned in Article 15. +— ‘The Work’:the Original Work or its Derivative Works. +— ‘The Source Code’:the human-readable form of the Work which is the most convenient for people to study and +modify. +— ‘The Executable Code’:any code which has generally been compiled and which is meant to be interpreted by +a computer as a program. +— ‘The Licensor’:the natural or legal person that distributes or communicates the Work under the Licence. +— ‘Contributor(s)’:any natural or legal person who modifies the Work under the Licence, or otherwise contributes to +the creation of a Derivative Work. +— ‘The Licensee’ or ‘You’:any natural or legal person who makes any usage of the Work under the terms of the +Licence. +— ‘Distribution’ or ‘Communication’:any act of selling, giving, lending, renting, distributing, communicating, +transmitting, or otherwise making available, online or offline, copies of the Work or providing access to its essential +functionalities at the disposal of any other natural or legal person. + +2.Scope of the rights granted by the Licence +The Licensor hereby grants You a worldwide, royalty-free, non-exclusive, sublicensable licence to do the following, for +the duration of copyright vested in the Original Work: +— use the Work in any circumstance and for all usage, +— reproduce the Work, +— modify the Work, and make Derivative Works based upon the Work, +— communicate to the public, including the right to make available or display the Work or copies thereof to the public +and perform publicly, as the case may be, the Work, +— distribute the Work or copies thereof, +— lend and rent the Work or copies thereof, +— sublicense rights in the Work or copies thereof. +Those rights can be exercised on any media, supports and formats, whether now known or later invented, as far as the +applicable law permits so. +In the countries where moral rights apply, the Licensor waives his right to exercise his moral right to the extent allowed +by law in order to make effective the licence of the economic rights here above listed. +The Licensor grants to the Licensee royalty-free, non-exclusive usage rights to any patents held by the Licensor, to the +extent necessary to make use of the rights granted on the Work under this Licence. + +3.Communication of the Source Code +The Licensor may provide the Work either in its Source Code form, or as Executable Code. If the Work is provided as +Executable Code, the Licensor provides in addition a machine-readable copy of the Source Code of the Work along with +each copy of the Work that the Licensor distributes or indicates, in a notice following the copyright notice attached to +the Work, a repository where the Source Code is easily and freely accessible for as long as the Licensor continues to +distribute or communicate the Work. + +4.Limitations on copyright +Nothing in this Licence is intended to deprive the Licensee of the benefits from any exception or limitation to the +exclusive rights of the rights owners in the Work, of the exhaustion of those rights or of other applicable limitations +thereto. + +5.Obligations of the Licensee +The grant of the rights mentioned above is subject to some restrictions and obligations imposed on the Licensee. Those +obligations are the following: + +Attribution right: The Licensee shall keep intact all copyright, patent or trademarks notices and all notices that refer to +the Licence and to the disclaimer of warranties. The Licensee must include a copy of such notices and a copy of the +Licence with every copy of the Work he/she distributes or communicates. The Licensee must cause any Derivative Work +to carry prominent notices stating that the Work has been modified and the date of modification. + +Copyleft clause: If the Licensee distributes or communicates copies of the Original Works or Derivative Works, this +Distribution or Communication will be done under the terms of this Licence or of a later version of this Licence unless +the Original Work is expressly distributed only under this version of the Licence — for example by communicating +‘EUPL v. 1.2 only’. The Licensee (becoming Licensor) cannot offer or impose any additional terms or conditions on the +Work or Derivative Work that alter or restrict the terms of the Licence. + +Compatibility clause: If the Licensee Distributes or Communicates Derivative Works or copies thereof based upon both +the Work and another work licensed under a Compatible Licence, this Distribution or Communication can be done +under the terms of this Compatible Licence. For the sake of this clause, ‘Compatible Licence’ refers to the licences listed +in the appendix attached to this Licence. Should the Licensee's obligations under the Compatible Licence conflict with +his/her obligations under this Licence, the obligations of the Compatible Licence shall prevail. + +Provision of Source Code: When distributing or communicating copies of the Work, the Licensee will provide +a machine-readable copy of the Source Code or indicate a repository where this Source will be easily and freely available +for as long as the Licensee continues to distribute or communicate the Work. +Legal Protection: This Licence does not grant permission to use the trade names, trademarks, service marks, or names +of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and +reproducing the content of the copyright notice. + +6.Chain of Authorship +The original Licensor warrants that the copyright in the Original Work granted hereunder is owned by him/her or +licensed to him/her and that he/she has the power and authority to grant the Licence. +Each Contributor warrants that the copyright in the modifications he/she brings to the Work are owned by him/her or +licensed to him/her and that he/she has the power and authority to grant the Licence. +Each time You accept the Licence, the original Licensor and subsequent Contributors grant You a licence to their contributions +to the Work, under the terms of this Licence. + +7.Disclaimer of Warranty +The Work is a work in progress, which is continuously improved by numerous Contributors. It is not a finished work +and may therefore contain defects or ‘bugs’ inherent to this type of development. +For the above reason, the Work is provided under the Licence on an ‘as is’ basis and without warranties of any kind +concerning the Work, including without limitation merchantability, fitness for a particular purpose, absence of defects or +errors, accuracy, non-infringement of intellectual property rights other than copyright as stated in Article 6 of this +Licence. +This disclaimer of warranty is an essential part of the Licence and a condition for the grant of any rights to the Work. + +8.Disclaimer of Liability +Except in the cases of wilful misconduct or damages directly caused to natural persons, the Licensor will in no event be +liable for any direct or indirect, material or moral, damages of any kind, arising out of the Licence or of the use of the +Work, including without limitation, damages for loss of goodwill, work stoppage, computer failure or malfunction, loss +of data or any commercial damage, even if the Licensor has been advised of the possibility of such damage. However, +the Licensor will be liable under statutory product liability laws as far such laws apply to the Work. + +9.Additional agreements +While distributing the Work, You may choose to conclude an additional agreement, defining obligations or services +consistent with this Licence. However, if accepting obligations, You may act only on your own behalf and on your sole +responsibility, not on behalf of the original Licensor or any other Contributor, and only if You agree to indemnify, +defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against such Contributor by +the fact You have accepted any warranty or additional liability. + +10.Acceptance of the Licence +The provisions of this Licence can be accepted by clicking on an icon ‘I agree’ placed under the bottom of a window +displaying the text of this Licence or by affirming consent in any other similar way, in accordance with the rules of +applicable law. Clicking on that icon indicates your clear and irrevocable acceptance of this Licence and all of its terms +and conditions. +Similarly, you irrevocably accept this Licence and all of its terms and conditions by exercising any rights granted to You +by Article 2 of this Licence, such as the use of the Work, the creation by You of a Derivative Work or the Distribution +or Communication by You of the Work or copies thereof. + +11.Information to the public +In case of any Distribution or Communication of the Work by means of electronic communication by You (for example, +by offering to download the Work from a remote location) the distribution channel or media (for example, a website) +must at least provide to the public the information requested by the applicable law regarding the Licensor, the Licence +and the way it may be accessible, concluded, stored and reproduced by the Licensee. + +12.Termination of the Licence +The Licence and the rights granted hereunder will terminate automatically upon any breach by the Licensee of the terms +of the Licence. +Such a termination will not terminate the licences of any person who has received the Work from the Licensee under +the Licence, provided such persons remain in full compliance with the Licence. + +13.Miscellaneous +Without prejudice of Article 9 above, the Licence represents the complete agreement between the Parties as to the +Work. +If any provision of the Licence is invalid or unenforceable under applicable law, this will not affect the validity or +enforceability of the Licence as a whole. Such provision will be construed or reformed so as necessary to make it valid +and enforceable. +The European Commission may publish other linguistic versions or new versions of this Licence or updated versions of +the Appendix, so far this is required and reasonable, without reducing the scope of the rights granted by the Licence. +New versions of the Licence will be published with a unique version number. +All linguistic versions of this Licence, approved by the European Commission, have identical value. Parties can take +advantage of the linguistic version of their choice. + +14.Jurisdiction +Without prejudice to specific agreement between parties, +— any litigation resulting from the interpretation of this License, arising between the European Union institutions, +bodies, offices or agencies, as a Licensor, and any Licensee, will be subject to the jurisdiction of the Court of Justice +of the European Union, as laid down in article 272 of the Treaty on the Functioning of the European Union, +— any litigation arising between other parties and resulting from the interpretation of this License, will be subject to +the exclusive jurisdiction of the competent court where the Licensor resides or conducts its primary business. + +15.Applicable Law +Without prejudice to specific agreement between parties, +— this Licence shall be governed by the law of the European Union Member State where the Licensor has his seat, +resides or has his registered office, +— this licence shall be governed by Belgian law if the Licensor has no seat, residence or registered office inside +a European Union Member State. + + + Appendix + +‘Compatible Licences’ according to Article 5 EUPL are: +— GNU General Public License (GPL) v. 2, v. 3 +— GNU Affero General Public License (AGPL) v. 3 +— Open Software License (OSL) v. 2.1, v. 3.0 +— Eclipse Public License (EPL) v. 1.0 +— CeCILL v. 2.0, v. 2.1 +— Mozilla Public Licence (MPL) v. 2 +— GNU Lesser General Public Licence (LGPL) v. 2.1, v. 3 +— Creative Commons Attribution-ShareAlike v. 3.0 Unported (CC BY-SA 3.0) for works other than software +— European Union Public Licence (EUPL) v. 1.1, v. 1.2 +— Québec Free and Open-Source Licence — Reciprocity (LiLiQ-R) or Strong Reciprocity (LiLiQ-R+). + +The European Commission may update this Appendix to later versions of the above licences without producing +a new version of the EUPL, as long as they provide the rights granted in Article 2 of this Licence and protect the +covered Source Code from exclusive appropriation. +All other changes or additions to this Appendix require the production of a new EUPL version. diff --git a/README.md b/README.md new file mode 100644 index 0000000..76b3e5e --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +# Ukkoclot + +A shitty small telegram bot written in common lisp. + +# Licensing + +European Union Public Licence, version 1.2. diff --git a/REUSE.toml b/REUSE.toml new file mode 100644 index 0000000..5798adc --- /dev/null +++ b/REUSE.toml @@ -0,0 +1,14 @@ +# See +version = 1 + +[[annotations]] + label = "Miscellaneous little shits I put under CC0" + path = [".gitignore", ".pre-commit-config.yaml", "config.default.lisp"] + SPDX-License-Identifier = "CC0-1.0" + SPDX-FileCopyrightText = " 2025 Uko Kokņevičs " + +[[annotations]] + label = "Docs or something" + path = ["README.md"] + SPDX-License-Identifier = "EUPL-1.2" + SPDX-FileCopyrightText = " 2025 Uko Kokņevičs " diff --git a/config.default.lisp b/config.default.lisp new file mode 100644 index 0000000..39b80c8 --- /dev/null +++ b/config.default.lisp @@ -0,0 +1,6 @@ +;; Copy this file to config.lisp and modify it there +(:bot-name "Ukko's Clot" + :bot-token "123456789:ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghi" + :db-path "./data.db" + :dev-group -1001234567890 + :owner 12345678) 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)))) diff --git a/ukkoclot.asd b/ukkoclot.asd new file mode 100644 index 0000000..eaada64 --- /dev/null +++ b/ukkoclot.asd @@ -0,0 +1,19 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs + +(defsystem "ukkoclot" + :class :package-inferred-system + :author "Uko Kokņevičs " + :maintainer "Uko Kokņevičs " + :licence "EUPL-1.2" + ;; TODO: :homepage + :version "0.0.1" + :description "ukkoclot: Ukko's shitty telegram bot" + :long-description #.(uiop:read-file-string (uiop:subpathname *load-pathname* "README.md")) + :pathname "src" + :depends-on (:ukkoclot/main) + ;; TODO: :in-order-to ((test-op (test-op ukkoclot-test))) + ) + +(register-system-packages :closer-mop '(:c2cl)) +(register-system-packages :dexador '(:dex)) -- cgit v1.2.3