├── README.md ├── v2 ├── test.py ├── README.md ├── match.lisp ├── api.lisp ├── types.lisp ├── high │ ├── callbacks.lisp │ └── permissions.lisp ├── errors.lisp ├── debug │ ├── diagram │ │ ├── vars.lisp │ │ ├── slot.lisp │ │ ├── generics.lisp │ │ ├── group.lisp │ │ └── utils.lisp │ └── diagram.lisp ├── workflow.lisp ├── vars.lisp ├── matchers │ ├── regex.lisp │ └── string.lisp ├── action.lisp ├── actor-reference.lisp ├── actions │ ├── delay.lisp │ ├── delete-messages.lisp │ ├── send-photo.lisp │ ├── send-text.lisp │ ├── edit-message-media.lisp │ └── send-invoice.lisp ├── debug.lisp ├── callback.lisp ├── sent-messages.lisp ├── states │ ├── wait-for-payment.lisp │ ├── ask-for-number.lisp │ └── ask-for-text.lisp ├── term │ └── back.lisp ├── server.lisp ├── high.lisp ├── utils.lisp └── generics.lisp ├── .local.el ├── .gitignore ├── qlfile ├── qlfile.lock ├── src ├── markup.lisp ├── response-processing.lisp ├── profile.lisp ├── inline.lisp ├── webhooks.lisp ├── pipeline.lisp ├── entities │ ├── generic.lisp │ ├── core.lisp │ └── command.lisp ├── files.lisp ├── commands.lisp ├── game.lisp ├── ci.lisp ├── media.lisp ├── envelope.lisp ├── stickers.lisp ├── core.lisp ├── callback.lisp ├── bot.lisp ├── utils.lisp ├── network.lisp ├── keyboard.lisp ├── inline-keyboard.lisp ├── user.lisp ├── telegram-call.lisp ├── update.lisp └── response.lisp ├── cl-telegram-bot-ci.asd ├── cl-telegram-bot-docs.asd ├── cl-telegram-bot-tests.asd ├── t2 └── matchers │ └── regex.lisp ├── cl-telegram-bot2-tests.asd ├── clpmfile ├── cl-telegram-bot2-examples.asd ├── cl-telegram-bot.asd ├── LICENSE ├── Lakefile ├── examples ├── text-chain.lisp ├── echo.lisp ├── gallery.lisp ├── commands.lisp ├── calc.lisp ├── payments.lisp └── all.lisp ├── .github └── workflows │ ├── ci.yml │ ├── docs.yml │ └── linter.yml ├── cl-telegram-bot2.asd ├── example └── bot.lisp ├── docs ├── examples.lisp └── states.lisp └── t └── core.lisp /README.md: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /v2/test.py: -------------------------------------------------------------------------------- 1 | 2 | # Factorial function: 3 | def fact 4 | -------------------------------------------------------------------------------- /.local.el: -------------------------------------------------------------------------------- 1 | (with-temp-file "/proc/self/comm" (insert "emacs tel-bot")) 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .qlot/ 2 | /docs/build/ 3 | *~ 4 | .#* 5 | .*.~undo-tree~ 6 | .DS_Store 7 | *.fasl 8 | .env 9 | -------------------------------------------------------------------------------- /qlfile: -------------------------------------------------------------------------------- 1 | dist ultralisp http://dist.ultralisp.org/ 2 | 3 | # This branch is what I use in my Emacs 4 | # github slynk svetlyak40wt/sly :branch patches 5 | -------------------------------------------------------------------------------- /v2/README.md: -------------------------------------------------------------------------------- 1 | Command to donwload api spec: 2 | 3 | 4 | curl 'https://raw.githubusercontent.com/rockneurotiko/telegram_api_json/refs/tags/0.9.0/exports/tg_api_pretty.json' > spec.json 5 | -------------------------------------------------------------------------------- /qlfile.lock: -------------------------------------------------------------------------------- 1 | ("quicklisp" . 2 | (:class qlot/source/dist:source-dist 3 | :initargs (:distribution "https://beta.quicklisp.org/dist/quicklisp.txt" :%version :latest) 4 | :version "2024-10-12")) 5 | ("ultralisp" . 6 | (:class qlot/source/dist:source-dist 7 | :initargs (:distribution "https://dist.ultralisp.org/" :%version :latest) 8 | :version "20250224155500")) 9 | -------------------------------------------------------------------------------- /v2/match.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/match 2 | (:use #:cl) 3 | (:export #:matchp 4 | #:matcher)) 5 | (in-package #:cl-telegram-bot2/match) 6 | 7 | 8 | (defclass matcher () 9 | ()) 10 | 11 | 12 | (defgeneric matchp (matcher obj) 13 | (:documentation "Should return T if OBJ match to the matcher. The simples matcher compares two strings.")) 14 | -------------------------------------------------------------------------------- /v2/api.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/api 2 | ;; Don't use any symbols from other packages 3 | ;; This prevents any conflicts in future and 4 | ;; we don't have to shadow any symbols here: 5 | (:use) 6 | (:import-from #:cl-telegram-bot2/spec 7 | #:define-tg-apis)) 8 | (cl:in-package #:cl-telegram-bot2/api) 9 | 10 | 11 | (define-tg-apis) 12 | -------------------------------------------------------------------------------- /v2/types.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/types 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/api) 4 | (:export #:reply-markup-type)) 5 | (in-package #:cl-telegram-bot2/types) 6 | 7 | 8 | (deftype reply-markup-type () 9 | `(or cl-telegram-bot2/api:reply-keyboard-markup 10 | cl-telegram-bot2/api:reply-keyboard-remove 11 | cl-telegram-bot2/api:inline-keyboard-markup 12 | cl-telegram-bot2/api:force-reply)) 13 | -------------------------------------------------------------------------------- /src/markup.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot/markup 2 | (:use #:cl) 3 | (:export #:to-markup)) 4 | (in-package #:cl-telegram-bot/markup) 5 | 6 | 7 | (defgeneric to-markup (obj) 8 | (:documentation "Transforms object into markup of Telegram API. 9 | 10 | Methods of this class should return a hash-table, representing OBJ 11 | in terms of Telegram API.") 12 | (:method ((obj hash-table)) 13 | obj)) 14 | -------------------------------------------------------------------------------- /src/response-processing.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot/response-processing 2 | (:use #:cl) 3 | (:export #:process-response 4 | #:interrupt-processing)) 5 | (in-package #:cl-telegram-bot/response-processing) 6 | 7 | 8 | (define-condition interrupt-processing () 9 | ()) 10 | 11 | 12 | (defgeneric process-response (bot message response) 13 | (:documentation "Processes immediate responses of different types.")) 14 | 15 | 16 | (defun interrupt-processing () 17 | (signal 'interrupt-processing)) 18 | -------------------------------------------------------------------------------- /cl-telegram-bot-ci.asd: -------------------------------------------------------------------------------- 1 | (defsystem "cl-telegram-bot-ci" 2 | :author "Alexander Artemenko " 3 | :license "MIT" 4 | :homepage "https://40ants.com/cl-telegram-bot/" 5 | :class :package-inferred-system 6 | :description "Provides CI settings for cl-telegram-bot." 7 | :source-control (:git "https://github.com/40ants/cl-telegram-bot") 8 | :bug-tracker "https://github.com/40ants/cl-telegram-bot/issues" 9 | :pathname "src" 10 | :depends-on ("40ants-ci" 11 | "cl-telegram-bot-ci/ci")) 12 | -------------------------------------------------------------------------------- /src/profile.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cl-telegram-bot/profile 2 | (:use #:cl)) 3 | (in-package cl-telegram-bot/profile) 4 | 5 | 6 | ;; TODO: refactor 7 | 8 | (defun get-user-profile-photos (b user-id &key offset limit) 9 | "https://core.telegram.org/bots/api#getuserprofilephotos" 10 | (let ((options 11 | (list 12 | (cons :user_id user-id)))) 13 | (when offset (nconc options `((:offset . ,offset)))) 14 | (when limit (nconc options `((:limit . ,limit)))) 15 | (apply #'make-request b "getUserProfilePhotos" options))) 16 | -------------------------------------------------------------------------------- /cl-telegram-bot-docs.asd: -------------------------------------------------------------------------------- 1 | (defsystem "cl-telegram-bot-docs" 2 | :author "Alexander Artemenko " 3 | :license "MIT" 4 | :homepage "https://40ants.com/cl-telegram-bot/" 5 | :class :package-inferred-system 6 | :description "Provides documentation for cl-telegram-bot." 7 | :source-control (:git "https://github.com/40ants/cl-telegram-bot") 8 | :bug-tracker "https://github.com/40ants/cl-telegram-bot/issues" 9 | :pathname "docs" 10 | :depends-on ("cl-telegram-bot" 11 | "cl-telegram-bot2" 12 | "cl-telegram-bot-media" 13 | "cl-telegram-bot-docs/index")) 14 | -------------------------------------------------------------------------------- /cl-telegram-bot-tests.asd: -------------------------------------------------------------------------------- 1 | (defsystem "cl-telegram-bot-tests" 2 | :author "Alexander Artemenko " 3 | :license "MIT" 4 | :homepage "https://40ants.com/cl-telegram-bot/" 5 | :class :package-inferred-system 6 | :description "Provides tests for cl-telegram-bot." 7 | :source-control (:git "https://github.com/40ants/cl-telegram-bot") 8 | :bug-tracker "https://github.com/40ants/cl-telegram-bot/issues" 9 | :pathname "t" 10 | :depends-on ("cl-telegram-bot-tests/core") 11 | :perform (test-op (op c) 12 | (unless (symbol-call :rove :run c) 13 | (error "Tests failed")))) 14 | -------------------------------------------------------------------------------- /t2/matchers/regex.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2-tests/matchers/regex 2 | (:use #:cl) 3 | (:import-from #:rove 4 | #:ok 5 | #:deftest) 6 | (:import-from #:cl-telegram-bot2/match 7 | #:matchp) 8 | (:import-from #:cl-telegram-bot2/matchers/regex 9 | #:regex-matcher)) 10 | (in-package #:cl-telegram-bot2-tests/matchers/regex) 11 | 12 | 13 | (deftest test-regex-matcher () 14 | (let ((matcher (regex-matcher "bar-\\d+"))) 15 | (ok (matchp matcher "bar-1234")) 16 | (ok (not (matchp matcher "foo-bar-1234"))) 17 | (ok (not (matchp matcher "bar-1234-blah"))))) 18 | -------------------------------------------------------------------------------- /cl-telegram-bot2-tests.asd: -------------------------------------------------------------------------------- 1 | (defsystem "cl-telegram-bot2-tests" 2 | :author "Alexander Artemenko " 3 | :license "MIT" 4 | :homepage "https://40ants.com/cl-telegram-bot/" 5 | :class :package-inferred-system 6 | :description "Provides tests for cl-telegram-bot." 7 | :source-control (:git "https://github.com/40ants/cl-telegram-bot") 8 | :bug-tracker "https://github.com/40ants/cl-telegram-bot/issues" 9 | :pathname "t2" 10 | :depends-on ("cl-telegram-bot2-tests/matchers/regex") 11 | :perform (test-op (op c) 12 | (unless (symbol-call :rove :run c) 13 | (error "Tests failed")))) 14 | -------------------------------------------------------------------------------- /v2/high/callbacks.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/high/callbacks 2 | (:use #:cl) 3 | (:import-from #:serapeum 4 | #:->) 5 | (:import-from #:cl-telegram-bot2/api 6 | #:update-callback-query 7 | #:callback-query-data 8 | #:update) 9 | (:export #:get-callback-data)) 10 | (in-package #:cl-telegram-bot2/high/callbacks) 11 | 12 | 13 | (-> get-callback-data (update) 14 | (values string &optional)) 15 | 16 | 17 | (defun get-callback-data (update) 18 | "Extracts callback query data from the UPDATE object." 19 | (let* ((query (update-callback-query update))) 20 | (callback-query-data query))) 21 | -------------------------------------------------------------------------------- /v2/errors.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/errors 2 | (:use #:cl) 3 | (:import-from #:alexandria 4 | #:required-argument) 5 | (:export #:telegram-error 6 | #:error-description)) 7 | (in-package #:cl-telegram-bot2/errors) 8 | 9 | 10 | (define-condition telegram-error (error) 11 | ((description :initarg :description 12 | :initform (required-argument "DESCRIPTION is required argument for TELEGRAM-ERROR class.") 13 | :type string 14 | :reader error-description)) 15 | (:report (lambda (c stream) 16 | (print-unreadable-object (c stream :type t) 17 | (write-string (error-description c) stream))))) 18 | -------------------------------------------------------------------------------- /clpmfile: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: common-lisp; -*- 2 | (:api-version "0.4") 3 | 4 | (:source "quicklisp" 5 | :url "https://beta.quicklisp.org/dist/quicklisp.txt" 6 | :type :quicklisp) 7 | 8 | ;; Don't move abover quicklisp before this issue 9 | ;; will be resolved: 10 | ;; https://github.com/ultralisp/ultralisp/issues/197 11 | (:source "ultralisp" 12 | :url "https://clpi.ultralisp.org/" 13 | :type :clpi) 14 | 15 | ;; Does not work because https://dist.ultralisp.org/ultralisp-versions.txt is missing 16 | ;; (:source "ultralisp" 17 | ;; :url "https://dist.ultralisp.org/ultralisp.txt" 18 | ;; :type :quicklisp) 19 | 20 | (:asd "cl-telegram-bot.asd") 21 | (:asd "cl-telegram-bot-tests.asd") 22 | (:asd "cl-telegram-bot-ci.asd") 23 | (:asd "cl-telegram-bot-docs.asd") 24 | 25 | -------------------------------------------------------------------------------- /v2/debug/diagram/vars.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/debug/diagram/vars 2 | (:use #:cl) 3 | (:import-from #:serapeum 4 | #:defvar-unbound) 5 | (:export 6 | #:*diagram-stream*)) 7 | (in-package #:cl-telegram-bot2/debug/diagram/vars) 8 | 9 | 10 | (defvar *diagram-stream*) 11 | 12 | (defvar *obj-to-id*) 13 | (defvar *id-to-obj*) 14 | (defvar *state-to-name*) 15 | (defvar *name-to-state*) 16 | (defvar *id-to-state*) 17 | (defvar *current-map-id*) 18 | (defvar *current-obj-id*) 19 | (defvar *send-text-limit* 30) 20 | 21 | 22 | (defvar-unbound *objects-created* 23 | "A list of object ids created by to-text generic-function.") 24 | 25 | 26 | (defvar-unbound *on-after-object* 27 | "A hash-table to register callbacks to be called after some object was rendered.") 28 | -------------------------------------------------------------------------------- /cl-telegram-bot2-examples.asd: -------------------------------------------------------------------------------- 1 | #-asdf3.1 (error "cl-telegram-bot requires ASDF 3.1 because for lower versions pathname does not work for package-inferred systems.") 2 | (defsystem "cl-telegram-bot2-examples" 3 | :description "Examples of Telegram Bot API Common Lisp library." 4 | :author "Alexander Artemenko " 5 | :license "MIT" 6 | :homepage "https://40ants.com/cl-telegram-bot/" 7 | :source-control (:git "https://github.com/40ants/cl-telegram-bot") 8 | :bug-tracker "https://github.com/40ants/cl-telegram-bot/issues" 9 | :class :40ants-asdf-system 10 | :defsystem-depends-on ("40ants-asdf-system") 11 | :pathname "examples" 12 | :depends-on ("clack-handler-hunchentoot" 13 | "cl-telegram-bot2-examples/all") 14 | :in-order-to ((test-op (test-op "cl-telegram-bot2-tests")))) 15 | -------------------------------------------------------------------------------- /cl-telegram-bot.asd: -------------------------------------------------------------------------------- 1 | #-asdf3.1 (error "cl-telegram-bot requires ASDF 3.1 because for lower versions pathname does not work for package-inferred systems.") 2 | (defsystem "cl-telegram-bot" 3 | :description "Telegram Bot API, based on sovietspaceship's work but mostly rewritten." 4 | :author "Alexander Artemenko " 5 | :license "MIT" 6 | :homepage "https://40ants.com/cl-telegram-bot/" 7 | :source-control (:git "https://github.com/40ants/cl-telegram-bot") 8 | :bug-tracker "https://github.com/40ants/cl-telegram-bot/issues" 9 | :class :40ants-asdf-system 10 | :defsystem-depends-on ("40ants-asdf-system") 11 | :pathname "src" 12 | :depends-on ("cl-telegram-bot/core") 13 | :in-order-to ((test-op (test-op "cl-telegram-bot-tests")))) 14 | 15 | 16 | (asdf:register-system-packages "log4cl" '("LOG")) 17 | -------------------------------------------------------------------------------- /src/inline.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cl-telegram-bot/inline 2 | (:use #:cl)) 3 | (in-package cl-telegram-bot/inline) 4 | 5 | 6 | (defun answer-inline-query (b inline-query-id results &key cache-time is-personal next-offset switch-pm-text) 7 | "https://core.telegram.org/bots/api#answerinlinequery 8 | https://core.telegram.org/bots/inline" 9 | (let ((options 10 | (list 11 | (cons :inline_query_id inline-query-id) 12 | (cons :results results)))) 13 | (when cache-time (nconc options `((:cache_time . ,cache-time)))) 14 | (when is-personal (nconc options `((:is_personal . ,is-personal)))) 15 | (when next-offset (nconc options `((:next_offset . ,next-offset)))) 16 | (when switch-pm-text (nconc options `((:switch_pm_text . ,switch-pm-text)))) 17 | (make-request b "answerInlineQuery" options))) 18 | -------------------------------------------------------------------------------- /v2/workflow.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/workflow 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/states/base 4 | #:base-state) 5 | (:import-from #:cl-telegram-bot2/term/back 6 | #:back) 7 | (:import-from #:cl-telegram-bot2/action 8 | #:action) 9 | (:import-from #:serapeum 10 | #:soft-list-of) 11 | (:export #:workflow-blocks 12 | #:workflow-block 13 | #:funcallable-symbol)) 14 | (in-package #:cl-telegram-bot2/workflow) 15 | 16 | 17 | (deftype funcallable-symbol () 18 | '(and symbol 19 | (satisfies fboundp))) 20 | 21 | 22 | (deftype workflow-block () 23 | '(or 24 | funcallable-symbol 25 | base-state 26 | action 27 | back)) 28 | 29 | 30 | (deftype workflow-blocks () 31 | '(soft-list-of workflow-block)) 32 | 33 | 34 | -------------------------------------------------------------------------------- /src/webhooks.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cl-telegram-bot/webhooks 2 | (:use #:cl) 3 | (:import-from #:log4cl)) 4 | (in-package cl-telegram-bot/webhooks) 5 | 6 | ;; TODO: refactor 7 | 8 | (defun set-webhook (b url &key certificate max-connections allowed-updates) 9 | "https://core.telegram.org/bots/api#setwebhook" 10 | (let ((options 11 | (list 12 | (cons :url url)))) 13 | (when certificate (nconc options `((:certificate . ,certificate)))) 14 | (when max-connections (nconc options `((:max_connections . ,max-connections)))) 15 | (when allowed-updates (nconc options `((:allowed_updates . ,allowed-updates)))) 16 | (apply #'make-request b "setWebhook" options))) 17 | 18 | 19 | (defun get-webhook-info (bot) 20 | "https://core.telegram.org/bots/api#getwebhookinfo" 21 | (log:debug "Retriving webhook info") 22 | (make-request bot "getWebhookInfo")) 23 | -------------------------------------------------------------------------------- /src/pipeline.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cl-telegram-bot/pipeline 2 | (:use #:cl) 3 | (:import-from #:log) 4 | (:export 5 | #:process)) 6 | (in-package cl-telegram-bot/pipeline) 7 | 8 | 9 | (defgeneric process (bot object) 10 | (:documentation "This method is called by when processing a single update. 11 | It is called multiple times on different parts of an update. 12 | Whole pipeline looks like that: 13 | 14 | For each update we call: 15 | process(update) 16 | process(update.payload) 17 | For each entity in payload: 18 | process(entity) 19 | ")) 20 | 21 | 22 | (defmethod process (bot object) 23 | "By default, processing does nothing" 24 | (declare (ignorable bot object)) 25 | (log:warn "No PROCESS method for processing objects of ~A type." 26 | (type-of object)) 27 | (values)) 28 | -------------------------------------------------------------------------------- /v2/debug/diagram/slot.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/debug/diagram/slot 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/debug/diagram/generics 4 | #:to-text 5 | #:render-handlers) 6 | (:export #:slot 7 | #:slot-name 8 | #:slot-handlers)) 9 | (in-package #:cl-telegram-bot2/debug/diagram/slot) 10 | 11 | 12 | (defclass slot () 13 | ((name :initarg :name 14 | :reader slot-name) 15 | (value :initarg :value 16 | :reader slot-handlers))) 17 | 18 | 19 | (defun slot (name value) 20 | (when value 21 | (make-instance 'slot 22 | :name name 23 | :value value))) 24 | 25 | 26 | (defun to-slot (obj) 27 | (slot (cl-telegram-bot2/debug/diagram/generics:slot-name obj) 28 | obj)) 29 | 30 | 31 | (defmethod render-handlers ((slot slot)) 32 | (render-handlers (slot-handlers slot))) 33 | 34 | 35 | (defmethod to-text ((slot slot)) 36 | (to-text (slot-handlers slot))) 37 | -------------------------------------------------------------------------------- /src/entities/generic.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot/entities/generic 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot/utils 4 | #:make-keyword) 5 | (:import-from #:arrows 6 | #:->) 7 | (:export #:make-entity 8 | #:make-entity-internal)) 9 | (in-package #:cl-telegram-bot/entities/generic) 10 | 11 | 12 | (defgeneric make-entity-internal (entity-type payload data) 13 | (:documentation "Extendable protocol to support entities of different kinds. 14 | First argument is a keyword, denoting a type of the entity. 15 | Payload is an object of type `message'. 16 | And data is a plist with data, describing the entity.")) 17 | 18 | 19 | (defun make-entity (payload data) 20 | (let ((entity-type (-> data 21 | (getf :|type|) 22 | (make-keyword)))) 23 | (make-entity-internal entity-type 24 | payload 25 | data))) 26 | -------------------------------------------------------------------------------- /src/entities/core.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot/entities/core 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot/message 4 | #:message) 5 | (:import-from #:cl-telegram-bot/chat 6 | #:get-chat) 7 | (:import-from #:cl-telegram-bot/entities/generic 8 | #:make-entity-internal) 9 | (:nicknames #:cl-telegram-bot/entities)) 10 | (in-package cl-telegram-bot/entities/core) 11 | 12 | 13 | (defclass entity () 14 | ((payload :type message 15 | :initarg :payload 16 | :reader get-payload) 17 | (raw-data :initarg :raw-data 18 | :reader get-raw-data))) 19 | 20 | 21 | (defclass unsupported-entity (entity) 22 | ()) 23 | 24 | 25 | (defmethod make-entity-internal (entity-type payload data) 26 | (declare (ignorable payload entity-type)) 27 | (make-instance 'unsupported-entity 28 | :raw-data data 29 | :payload payload)) 30 | 31 | 32 | (defmethod get-chat ((command entity)) 33 | (get-chat (get-payload command))) 34 | -------------------------------------------------------------------------------- /v2/vars.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/vars 2 | (:use #:cl) 3 | (:import-from #:serapeum 4 | #:defvar-unbound) 5 | (:export #:*default-special-bindings*)) 6 | (in-package #:cl-telegram-bot2/vars) 7 | 8 | 9 | (defvar-unbound *current-bot* 10 | "An internal variable to hold current bot for replying.") 11 | 12 | (defvar-unbound *current-user* 13 | "An internal variable to hold current user talking to the bot.") 14 | 15 | (defvar-unbound *current-chat* 16 | "This var will be bound when PROCESS method is called on chat state.") 17 | 18 | (defvar-unbound *current-state* 19 | "This var will be bound when PROCESS method is called on chat state.") 20 | 21 | 22 | (defvar *default-special-bindings* 23 | nil 24 | "This variable holds an alist associating special variable symbols 25 | to forms to evaluate. 26 | 27 | State processing might be done by different threads that is 28 | why you might want to keep some context around. 29 | 30 | Don't modify this variable, just cons onto it. Preceeding values 31 | will take a priority.") 32 | -------------------------------------------------------------------------------- /v2/debug/diagram/generics.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/debug/diagram/generics 2 | (:use #:cl) 3 | (:export #:render-handler-link 4 | #:render-handlers 5 | #:slot-name 6 | #:get-slots 7 | #:to-text)) 8 | (in-package #:cl-telegram-bot2/debug/diagram/generics) 9 | 10 | 11 | (defgeneric render-handler-link (handler) 12 | (:documentation "Renders a map item for a given handler. 13 | 14 | It should use render-mapslot-value-with-link or render-mapslot-value functions 15 | for proper rendering of `PlantUML`.")) 16 | 17 | 18 | (defgeneric render-handlers (object) 19 | (:documentation "Renders a map with a list of handlers for some event.")) 20 | 21 | 22 | (defgeneric slot-name (obj) 23 | (:documentation "Returns a name for a state slot for such objects as callbacks or commands.")) 24 | 25 | 26 | (defgeneric get-slots (state) 27 | (:documentation "Returns state's slots or groups of slots as a list.")) 28 | 29 | 30 | (defgeneric to-text (obj) 31 | (:documentation "Renders object as an entity on `PlantUML` diagram.")) 32 | 33 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2016 Rei 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /v2/matchers/regex.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/matchers/regex 2 | (:use #:cl) 3 | (:import-from #:serapeum 4 | #:->) 5 | (:import-from #:cl-telegram-bot2/match 6 | #:matchp 7 | #:matcher) 8 | (:import-from #:str 9 | #:ensure-prefix 10 | #:ensure-suffix) 11 | (:import-from #:cl-ppcre 12 | #:count-matches) 13 | (:export #:regex-matcher 14 | #:matcher-regex)) 15 | (in-package #:cl-telegram-bot2/matchers/regex) 16 | 17 | 18 | (defclass regex-matcher (matcher) 19 | ((regex :initarg :regex 20 | :type string 21 | :reader matcher-regex))) 22 | 23 | 24 | (-> regex-matcher (string) 25 | (values regex-matcher &optional)) 26 | 27 | 28 | (defun regex-matcher (string) 29 | (make-instance 'regex-matcher 30 | :regex (ensure-prefix "^" 31 | (ensure-suffix "$" string)))) 32 | 33 | 34 | (defmethod matchp ((matcher regex-matcher) (obj string)) 35 | (not (zerop (count-matches (matcher-regex matcher) 36 | obj)))) 37 | -------------------------------------------------------------------------------- /v2/matchers/string.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/matchers/string 2 | (:use #:cl) 3 | (:import-from #:serapeum 4 | #:->) 5 | (:import-from #:cl-telegram-bot2/match 6 | #:matcher 7 | #:matchp) 8 | (:export #:string-matcher 9 | #:matcher-string 10 | #:case-insensitive-p)) 11 | (in-package #:cl-telegram-bot2/matchers/string) 12 | 13 | 14 | (defclass string-matcher (matcher) 15 | ((string :initarg :string 16 | :type string 17 | :reader matcher-string) 18 | (case-insensitive :initarg :case-insensitive 19 | :type boolean 20 | :reader case-insensitive-p))) 21 | 22 | 23 | (-> string-matcher (string &key (:case-insensitive boolean)) 24 | (values string-matcher &optional)) 25 | 26 | 27 | (defun string-matcher (string &key case-insensitive) 28 | (make-instance 'string-matcher 29 | :string string 30 | :case-insensitive case-insensitive)) 31 | 32 | 33 | (defmethod matchp ((matcher string-matcher) (obj string)) 34 | (cond 35 | ((case-insensitive-p matcher) 36 | (string-equal (matcher-string matcher) 37 | obj)) 38 | (t 39 | (string= (matcher-string matcher) 40 | obj)))) 41 | -------------------------------------------------------------------------------- /Lakefile: -------------------------------------------------------------------------------- 1 | #|-*- mode:lisp -*-|# 2 | 3 | (push "~/projects/40ants-lake/" asdf:*central-registry*) 4 | (push "~/projects/cl-mustache/" asdf:*central-registry*) 5 | 6 | (ql:quickload :40ants-lake 7 | :silent t) 8 | 9 | (defpackage :lake.user 10 | (:use :cl :lake) 11 | (:import-from #:40ants-lake/utils 12 | #:alias) 13 | (:import-from #:40ants-lake/environment 14 | #:load-env-file) 15 | (:import-from #:40ants-lake/app 16 | #:defapps 17 | #:app) 18 | (:import-from #:40ants-lake/component/webservice 19 | #:webservice 20 | #:proxy) 21 | (:import-from #:40ants-lake/component/daemon 22 | #:daemon) 23 | (:import-from #:40ants-lake/env-val 24 | #:env-val) 25 | (:shadowing-import-from :lake 26 | :directory)) 27 | (in-package :lake.user) 28 | 29 | 30 | (when (probe-file ".local-config.lisp") 31 | (load ".local-config.lisp")) 32 | 33 | 34 | (load-env-file) 35 | 36 | 37 | (let ((backend-port (env-val :dev 10120))) 38 | (defapps 39 | (app "cl-echo-bot" 40 | :components (list (webservice (env-val :dev "cl-echo-bot.dev.40ants.com") 41 | :routes (proxy "/" 42 | backend-port)))))) 43 | -------------------------------------------------------------------------------- /src/files.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cl-telegram-bot/files 2 | (:use #:cl)) 3 | (in-package cl-telegram-bot/files) 4 | 5 | ;; TODO: refactor 6 | 7 | (defmacro with-ok-results ((unserialized results) &body body) 8 | `(let ((,results (slot-value ,unserialized (find-json-symbol :result)))) 9 | (if (slot-value ,unserialized (find-json-symbol :ok)) 10 | (progn ,@body) 11 | nil))) 12 | 13 | 14 | (defun download-file (b file-id) 15 | "Get the path for a file from a file-id (see: get-file) and then 16 | download it. Returns nil if the value of the http response code is 17 | not success (200); otherwise it will returns three values: the 18 | data, the http headers and the exension of the original file" 19 | (with-package :cl-telegram-bot 20 | (let* ((file-spec (decode (get-file b file-id)))) 21 | (with-ok-results (file-spec results) 22 | (alexandria:when-let* ((path (access results 'file--path)) 23 | (uri (concatenate 'string (file-endpoint b) path)) 24 | (extension (cl-ppcre:scan-to-strings "\\..*$" path))) 25 | (dexador:get uri)))))) 26 | 27 | 28 | (defun get-file (b file-id) 29 | "https://core.telegram.org/bots/api#getfile" 30 | (let ((options 31 | (list 32 | (cons :file_id file-id)))) 33 | (make-request b "getFile" options))) 34 | 35 | -------------------------------------------------------------------------------- /src/commands.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot/commands 2 | (:use #:cl) 3 | (:import-from #:log) 4 | (:import-from #:cl-telegram-bot/network 5 | #:make-request) 6 | (:import-from #:cl-telegram-bot/bot 7 | #:bot) 8 | (:import-from #:serapeum 9 | #:soft-alist-of 10 | #:defvar-unbound)) 11 | (in-package #:cl-telegram-bot/commands) 12 | 13 | 14 | (declaim (ftype (function (bot (or (soft-alist-of string string) 15 | (serapeum:soft-list-of string))) 16 | (values)) 17 | set-my-commands)) 18 | 19 | ;; TODO: Support scope and language optional arguments 20 | (defun set-my-commands (bot commands) 21 | "https://core.telegram.org/bots/api#setmycommands" 22 | (log:debug "Sending commands to the server" commands) 23 | (make-request bot "setMyCommands" 24 | :|commands| (loop for command in commands 25 | collect (etypecase command 26 | (string (list :|command| command 27 | :|description| "No documentation.")) 28 | (cons (list :|command| (car command) 29 | :|description| (cdr command)))))) 30 | (values)) 31 | -------------------------------------------------------------------------------- /examples/text-chain.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2-examples/text-chain 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/bot 4 | #:defbot) 5 | (:import-from #:cl-telegram-bot2/server 6 | #:stop-polling 7 | #:start-polling) 8 | (:import-from #:cl-telegram-bot2/state 9 | #:state) 10 | (:import-from #:cl-telegram-bot2/actions/send-text 11 | #:send-text) 12 | (:import-from #:cl-telegram-bot2/actions/delete-messages 13 | #:delete-messages)) 14 | (in-package #:cl-telegram-bot2-examples/text-chain) 15 | 16 | 17 | 18 | (defbot test-bot () 19 | () 20 | (:initial-state 21 | (state 22 | (state (send-text "Hello!") 23 | :on-deletion (delete-messages) 24 | :on-update (state (send-text "How are you doing?") 25 | :on-deletion (delete-messages) 26 | :on-update (state (send-text "Bye!") 27 | :on-deletion (delete-messages)))) 28 | :id "text-chain-example"))) 29 | 30 | 31 | (defvar *bot* nil) 32 | 33 | 34 | (defun stop () 35 | (when *bot* 36 | (stop-polling *bot*) 37 | (setf *bot* nil))) 38 | 39 | 40 | (defun start () 41 | (stop) 42 | 43 | (unless *bot* 44 | (setf *bot* 45 | (make-test-bot (uiop:getenv "TELEGRAM_TOKEN")))) 46 | 47 | (start-polling *bot* :debug t)) 48 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | { 2 | "name": "CI", 3 | "on": { 4 | "push": { 5 | "branches": [ 6 | "master" 7 | ] 8 | }, 9 | "pull_request": null, 10 | "schedule": [ 11 | { 12 | "cron": "0 10 * * 1" 13 | } 14 | ] 15 | }, 16 | "jobs": { 17 | "run-tests": { 18 | "strategy": { 19 | "fail-fast": false, 20 | "matrix": { 21 | "lisp": [ 22 | "sbcl-bin/2.5.10", 23 | "ccl-bin" 24 | ] 25 | } 26 | }, 27 | "runs-on": "ubuntu-latest", 28 | "env": { 29 | "OS": "ubuntu-latest", 30 | "QUICKLISP_DIST": "quicklisp", 31 | "LISP": "${{ matrix.lisp }}" 32 | }, 33 | "steps": [ 34 | { 35 | "name": "Checkout Code", 36 | "uses": "actions/checkout@v4" 37 | }, 38 | { 39 | "name": "Setup Common Lisp Environment", 40 | "uses": "40ants/setup-lisp@v4", 41 | "with": { 42 | "asdf-system": "cl-telegram-bot", 43 | "cache": "true" 44 | } 45 | }, 46 | { 47 | "name": "Run Tests", 48 | "uses": "40ants/run-tests@v2", 49 | "with": { 50 | "asdf-system": "cl-telegram-bot", 51 | "coveralls-token": "\n${{ matrix.lisp == 'sbcl-bin' &&\n matrix.os == 'ubuntu-latest' &&\n matrix.quicklisp == 'ultralisp' &&\n secrets.github_token }}" 52 | } 53 | } 54 | ] 55 | } 56 | } 57 | } -------------------------------------------------------------------------------- /examples/echo.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2-examples/echo 2 | (:use #:cl) 3 | (:import-from #:bordeaux-threads) 4 | (:import-from #:cl-telegram-bot2/state 5 | #:state) 6 | (:import-from #:cl-telegram-bot2/actions/send-text 7 | #:send-text) 8 | (:import-from #:cl-telegram-bot2/bot 9 | #:defbot) 10 | (:import-from #:cl-telegram-bot2/server 11 | #:stop-polling 12 | #:start-polling) 13 | (:import-from #:cl-telegram-bot2/high 14 | #:reply 15 | #:chat-state) 16 | (:import-from #:cl-telegram-bot2/api 17 | #:update-message 18 | #:message-text 19 | #:message-message-id) 20 | (:import-from #:40ants-logging)) 21 | (in-package #:cl-telegram-bot2-examples/echo) 22 | 23 | 24 | (defun reply-with-same-text (update) 25 | (reply (message-text 26 | (update-message update))) 27 | (values)) 28 | 29 | 30 | (defbot test-bot () 31 | () 32 | (:initial-state 33 | (state (send-text "Hello, I'm the echo bot.") 34 | :id "echo-example" 35 | :on-update 'reply-with-same-text))) 36 | 37 | 38 | (defvar *bot* nil) 39 | 40 | 41 | (defun stop () 42 | (when *bot* 43 | (stop-polling *bot*) 44 | (setf *bot* nil) 45 | 46 | (sleep 1) 47 | (bt:all-threads))) 48 | 49 | 50 | (defun start () 51 | (stop) 52 | 53 | (40ants-logging:setup-for-repl :level :warn) 54 | 55 | (unless *bot* 56 | (setf *bot* 57 | (make-test-bot (uiop:getenv "TELEGRAM_TOKEN")))) 58 | 59 | (start-polling *bot* :debug t)) 60 | -------------------------------------------------------------------------------- /.github/workflows/docs.yml: -------------------------------------------------------------------------------- 1 | { 2 | "name": "DOCS", 3 | "on": { 4 | "push": { 5 | "branches": [ 6 | "master" 7 | ] 8 | }, 9 | "pull_request": null, 10 | "schedule": [ 11 | { 12 | "cron": "0 10 * * 1" 13 | } 14 | ] 15 | }, 16 | "jobs": { 17 | "build-docs": { 18 | "runs-on": "ubuntu-24.04", 19 | "env": { 20 | "OS": "ubuntu-24.04", 21 | "QUICKLISP_DIST": "quicklisp", 22 | "LISP": "sbcl-bin/2.5.10" 23 | }, 24 | "steps": [ 25 | { 26 | "name": "Checkout Code", 27 | "uses": "actions/checkout@v4" 28 | }, 29 | { 30 | "name": "Setup Common Lisp Environment", 31 | "uses": "40ants/setup-lisp@v4", 32 | "with": { 33 | "asdf-system": "cl-telegram-bot-docs", 34 | "dynamic-space-size": "4gb", 35 | "cache": "true" 36 | } 37 | }, 38 | { 39 | "name": "Install PlantUML", 40 | "run": "sudo apt-get install -y plantuml", 41 | "shell": "bash" 42 | }, 43 | { 44 | "name": "Update PlantUML", 45 | "run": "sudo curl --output /usr/share/plantuml/plantuml.jar -L https://github.com/plantuml/plantuml/releases/download/v1.2024.8/plantuml-mit-1.2024.8.jar", 46 | "shell": "bash" 47 | }, 48 | { 49 | "name": "Build Docs", 50 | "uses": "40ants/build-docs@v1", 51 | "with": { 52 | "asdf-system": "cl-telegram-bot-docs", 53 | "error-on-warnings": true 54 | } 55 | } 56 | ] 57 | } 58 | } 59 | } -------------------------------------------------------------------------------- /v2/high/permissions.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/high/permissions 2 | (:use #:cl) 3 | (:import-from #:serapeum 4 | #:dict 5 | #:-> 6 | #:soft-list-of) 7 | (:import-from #:str 8 | #:replace-all) 9 | (:import-from #:cl-telegram-bot2/utils 10 | #:to-json) 11 | (:export 12 | #:chat-administration-permission 13 | #:chat-administration-permissions)) 14 | (in-package #:cl-telegram-bot2/high/permissions) 15 | 16 | 17 | (deftype chat-administration-permission () 18 | "API docs: https://core.telegram.org/bots/api#chatadministratorrights" 19 | `(member :is-anonymous 20 | :can-manage-chat 21 | :can-delete-messages 22 | :can-manage-video-chats 23 | :can-restrict-members 24 | :can-promote-members 25 | :can-change-info 26 | :can-invite-users 27 | :can-post-stories 28 | :can-edit-stories 29 | :can-delete-stories 30 | :can-post-messages 31 | :can-edit-messages 32 | :can-pin-messages 33 | :can-manage-topics)) 34 | 35 | 36 | (deftype chat-administration-permissions () 37 | `(soft-list-of chat-administration-permission)) 38 | 39 | 40 | (-> permissions-to-json (chat-administration-permissions) 41 | (values string &optional)) 42 | 43 | (defun permissions-to-json (permissions) 44 | (loop with hash = (dict) 45 | for permission in permissions 46 | do (setf (gethash (replace-all "-" "_" 47 | (string-downcase permission)) 48 | hash) 49 | yason:true) 50 | finally (return (to-json hash)))) 51 | -------------------------------------------------------------------------------- /.github/workflows/linter.yml: -------------------------------------------------------------------------------- 1 | { 2 | "name": "LINTER", 3 | "on": { 4 | "push": { 5 | "branches": [ 6 | "master" 7 | ] 8 | }, 9 | "pull_request": null, 10 | "schedule": [ 11 | { 12 | "cron": "0 10 * * 1" 13 | } 14 | ] 15 | }, 16 | "jobs": { 17 | "linter": { 18 | "runs-on": "ubuntu-latest", 19 | "env": { 20 | "DYNAMIC_SPACE_SIZE": "4Gb", 21 | "OS": "ubuntu-latest", 22 | "QUICKLISP_DIST": "quicklisp", 23 | "LISP": "sbcl-bin/2.5.10" 24 | }, 25 | "steps": [ 26 | { 27 | "name": "Checkout Code", 28 | "uses": "actions/checkout@v4" 29 | }, 30 | { 31 | "name": "Setup Common Lisp Environment", 32 | "uses": "40ants/setup-lisp@v4", 33 | "with": { 34 | "asdf-system": "cl-telegram-bot", 35 | "cache": "true" 36 | } 37 | }, 38 | { 39 | "name": "Change dist to Ultralisp if qlfile does not exist", 40 | "run": "if [[ ! -e qlfile ]]; then echo 'dist ultralisp http://dist.ultralisp.org' > qlfile; fi", 41 | "shell": "bash" 42 | }, 43 | { 44 | "name": "Update Qlot", 45 | "run": "qlot update --no-deps", 46 | "shell": "bash" 47 | }, 48 | { 49 | "name": "Install SBLint wrapper", 50 | "run": "qlot exec ros install 40ants-asdf-system 40ants-linter", 51 | "shell": "bash" 52 | }, 53 | { 54 | "name": "Run Linter", 55 | "run": "qlot exec 40ants-linter --system \"cl-telegram-bot, cl-telegram-bot2, cl-telegram-bot2-examples, cl-telegram-bot-tests\" --imports", 56 | "shell": "bash" 57 | } 58 | ] 59 | } 60 | } 61 | } -------------------------------------------------------------------------------- /v2/action.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/action 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/debug/diagram/generics 4 | #:to-text 5 | #:render-handler-link) 6 | (:import-from #:cl-telegram-bot2/debug/diagram/utils 7 | #:render-mapslot-value) 8 | (:export #:action 9 | #:call-if-action)) 10 | (in-package #:cl-telegram-bot2/action) 11 | 12 | 13 | (defclass action () 14 | ()) 15 | 16 | 17 | (defun call-if-action (obj func &rest args) 18 | "Useful in CL-TELEGRAM-BOT2/GENERICS:PROCESS-STATE generic-function methods in case if 19 | state has additional handler stored in the slot and this 20 | slot can be either state or action or a list of actions and states. 21 | 22 | This function is recursive, because processing of an action 23 | could return another action and we should call FUNC until 24 | a new state or NIL will be returned." 25 | (typecase obj 26 | (list 27 | ;; Some handlers may represent a list of actions 28 | ;; and states, thus we need to call FUNC 29 | ;; while a non-nil and non-action object will be returned. 30 | (loop for item in obj 31 | thereis (apply #'call-if-action 32 | item func args))) 33 | (action 34 | (apply #'call-if-action 35 | (apply func obj args) 36 | func 37 | args)) 38 | (t 39 | obj))) 40 | 41 | 42 | (defmethod render-handler-link ((action action)) 43 | (render-mapslot-value 44 | "action" 45 | (symbol-name 46 | (class-name (class-of action))))) 47 | 48 | 49 | (defmethod to-text ((action action)) 50 | ;; NOTE: Decided to not render blocks for funcs and actions. 51 | ;; Probably will need to show again if I decide to render 52 | ;; output arrows from functions. 53 | (values)) 54 | -------------------------------------------------------------------------------- /v2/debug/diagram/group.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/debug/diagram/group 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/debug/diagram/generics 4 | #:to-text 5 | #:render-handlers) 6 | (:import-from #:cl-telegram-bot2/debug/diagram/slot 7 | #:slot 8 | #:slot-name 9 | #:to-slot) 10 | (:export #:group 11 | #:group-name 12 | #:group-slots)) 13 | (in-package #:cl-telegram-bot2/debug/diagram/group) 14 | 15 | 16 | (defclass group () 17 | ((name :initarg :name 18 | :reader group-name) 19 | (slots :initarg :slots 20 | :reader group-slots))) 21 | 22 | 23 | (defun group (name objects) 24 | (when objects 25 | (make-instance 'group 26 | :name name 27 | :slots 28 | (mapcar #'to-slot 29 | objects)))) 30 | 31 | 32 | (defmethod render-handlers ((group group)) 33 | (loop for slot in (group-slots group) 34 | do (render-handlers slot))) 35 | 36 | 37 | (defmethod to-text ((group group)) 38 | (to-text (group-slots group))) 39 | 40 | 41 | (defun sort-slots-and-groups (objs) 42 | (sort (copy-list objs) 43 | (lambda (left right) 44 | (cond 45 | ((and (typep left 'slot) 46 | (typep right 'slot)) 47 | (string< (slot-name left) 48 | (slot-name right))) 49 | ((and (typep left 'slot) 50 | (typep right 'group)) 51 | t) 52 | ((and (typep left 'group) 53 | (typep right 'slot)) 54 | nil) 55 | ((and (typep left 'group) 56 | (typep right 'group)) 57 | (string< (group-name left) 58 | (group-name right))))))) 59 | -------------------------------------------------------------------------------- /src/game.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cl-telegram-bot/game 2 | (:use #:cl)) 3 | (in-package cl-telegram-bot/game) 4 | 5 | 6 | (defun send-game (b chat-id game-short-name &key disable-notification reply-to-message-id reply-markup) 7 | "https://core.telegram.org/bots/api#sendgame" 8 | (let ((options 9 | (list 10 | (cons :chat_id chat-id) 11 | (cons :game_short_name game-short-name)))) 12 | (when disable-notification (nconc options `((:disable_notification . ,disable-notification)))) 13 | (when reply-to-message-id (nconc options `((:reply_to_message_id . ,reply-to-message-id)))) 14 | (when reply-markup (nconc options `((:reply_markup . ,reply-markup)))) 15 | (make-request b "sendGame" options))) 16 | 17 | (defun set-game-score (b user-id score &key force disable-edit-message chat-id message-id inline-message-id) 18 | "https://core.telegram.org/bots/api#setgamescore" 19 | (let ((options 20 | (list 21 | (cons :user_id user-id) 22 | (cons :score score)))) 23 | (when force (nconc options `((:force . ,force)))) 24 | (when disable-edit-message (nconc options `((:disable_edit_message . ,disable-edit-message)))) 25 | (when chat-id (nconc options `((:chat_id . ,chat-id)))) 26 | (when message-id (nconc options `((:message_id . ,message-id)))) 27 | (when inline-message-id (nconc options `((:inline_message_id . ,inline-message-id)))) 28 | (make-request b "setGameScore" options))) 29 | 30 | (defun get-game-high-scores (b user-id &key chat-id message-id inline-message-id) 31 | "https://core.telegram.org/bots/api#getgamehighscores" 32 | (let ((options 33 | (list 34 | (cons :user_id user-id)))) 35 | (when chat-id (nconc options `((:chat_id . ,chat-id)))) 36 | (when message-id (nconc options `((:message_id . ,message-id)))) 37 | (when inline-message-id (nconc options `((:inline_message_id . ,inline-message-id)))) 38 | (make-request b "getGameHighScores" options))) 39 | 40 | -------------------------------------------------------------------------------- /v2/actor-reference.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/actor-reference 2 | (:use #:cl) 3 | (:import-from #:sento.actor-context 4 | #:actor-context) 5 | (:import-from #:alexandria 6 | #:required-argument) 7 | (:import-from #:serapeum 8 | #:->)) 9 | (in-package #:cl-telegram-bot2/actor-reference) 10 | 11 | 12 | (defclass actor-ref () 13 | ((context :initarg :context 14 | :initform (required-argument "Argument :CONTEXT is required.") 15 | :type actor-context 16 | :reader %actor-context) 17 | (actor-name :initarg :actor-name 18 | :initform (required-argument "Argument :ACTOR-NAME is required.") 19 | :type string 20 | :reader %actor-name))) 21 | 22 | 23 | (-> actor-ref (actor-context string) 24 | (values actor-ref &optional)) 25 | 26 | (defun actor-ref (context actor-name) 27 | "Creates an actor reference which can be used to ASK actor with given name. 28 | 29 | NAME should be a full name of the actor in the given CONTEXT, like /user/request-processor." 30 | (unless (sento.actor-context:find-actors 31 | context actor-name) 32 | (error "Actor ~A does not exist." 33 | actor-name)) 34 | 35 | (make-instance 'actor-ref 36 | :context context 37 | :actor-name actor-name)) 38 | 39 | 40 | (defmethod sento.actor:ask ((self actor-ref) message &key (time-out nil)) 41 | (sento.actor:ask (first 42 | (sento.actor-context:find-actors 43 | (%actor-context self) 44 | (%actor-name self))) 45 | message 46 | :time-out time-out)) 47 | 48 | 49 | (defmethod sento.actor:ask-s ((self actor-ref) message &key (time-out nil)) 50 | (sento.actor:ask-s (first 51 | (sento.actor-context:find-actors 52 | (%actor-context self) 53 | (%actor-name self))) 54 | message 55 | :time-out time-out)) 56 | -------------------------------------------------------------------------------- /cl-telegram-bot2.asd: -------------------------------------------------------------------------------- 1 | #-asdf3.1 (error "cl-telegram-bot requires ASDF 3.1 because for lower versions pathname does not work for package-inferred systems.") 2 | (defsystem "cl-telegram-bot2" 3 | :description "Telegram Bot API, completely rewritten. Autogenerates code from JSON spec and adds high-level declarative DSL on top." 4 | :author "Alexander Artemenko " 5 | :license "MIT" 6 | :homepage "https://40ants.com/cl-telegram-bot/" 7 | :source-control (:git "https://github.com/40ants/cl-telegram-bot") 8 | :bug-tracker "https://github.com/40ants/cl-telegram-bot/issues" 9 | :class :40ants-asdf-system 10 | :defsystem-depends-on ("40ants-asdf-system") 11 | :pathname "v2" 12 | :depends-on ("cl-telegram-bot2/api" 13 | "cl-telegram-bot2/pipeline" 14 | "cl-telegram-bot2/server" 15 | "cl-telegram-bot2/state" 16 | "cl-telegram-bot2/actions/delete-messages" 17 | "cl-telegram-bot2/actions/edit-message-media" 18 | "cl-telegram-bot2/actions/send-invoice" 19 | "cl-telegram-bot2/actions/send-photo" 20 | "cl-telegram-bot2/actions/send-text" 21 | "cl-telegram-bot2/matchers/string" 22 | "cl-telegram-bot2/matchers/regex" 23 | "cl-telegram-bot2/states/ask-for-text" 24 | "cl-telegram-bot2/states/ask-for-choice" 25 | "cl-telegram-bot2/high/keyboard" 26 | "cl-telegram-bot2/high/callbacks") 27 | :in-order-to ((test-op (test-op "cl-telegram-bot2-tests")))) 28 | 29 | 30 | (asdf:register-system-packages "bordeaux-threads" '("BORDEAUX-THREADS-2")) 31 | (asdf:register-system-packages "log4cl" '("LOG")) 32 | (asdf:register-system-packages "utilities.print-items" '("PRINT-ITEMS")) 33 | (asdf:register-system-packages "dexador" '("DEX")) 34 | (asdf:register-system-packages "sento" '("SENTO.ACTOR-SYSTEM" 35 | "SENTO.ACTOR-CONTEXT" 36 | "SENTO.ACTOR" 37 | "SENTO.ACTOR-CELL")) 38 | -------------------------------------------------------------------------------- /v2/actions/delay.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/actions/delay 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/spec 4 | #:*token*) 5 | (:import-from #:log4cl-extras/error 6 | #:with-log-unhandled) 7 | (:import-from #:sento.wheel-timer 8 | #:schedule-once) 9 | (:import-from #:sento.actor-context 10 | #:system) 11 | (:import-from #:sento.actor-system 12 | #:scheduler) 13 | (:import-from #:sento.actor 14 | #:*self*) 15 | (:export #:delay 16 | #:cancel-delayed-execution)) 17 | (in-package #:cl-telegram-bot2/actions/delay) 18 | 19 | 20 | (defvar *system* nil 21 | "We need to store current actor system because during the delayed code execution *self* variable does not point to any actor.") 22 | 23 | 24 | (defun current-system () 25 | (or *system* 26 | (when *self* 27 | (system *self*)) 28 | (error "Unable to get current actor system"))) 29 | 30 | 31 | (defun call-delay (seconds thunk) 32 | (let* ((system (current-system)) 33 | (timer-wheel (scheduler system)) 34 | (token *token*)) 35 | 36 | (flet ((wrapped-delayed-thunk () 37 | (with-log-unhandled () 38 | (let ((*token* token) 39 | (*system* system)) 40 | (funcall thunk))))) 41 | 42 | (schedule-once timer-wheel seconds 43 | #'wrapped-delayed-thunk)))) 44 | 45 | 46 | (defmacro delay ((seconds) &body body) 47 | "This macro allows to call BODY with given delay. 48 | 49 | During the body call current bot's telegram token will be available and you can send messages. 50 | 51 | Retruned value (signature) can be used to cancel delayed code using call to CANCEL-DELAYED-EXECUTION." 52 | `(flet ((delayed-thunk () 53 | ,@body)) 54 | (call-delay ,seconds #'delayed-thunk))) 55 | 56 | 57 | (defun cancel-delayed-execution (signature) 58 | "Cancels code execution delayed by DELAY macro." 59 | (let* ((system (current-system)) 60 | (timer-wheel (scheduler system))) 61 | 62 | (sento.wheel-timer:cancel timer-wheel signature))) 63 | -------------------------------------------------------------------------------- /src/ci.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot-ci/ci 2 | (:use #:cl) 3 | (:import-from #:40ants-ci/jobs/linter) 4 | (:import-from #:40ants-ci/jobs/run-tests 5 | #:run-tests) 6 | (:import-from #:40ants-ci/jobs/docs 7 | #:build-docs) 8 | (:import-from #:40ants-ci/workflow 9 | #:defworkflow) 10 | (:import-from #:40ants-ci/steps/sh 11 | #:sh)) 12 | (in-package #:cl-telegram-bot-ci/ci) 13 | 14 | 15 | (defworkflow linter 16 | :on-push-to "master" 17 | :by-cron "0 10 * * 1" 18 | :on-pull-request t 19 | :cache t 20 | :jobs ((40ants-ci/jobs/linter:linter 21 | :lisp "sbcl-bin/2.5.10" 22 | :asdf-systems ("cl-telegram-bot" 23 | "cl-telegram-bot2" 24 | "cl-telegram-bot2-examples" 25 | ;; Documentation intentionally has 26 | ;; a lot of unused imports. Actually they 27 | ;; are used in docstrings, but linter 28 | ;; can't understand this case. 29 | ;; "cl-telegram-bot-docs" 30 | "cl-telegram-bot-tests") 31 | :env (("DYNAMIC_SPACE_SIZE" . "4Gb")) 32 | :check-imports t))) 33 | 34 | 35 | (defworkflow docs 36 | :on-push-to "master" 37 | :by-cron "0 10 * * 1" 38 | :on-pull-request t 39 | :cache t 40 | :jobs ((build-docs 41 | :lisp "sbcl-bin/2.5.10" 42 | :os "ubuntu-24.04" 43 | :asdf-system "cl-telegram-bot-docs" 44 | :dynamic-space-size "4gb" 45 | :steps (list 46 | (sh "Install PlantUML" 47 | "sudo apt-get install -y plantuml") 48 | ;; Ubuntu 24.04 uses old PlantUML version, so we upgrade it here: 49 | (sh "Update PlantUML" 50 | "sudo curl --output /usr/share/plantuml/plantuml.jar -L https://github.com/plantuml/plantuml/releases/download/v1.2024.8/plantuml-mit-1.2024.8.jar"))))) 51 | 52 | 53 | (defworkflow ci 54 | :on-push-to "master" 55 | :by-cron "0 10 * * 1" 56 | :on-pull-request t 57 | :cache t 58 | :jobs ((run-tests 59 | :asdf-system "cl-telegram-bot" 60 | :lisp ("sbcl-bin/2.5.10" 61 | "ccl-bin") 62 | :coverage t))) 63 | -------------------------------------------------------------------------------- /src/media.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cl-telegram-bot/media 2 | (:use #:cl)) 3 | (in-package cl-telegram-bot/media) 4 | 5 | 6 | ;; TODO: refactor 7 | 8 | (defun send-location (b chat-id latitude longitude &key disable-notification reply-to-message-id reply-markup) 9 | "https://core.telegram.org/bots/api#sendlocation" 10 | (let ((options 11 | (list 12 | (cons :chat_id chat-id) 13 | (cons :latitude latitude) 14 | (cons :longitude longitude)))) 15 | (when disable-notification (nconc options `((:disable_notification . ,disable-notification)))) 16 | (when reply-to-message-id (nconc options `((:reply_to_message_id . ,reply-to-message-id)))) 17 | (when reply-markup (nconc options `((:reply_markup . ,reply-markup)))) 18 | (make-request b "sendLocation" options))) 19 | 20 | (defun send-venue (b chat-id latitude longitude title address &key foursquare-id disable-notification reply-to-message-id reply-markup) 21 | "https://core.telegram.org/bots/api#sendvenue" 22 | (let ((options 23 | (list 24 | (cons :chat_id chat-id) 25 | (cons :latitude latitude) 26 | (cons :longitude longitude) 27 | (cons :title title) 28 | (cons :address address)))) 29 | (when foursquare-id (nconc options `((:foursquare_id . ,foursquare-id)))) 30 | (when disable-notification (nconc options `((:disable_notification . ,disable-notification)))) 31 | (when reply-to-message-id (nconc options `((:reply_to_message_id . ,reply-to-message-id)))) 32 | (when reply-markup (nconc options `((:reply_markup . ,reply-markup)))) 33 | (make-request b "sendVenue" options))) 34 | 35 | (defun send-contact (b chat-id phone-number first-name &key last-name disable-notification reply-to-message-id reply-markup) 36 | "https://core.telegram.org/bots/api#sendcontact" 37 | (let ((options 38 | (list 39 | (cons :chat_id chat-id) 40 | (cons :phone_number phone-number) 41 | (cons :first_name first-name)))) 42 | (when last-name (nconc options `((:last_name . ,last-name)))) 43 | (when disable-notification (nconc options `((:disable_notification . ,disable-notification)))) 44 | (when reply-to-message-id (nconc options `((:reply_to_message_id . ,reply-to-message-id)))) 45 | (when reply-markup (nconc options `((:reply_markup . ,reply-markup)))) 46 | (make-request b "sendContact" options))) 47 | 48 | 49 | -------------------------------------------------------------------------------- /v2/debug.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/debug 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/bot) 4 | (:export 5 | #:bot-actors-info)) 6 | (in-package #:cl-telegram-bot2/debug) 7 | 8 | 9 | ;; (defun queue-size (q) 10 | ;; (etypecase q 11 | ;; (sento.queue::queue 12 | ;; (+ (length (sento.queue::queue-head q)) 13 | ;; (length (sento.queue::queue-tail q)))) 14 | ;; (sento.queue:queue-bounded 15 | ;; (sento.queue:queued-count q)) 16 | 17 | ;; (sento.queue:queue-unbounded 18 | ;; (let ((inner-queue (slot-value q 19 | ;; 'sento.queue::queue))) 20 | ;; (queue-size inner-queue))))) 21 | 22 | 23 | (defun bot-actors-info (bot) 24 | (actors-info (cl-telegram-bot2/bot::actors-system bot))) 25 | 26 | 27 | (defun actors-info (system &key (verbose nil)) 28 | (let* ((actors (append (sento.actor-system::%all-actors system :user) 29 | (sento.actor-system::%all-actors system :internal)))) 30 | (loop for actor in (sort 31 | ;; Sort is destructive, so we have to copy actors list here 32 | (copy-list actors) 33 | #'string< 34 | :key #'sento.actor-cell:name) 35 | for msgbox = (sento.actor-cell:msgbox actor) 36 | for pinned = (typep msgbox 'sento.messageb:message-box/bt) 37 | for thread = (when pinned 38 | (slot-value msgbox 'sento.messageb::queue-thread)) 39 | for queue = (slot-value msgbox 40 | 'sento.messageb::queue) 41 | do (if thread 42 | (format t "~A: ~A (~A) ~@[msgbox-name=~A~]~%" 43 | (sento.actor-cell:name actor) 44 | (sento.queue:queued-count queue) 45 | ;; (queue-size queue) 46 | (if (bt2:thread-alive-p thread) 47 | "thread alive" 48 | "thread died") 49 | (when verbose 50 | (sento.messageb::name msgbox))) 51 | (format t "~A: ~A~%" 52 | (sento.actor-cell:name actor) 53 | (sento.queue:queued-count queue) 54 | ;; (queue-size queue) 55 | ))))) ;; 56 | 57 | -------------------------------------------------------------------------------- /example/bot.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:example-bot/bot 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot 4 | #:start-processing 5 | #:on-message 6 | #:defbot) 7 | (:import-from #:cl-telegram-bot/chat 8 | #:private-chat 9 | #:get-username) 10 | (:import-from #:cl-telegram-bot/message 11 | #:get-current-chat) 12 | (:import-from #:serapeum 13 | #:dict 14 | #:fmt) 15 | (:import-from #:cl-telegram-bot/response 16 | #:alert 17 | #:notify 18 | #:reply) 19 | (:import-from #:cl-telegram-bot/inline-keyboard 20 | #:callback-button 21 | #:inline-keyboard)) 22 | (in-package #:example-bot/bot) 23 | 24 | 25 | (defbot example-bot) 26 | 27 | 28 | (defmethod on-message ((bot example-bot) 29 | text) 30 | (let* ((chat (get-current-chat)) 31 | (username (get-username chat))) 32 | (log:info "Talking to" username) 33 | (let ((keyboard (when (string-equal text "show") 34 | (inline-keyboard 35 | (list 36 | (callback-button "Alert" "alert") 37 | (callback-button "Notify" "notify") 38 | (callback-button "Text me" "text")))))) 39 | (reply (fmt "Привет ~A!" 40 | username) 41 | :reply-markup keyboard)))) 42 | 43 | 44 | (defmethod cl-telegram-bot/callback:on-callback ((bot example-bot) 45 | callback) 46 | (let ((data (cl-telegram-bot/callback:callback-data callback))) 47 | (cond 48 | ((string-equal data 49 | "alert") 50 | (cl-telegram-bot/response:alert "You pressed alert button!")) 51 | 52 | ((string-equal data 53 | "notify") 54 | (cl-telegram-bot/response:reply "Just replying with text.") 55 | (cl-telegram-bot/response:notify "You pressed notify button!")) 56 | (t 57 | (cl-telegram-bot/response:reply "Just replying with text."))))) 58 | 59 | 60 | (defun start (&key token) 61 | (start-processing (make-example-bot (or token 62 | (uiop:getenv "TELEGRAM_TOKEN") 63 | (error "Define TELEGRAM_TOKEN env var."))) 64 | :debug t)) 65 | -------------------------------------------------------------------------------- /src/envelope.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot/envelope 2 | (:use #:cl) 3 | (:import-from #:log) 4 | (:import-from #:cl-telegram-bot/pipeline 5 | #:process) 6 | (:export #:wrapped-message 7 | #:envelope 8 | #:edited-message 9 | #:channel-post 10 | #:edited-channel-post 11 | #:edited-message-p 12 | #:channel-post-p)) 13 | (in-package #:cl-telegram-bot/envelope) 14 | 15 | 16 | (defvar *wrappers* nil 17 | "This var will hold a list of wrappers during the call to PROCESS generic-function. It is used by functions CHANNEL-POST-P and EDITED-MESSAGE-P.") 18 | 19 | 20 | (defclass envelope () 21 | ((message :initarg :message 22 | :reader wrapped-message)) 23 | (:documentation "This is the container for a message. From the type of container we can understand if this message was sent to a channel or maybe edited, etc.")) 24 | 25 | 26 | (defclass edited-message (envelope) 27 | () 28 | (:documentation "This container wraps CL-TELEGRAM-BOT/MESSAGE:MESSAGE when user edits a message.")) 29 | 30 | 31 | (defclass channel-post (envelope) 32 | () 33 | (:documentation "This container wraps CL-TELEGRAM-BOT/MESSAGE:MESSAGE when somebody sends a message to a channel.")) 34 | 35 | 36 | (defclass edited-channel-post (envelope) 37 | () 38 | (:documentation "This container wraps CL-TELEGRAM-BOT/MESSAGE:MESSAGE when somebody edits a message in a channel.")) 39 | 40 | 41 | (defmethod process ((bot t) (envelope envelope)) 42 | "By default, just calls `process' on the wrapped message." 43 | (log:debug "Processing envelope" envelope) 44 | (let ((message (wrapped-message envelope)) 45 | (*wrappers* (cons envelope *wrappers*))) 46 | (process bot message))) 47 | 48 | 49 | (declaim (ftype (function () boolean) 50 | channel-post-p)) 51 | 52 | (defun channel-post-p () 53 | "Returns T if current message was posted to a channel." 54 | (loop for wrapper in *wrappers* 55 | thereis (or (typep wrapper 'channel-post) 56 | (typep wrapper 'edited-channel-post)))) 57 | 58 | 59 | (declaim (ftype (function () boolean) 60 | edited-message-p)) 61 | 62 | (defun edited-message-p () 63 | "Returns T if current message is an update for existing message in the channel of group chat." 64 | (loop for wrapper in *wrappers* 65 | thereis (or (typep wrapper 'edited-message) 66 | (typep wrapper 'edited-channel-post)))) 67 | -------------------------------------------------------------------------------- /v2/callback.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/callback 2 | (:use #:cl) 3 | (:import-from #:alexandria 4 | #:required-argument) 5 | (:import-from #:serapeum 6 | #:->) 7 | (:import-from #:cl-telegram-bot2/workflow 8 | #:workflow-block 9 | #:workflow-blocks) 10 | (:import-from #:cl-telegram-bot2/debug/diagram/generics 11 | #:to-text 12 | #:render-handlers) 13 | (:import-from #:cl-telegram-bot2/debug/diagram/utils 14 | #:render-handlers-inner 15 | #:obj-id) 16 | (:import-from #:cl-telegram-bot2/match 17 | #:matcher) 18 | (:import-from #:cl-telegram-bot2/matchers/string 19 | #:string-matcher) 20 | (:export #:callback 21 | #:callback-matcher 22 | #:callback-handlers)) 23 | (in-package #:cl-telegram-bot2/callback) 24 | 25 | 26 | (defclass callback () 27 | ((matcher :initarg :matcher 28 | :type matcher 29 | :initform (required-argument "DATA is required argument for CALLBACK class.") 30 | :reader callback-matcher) 31 | (handlers :initarg :handlers 32 | :type workflow-blocks 33 | :initform (required-argument "HANDLERS is required argument for CALLBACK class.") 34 | :reader callback-handlers)) 35 | (:documentation "Representation of callback handlers to be triggered on given callback data.")) 36 | 37 | 38 | (-> callback ((or string matcher) 39 | (or workflow-block 40 | workflow-blocks)) 41 | (values callback &optional)) 42 | 43 | (defun callback (string-or-matcher handlers) 44 | (let ((handlers (uiop:ensure-list handlers))) 45 | (unless handlers 46 | (error "Callback should have at least one handler.")) 47 | (make-instance 'callback 48 | :matcher (etypecase string-or-matcher 49 | (string 50 | (string-matcher string-or-matcher)) 51 | (matcher 52 | string-or-matcher)) 53 | :handlers handlers))) 54 | 55 | 56 | (defmethod render-handlers ((obj callback)) 57 | (render-handlers-inner (callback-handlers obj) 58 | (obj-id obj))) 59 | 60 | 61 | ;; NOTE: previously we used callback-data as slot name, 62 | ;; but then this data slot was replaced with matcher. 63 | ;; (defmethod slot-name ((obj callback)) 64 | ;; (cl-telegram-bot2/callback:callback-data obj)) 65 | 66 | 67 | (defmethod to-text ((command callback)) 68 | (to-text 69 | (callback-handlers command))) 70 | -------------------------------------------------------------------------------- /src/stickers.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cl-telegram-bot/stickers 2 | (:use #:cl)) 3 | (in-package cl-telegram-bot/stickers) 4 | 5 | ;; TODO: refactor 6 | 7 | 8 | (defun send-sticker (b chat-id sticker &key disable-notification reply-to-message-id reply-markup) 9 | "https://core.telegram.org/bots/api#sendsticker" 10 | (let ((options 11 | (list 12 | (cons :chat_id chat-id) 13 | (cons :sticker sticker)))) 14 | (when disable-notification (nconc options `((:disable_notification . ,disable-notification)))) 15 | (when reply-to-message-id (nconc options `((:reply_to_message_id . ,reply-to-message-id)))) 16 | (when reply-markup (nconc options `((:reply_markup . ,reply-markup)))) 17 | (apply #'make-request b "sendSticker" options))) 18 | 19 | (defun get-sticker-set (b name) 20 | "https://core.telegram.org/bots/api#getstickerset" 21 | (apply #'make-request b "getStickerSet" :name name)) 22 | 23 | (defun upload-sticker-file (b user-id png-sticker) 24 | "https://core.telegram.org/bots/api#uploadstickerfile" 25 | (apply #'make-request b "uploadStickerFile" 26 | :user_id user-id :png_sticker png-sticker)) 27 | 28 | (defun create-new-sticker-set (b user-id name title png-sticker emojis &key contains-masks mask-position) 29 | "https://core.telegram.org/bots/api#createnewstickerset" 30 | (let ((options 31 | (list 32 | (cons :user_id user-id) 33 | (cons :name name) 34 | (cons :title title) 35 | (cons :png_sticker png-sticker) 36 | (cons :emojis emojis)))) 37 | (when contains-masks (nconc options `((:contains_masks . ,contains-masks)))) 38 | (when mask-position (nconc options `((:mask_position . ,mask-position)))) 39 | (apply #'make-request b "createNewStickerSet" options))) 40 | 41 | (defun add-sticker-to-set (b user-id name png-sticker emojis &key mask-position) 42 | "https://core.telegram.org/bots/api#addstickertoset" 43 | (let ((options 44 | (list 45 | (cons :user_id user-id) 46 | (cons :name name) 47 | (cons :png_sticker png-sticker) 48 | (cons :emojis emojis)))) 49 | (when mask-position (nconc options `((:mask_position . ,mask-position)))) 50 | (apply #'make-request b "addStickerToSet" options))) 51 | 52 | (defun set-sticker-position-in-set (b sticker position) 53 | "https://core.telegram.org/bots/api#setstickerpositioninset" 54 | (make-request b "setStickerPositionInSet" :sticker sticker :position position)) 55 | 56 | (defun delete-sticker-from-set (b sticker) 57 | "https://core.telegram.org/bots/api#deletestickerfromset" 58 | (make-request b "deleteStickerFromSet" :sticker sticker)) 59 | 60 | -------------------------------------------------------------------------------- /v2/sent-messages.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/sent-messages 2 | (:use #:cl) 3 | (:import-from #:serapeum 4 | #:fmt 5 | #:-> 6 | #:pretty-print-hash-table 7 | #:dict 8 | #:soft-list-of) 9 | (:import-from #:cl-telegram-bot2/generics 10 | #:on-result 11 | #:on-state-activation 12 | #:process-state) 13 | (:import-from #:cl-telegram-bot2/api 14 | #:update 15 | #:update-message 16 | #:message-message-id) 17 | (:import-from #:cl-telegram-bot2/high 18 | #:collect-sent-messages) 19 | (:import-from #:cl-telegram-bot2/bot 20 | #:bot) 21 | (:import-from #:cl-telegram-bot2/states/base 22 | #:state-id 23 | #:sent-message-ids 24 | #:received-message-ids 25 | #:base-state) 26 | (:export #:save-received-message-id 27 | #:capture-sent-messages)) 28 | (in-package #:cl-telegram-bot2/sent-messages) 29 | 30 | 31 | (defmacro capture-sent-messages ((state-var) &body body) 32 | "Use this macro to capture messages end during PROCESS-STATE generic-function handling 33 | in case if your state inherits from BASE-STATE but does not call CALL-NEXT-METHOD." 34 | `(multiple-value-bind (sent-messages result) 35 | (collect-sent-messages 36 | ,@body) 37 | 38 | (loop for message in sent-messages 39 | do (push (message-message-id message) 40 | (sent-message-ids ,state-var))) 41 | (values result))) 42 | 43 | 44 | (-> save-received-message-id (base-state update) 45 | (values &optional)) 46 | 47 | (defun save-received-message-id (state update) 48 | "If some state class processes update and don't call CALL-NEXT-METHOD, 49 | then it have to call this function to register received message id. 50 | 51 | If you don't do this, then received messages deletion will not work 52 | for this state." 53 | (let ((message (update-message update))) 54 | (when message 55 | (push (message-message-id message) 56 | (received-message-ids state)))) 57 | (values)) 58 | 59 | 60 | (defmethod process-state :around ((bot bot) (state base-state) (update t)) 61 | (save-received-message-id state update) 62 | 63 | (capture-sent-messages (state) 64 | (call-next-method))) 65 | 66 | 67 | (defmethod on-state-activation :around ((state base-state)) 68 | (capture-sent-messages (state) 69 | (call-next-method))) 70 | 71 | 72 | (defmethod on-result :around ((state base-state) result) 73 | (capture-sent-messages (state) 74 | (call-next-method))) 75 | -------------------------------------------------------------------------------- /src/core.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot/core 2 | (:use #:cl) 3 | (:nicknames #:cl-telegram-bot) 4 | (:import-from #:bordeaux-threads 5 | #:make-thread 6 | #:destroy-thread) 7 | (:import-from #:log) 8 | (:import-from #:cl-telegram-bot/update 9 | #:process-updates) 10 | (:import-from #:cl-telegram-bot/response 11 | #:reply) 12 | (:import-from #:cl-telegram-bot/bot 13 | #:debug-mode 14 | #:defbot) 15 | (:import-from #:cl-telegram-bot/message 16 | #:on-message) 17 | (:import-from #:cl-telegram-bot/entities/command 18 | #:update-commands 19 | #:on-command) 20 | (:import-from #:trivial-backtrace 21 | #:print-backtrace) 22 | ;; This package exports only essential symbols, needed 23 | ;; in 80% cases. 24 | (:export #:defbot 25 | #:on-message 26 | #:reply 27 | #:start-processing 28 | #:stop-processing 29 | #:on-command)) 30 | (in-package cl-telegram-bot/core) 31 | 32 | 33 | 34 | (defvar *threads* nil) 35 | 36 | 37 | (defun start-processing (bot &key debug 38 | (delay-between-retries 10) 39 | (thread-name "telegram-bot")) 40 | (when (getf *threads* bot) 41 | (error "Processing already started.")) 42 | 43 | (setf (debug-mode bot) debug) 44 | 45 | (log:info "Starting thread to process updates for" bot) 46 | (flet ((continue-processing-if-not-debug (condition) 47 | (let ((restart (find-restart 'cl-telegram-bot/update::continue-processing 48 | condition))) 49 | (when restart 50 | (let ((traceback (print-backtrace 51 | condition :output nil))) 52 | (log:error "Unable to process Telegram updates" traceback)) 53 | 54 | (unless (debug-mode bot) 55 | (invoke-restart restart delay-between-retries))))) 56 | (stop-bot () 57 | (stop-processing bot))) 58 | 59 | (update-commands bot) 60 | 61 | (setf (getf *threads* bot) 62 | (make-thread 63 | (lambda () 64 | (handler-bind ((error #'continue-processing-if-not-debug)) 65 | (process-updates bot))) 66 | :name thread-name)) 67 | 68 | ;; Here we return a closure to stop the bot: 69 | #'stop-bot)) 70 | 71 | 72 | (defun stop-processing (bot) 73 | (let ((thread (getf *threads* bot))) 74 | (when thread 75 | (when (bt:thread-alive-p thread) 76 | (log:info "Stopping thread for" bot) 77 | (destroy-thread thread)) 78 | (setf (getf *threads* bot) 79 | nil)))) 80 | -------------------------------------------------------------------------------- /src/callback.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot/callback 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot/message 4 | #:message 5 | #:*current-message* 6 | #:get-rest-args 7 | #:get-text 8 | #:*current-bot* 9 | #:send-message) 10 | (:import-from #:cl-telegram-bot/pipeline 11 | #:process) 12 | (:import-from #:log) 13 | (:import-from #:cl-telegram-bot/chat 14 | #:get-chat 15 | #:get-chat-id) 16 | (:import-from #:cl-telegram-bot/response-processing 17 | #:process-response) 18 | (:export #:callback-data 19 | #:callback 20 | #:make-callback 21 | #:on-callback 22 | #:callback-id 23 | #:callback-message)) 24 | (in-package #:cl-telegram-bot/callback) 25 | 26 | 27 | (defclass callback () 28 | ((id :initarg :id 29 | :type string 30 | :reader callback-id) 31 | (data :initarg :data 32 | :type string 33 | :reader callback-data) 34 | (message :initarg :message 35 | :type message 36 | :reader callback-message))) 37 | 38 | 39 | (defgeneric on-callback (bot callback) 40 | (:documentation "Called when user clicks callback button. Second argument is an object of CALLBACK type.") 41 | (:method ((bot t) (callback t)) 42 | ;; Doing nothing 43 | (values))) 44 | 45 | 46 | (defgeneric make-callback (bot callback-data) 47 | (:documentation "Called when user clicks callback button. Should return an instance of CALLBACK class. 48 | 49 | Application may override this method to return objects of different callback classes depending on 50 | callback-data string. This way it mab be easier to define more specific methods for 51 | ON-CALLBACK generic-function.") 52 | (:method ((bot t) (callback-data t)) 53 | (let ((id (getf callback-data :|id|)) 54 | (data (getf callback-data :|data|)) 55 | (message-data (getf callback-data :|message|))) 56 | (make-instance 'callback 57 | :id id 58 | :data data 59 | :message (cl-telegram-bot/message:make-message message-data))))) 60 | 61 | 62 | (defmethod process ((bot t) (callback callback)) 63 | "" 64 | (log:debug "Processing callback" callback) 65 | 66 | (let ((*current-bot* bot) 67 | (*current-message* callback)) 68 | (handler-case 69 | (on-callback bot callback) 70 | (cl-telegram-bot/response-processing:interrupt-processing (condition) 71 | (declare (ignore condition)) 72 | (log:debug "Interrupting callback processing" callback)))) 73 | (values)) 74 | 75 | 76 | (defmethod get-chat ((callback callback)) 77 | (get-chat (callback-message callback))) 78 | -------------------------------------------------------------------------------- /docs/examples.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot-docs/examples 2 | (:use #:cl) 3 | (:import-from #:40ants-doc 4 | #:defsection) 5 | (:import-from #:40ants-doc-plantuml 6 | #:defdiagram) 7 | (:import-from #:cl-telegram-bot2/debug/diagram 8 | #:workflow-to-text) 9 | (:import-from #:cl-telegram-bot2-examples/calc)) 10 | (in-package #:cl-telegram-bot-docs/examples) 11 | 12 | 13 | (defsection @examples (:title "Examples") 14 | "Directory [examples](https://github.com/40ants/cl-telegram-bot/tree/master/examples) contains 15 | code of all v2 examples. There are different kinds of bots: 16 | 17 | - calc - shows how to switch states while collecting information from user and how to return results back to initial state. 18 | - commands - shows how to bind commands to the telegram bot states. 19 | - echo - a simple bot which replies with the same text. 20 | - gallery - demonstrates how to show an image with inline keyboard and how to edit this message, replacing the image when users has switched to the next one. 21 | - mini-app - this example starts a web-server and opens a mini-app inside the Telegram messenger. 22 | - payments - a demo showing how to send an invoice and to process a payment. You will need to register your own payment provider in the BotFather and to change provider token in the bot's code. 23 | - text-chain - a simple demo changing states each type bot receives a message. 24 | 25 | All these examples can be run on their own or as a part of the bigger Megabot. See @RUNNING section to learn how to run the Megabot. 26 | " 27 | (@running section) 28 | (@calc section)) 29 | 30 | 31 | (defsection @running (:title "Running Examples") 32 | " 33 | To run a bot combining all examples, register some bot at BotFather, then do: 34 | 35 | ``` 36 | CL-USER> (ql:quickload :cl-telegram-bot2-examples) 37 | 38 | CL-USER> (setf (uiop:getenv \"TELEGRAM_TOKEN\") 39 | \"520*****:AAH*****\") 40 | 41 | CL-USER> (cl-telegram-bot2-examples:start) 42 | ``` 43 | 44 | ") 45 | 46 | 47 | (defsection @calc (:title "Calc Example") 48 | " 49 | 50 | Example in the calc.lisp file consist of 3 types of the state. 51 | 52 | In it's first state it greets the user and then switches to the next state 53 | where it awaits while user will provide a number. Then it switches to the next 54 | state where waits for another number and finally to the state where user should 55 | choose one of the arithmetic operations: 56 | 57 | ![](asdf:cl-telegram-bot-media:images/examples/calc-bot.gif) 58 | 59 | If we'll use /debug command to draw the diagram of the state transitions, then 60 | it will show a picture like this: 61 | 62 | " 63 | 64 | (@calc-states diagram)) 65 | 66 | 67 | 68 | (defdiagram @calc-states () 69 | (workflow-to-text 70 | (cl-telegram-bot2-examples/calc::make-test-bot ""))) 71 | 72 | -------------------------------------------------------------------------------- /t/core.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot-tests/core 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot/chat) 4 | (:import-from #:cl-telegram-bot/message 5 | #:get-entities 6 | #:get-text 7 | #:get-chat) 8 | (:import-from #:cl-telegram-bot/update 9 | #:get-update-id 10 | #:get-payload 11 | #:make-update) 12 | (:import-from #:cl-telegram-bot/entities/command 13 | #:get-rest-text 14 | #:get-command 15 | #:bot-command) 16 | (:import-from #:rove 17 | #:ok 18 | #:deftest)) 19 | (in-package #:cl-telegram-bot-tests/core) 20 | 21 | 22 | (deftest convert-message-into-the-object 23 | (let* ((data '(:|message| 24 | (:|entities| ((:|type| "bot_command" :|length| 16 :|offset| 0)) 25 | :|text| "/reverse_message Привет Мир!" 26 | :|date| 1521048276 27 | :|chat| (:|type| "private" 28 | :|username| "svetlyak40wt" 29 | :|last_name| "svetlyak40wt" 30 | :|first_name| "Alexander Artemenko" 31 | :|id| 76226374) 32 | :|from| (:|language_code| "en" 33 | :|username| "svetlyak40wt" 34 | :|last_name| "svetlyak40wt" 35 | :|first_name| "Alexander Artemenko" 36 | :|is_bot| NIL 37 | :|id| 76226374) 38 | :|message_id| 3) 39 | :|update_id| 617953963)) 40 | (update (make-update data))) 41 | 42 | (ok (= (get-update-id update) 43 | 617953963) 44 | "Update should have an ID.") 45 | 46 | (let* ((message (get-payload update))) 47 | 48 | (ok message 49 | "Update object should have a message inside") 50 | 51 | (ok (string= 52 | (get-text message) 53 | "/reverse_message Привет Мир!") 54 | "And message should have text \"/reverse_message Привет Мир!\"") 55 | 56 | (let ((chat (get-chat message))) 57 | (ok chat 58 | "Message should be bound to a private chat") 59 | (ok (typep chat 'cl-telegram-bot/chat:private-chat))) 60 | 61 | (let ((entities (get-entities message))) 62 | (ok (= (length entities) 63 | 1)) 64 | (let ((entity (first entities))) 65 | (ok (typep entity 'bot-command) 66 | "Entity should be a bot-command") 67 | (ok (eql (get-command entity) 68 | :reverse-message) 69 | "Command should be :reverse-message") 70 | (ok (equal (get-rest-text entity) 71 | "Привет Мир!") 72 | "Test after the command should be\"Привет Мир!\"")))))) 73 | -------------------------------------------------------------------------------- /src/bot.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :cl-telegram-bot/bot 2 | (:use #:cl) 3 | (:import-from #:alexandria 4 | #:symbolicate) 5 | (:export #:api-uri 6 | #:bot 7 | #:debug-mode 8 | #:defbot 9 | #:file-endpoint 10 | #:get-endpoint 11 | #:get-last-update-id 12 | #:token 13 | #:sent-commands-cache 14 | #:bot-info)) 15 | (in-package #:cl-telegram-bot/bot) 16 | 17 | 18 | (defclass bot () 19 | ((id 20 | :documentation "Update id" 21 | :initform 0 22 | :accessor get-last-update-id) 23 | (token 24 | :initarg :token 25 | :documentation "Bot token given by BotFather" 26 | :accessor token 27 | :initform nil) 28 | (api-uri 29 | :initarg :api-uri 30 | :initform "https://api.telegram.org/" 31 | :accessor api-uri) 32 | (endpoint 33 | :initarg :endpoint 34 | :reader get-endpoint 35 | :documentation "HTTPS endpoint") 36 | (file-endpoint 37 | :initarg :file-endpoint 38 | :accessor file-endpoint 39 | :documentation "HTTPS file-endpoint" 40 | :initform nil) 41 | (bot-info :initform nil 42 | :documentation "This slot will be filled with CL-TELEGRAM-BOT/USER:USER object on first access using a call to CL-TELEGRAM-BOT/USER:GET-ME function." 43 | :reader bot-info) 44 | (debug-mode 45 | :initform nil 46 | :initarg :debug-mode 47 | :accessor debug-mode 48 | :documentation "When debug mode is T, then interactive debugger will be called on each error.") 49 | (sent-commands-cache :initform nil 50 | :documentation "Command processing code will use this cache to update commands list on the server 51 | when a new method for CL-TELEGRAM-BOT/ENTITIES/COMMAND:ON-COMMAND generic-function is defined. 52 | 53 | This slot is for internal use." 54 | :accessor sent-commands-cache))) 55 | 56 | 57 | (defmacro defbot (name &optional slots options) 58 | "Use this macro to define a class of your Telegram bot." 59 | `(progn 60 | (defclass ,name (bot) 61 | ,slots 62 | ,@options) 63 | 64 | (defun ,(symbolicate 'make- name) (token &rest args) 65 | (apply 'make-instance 66 | ',name 67 | :token token 68 | args)))) 69 | 70 | 71 | (defmethod initialize-instance :after ((bot bot) &key &allow-other-keys) 72 | (with-accessors ((token token) 73 | (file-endpoint file-endpoint) 74 | (api-uri api-uri)) bot 75 | (setf (slot-value bot 'endpoint) 76 | (concatenate 'string api-uri "bot" token "/") 77 | (slot-value bot 'file-endpoint) 78 | (concatenate 'string api-uri "file/" "bot" token "/")))) 79 | 80 | 81 | (defmethod print-object ((bot bot) stream) 82 | (print-unreadable-object 83 | (bot stream :type t) 84 | (format stream 85 | "id=~A" (get-last-update-id bot)))) 86 | -------------------------------------------------------------------------------- /src/utils.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot/utils 2 | (:use #:cl) 3 | (:import-from #:str) 4 | (:import-from #:arrows 5 | #:->) 6 | (:import-from #:serapeum 7 | #:collecting 8 | #:soft-list-of) 9 | (:import-from #:cl-ppcre 10 | #:regex-replace) 11 | (:import-from #:cl-strings 12 | #:replace-all) 13 | (:import-from #:kebab 14 | #:to-snake-case) 15 | (:import-from #:alexandria 16 | #:positive-fixnum 17 | #:proper-list) 18 | 19 | (:export #:make-keyword 20 | #:obfuscate 21 | #:api-response-to-plist 22 | #:split-by-lines)) 23 | (in-package cl-telegram-bot/utils) 24 | 25 | 26 | (defun make-keyword (text) 27 | (-> text 28 | (replace-all "_" "-") 29 | (nstring-upcase) 30 | (alexandria:make-keyword))) 31 | 32 | 33 | (defun obfuscate (url) 34 | (regex-replace "/bot.*?/" 35 | url 36 | "/bot/")) 37 | 38 | 39 | (defun make-json-keyword (arg) 40 | (check-type arg symbol) 41 | (-> arg 42 | (symbol-name) 43 | (to-snake-case) 44 | (alexandria:make-keyword))) 45 | 46 | 47 | (serapeum:-> api-response-to-plist (proper-list) 48 | (values proper-list &optional)) 49 | 50 | (defun api-response-to-plist (plist) 51 | "Transforms a plist with keys like :|foo_bar| into a plist with keys like :foo-bar. 52 | 53 | This can be useful to pass data into CL object contructors." 54 | (loop for (key value) on plist by #'cddr 55 | append (list (-> key 56 | (symbol-name) 57 | (make-keyword)) 58 | value))) 59 | 60 | (serapeum:-> split-by-lines (string &key 61 | (:max-size positive-fixnum) 62 | (:trim-whitespaces-p boolean)) 63 | (values (soft-list-of string))) 64 | 65 | (defun split-by-lines (text &key (max-size 4096) (trim-whitespaces-p t)) 66 | (flet ((trim-if-needed (text) 67 | (if trim-whitespaces-p 68 | (str:trim text) 69 | text))) 70 | (declare (dynamic-extent #'trim-if-needed)) 71 | 72 | (collecting 73 | (loop with start-at = 0 74 | with end-at = 0 75 | for char across text 76 | for pos upfrom 0 77 | when (char= char #\Newline) 78 | do (cond 79 | ((<= (- pos start-at) 80 | max-size) 81 | (setf end-at pos)) 82 | (t 83 | (collect 84 | (trim-if-needed 85 | (subseq text start-at 86 | (1+ end-at)))) 87 | (setf start-at 88 | (1+ end-at)) 89 | (setf end-at 90 | pos))) 91 | finally (collect 92 | (trim-if-needed 93 | (subseq text start-at))))))) 94 | -------------------------------------------------------------------------------- /v2/actions/delete-messages.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/actions/delete-messages 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/action 4 | #:action) 5 | (:import-from #:cl-telegram-bot2/vars 6 | #:*current-chat* 7 | #:*current-state*) 8 | (:import-from #:cl-telegram-bot2/api 9 | #:message-chat 10 | #:update-message 11 | #:update 12 | #:chat-id 13 | #:send-message) 14 | (:import-from #:cl-telegram-bot2/generics 15 | #:on-state-deletion 16 | #:on-result 17 | #:process-state 18 | #:on-state-activation) 19 | (:import-from #:serapeum 20 | #:soft-list-of 21 | #:->) 22 | (:import-from #:cl-telegram-bot2/utils 23 | #:call-if-needed) 24 | (:import-from #:cl-telegram-bot2/states/base 25 | #:received-message-ids 26 | #:sent-message-ids) 27 | (:export #:delete-messages 28 | #:delete-sent-messages-p 29 | #:delete-received-messages-p)) 30 | (in-package #:cl-telegram-bot2/actions/delete-messages) 31 | 32 | 33 | (defclass delete-messages (action) 34 | ((delete-sent-messages :initarg :sent 35 | :type boolean 36 | :initform t 37 | :reader delete-sent-messages-p) 38 | (delete-received-messages :initarg :received 39 | :type boolean 40 | :initform t 41 | :reader delete-received-messages-p)) 42 | (:documentation "Delete all messages created in the current current state.")) 43 | 44 | 45 | (-> delete-messages (&key 46 | (:sent boolean) 47 | (:received boolean)) 48 | (values delete-messages &optional)) 49 | 50 | 51 | (defun delete-messages (&key 52 | (sent t) 53 | (received t)) 54 | (make-instance 'delete-messages 55 | :sent sent 56 | :received received)) 57 | 58 | 59 | (-> delete-created-messages (delete-messages) 60 | (values &optional)) 61 | 62 | (defun delete-created-messages (action) 63 | (let* ((state *current-state*) 64 | (ids (append 65 | (when (delete-sent-messages-p action) 66 | (sent-message-ids state)) 67 | (when (delete-received-messages-p action) 68 | (received-message-ids state))))) 69 | 70 | (log:debug "Deleting messages created in" state) 71 | 72 | (when ids 73 | (log:debug "These messages will be deleted" ids) 74 | 75 | (cl-telegram-bot2/api:delete-messages (chat-id *current-chat*) 76 | ids) 77 | (setf (sent-message-ids *current-state*) 78 | nil)) 79 | (values))) 80 | 81 | 82 | (defmethod on-state-activation ((action delete-messages)) 83 | (delete-created-messages action) 84 | (values)) 85 | 86 | 87 | (defmethod process-state ((bot t) (action delete-messages) update) 88 | (delete-created-messages action) 89 | (values)) 90 | 91 | 92 | (defmethod on-result ((action delete-messages) result) 93 | (delete-created-messages action) 94 | (values)) 95 | 96 | 97 | (defmethod on-state-deletion ((action delete-messages)) 98 | (delete-created-messages action) 99 | (values)) 100 | -------------------------------------------------------------------------------- /v2/states/wait-for-payment.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/states/wait-for-payment 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/generics 4 | #:process-state 5 | #:on-state-activation) 6 | (:import-from #:cl-telegram-bot2/high 7 | #:reply) 8 | (:import-from #:cl-telegram-bot2/states/base 9 | #:base-state) 10 | (:import-from #:cl-telegram-bot2/api 11 | #:pre-checkout-query 12 | #:pre-checkout-query-id 13 | #:answer-pre-checkout-query 14 | #:message-text 15 | #:update-message) 16 | (:import-from #:cl-telegram-bot2/action 17 | #:call-if-action 18 | #:action) 19 | (:import-from #:cl-telegram-bot2/workflow 20 | #:funcallable-symbol 21 | #:workflow-blocks) 22 | (:import-from #:cl-telegram-bot2/utils 23 | #:call-if-needed) 24 | (:import-from #:cl-telegram-bot2/state-with-commands 25 | #:state-with-commands-mixin) 26 | (:import-from #:alexandria 27 | #:curry) 28 | (:export #:wait-for-payment 29 | #:on-success)) 30 | (in-package #:cl-telegram-bot2/states/wait-for-payment) 31 | 32 | 33 | (defclass wait-for-payment (state-with-commands-mixin base-state) 34 | ((on-success :initarg :on-success 35 | :initform nil 36 | :type (or symbol 37 | workflow-blocks) 38 | :reader on-success 39 | :documentation "On success could be an fbound symbol which function returns a list of workflow blocks or a list of workflow blocks."))) 40 | 41 | 42 | (defun wait-for-payment (&key on-success commands) 43 | (make-instance 'wait-for-payment 44 | :on-success (typecase on-success 45 | (symbol on-success) 46 | (t 47 | (uiop:ensure-list on-success))) 48 | :commands commands)) 49 | 50 | 51 | (defmethod process-state ((bot t) (state wait-for-payment) update) 52 | (let* ((message 53 | (cl-telegram-bot2/api:update-message 54 | update)) 55 | (successful-payment 56 | ;; Sometimes user might click a button again and update will have no 57 | ;; a message at all, only callback-query. 58 | (when message 59 | (cl-telegram-bot2/api:message-successful-payment message)))) 60 | 61 | (cond 62 | (successful-payment 63 | (cond 64 | ((on-success state) 65 | (let ((action-or-state 66 | (call-if-needed (on-success state) 67 | successful-payment))) 68 | (call-if-action action-or-state 69 | (curry #'process-state bot) 70 | update))) 71 | (t 72 | (error "There is no ON-SUCCESS handler for ~S state." 73 | (type-of state))))) 74 | (t 75 | ;; TODO: Probably we should show a Back button if user just enters a text 76 | ;; or does some callback calls while we are waiting for the payment? 77 | (cl-telegram-bot2/high:reply "We are still waiting for the payment."))))) 78 | 79 | 80 | ;; (defmethod cl-telegram-bot2/generics:on-pre-checkout-query ((state wait-for-payment) (query pre-checkout-query)) 81 | ;; (answer-pre-checkout-query (pre-checkout-query-id query) 82 | ;; (aif (on-pre-checkout-query state) 83 | ;; (funcall it query) 84 | ;; t))) 85 | -------------------------------------------------------------------------------- /examples/gallery.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2-examples/gallery 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/bot 4 | #:defbot) 5 | (:import-from #:cl-telegram-bot2/server 6 | #:stop-polling 7 | #:start-polling) 8 | (:import-from #:serapeum 9 | #:fmt) 10 | (:import-from #:cl-telegram-bot2/state 11 | #:state) 12 | (:import-from #:cl-telegram-bot2/actions/send-photo 13 | #:send-photo) 14 | (:import-from #:cl-telegram-bot2/actions/edit-message-media 15 | #:edit-message-media) 16 | (:import-from #:cl-telegram-bot2/states/base 17 | #:var) 18 | (:import-from #:cl-telegram-bot2/actions/delete-messages 19 | #:delete-messages) 20 | (:import-from #:cl-telegram-bot2/callback 21 | #:callback) 22 | (:import-from #:cl-telegram-bot-media 23 | #:get-path-to-dir) 24 | (:documentation "This example shows how to keep use state's vars to keep current photo's index and to edit message's media when user clicks on Prev/Next buttons.")) 25 | (in-package #:cl-telegram-bot2-examples/gallery) 26 | 27 | 28 | (defparameter *photos* 29 | (directory (uiop:wilden 30 | (get-path-to-dir "images" "cats")))) 31 | 32 | 33 | (defun make-keyboard (photo-index) 34 | (remove nil 35 | (list 36 | (unless (zerop photo-index) 37 | "Prev") 38 | (unless (= photo-index 39 | (1- (length *photos*))) 40 | "Next")))) 41 | 42 | 43 | (defun show-photo () 44 | (let ((photo-index (var "photo-index"))) 45 | 46 | (unless photo-index 47 | (setf photo-index 0) 48 | (setf (var "photo-index") 49 | photo-index)) 50 | 51 | (send-photo (elt *photos* photo-index) 52 | :caption (fmt "Cat ~A" (1+ photo-index)) 53 | :inline-keyboard (make-keyboard photo-index)))) 54 | 55 | 56 | (defun show-next-photo () 57 | (let ((photo-index (min (1- (length *photos*)) 58 | (1+ (var "photo-index"))))) 59 | 60 | (setf (var "photo-index") 61 | photo-index) 62 | 63 | (edit-message-media (elt *photos* photo-index) 64 | :caption (fmt "Cat ~A" (1+ photo-index)) 65 | :inline-keyboard (make-keyboard photo-index)))) 66 | 67 | (defun show-prev-photo () 68 | (let ((photo-index (max 0 69 | (1- (var "photo-index"))))) 70 | 71 | (setf (var "photo-index") 72 | photo-index) 73 | 74 | (edit-message-media (elt *photos* photo-index) 75 | :caption (fmt "Cat ~A" (1+ photo-index)) 76 | :inline-keyboard (make-keyboard photo-index)))) 77 | 78 | 79 | (defbot test-bot () 80 | () 81 | (:initial-state 82 | (state 'show-photo 83 | :id "gallery-example" 84 | :on-update 'show-photo 85 | :on-deletion (delete-messages) 86 | :on-callback-query 87 | (list (callback "Next" 88 | 'show-next-photo) 89 | (callback "Prev" 90 | 'show-prev-photo))))) 91 | 92 | 93 | ;; Technical part 94 | 95 | (defvar *bot* nil) 96 | 97 | 98 | (defun stop () 99 | (when *bot* 100 | (stop-polling *bot*) 101 | (setf *bot* nil)) 102 | (values)) 103 | 104 | 105 | (defun start () 106 | (stop) 107 | 108 | (unless *bot* 109 | (setf *bot* 110 | (make-test-bot (uiop:getenv "TELEGRAM_TOKEN")))) 111 | 112 | (start-polling *bot* :debug t)) 113 | -------------------------------------------------------------------------------- /src/network.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cl-telegram-bot/network 2 | (:use #:cl) 3 | (:import-from #:alexandria) 4 | (:import-from #:dexador) 5 | (:import-from #:jonathan) 6 | (:import-from #:log) 7 | (:import-from #:yason) 8 | (:import-from #:cl-telegram-bot/utils 9 | #:obfuscate) 10 | (:import-from #:cl-telegram-bot/bot 11 | #:get-endpoint) 12 | (:import-from #:serapeum 13 | #:href) 14 | (:export 15 | #:make-request 16 | #:request-error 17 | #:set-proxy 18 | #:what)) 19 | (in-package #:cl-telegram-bot/network) 20 | 21 | (defvar *proxy* nil) 22 | 23 | (defun set-proxy (proxy) 24 | (setf *proxy* proxy)) 25 | 26 | (define-condition request-error (error) 27 | ((what :initarg :what 28 | :reader what)) 29 | (:report (lambda (condition stream) 30 | (format stream "Request error: ~A" (what condition))))) 31 | 32 | 33 | (defun make-request (bot name &rest options &key (streamp nil) (timeout 3) &allow-other-keys) 34 | (declare (ignore streamp)) 35 | "Perform HTTP request to 'name API method with 'options JSON-encoded object." 36 | (let ((url (concatenate 'string (get-endpoint bot) name))) 37 | (log:debug "Posting data to" 38 | (obfuscate url) 39 | options) 40 | (let* ((max-timeout (* timeout 10)) 41 | (processed-options (loop for (key value) 42 | on (alexandria:remove-from-plist options :timeout :streamp) 43 | by #'cddr 44 | when value 45 | collect (kebab:to-snake-case key) 46 | and 47 | collect value)) 48 | (encoded-content (jonathan:to-json processed-options)) 49 | (response 50 | (if *proxy* 51 | (dexador:post url 52 | :headers '(("Content-Type" . "application/json")) 53 | :content encoded-content 54 | :read-timeout max-timeout 55 | :connect-timeout max-timeout 56 | :proxy *proxy*) 57 | (handler-bind ((dexador.error:http-request-too-many-requests 58 | (lambda (err) 59 | (let* ((response (dexador:response-body err)) 60 | (data (yason:parse response)) 61 | (sleep-time (or (href data "parameters" "retry_after") 62 | (progn 63 | (log:warn "Unable to get parameters->retry_after from" response) 64 | 10)))) 65 | (sleep sleep-time) 66 | (dexador:retry-request err)))) 67 | (dexador.error:http-request-bad-gateway #'dexador:retry-request)) 68 | (dexador:post url 69 | :headers '(("Content-Type" . "application/json")) 70 | :content (jonathan:to-json processed-options) 71 | :read-timeout max-timeout 72 | :connect-timeout max-timeout)))) 73 | (data (jonathan:parse response))) 74 | (unless (getf data :|ok|) 75 | (log:error "Wrong data received from the server" data) 76 | (error 'request-error :what data)) 77 | 78 | (getf data :|result|)))) 79 | -------------------------------------------------------------------------------- /v2/actions/send-photo.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/actions/send-photo 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/action 4 | #:action) 5 | (:import-from #:cl-telegram-bot2/api 6 | #:message-chat 7 | #:update-message 8 | #:update 9 | #:chat-id 10 | #:send-message) 11 | (:import-from #:cl-telegram-bot2/generics 12 | #:on-result 13 | #:process-state 14 | #:on-state-activation) 15 | (:import-from #:cl-telegram-bot2/high 16 | #:reply) 17 | (:import-from #:serapeum 18 | #:soft-list-of 19 | #:->) 20 | (:import-from #:cl-telegram-bot2/utils 21 | #:call-if-needed) 22 | (:export #:send-photo 23 | #:image-path 24 | #:caption 25 | #:inline-keyboard)) 26 | (in-package #:cl-telegram-bot2/actions/send-photo) 27 | 28 | 29 | (defclass send-photo (action) 30 | ((path :initarg :path 31 | :type (or string 32 | pathname 33 | symbol) 34 | :reader image-path) 35 | (caption :initarg :caption 36 | :type string 37 | :reader caption) 38 | (inline-keyboard :initarg :inline-keyboard 39 | :type (soft-list-of string) 40 | :reader inline-keyboard))) 41 | 42 | 43 | (-> send-photo ((or string pathname symbol) 44 | &key 45 | (:caption string) 46 | (:inline-keyboard (soft-list-of string))) 47 | (values send-photo &optional)) 48 | 49 | (defun send-photo (path-or-func-name &key caption inline-keyboard) 50 | (when (and (symbolp path-or-func-name) 51 | (not (fboundp path-or-func-name))) 52 | (error "SEND-PHOTO waits a path or fbound symbol. ~S is not fbound." 53 | path-or-func-name)) 54 | 55 | (make-instance 'send-photo 56 | :path path-or-func-name 57 | :caption (or caption "") 58 | :inline-keyboard inline-keyboard)) 59 | 60 | 61 | (defmethod print-object ((obj send-photo) stream) 62 | (print-unreadable-object (obj stream :type t) 63 | (format stream "~S" 64 | (image-path obj)))) 65 | 66 | 67 | (defun send-reply (action) 68 | (let* ((path (call-if-needed 69 | (image-path action))) 70 | (caption (call-if-needed 71 | (caption action))) 72 | (buttons (call-if-needed 73 | (inline-keyboard action))) 74 | (reply-markup 75 | (when buttons 76 | (make-instance 'cl-telegram-bot2/api:inline-keyboard-markup 77 | :inline-keyboard 78 | (list 79 | (loop for button in buttons 80 | collect (make-instance 'cl-telegram-bot2/api:inline-keyboard-button 81 | :text button 82 | :callback-data button))))))) 83 | (apply #'cl-telegram-bot2/high:reply-with-photo 84 | path 85 | :caption caption 86 | (when reply-markup 87 | (list 88 | :reply-markup reply-markup))))) 89 | 90 | 91 | (defmethod on-state-activation ((action send-photo)) 92 | (send-reply action) 93 | (values)) 94 | 95 | 96 | (defmethod process-state ((bot t) (action send-photo) update) 97 | (send-reply action) 98 | (values)) 99 | 100 | 101 | (defmethod on-result ((action send-photo) result) 102 | (send-reply action) 103 | (values)) 104 | -------------------------------------------------------------------------------- /v2/term/back.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/term/back 2 | (:use #:cl) 3 | (:import-from #:alexandria 4 | #:required-argument) 5 | (:import-from #:serapeum 6 | #:->) 7 | (:import-from #:cl-telegram-bot2/generics 8 | #:process-state) 9 | (:import-from #:cl-telegram-bot2/debug/diagram/utils 10 | #:find-state-by-id) 11 | (:import-from #:cl-telegram-bot2/debug/diagram/generics 12 | #:to-text 13 | #:render-handler-link) 14 | (:export #:back 15 | #:back-to 16 | #:back-to-nth-parent 17 | #:result 18 | #:parent-number 19 | #:state-class 20 | #:back-to-id 21 | #:parent-id)) 22 | (in-package #:cl-telegram-bot2/term/back) 23 | 24 | 25 | ;; TODO: probably we have to define a TERMINATOR 26 | ;; class for objects which interrupt processing 27 | ;; of the actions chain 28 | (defclass back () 29 | ((result :initarg :result 30 | :initform nil 31 | :reader result))) 32 | 33 | 34 | (-> back (&optional t) 35 | (values back &optional)) 36 | 37 | (defun back (&optional result) 38 | (make-instance 'back 39 | :result result)) 40 | 41 | 42 | (defclass back-to (back) 43 | ((state-class :initarg :state-class 44 | :initform (required-argument "State class is required argument.") 45 | :reader state-class))) 46 | 47 | 48 | (-> back-to (symbol &optional t) 49 | (values back-to &optional)) 50 | 51 | (defun back-to (state-class &optional result) 52 | (make-instance 'back-to 53 | :state-class state-class 54 | :result result)) 55 | 56 | 57 | (defclass back-to-nth-parent (back) 58 | ((n :initarg :n 59 | :initform (required-argument "Parent number required argument.") 60 | :type (integer 1) 61 | :reader parent-number))) 62 | 63 | 64 | (-> back-to-nth-parent ((integer 1) &optional t) 65 | (values back-to-nth-parent &optional)) 66 | 67 | (defun back-to-nth-parent (n &optional result) 68 | (make-instance 'back-to-nth-parent 69 | :n n 70 | :result result)) 71 | 72 | 73 | (defclass back-to-id (back) 74 | ((id :initarg :id 75 | :initform (required-argument "Parent id is required argument.") 76 | :type string 77 | :reader parent-id))) 78 | 79 | 80 | (-> back-to-id (string &optional t) 81 | (values back-to-id &optional)) 82 | 83 | (defun back-to-id (id &optional result) 84 | (make-instance 'back-to-id 85 | :id id 86 | :result result)) 87 | 88 | 89 | (defmethod print-object ((obj back-to-id) stream) 90 | (print-unreadable-object (obj stream :type t :identity t) 91 | (format stream "~S" 92 | (parent-id obj)))) 93 | 94 | 95 | (defmethod process-state (bot (item back) update) 96 | ;; If a some action returns a BACK object when processing a list of actions, 97 | ;; then PROCESS-STATE generic-function will be called on it again 98 | ;; and in this case we should return the same BACK object to interrupt the list processing 99 | (values item)) 100 | 101 | 102 | (defmethod render-handler-link ((action back-to-id)) 103 | 104 | (let* ((parent-id (parent-id action)) 105 | (state (or (find-state-by-id parent-id) 106 | (error "Unable to find state with id ~S." 107 | parent-id)))) 108 | (render-handler-link state))) 109 | 110 | 111 | (defmethod to-text ((action back)) 112 | ;; We don't render back blocks explicintly, replacing the 113 | ;; with a link between handler in the map and the state\ 114 | (values)) 115 | -------------------------------------------------------------------------------- /src/keyboard.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot/keyboard 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot/markup 4 | #:to-markup) 5 | (:import-from #:serapeum 6 | #:dict) 7 | (:export #:keyboard 8 | #:keyboard-rows 9 | #:button-text 10 | #:button)) 11 | (in-package #:cl-telegram-bot/keyboard) 12 | 13 | 14 | (defclass keyboard () 15 | ((rows :initarg :rows 16 | :type list 17 | :initform nil 18 | :reader keyboard-rows) 19 | (persistent :initarg :persistent 20 | :type boolean 21 | :initform nil 22 | :reader persistentp 23 | :documentation "Requests clients to always show the keyboard when the regular keyboard is hidden.") 24 | (resize :initarg :resize 25 | :type boolean 26 | :initform nil 27 | :reader resizep 28 | :documentation "Requests clients to resize the keyboard vertically for optimal fit (e.g., make the keyboard smaller if there are just two rows of buttons).") 29 | (one-time :initarg :one-time 30 | :type boolean 31 | :initform nil 32 | :reader one-time-p 33 | :documentation "Requests clients to hide the keyboard as soon as it's been used.") 34 | (selective :initarg :selective 35 | :type boolean 36 | :initform nil 37 | :reader selectivep 38 | :documentation "Use this parameter if you want to show the keyboard to specific users only.") 39 | (input-field-placeholder :initarg :input-field-placeholder 40 | :initform nil 41 | :reader input-field-placeholder 42 | :documentation "The placeholder to be shown in the input field when the keyboard is active.")) 43 | (:documentation "Represents a keyboard specified in API https://core.telegram.org/bots/api#replykeyboardmarkup.")) 44 | 45 | 46 | (defclass button () 47 | ((text :initarg :text 48 | :type string 49 | :reader button-text)) 50 | (:documentation "Base class for all inline keyboard buttons. 51 | 52 | API: https://core.telegram.org/bots/api#keyboardbutton")) 53 | 54 | 55 | (defun keyboard (rows &rest args &key peristent resize one-time selective input-field-placeholder) 56 | "Returns a keyboard which can be passed 57 | to CL-TELEGRAM-BOT/RESPONSE:REPLY as REPLY-MARKUP argument. 58 | 59 | Each row should be a list of BUTTON objects or a single 60 | object of this class. In latter case, such row will have only one button." 61 | (declare (ignore peristent resize one-time selective input-field-placeholder)) 62 | (apply #'make-instance 63 | 'keyboard 64 | :rows (mapcar #'uiop:ensure-list rows) 65 | args)) 66 | 67 | 68 | (defun button (text) 69 | (make-instance 'button 70 | :text text)) 71 | 72 | 73 | (defmethod to-markup ((keyboard keyboard)) 74 | (let ((result (dict "keyboard" 75 | (loop for row in (keyboard-rows keyboard) 76 | collect (mapcar #'to-markup row))))) 77 | (when (persistentp keyboard) 78 | (setf (gethash "is_persistent" result) t)) 79 | 80 | (when (resizep keyboard) 81 | (setf (gethash "resize_keyboard" result) t)) 82 | 83 | (when (one-time-p keyboard) 84 | (setf (gethash "one_time_keyboard" result) t)) 85 | 86 | (when (selectivep keyboard) 87 | (setf (gethash "selective" result) t)) 88 | 89 | (when (input-field-placeholder keyboard) 90 | (setf (gethash "input_field_placeholder" result) 91 | (input-field-placeholder keyboard))) 92 | 93 | (values result))) 94 | 95 | 96 | (defmethod to-markup ((button button)) 97 | (dict "text" (button-text button))) 98 | 99 | -------------------------------------------------------------------------------- /v2/server.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/server 2 | (:use #:cl) 3 | (:import-from #:log) 4 | (:import-from #:trivial-backtrace 5 | #:print-backtrace) 6 | (:import-from #:cl-telegram-bot2/pipeline 7 | #:process-updates 8 | #:continue-processing) 9 | (:import-from #:cl-telegram-bot2/bot 10 | #:debug-mode) 11 | (:import-from #:bordeaux-threads-2 12 | #:bordeaux-threads-simple-error 13 | #:make-thread 14 | #:destroy-thread 15 | #:thread-name 16 | #:all-threads) 17 | (:import-from #:str 18 | #:starts-with?) 19 | (:export #:start-polling 20 | #:stop-polling)) 21 | (in-package #:cl-telegram-bot2/server) 22 | 23 | 24 | 25 | (defvar *threads* nil) 26 | 27 | 28 | (defun start-polling (bot &key 29 | debug 30 | (delay-between-retries 10) 31 | (thread-name "telegram-bot")) 32 | "Start processing new updates from the Telegram API. 33 | 34 | Pass bot instance as the first argument and maybe some other optional arguments. 35 | 36 | If DEBUG argument is T, then bot will ignore updates which it can't to process without errors. 37 | Otherwise, an interactive debugger will popup." 38 | 39 | (when (getf *threads* bot) 40 | (error "Processing already started.")) 41 | 42 | (setf (debug-mode bot) debug) 43 | 44 | (log:info "Starting thread to process updates for" bot) 45 | (flet ((continue-processing-if-not-debug (condition) 46 | (let ((restart (find-restart 'continue-processing 47 | condition))) 48 | (when restart 49 | (let ((traceback (print-backtrace 50 | condition :output nil))) 51 | (log:error "Unable to process Telegram updates" traceback)) 52 | 53 | (unless (debug-mode bot) 54 | (invoke-restart restart delay-between-retries))))) 55 | (stop-bot () 56 | (stop-polling bot))) 57 | 58 | (cl-telegram-bot2/bot::start-actors bot) 59 | 60 | (setf (getf *threads* bot) 61 | (make-thread 62 | (lambda () 63 | (handler-bind ((serious-condition #'continue-processing-if-not-debug)) 64 | (process-updates bot))) 65 | :name thread-name)) 66 | 67 | ;; Here we return a closure to stop the bot: 68 | #'stop-bot)) 69 | 70 | 71 | (defun destroy-thread-safely (thread) 72 | (when (bt2:thread-alive-p thread) 73 | (log:info "Stopping thread for" thread) 74 | (handler-bind ((bordeaux-threads-simple-error 75 | (lambda (e) 76 | (declare (ignore e)) 77 | ;; In case if thread was already stopped as the result 78 | ;; of race-condition we need to check it again 79 | (unless (bt2:thread-alive-p thread) 80 | (return-from destroy-thread-safely))))) 81 | (destroy-thread thread)))) 82 | 83 | 84 | (defun clean-threads () 85 | "TODO: we need to figure out why the threads are not being cleaned up. Maybe this happens when errors happen?" 86 | (loop for tr in (all-threads) 87 | when (or (starts-with? "message-thread" (thread-name tr)) 88 | (starts-with? "timer-wheel" (thread-name tr)) 89 | (starts-with? "telegram-bot" (thread-name tr))) 90 | do (destroy-thread-safely tr))) 91 | 92 | 93 | (defun stop-polling (bot) 94 | (let ((thread (getf *threads* bot))) 95 | (when thread 96 | (destroy-thread-safely thread) 97 | 98 | (setf (getf *threads* bot) 99 | nil)) 100 | (cl-telegram-bot2/bot::stop-actors bot) 101 | (clean-threads))) 102 | -------------------------------------------------------------------------------- /src/inline-keyboard.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot/inline-keyboard 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot/network 4 | #:make-request) 5 | (:import-from #:cl-telegram-bot/callback 6 | #:callback) 7 | (:import-from #:cl-telegram-bot/markup 8 | #:to-markup) 9 | (:import-from #:serapeum 10 | #:dict) 11 | (:export #:answer-callback-query 12 | #:inline-keyboard 13 | #:keyboard-rows 14 | #:button-text 15 | #:inline-keyboard-button 16 | #:callback-button 17 | #:url-button 18 | #:callback-button-data 19 | #:button-url)) 20 | (in-package cl-telegram-bot/inline-keyboard) 21 | 22 | 23 | (defclass inline-keyboard () 24 | ((rows :initarg :rows 25 | :type list 26 | :initform nil 27 | :reader keyboard-rows)) 28 | (:documentation "Represents an inline keyboard as specified in API https://core.telegram.org/bots/api#inlinekeyboardmarkup.")) 29 | 30 | 31 | (defmethod print-object ((obj inline-keyboard) stream) 32 | (print-unreadable-object (obj stream :type t) 33 | (format stream "~S" (keyboard-rows obj)))) 34 | 35 | 36 | (defclass inline-keyboard-button () 37 | ((text :initarg :text 38 | :type string 39 | :reader button-text)) 40 | (:documentation "Base class for all inline keyboard buttons. 41 | 42 | API: https://core.telegram.org/bots/api#inlinekeyboardbutton")) 43 | 44 | 45 | (defmethod print-object ((obj inline-keyboard-button) stream) 46 | (print-unreadable-object (obj stream :type t) 47 | (format stream "~S" (button-text obj)))) 48 | 49 | 50 | (defclass callback-button (inline-keyboard-button) 51 | ((data :initarg :data 52 | :type string 53 | :reader callback-button-data))) 54 | 55 | 56 | (defclass url-button (inline-keyboard-button) 57 | ((url :initarg :data 58 | :type string 59 | :reader button-url))) 60 | 61 | 62 | (defun inline-keyboard (rows) 63 | "Returns an inline keyboard which can be passed 64 | to CL-TELEGRAM-BOT/RESPONSE:REPLY as REPLY-MARKUP argument. 65 | 66 | Each row should be a list of INLINE-KEYBOARD-BUTTON objects or a single 67 | object of this class. In latter case, such row will have only one button." 68 | (make-instance 'inline-keyboard 69 | :rows (mapcar #'uiop:ensure-list rows))) 70 | 71 | 72 | (defun callback-button (text data) 73 | "Creates a button which will call a callback." 74 | (make-instance 'callback-button :text text 75 | :data data)) 76 | 77 | (defun url-button (text url) 78 | "Creates a button which will open an url." 79 | (make-instance 'url-button :text text 80 | :url url)) 81 | 82 | 83 | (defun answer-callback-query (bot callback &key text show-alert url) 84 | "https://core.telegram.org/bots/api#answercallbackquery" 85 | (check-type callback callback) 86 | (let ((options 87 | (append 88 | (list 89 | :callback_query_id (cl-telegram-bot/callback:callback-id callback)) 90 | (when text 91 | (list :text text)) 92 | (when show-alert 93 | (list :show_alert show-alert)) 94 | (when url 95 | (list :url url))))) 96 | (apply #'make-request bot "answerCallbackQuery" options))) 97 | 98 | 99 | (defmethod to-markup ((keyboard inline-keyboard)) 100 | (dict "inline_keyboard" 101 | (loop for row in (keyboard-rows keyboard) 102 | collect (mapcar #'to-markup row)))) 103 | 104 | (defmethod to-markup ((button callback-button)) 105 | (dict "text" (button-text button) 106 | "callback_data" (callback-button-data button))) 107 | 108 | 109 | (defmethod to-markup ((button url-button)) 110 | (dict "text" (button-text button) 111 | "url" (button-url button))) 112 | -------------------------------------------------------------------------------- /examples/commands.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2-examples/commands 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/bot 4 | #:defbot) 5 | (:import-from #:cl-telegram-bot2/server 6 | #:stop-polling 7 | #:start-polling) 8 | (:import-from #:cl-telegram-bot2/high 9 | #:reply 10 | #:chat-state) 11 | (:import-from #:cl-telegram-bot2/state-with-commands 12 | #:global-command 13 | #:command) 14 | (:import-from #:cl-telegram-bot2/state 15 | #:state) 16 | (:import-from #:cl-telegram-bot2/term/back 17 | #:back-to-id) 18 | (:import-from #:cl-telegram-bot2/actions/send-text 19 | #:send-text) 20 | (:import-from #:str 21 | #:trim) 22 | (:import-from #:cl-telegram-bot2/actions/delete-messages 23 | #:delete-messages)) 24 | (in-package #:cl-telegram-bot2-examples/commands) 25 | 26 | 27 | (defun on-help-command (arg update) 28 | (declare (ignore arg update)) 29 | (reply "This bot has two states. 30 | 31 | At the initial state only two commands are available: 32 | 33 | /next - switches bot into the second state. 34 | /help - shows this text. 35 | 36 | The second state changes /next command to the /back and provides 37 | additional command /reverse, which will reverse any given text.") 38 | ;; It is important to return nothing if we want switch 39 | ;; bot to a new state from this handler 40 | (values)) 41 | 42 | 43 | (defun on-reverse-command (arg update) 44 | (declare (ignore update)) 45 | (let ((trimmed (trim arg))) 46 | (cond 47 | ((or (null trimmed) 48 | (string= trimmed "")) 49 | (reply "This command requires an argument.")) 50 | (t 51 | (reply (reverse arg))))) 52 | ;; It is important to return nothing if we want switch 53 | ;; bot to a new state from this handler 54 | (values)) 55 | 56 | 57 | (defbot test-bot () 58 | () 59 | (:initial-state 60 | (state (send-text "Initial state. Give /next command to go to the second state.") 61 | :id "commands-example" 62 | :on-result (send-text "Welcome back! Give /next command to go to the second state.") 63 | :on-update (send-text "Give /next command to go to the second state.") 64 | :on-deletion (delete-messages) 65 | :commands (list 66 | (command "/next" 67 | (state (send-text "Second state. Give /reverse command with an argument to return it in a reversed way. 68 | 69 | Or do /back command to go to the initial state. 70 | 71 | Note how commands list is changed depending on current bot's state.") 72 | :id "commands-example-step2" 73 | :on-update (send-text "Give /back command to go to the initial state.") 74 | :on-deletion (delete-messages) 75 | :commands (list 76 | (command "/back" (back-to-id "commands-example") 77 | :description "Switch to the prev state") 78 | (command "/reverse" 'on-reverse-command 79 | :description "Switch to the prev state"))) 80 | :description "Switch to the next state") 81 | (global-command "/help" 'on-help-command 82 | :description "Show information about bot's commands."))))) 83 | 84 | 85 | (defvar *bot* nil) 86 | 87 | 88 | (defun stop () 89 | (when *bot* 90 | (stop-polling *bot*) 91 | (setf *bot* nil))) 92 | 93 | 94 | (defun start () 95 | (stop) 96 | 97 | (unless *bot* 98 | (setf *bot* 99 | (make-test-bot (uiop:getenv "TELEGRAM_TOKEN")))) 100 | 101 | (start-polling *bot* :debug t)) 102 | 103 | -------------------------------------------------------------------------------- /src/user.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot/user 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot/utils 4 | #:api-response-to-plist) 5 | (:import-from #:cl-telegram-bot/bot 6 | #:bot-info 7 | #:bot) 8 | (:import-from #:cl-telegram-bot/network 9 | #:make-request) 10 | (:import-from #:serapeum 11 | #:->) 12 | (:export #:user 13 | #:user-id 14 | #:username 15 | #:is-premium 16 | #:language-code 17 | #:first-name 18 | #:bot-p 19 | #:can-connect-to-business-p 20 | #:supports-inline-queries-p 21 | #:can-read-all-group-messages-p 22 | #:can-join-groups-p 23 | #:raw-data 24 | #:get-me 25 | #:last-name 26 | #:get-user-info 27 | #:has-main-web-app-p)) 28 | (in-package #:cl-telegram-bot/user) 29 | 30 | 31 | (defclass user () 32 | ((id :initarg :id 33 | :type integer 34 | :reader user-id) 35 | (username :initarg :username 36 | :type (or null string) 37 | :initform nil 38 | :reader username) 39 | (first-name :initarg :first-name 40 | :type string 41 | :reader first-name) 42 | (last-name :initarg :last-name 43 | :type (or null string) 44 | :initform nil 45 | :reader last-name) 46 | (language-code :initarg :language-code 47 | :type (or null string) 48 | :initform nil 49 | :reader language-code) 50 | (is-premium :initarg :is-premium 51 | :type boolean 52 | :initform nil 53 | :reader is-premium) 54 | (is-bot :initarg :is-bot 55 | :type boolean 56 | :reader bot-p) 57 | (can-connect-to-business :initarg :can-connect-to-business 58 | :type boolean 59 | :initform nil 60 | :reader can-connect-to-business-p) 61 | (supports-inline-queries :initarg :supports-inline-queries 62 | :type boolean 63 | :initform nil 64 | :reader supports-inline-queries-p) 65 | (can-read-all-group-messages :initarg :can-read-all-group-messages 66 | :type boolean 67 | :initform nil 68 | :reader can-read-all-group-messages-p) 69 | (can-join-groups :initarg :can-join-groups 70 | :type boolean 71 | :initform nil 72 | :reader can-join-groups-p) 73 | (has-main-web-app :initarg :has-main-web-app 74 | :type boolean 75 | :initform nil 76 | :reader has-main-web-app-p) 77 | (raw-data :initarg :raw-data 78 | :reader raw-data))) 79 | 80 | 81 | (defmethod print-object ((user user) stream) 82 | (print-unreadable-object (user stream :type t) 83 | (format stream "~S @~A" 84 | (first-name user) 85 | (username user)))) 86 | 87 | 88 | (defun make-user-from-raw (raw-data) 89 | (let ((initargs (api-response-to-plist raw-data))) 90 | (apply #'make-instance 91 | 'user 92 | :raw-data raw-data 93 | initargs))) 94 | 95 | 96 | (-> get-me (bot) 97 | (values user &optional)) 98 | 99 | (defun get-me (bot) 100 | "https://core.telegram.org/bots/api#getme" 101 | (make-user-from-raw 102 | (make-request bot "getMe"))) 103 | 104 | 105 | (defmethod bot-info :around ((bot bot)) 106 | (unless (slot-value bot 'bot-info) 107 | (setf (slot-value bot 'bot-info) 108 | (get-me bot))) 109 | (call-next-method)) 110 | 111 | 112 | 113 | (defgeneric get-user-info (obj) 114 | (:documentation "Returns a USER object related to the object. 115 | 116 | If object is not bound to a user, then NIL should be returned.") 117 | (:method ((obj t)) 118 | (values nil))) 119 | -------------------------------------------------------------------------------- /src/telegram-call.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot/telegram-call 2 | (:use #:cl) 3 | (:import-from #:arrows 4 | #:->) 5 | (:import-from #:cl-telegram-bot/utils 6 | #:make-json-keyword) 7 | (:import-from #:cl-telegram-bot/network 8 | #:make-request) 9 | (:import-from #:alexandria 10 | #:with-gensyms 11 | #:ensure-symbol 12 | #:make-keyword) 13 | (:import-from #:kebab 14 | #:to-camel-case)) 15 | (in-package cl-telegram-bot/telegram-call) 16 | 17 | 18 | (defgeneric prepare-arg (arg) 19 | (:documentation "Returns argument as a list with two values. 20 | Input argument is a keyword. 21 | 22 | For example, if arg is :user-id, then output will be: 23 | (list :|user_id| user-id) 24 | 25 | You can redefine this method to process special cases, for example, 26 | :chat is such special case. Ee should transform it to pass chat_id: 27 | (list :|chat_id| (get-chat-id chat)) 28 | ")) 29 | 30 | 31 | (defmethod prepare-arg ((arg t)) 32 | `(,(make-json-keyword arg) 33 | ;; We need to intern symbol into the package which calls our macro 34 | ,(ensure-symbol arg))) 35 | 36 | 37 | (defun get-method-name (name) 38 | "Returns a name for Telegram method. 39 | It is a camelcased string. 40 | As input, receives either a symbol or a list with two items." 41 | (typecase name 42 | ;; If it is a symbol, we need to create a camel-cased string from it 43 | (symbol (-> name 44 | (symbol-name) 45 | (to-camel-case))) 46 | ;; If it is a list, then just return the second item, because it denotes 47 | ;; a Telegram's method name. 48 | (list (unless (= (length name) 49 | 2) 50 | (error "~S should be a symbol or a list of two items" 51 | name)) 52 | (let ((second-item (second name))) 53 | (check-type second-item string) 54 | (values second-item))) 55 | (t (error "~S should be a symbol or a list of two items" 56 | name)))) 57 | 58 | 59 | (defun get-func-name (name) 60 | "Returns a name for the Lisp function to call a Telegram's method." 61 | (typecase name 62 | ;; If it is a symbol, return it as is. 63 | (symbol name) 64 | ;; If it is a list, then just return the first item, because it denotes 65 | ;; a Telegram's method name. 66 | (list (unless (= (length name) 67 | 2) 68 | (error "~S should be a symbol or a list of two items" 69 | name)) 70 | (let ((first-item (first name))) 71 | (check-type first-item symbol) 72 | (values first-item))) 73 | (t (error "~S should be a symbol or a list of two items" 74 | name)))) 75 | 76 | 77 | (defun get-docstring (body) 78 | (check-type body list) 79 | (when (typep (first body) 80 | 'string) 81 | (first body))) 82 | 83 | 84 | (defun without-docstring (body) 85 | "Strips docstring if it was provided." 86 | (check-type body list) 87 | (cond 88 | ((typep (first body) 89 | 'string) 90 | (rest body)) 91 | (t body))) 92 | 93 | 94 | (defmacro def-telegram-call (name args &body body) 95 | "During the body evaluaction, result of call to API will be available 96 | as `response'" 97 | (with-gensyms (opts-var bot-var) 98 | (let* ((func-name (get-func-name name)) 99 | (telegram-method-name (get-method-name name)) 100 | (prepared-args (loop for arg in args 101 | for keyworded-arg = (make-keyword arg) 102 | appending (prepare-arg keyworded-arg)))) 103 | `(defun ,func-name (,bot-var ,@args) 104 | ,(get-docstring body) 105 | (let* ((,opts-var (list ,@prepared-args)) 106 | (response (apply #'make-request ,bot-var 107 | ,telegram-method-name 108 | ,opts-var))) 109 | (declare (ignorable response)) 110 | ,@(or (without-docstring 111 | body) 112 | '(response))))))) 113 | -------------------------------------------------------------------------------- /examples/calc.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2-examples/calc 2 | (:use #:cl) 3 | (:import-from #:bordeaux-threads) 4 | (:import-from #:cl-telegram-bot2/state 5 | #:state) 6 | (:import-from #:cl-telegram-bot2/actions/send-text 7 | #:send-text) 8 | (:import-from #:cl-telegram-bot2/bot 9 | #:defbot) 10 | (:import-from #:cl-telegram-bot2/server 11 | #:stop-polling 12 | #:start-polling) 13 | (:import-from #:serapeum 14 | #:dict 15 | #:fmt) 16 | (:import-from #:cl-telegram-bot2/states/ask-for-number 17 | #:ask-for-number) 18 | (:import-from #:cl-telegram-bot2/states/base 19 | #:var) 20 | (:import-from #:cl-telegram-bot2/states/ask-for-choice 21 | #:ask-for-choice) 22 | (:import-from #:40ants-logging) 23 | (:import-from #:cl-telegram-bot2/term/back 24 | #:back-to-id) 25 | (:import-from #:cl-telegram-bot2/actions/delete-messages 26 | #:delete-messages)) 27 | (in-package #:cl-telegram-bot2-examples/calc) 28 | 29 | 30 | 31 | (defun calc-result () 32 | (let* ((num1 (var "first-num")) 33 | (num2 (var "second-num")) 34 | (op-name (var "operation-name")) 35 | (op (gethash op-name 36 | (dict "plus" #'+ 37 | "minus" #'- 38 | "mul" #'* 39 | "div" #'/)))) 40 | (funcall op num1 41 | num2))) 42 | 43 | (defun send-result (result) 44 | (send-text 45 | (format nil "Result is: ~A" 46 | result))) 47 | 48 | 49 | (defun make-prompt-for-op-choice () 50 | (fmt "Select an operation to apply to ~A and ~A:" 51 | (var "first-num") 52 | (var "second-num"))) 53 | 54 | 55 | (defbot test-bot () 56 | () 57 | (:initial-state 58 | (state (state (list 59 | (send-text "Let's calculate!") 60 | (ask-for-number 61 | "Enter the first number:" 62 | :to "first-num" 63 | :on-validation-error (send-text "Enter the number, please.") 64 | :on-deletion (delete-messages) 65 | :on-success (ask-for-number 66 | "Enter the second number:" 67 | :to "second-num" 68 | :on-validation-error (send-text "Enter the number, please.") 69 | :on-deletion (delete-messages) 70 | :on-success (ask-for-choice 71 | 'make-prompt-for-op-choice 72 | '(("+" . "plus") 73 | ("-" . "minus") 74 | ("*" . "mul") 75 | ("/" . "div")) 76 | :to "operation-name" 77 | :on-success (list ;; Here we just calculate result 78 | ;; and return back to "start" state 79 | ;; which will send result to the user 80 | ;; in the :ON-RESULT handler 81 | (back-to-id "calc-example" 82 | 'calc-result)))))) 83 | :on-deletion (delete-messages)) 84 | :id "calc-example" 85 | :on-result 'send-result))) 86 | 87 | 88 | (defvar *bot* nil) 89 | 90 | 91 | (defun stop () 92 | (when *bot* 93 | (stop-polling *bot*) 94 | (setf *bot* nil) 95 | 96 | (sleep 1) 97 | (bt:all-threads))) 98 | 99 | 100 | (defun start () 101 | (stop) 102 | 103 | (40ants-logging:setup-for-repl :level :warn) 104 | 105 | (unless *bot* 106 | (setf *bot* 107 | (make-test-bot (uiop:getenv "TELEGRAM_TOKEN")))) 108 | 109 | (start-polling *bot* :debug t)) 110 | -------------------------------------------------------------------------------- /v2/actions/send-text.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/actions/send-text 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/action 4 | #:action) 5 | (:import-from #:cl-telegram-bot2/generics 6 | #:on-result 7 | #:process-state 8 | #:on-state-activation) 9 | (:import-from #:cl-telegram-bot2/high 10 | #:reply) 11 | (:import-from #:serapeum 12 | #:fmt 13 | #:soft-list-of 14 | #:->) 15 | (:import-from #:cl-telegram-bot2/utils 16 | #:call-if-needed) 17 | (:import-from #:cl-telegram-bot2/types 18 | #:reply-markup-type 19 | #:inline-keyboard-buttons) 20 | (:import-from #:cl-telegram-bot2/debug/diagram/generics 21 | #:render-handler-link) 22 | (:import-from #:cl-telegram-bot2/debug/diagram/utils 23 | #:render-mapslot-value) 24 | (:import-from #:str 25 | #:shorten) 26 | (:import-from #:cl-telegram-bot2/debug/diagram/vars 27 | #:*send-text-limit*) 28 | (:export #:send-text 29 | #:text 30 | #:reply-markup 31 | #:parse-mode)) 32 | (in-package #:cl-telegram-bot2/actions/send-text) 33 | 34 | 35 | (defclass send-text (action) 36 | ((text :initarg :text 37 | :type (or symbol 38 | string) 39 | :reader text) 40 | (reply-markup :initarg :reply-markup 41 | :initform nil 42 | :type (or null 43 | symbol 44 | reply-markup-type) 45 | :reader reply-markup) 46 | (parse-mode :initarg :parse-mode 47 | :initform nil 48 | :type (or null 49 | symbol 50 | string) 51 | :documentation "Supported values are: `\"Markdown\"`, `\"MarkdownV2\"` or `\"HTML\"`. Read more about formatting options in the Telegram documentaion: https://core.telegram.org/bots/api#formatting-options" 52 | :reader parse-mode))) 53 | 54 | 55 | (-> send-text ((or string symbol) 56 | &key 57 | (:reply-markup (or null reply-markup-type)) 58 | (:parse-mode (or null string))) 59 | (values send-text &optional)) 60 | 61 | 62 | (defun send-text (text-or-func-name 63 | &key 64 | reply-markup 65 | parse-mode) 66 | (when (and (symbolp text-or-func-name) 67 | (not (fboundp text-or-func-name))) 68 | (error "SEND-TEXT waits a text or fbound symbol. ~S is not fbound." 69 | text-or-func-name)) 70 | 71 | (make-instance 'send-text 72 | :text text-or-func-name 73 | :reply-markup reply-markup 74 | :parse-mode parse-mode)) 75 | 76 | 77 | (defmethod print-object ((obj send-text) stream) 78 | (print-unreadable-object (obj stream :type t) 79 | (format stream "~S" 80 | (text obj)))) 81 | 82 | 83 | (-> do-action (send-text) 84 | (values &optional)) 85 | 86 | (defun do-action (action) 87 | (let* ((text (call-if-needed 88 | (text action))) 89 | (parse-mode (call-if-needed (parse-mode action))) 90 | (reply-markup (call-if-needed (reply-markup action)))) 91 | (apply #'reply 92 | text 93 | (append 94 | (when parse-mode 95 | (list :parse-mode parse-mode)) 96 | (when reply-markup 97 | (list :reply-markup (reply-markup action)))))) 98 | (values)) 99 | 100 | 101 | (defmethod on-state-activation ((action send-text)) 102 | (do-action action)) 103 | 104 | 105 | (defmethod process-state ((bot t) (action send-text) update) 106 | (do-action action)) 107 | 108 | 109 | (defmethod on-result ((action send-text) result) 110 | (do-action action)) 111 | 112 | 113 | 114 | (defmethod render-handler-link ((action send-text)) 115 | (render-mapslot-value 116 | "action" 117 | (fmt "~A\\n~A" 118 | (class-name (class-of action)) 119 | (let ((text (text action))) 120 | (etypecase text 121 | (string 122 | (shorten *send-text-limit* 123 | text)) 124 | (symbol 125 | text)))))) 126 | -------------------------------------------------------------------------------- /v2/states/ask-for-number.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/states/ask-for-number 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/generics 4 | #:process-state 5 | #:on-state-activation) 6 | (:import-from #:cl-telegram-bot2/state 7 | #:validate-on-deletion-arg 8 | #:base-state) 9 | (:import-from #:cl-telegram-bot2/states/base 10 | #:state-var) 11 | (:import-from #:cl-telegram-bot2/pipeline 12 | #:back) 13 | (:import-from #:cl-telegram-bot2/high 14 | #:reply) 15 | (:import-from #:cl-telegram-bot2/api 16 | #:message-text 17 | #:update-message) 18 | (:import-from #:str 19 | #:trim) 20 | (:import-from #:serapeum 21 | #:soft-list-of) 22 | (:import-from #:cl-telegram-bot2/action 23 | #:action) 24 | (:import-from #:cl-telegram-bot2/state 25 | #:state) 26 | (:import-from #:cl-telegram-bot2/debug/diagram/generics 27 | #:get-slots) 28 | (:import-from #:cl-telegram-bot2/debug/diagram/slot 29 | #:slot) 30 | (:export #:ask-for-number 31 | #:prompt 32 | #:var-name 33 | #:on-success 34 | #:on-validation-error)) 35 | (in-package #:cl-telegram-bot2/states/ask-for-number) 36 | 37 | 38 | (defparameter *default-var-name* "result") 39 | 40 | 41 | ;; To allow this state process global commands, we need 42 | ;; to inherit it from state-with-commands-mixin. 43 | (defclass ask-for-number (state) 44 | ((prompt :initarg :prompt 45 | :type string 46 | :reader prompt) 47 | (var-name :initarg :to 48 | :initform *default-var-name* 49 | :type string 50 | :reader var-name) 51 | (on-success :initarg :on-success 52 | :initform nil 53 | :type (soft-list-of 54 | (or base-state 55 | action 56 | back)) 57 | :reader on-success) 58 | (on-validation-error :initarg :on-validation-error 59 | :initform nil 60 | :type (soft-list-of 61 | (or base-state 62 | action 63 | back)) 64 | :reader on-validation-error))) 65 | 66 | 67 | (defun ask-for-number (prompt &key 68 | (to *default-var-name*) 69 | on-success 70 | on-validation-error 71 | on-deletion) 72 | 73 | (make-instance 'ask-for-number 74 | :prompt prompt 75 | :to to 76 | :on-success (uiop:ensure-list 77 | on-success) 78 | :on-validation-error (uiop:ensure-list 79 | on-validation-error) 80 | :on-deletion (validate-on-deletion-arg on-deletion))) 81 | 82 | 83 | (defmethod on-state-activation ((state ask-for-number)) 84 | (reply (prompt state)) 85 | (values)) 86 | 87 | 88 | (defmethod process-state ((bot t) (state ask-for-number) update) 89 | (let* ((message 90 | (update-message 91 | update)) 92 | (text 93 | (when message 94 | (message-text message)))) 95 | 96 | (cond 97 | (text 98 | (let ((parsed (ignore-errors 99 | (parse-integer (trim text))))) 100 | (cond 101 | (parsed 102 | (setf (state-var state 103 | (var-name state)) 104 | parsed) 105 | 106 | (process-state bot 107 | (on-success state) 108 | update)) 109 | (t 110 | (process-state bot 111 | (on-validation-error state) 112 | update))))) 113 | (t 114 | (values))))) 115 | 116 | 117 | (defmethod get-slots ((state ask-for-number)) 118 | (append 119 | (loop for slot-name in (list 120 | 'on-success 121 | 'on-validation-error) 122 | collect 123 | (slot (string-downcase slot-name) 124 | (slot-value state slot-name))) 125 | (call-next-method))) 126 | -------------------------------------------------------------------------------- /examples/payments.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2-examples/payments 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/bot 4 | #:defbot) 5 | (:import-from #:cl-telegram-bot2/server 6 | #:stop-polling 7 | #:start-polling) 8 | (:import-from #:cl-telegram-bot2/actions/send-invoice 9 | #:send-invoice) 10 | (:import-from #:cl-telegram-bot2/state-with-commands 11 | #:global-command 12 | #:command 13 | #:state-with-commands-mixin) 14 | (:import-from #:serapeum 15 | #:fmt) 16 | (:import-from #:cl-telegram-bot2/api 17 | #:answer-pre-checkout-query 18 | #:pre-checkout-query 19 | #:message-message-id) 20 | (:import-from #:cl-telegram-bot2/state-with-commands 21 | #:command 22 | #:state-with-commands-mixin) 23 | (:import-from #:cl-telegram-bot2/generics 24 | #:on-pre-checkout-query 25 | #:on-result 26 | #:on-state-activation 27 | #:process) 28 | (:import-from #:cl-telegram-bot2/state 29 | #:state) 30 | (:import-from #:cl-telegram-bot2/actions/send-text 31 | #:send-text) 32 | (:import-from #:cl-telegram-bot2/term/back 33 | #:back-to-id)) 34 | (in-package #:cl-telegram-bot2-examples/payments) 35 | 36 | 37 | (defbot test-bot () 38 | () 39 | (:initial-state 40 | (state (send-text "Use command /pay to start payment process.") 41 | :id "payments-example" 42 | :on-update (send-text "Give /pay command to start payment process.") 43 | :on-result (send-text "Welcome back! Give /pay command to start payment process.") 44 | :commands (let ((back (back-to-id "payments-example"))) 45 | (list (command "/pay" 46 | (send-invoice 47 | ;; title 48 | "Payment for the service" 49 | ;; description 50 | "This is the test service which will not be provided." 51 | ;; payload 52 | "foo-bar-payload" 53 | ;; provider token 54 | "381764678:TEST:100070" 55 | ;; currency 56 | "RUB" 57 | ;; prices 58 | (list (serapeum:dict "label" "Руб" 59 | "amount" (* 120 60 | ;; Выражать цену надо в копейках 61 | 100))) 62 | :on-success (list (send-text "Thank you for the payment!") 63 | back 64 | ;; (back-to-id "payments-example") 65 | ) 66 | :commands (list (command "/back" 67 | ;; TODO: найти способ удалить invoice message 68 | (list 69 | (send-text "Invoice canceled!") 70 | back 71 | ;; (back-to-id "payments-example") 72 | )))))))))) 73 | 74 | 75 | (defmethod on-pre-checkout-query ((bot test-bot) (query pre-checkout-query)) 76 | (answer-pre-checkout-query (cl-telegram-bot2/api:pre-checkout-query-id query) 77 | t) 78 | (values)) 79 | 80 | 81 | ;; Technical parts: 82 | 83 | (defvar *bot* nil) 84 | 85 | 86 | (defun stop () 87 | (when *bot* 88 | (stop-polling *bot*) 89 | (setf *bot* nil))) 90 | 91 | 92 | (defun start () 93 | (stop) 94 | 95 | (unless *bot* 96 | (setf *bot* 97 | (make-test-bot (uiop:getenv "TELEGRAM_TOKEN")))) 98 | 99 | (start-polling *bot* :debug t)) 100 | 101 | -------------------------------------------------------------------------------- /v2/high.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/high 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/api 4 | #:chat-title 5 | #:send-photo 6 | #:message-chat 7 | #:update-message 8 | #:update 9 | #:chat-id 10 | #:send-message) 11 | (:import-from #:cl-telegram-bot2/vars 12 | #:*current-chat*) 13 | (:import-from #:lambda-fiddle 14 | #:key-lambda-vars) 15 | (:import-from #:trivial-arguments 16 | #:arglist) 17 | (:import-from #:cl-telegram-bot2/errors 18 | #:error-description 19 | #:telegram-error) 20 | (:documentation "High level API for implementing Telegram bots.") 21 | (:export #:reply 22 | #:chat-state 23 | #:collect-sent-messages 24 | #:reply-with-photo)) 25 | (in-package #:cl-telegram-bot2/high) 26 | 27 | 28 | ;; TODO: Probably remove 29 | (defclass chat-state () 30 | ()) 31 | 32 | 33 | (defvar *collected-messages*) 34 | 35 | 36 | (defmacro collect-sent-messages (&body body) 37 | "Returns as the first value a list of messages created by REPLY function called 38 | during BODY execution. Values returned by the BODY code are returned as the second, 39 | third and following arguments. 40 | 41 | Also, messages are collected when these actions are called: 42 | 43 | - CL-TELEGRAM-BOT2/ACTIONS/SEND-TEXT:SEND-TEXT 44 | - CL-TELEGRAM-BOT2/ACTIONS/SEND-PHOTO:SEND-PHOTO" 45 | `(let ((vars 46 | ;; This check allows us to use nested calls to collect-sent-messages. 47 | ;; Here inner call can see messages added during outer call, 48 | ;; but I don't consider this an issue for the moment. 49 | (unless (boundp '*collected-messages*) 50 | (list '*collected-messages*))) 51 | (vals 52 | (unless (boundp '*collected-messages*) 53 | (list nil)))) 54 | (progv vars vals 55 | (let ((result-values (multiple-value-list ,@body))) 56 | (values-list (list* *collected-messages* 57 | result-values)))))) 58 | 59 | 60 | (defmacro defun-with-same-keys ((func-name copy-kwargs-from-func) lambda-list &body body) 61 | "We have to use this macro, to not hardcode all possible keyword arguments from an autogenerated API functions. 62 | 63 | This needed primary for a convenience, because this way these arguments will be suggested by autocompletion." 64 | (let* ((additional-keyword-args 65 | (key-lambda-vars 66 | (arglist copy-kwargs-from-func))) 67 | (new-lambda-list (append lambda-list 68 | (list* '&key 69 | additional-keyword-args)))) 70 | `(defun ,func-name ,new-lambda-list 71 | (declare (ignorable ,@additional-keyword-args)) 72 | ,@body))) 73 | 74 | 75 | (defun-with-same-keys (reply send-message) 76 | (text &rest rest) 77 | (let* ((chat-id (chat-id *current-chat*)) 78 | (chat-title (chat-title *current-chat*)) 79 | (message (handler-bind 80 | ((telegram-error (lambda (err) 81 | (when (string= (error-description err) 82 | "Bad Request: need administrator rights in the channel chat") 83 | (log:warn "Unable to reply to chat ~S (~A) because bot needs administration rights on this channel" 84 | chat-title 85 | chat-id) 86 | (return-from reply nil))))) 87 | (apply #'send-message 88 | chat-id 89 | text 90 | rest)))) 91 | (when (boundp '*collected-messages*) 92 | (push message *collected-messages*)) 93 | (values message))) 94 | 95 | 96 | (defun-with-same-keys (reply-with-photo send-photo) 97 | (photo &rest rest) 98 | (let* ((chat-id (chat-id *current-chat*)) 99 | (message (apply #'send-photo 100 | chat-id 101 | photo 102 | rest))) 103 | (when (boundp '*collected-messages*) 104 | (push message *collected-messages*)) 105 | (values message))) 106 | 107 | -------------------------------------------------------------------------------- /v2/actions/edit-message-media.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/actions/edit-message-media 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/action 4 | #:action) 5 | (:import-from #:cl-telegram-bot2/vars 6 | #:*current-state* 7 | #:*current-chat*) 8 | (:import-from #:cl-telegram-bot2/api 9 | #:message-chat 10 | #:update-message 11 | #:update 12 | #:chat-id 13 | #:send-message) 14 | (:import-from #:cl-telegram-bot2/generics 15 | #:on-result 16 | #:process-state 17 | #:on-state-activation) 18 | (:import-from #:serapeum 19 | #:soft-list-of 20 | #:->) 21 | (:import-from #:cl-telegram-bot2/utils 22 | #:call-if-needed) 23 | (:import-from #:cl-telegram-bot2/states/base 24 | #:sent-message-ids) 25 | (:export #:edit-message-media 26 | #:caption 27 | #:media-path 28 | #:inline-keyboard)) 29 | (in-package #:cl-telegram-bot2/actions/edit-message-media) 30 | 31 | 32 | (defclass edit-message-media (action) 33 | ((path :initarg :path 34 | :type (or string 35 | pathname 36 | symbol) 37 | :reader media-path) 38 | (caption :initarg :caption 39 | :type string 40 | :reader caption) 41 | (inline-keyboard :initarg :inline-keyboard 42 | :type (soft-list-of string) 43 | :reader inline-keyboard))) 44 | 45 | 46 | (-> edit-message-media ((or string pathname symbol) 47 | &key 48 | (:caption string) 49 | (:inline-keyboard (soft-list-of string))) 50 | (values edit-message-media &optional)) 51 | 52 | 53 | (defun edit-message-media (path-or-func-name &key caption inline-keyboard) 54 | (when (and (symbolp path-or-func-name) 55 | (not (fboundp path-or-func-name))) 56 | (error "EDIT-MESSAGE-MEDIA waits a path or fbound symbol. ~S is not fbound." 57 | path-or-func-name)) 58 | 59 | (make-instance 'edit-message-media 60 | :path path-or-func-name 61 | :caption (or caption "") 62 | :inline-keyboard inline-keyboard)) 63 | 64 | 65 | (defmethod print-object ((obj edit-message-media) stream) 66 | (print-unreadable-object (obj stream :type t) 67 | (format stream "~S" 68 | (media-path obj)))) 69 | 70 | 71 | (defun send-reply (action) 72 | (let ((path (call-if-needed 73 | (media-path action))) 74 | (caption (call-if-needed 75 | (caption action))) 76 | (buttons (call-if-needed 77 | (inline-keyboard action))) 78 | (message-id (first (sent-message-ids *current-state*))) 79 | (chat-id (chat-id *current-chat*))) 80 | 81 | (cond 82 | (message-id 83 | (cl-telegram-bot2/api:edit-message-media 84 | (make-instance 'cl-telegram-bot2/api:input-media-photo 85 | :type "photo" 86 | :media path 87 | ;; These options aren't supported yet 88 | ;; has_spoiler 89 | ;; show_caption_above_media 90 | ;; parse_mode 91 | ;; caption_entities 92 | :caption caption) 93 | :chat-id chat-id 94 | :message-id message-id 95 | :reply-markup 96 | (make-instance 'cl-telegram-bot2/api:inline-keyboard-markup 97 | :inline-keyboard 98 | (list 99 | (loop for button in buttons 100 | collect (make-instance 'cl-telegram-bot2/api:inline-keyboard-button 101 | :text button 102 | :callback-data button)))))) 103 | (t 104 | (log:warn "There is no message-ids to edit in the" 105 | *current-state*))))) 106 | 107 | 108 | (defmethod on-state-activation ((action edit-message-media)) 109 | (send-reply action) 110 | (values)) 111 | 112 | 113 | (defmethod process-state ((bot t) (action edit-message-media) update) 114 | (send-reply action) 115 | (values)) 116 | 117 | 118 | (defmethod on-result ((action edit-message-media) result) 119 | (send-reply action) 120 | (values)) 121 | -------------------------------------------------------------------------------- /v2/utils.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/utils 2 | (:use #:cl) 3 | (:import-from #:trivial-arguments 4 | #:arglist) 5 | (:import-from #:lambda-fiddle 6 | #:required-lambda-vars) 7 | (:import-from #:serapeum 8 | #:->) 9 | (:import-from #:alexandria 10 | #:non-negative-fixnum 11 | #:positive-fixnum) 12 | (:import-from #:yason 13 | #:with-output-to-string*) 14 | (:export #:call-if-needed 15 | #:deep-copy 16 | #:arity 17 | #:from-json 18 | #:to-json 19 | #:call-with-one-or-zero-args 20 | #:fbound-symbol)) 21 | (in-package #:cl-telegram-bot2/utils) 22 | 23 | 24 | (-> arity ((or symbol function)) 25 | (values non-negative-fixnum &optional)) 26 | 27 | 28 | 29 | (defun arity (funcallable) 30 | (length (required-lambda-vars 31 | (arglist funcallable)))) 32 | 33 | 34 | (defun call-if-needed (value &rest args) 35 | "If value is a fbound SYMBOL, then calls as a function and then returns a result." 36 | (typecase value 37 | (symbol 38 | (if (fboundp value) 39 | (apply value args) 40 | value)) 41 | (t 42 | value))) 43 | 44 | 45 | (defun call-with-one-or-zero-args (symbol arg) 46 | "If value is a fbound SYMBOL, then calls as a function with given ARG or without it depending on function arity." 47 | (cond 48 | ((fboundp symbol) 49 | (case (arity symbol) 50 | (0 51 | (funcall symbol)) 52 | (1 53 | ;; If function accepts a single argument, 54 | ;; then we call it with arg. 55 | ;; This way args like web-app-data 56 | ;; could be processed. 57 | (funcall symbol arg)) 58 | (otherwise 59 | (error "Unable to process ~A because function ~S requires ~A arguments." 60 | arg 61 | symbol 62 | (arity symbol))))) 63 | (t 64 | (error "Symbol ~S should be funcallble." 65 | symbol)))) 66 | 67 | 68 | (-> bool-value-to-symbol (t) 69 | (values (member yason:true yason:false) 70 | &optional)) 71 | 72 | (defun bool-value-to-symbol (value) 73 | (if value 74 | yason:true 75 | yason:false)) 76 | 77 | 78 | (-> to-json (t &key (:indent (or null integer))) 79 | (values string &optional)) 80 | 81 | 82 | (defun to-json (obj &key indent) 83 | (with-output-to-string* (:indent indent) 84 | (yason:encode obj))) 85 | 86 | 87 | (-> from-json (string) 88 | (values t &optional)) 89 | 90 | (defun from-json (string) 91 | (yason:parse string 92 | :json-arrays-as-vectors t)) 93 | 94 | 95 | 96 | ;; This deep copy code was taken from CL-MOP 97 | ;; https://github.com/Inaimathi/cl-mop 98 | ;; but code for copying a list was replaced with code 99 | ;; a code making a deep copy each list item. 100 | 101 | 102 | (defgeneric deep-copy (object) 103 | (:documentation "Does a general deep-copy on the given object and sub-pieces. 104 | Returns atoms, numbers and chars. 105 | Runs copy-tree on lists, and copy-seq on other sequences. 106 | Runs copy-structure on pathnames, hash tables and other structure-objects")) 107 | 108 | (defmethod deep-copy (object) 109 | "The default unspecialized case should only catch atoms, numbers and characters. 110 | It merely returns its results." 111 | object) 112 | 113 | (defmethod deep-copy ((object standard-object)) 114 | "The default deep copy specializes on STANDARD-OBJECT. It takes an object and returns a deep copy." 115 | (let ((copy (allocate-instance (class-of object)))) 116 | (loop for slot in (closer-mop:class-slots 117 | (class-of object)) 118 | for slot-name = (closer-mop:slot-definition-name slot) 119 | when (slot-boundp object slot-name) 120 | do (setf (slot-value copy slot-name) 121 | (deep-copy (slot-value object slot-name)))) 122 | (values copy))) 123 | 124 | (defmethod deep-copy ((object cons)) 125 | "A deep copy of a general sequence is merely (copy-seq sequence)." 126 | (cons (deep-copy (car object)) 127 | (deep-copy (cdr object)))) 128 | 129 | (defmethod deep-copy ((object sequence)) 130 | "A deep copy of a general sequence is merely (copy-seq sequence)." 131 | (map (type-of object) 132 | #'deep-copy 133 | object)) 134 | 135 | (defmethod deep-copy ((object structure-object)) 136 | "A deep copy of a structure-object is (copy-structure object)." 137 | (copy-structure object)) 138 | 139 | 140 | (deftype fbound-symbol () 141 | "This type denotes symbols bound to the functions. Such symbol could be funcalled." 142 | '(and 143 | symbol 144 | (satisfies fboundp))) 145 | -------------------------------------------------------------------------------- /docs/states.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot-docs/states 2 | (:use #:cl) 3 | (:import-from #:40ants-doc 4 | #:defsection) 5 | (:import-from #:cl-telegram-bot2/state 6 | #:state) 7 | (:import-from #:cl-telegram-bot2/actions/send-text 8 | #:send-text) 9 | (:import-from #:cl-telegram-bot2/actions/send-photo 10 | #:send-photo) 11 | (:import-from #:cl-telegram-bot2/actions/send-invoice 12 | #:send-invoice) 13 | (:import-from #:cl-telegram-bot2/actions/edit-message-media 14 | #:edit-message-media)) 15 | (in-package #:cl-telegram-bot-docs/states) 16 | 17 | 18 | (defsection @states-and-actions (:title "States and Actions") 19 | " 20 | This framework makes it possible to define bot with all allowed state. 21 | 22 | The state defines behaviour of the bot, the way it should respond to commands, updates and other events. 23 | " 24 | (@states section) 25 | (@actions section) 26 | (@event-processing section)) 27 | 28 | 29 | (defsection @states (:title "States") 30 | " 31 | There can be more than one handler for the event. We call these handlers \"Actions\". 32 | 33 | An action should return a NIL or a new state. In latter case, the current bot's state will be changed to the new one and handlers for `on-activation` event will be called. 34 | 35 | State is constructed using STATE function, which accepts handlers for different kinds of events. Here is simples state which greets a user when it start the chat and then reply with the same text: 36 | 37 | ``` 38 | (defun reply-with-same-text (update) 39 | (reply (message-text 40 | (update-message update))) 41 | (values)) 42 | 43 | 44 | (state (send-text \"Hello, I'm the echo bot.\") 45 | :on-update 'reply-with-same-text) 46 | ``` 47 | 48 | The first argument to STATE function is a handler for `on-activation` event. If you don't want to react on activation, you can pass NIL instead. The SEND-TEXT function returns an action instance. This way, we tell what bot should do, we use a declarative way to describe bot's behaviour. 49 | 50 | The :ON-UPDATE argument specifies a handler for `on-update` event. This is the most generic event which occur when bot receives an update which wasn't processed by other event handlers. For this handler we are using a custom function bound to the symbol `reply-with-same-text`. The function accepts a single argument - update object. Use generic functions from `cl-telegram-bot2/api` package to work with this update object. 51 | 52 | The reason why we only accept a special action object or a symbol but not a lambda function is because this way we'll be able to generate schemas of all states and transitions between them. Another reason is that it will be possible to redefine fbound function and use interactive approach to changing bot's behaviour. 53 | 54 | See other support events in STATE function documentation. 55 | ") 56 | 57 | 58 | (defsection @actions (:title "Actions") 59 | " 60 | Actions in cl-telegra-bot are small objects holding an information about what should be done on some event. Typically, you will want to reply with some text or send a photo. 61 | 62 | Usually, actions are created using a function having the same name as action's class. Here are which actions are available: 63 | 64 | - [SEND-TEXT][function] 65 | - [SEND-PHOTO][function] 66 | - [SEND-INVOICE][function] 67 | - [EDIT-MESSAGE-MEDIA][function] 68 | 69 | More actions will be added in future and you can create your own. 70 | 71 | Also, a function bound symbol can be used instead an action object. Why do we require a symbol but not a function object? Because symbol has a name and it can be useful when we want to save bot's state or to render states graph. 72 | ") 73 | 74 | 75 | (defsection @event-processing (:title "Event processing") 76 | " 77 | When some event occur, a corresponding generic function is called first on state object then on an action specified for this kind. 78 | 79 | For example, if new update was received, then CL-TELEGRAM-BOT2/GENERICS:PROCESS-UPDATE generic-function will be called with current state as the first argument 80 | and update object as the second argument. Then the method specified on state class will call the same CL-TELEGRAM-BOT2/GENERICS:PROCESS-UPDATE generic-function 81 | on the object specified as :ON-UPDATE argument for the action. If action is a symbol, then it's function will be called with update object as a single argument in case if this function accepts one argument and without any arguments otherwise. 82 | 83 | Action's method should return should return a new state object if it wants to change the current bot's state or NIL otherwise. If new state was returned, then `on-activate` event will be processed afterwards. 84 | 85 | Instead of one action a list of actions can be specified as an event handler. In this case processing will stop on an action which returns a new state. 86 | ") 87 | -------------------------------------------------------------------------------- /v2/generics.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/generics 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/api 4 | #:pre-checkout-query) 5 | (:import-from #:log) 6 | (:export #:process-update 7 | #:process-state 8 | #:on-state-activation 9 | #:on-state-deletion 10 | #:on-result 11 | #:on-pre-checkout-query)) 12 | (in-package #:cl-telegram-bot2/generics) 13 | 14 | 15 | (defgeneric process-update (bot update) 16 | (:documentation "This generic-function will be called inside an actor. 17 | 18 | Default method resposible for extracting the current state from the stack 19 | and calling PROCESS-STATE generic-function to get a new state.")) 20 | 21 | (defgeneric process-state (bot state object) 22 | (:documentation "This method is called by when processing a single update. 23 | It is called multiple times on different parts of an update. 24 | Whole pipeline looks like that: 25 | 26 | For each update we call: 27 | 28 | ``` 29 | process-update(bot, update) 30 | new_state = process-state(bot, current_state, update) 31 | ``` 32 | ")) 33 | 34 | 35 | (defmethod process-state (bot state object) 36 | "By default, processing does nothing" 37 | (log:warn "No PROCESS-STATE method for processing objects like ~A by ~A." 38 | object 39 | (type-of state)) 40 | (values)) 41 | 42 | 43 | (defmethod process-state :around (bot bot-or-state object) 44 | "By default, processing does nothing" 45 | (log:debug "Calling PROCESS method for processing objects of ~A type by ~A: ~S" 46 | (type-of object) 47 | (type-of bot-or-state) 48 | bot-or-state) 49 | (call-next-method)) 50 | 51 | 52 | 53 | (defgeneric on-state-activation (state) 54 | (:documentation "This method is called when chat actor's state is changed to a given STATE. 55 | 56 | Such hook can be used to send some prompt to the user. 57 | ") 58 | (:method ((state t)) 59 | "By default, nothing happens on activation." 60 | (values)) 61 | 62 | (:method :around ((state t)) 63 | (log:debug "Calling ON-STATE-ACTIVATION method for processing object of ~A type: ~S" 64 | (type-of state) 65 | state) 66 | (call-next-method))) 67 | 68 | 69 | (defgeneric on-state-deletion (state) 70 | (:documentation "This method is called when chat actor's state is returned from a given STATE back to the previous state. 71 | 72 | The method is called only when state is removed from the stack. When a new state is added to the stack, 73 | this method will not be called for a previous state. 74 | 75 | Such hook can be used to hide a keyboard or to delete temporary messages. 76 | ") 77 | (:method ((state t)) 78 | "By default, nothing happens on deactivation." 79 | (values)) 80 | 81 | (:method :around ((state t)) 82 | (log:debug "Calling ON-STATE-DELETION method for processing object of ~A type: ~S" 83 | (type-of state) 84 | state) 85 | (call-next-method))) 86 | 87 | 88 | (defgeneric on-result (state result) 89 | (:documentation "This method is called when some state exits and returns a result using CL-TELEGRAM-BOT2/TERM/BACK:BACK function.") 90 | 91 | (:method ((state t) (result t)) 92 | "By default, nothing happens for state processing." 93 | (values)) 94 | 95 | (:method :around ((state t) result) 96 | (log:debug "Calling ON-RESULT method for processing object of ~A type and result ~A." 97 | (type-of state) 98 | result) 99 | (call-next-method))) 100 | 101 | 102 | (defgeneric on-pre-checkout-query (bot query) 103 | (:documentation "Pre-checkout-query object will be passed as this single arguement and 104 | function should return a boolean. When the function return True, user 105 | may proceed to the payment. 106 | 107 | Pre-checkout queries are not bound the the chat, so 108 | current-chat and current-state are not available during processing. 109 | This is why methods of this generic function should be defined on bot class. 110 | 111 | You can use CL-TELEGRAM-BOT2/API:PRE-CHECKOUT-QUERY-INVOICE-PAYLOAD function 112 | to extract payload from the query and find associated invoice.") 113 | 114 | (:method ((bot t) (query pre-checkout-query)) 115 | (log:debug "Method on-pre-checkout-query is not defined for ~S." 116 | (class-name 117 | (class-of bot))) 118 | (values))) 119 | -------------------------------------------------------------------------------- /v2/actions/send-invoice.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/actions/send-invoice 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/action 4 | #:action) 5 | (:import-from #:cl-telegram-bot2/generics 6 | #:process-state 7 | #:on-result 8 | #:on-state-activation) 9 | (:import-from #:cl-telegram-bot2/high 10 | #:reply) 11 | (:import-from #:serapeum 12 | #:soft-list-of 13 | #:->) 14 | (:import-from #:cl-telegram-bot2/utils 15 | #:call-if-needed) 16 | (:import-from #:cl-telegram-bot2/workflow 17 | #:workflow-blocks 18 | #:workflow-block) 19 | (:import-from #:cl-telegram-bot2/states/wait-for-payment 20 | #:wait-for-payment) 21 | (:import-from #:cl-telegram-bot2/state-with-commands 22 | #:command) 23 | (:export #:send-invoice 24 | #:title 25 | #:description 26 | #:payload 27 | #:provider-token 28 | #:currency 29 | #:prices 30 | #:on-success 31 | #:commands 32 | #:prices-list)) 33 | (in-package #:cl-telegram-bot2/actions/send-invoice) 34 | 35 | 36 | (deftype prices-list () 37 | "Type of PRICES arguments for SEND-INVOICE class." 38 | '(soft-list-of hash-table)) 39 | 40 | 41 | (defclass send-invoice (action) 42 | ((title :initarg :title 43 | :type (or string 44 | symbol) 45 | :reader title) 46 | (description :initarg :description 47 | :type (or string 48 | symbol) 49 | :reader description) 50 | (payload :initarg :payload 51 | :type (or string 52 | symbol) 53 | :reader payload) 54 | (provider-token :initarg :provider-token 55 | :type (or string 56 | symbol) 57 | :reader provider-token) 58 | (currency :initarg :currency 59 | :type (or string 60 | symbol) 61 | :reader currency) 62 | (prices :initarg :prices 63 | :type (or prices-list 64 | symbol) 65 | :reader prices) 66 | (on-success :initarg :on-success 67 | :type (or workflow-block 68 | workflow-blocks 69 | symbol) 70 | :reader on-success) 71 | (commands :initarg :commands 72 | :initform nil 73 | :type (soft-list-of command) 74 | :reader commands))) 75 | 76 | 77 | (-> send-invoice ((or string symbol) 78 | (or string symbol) 79 | (or string symbol) 80 | (or string symbol) 81 | (or string symbol) 82 | (or prices-list symbol) 83 | &key 84 | (:on-success (or workflow-block 85 | workflow-blocks 86 | symbol)) 87 | (:commands (soft-list-of command))) 88 | (values send-invoice &optional)) 89 | 90 | (defun send-invoice (title description payload provider-token currency prices &key on-success commands) 91 | (make-instance 'send-invoice 92 | :title title 93 | :description description 94 | :payload payload 95 | :provider-token provider-token 96 | :currency currency 97 | :prices prices 98 | :on-success on-success 99 | :commands commands)) 100 | 101 | 102 | (defmethod print-object ((obj send-invoice) stream) 103 | (print-unreadable-object (obj stream :type t) 104 | (format stream "~S" 105 | (title obj)))) 106 | 107 | 108 | (-> perform-action (send-invoice) 109 | (values wait-for-payment &optional)) 110 | 111 | (defun perform-action (action) 112 | (cl-telegram-bot2/api::send-invoice 113 | (cl-telegram-bot2/api::chat-id cl-telegram-bot2/vars::*current-chat*) 114 | ;; title 115 | (call-if-needed 116 | (title action)) 117 | ;; description 118 | (call-if-needed 119 | (description action)) 120 | ;; payload 121 | (call-if-needed 122 | (payload action)) 123 | ;; currency 124 | (call-if-needed 125 | (currency action)) 126 | ;; prices 127 | (call-if-needed 128 | (prices action)) 129 | 130 | :provider-token (call-if-needed 131 | (provider-token action))) 132 | 133 | (wait-for-payment :on-success (on-success action) 134 | :commands (commands action))) 135 | 136 | 137 | (defmethod on-state-activation ((action send-invoice)) 138 | (perform-action action)) 139 | 140 | 141 | (defmethod process-state ((bot t) (action send-invoice) update) 142 | (perform-action action)) 143 | 144 | 145 | (defmethod on-result ((action send-invoice) result) 146 | (perform-action action)) 147 | -------------------------------------------------------------------------------- /v2/debug/diagram.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/debug/diagram 2 | (:use #:cl) 3 | (:import-from #:40ants-plantuml) 4 | (:import-from #:cl-telegram-bot2/state 5 | #:state) 6 | (:import-from #:cl-telegram-bot2/server 7 | #:stop-polling 8 | #:start-polling) 9 | (:import-from #:cl-telegram-bot2/actions/send-text 10 | #:send-text) 11 | (:import-from #:cl-telegram-bot2/state-with-commands 12 | #:global-command 13 | #:command) 14 | (:import-from #:cl-telegram-bot2-examples/calc) 15 | (:import-from #:cl-telegram-bot2-examples/commands) 16 | (:import-from #:cl-telegram-bot2-examples/gallery) 17 | (:import-from #:cl-telegram-bot2-examples/payments) 18 | (:import-from #:cl-telegram-bot2-examples/mini-app) 19 | (:import-from #:cl-telegram-bot2-examples/echo) 20 | (:import-from #:cl-telegram-bot2-examples/text-chain) 21 | (:import-from #:cl-telegram-bot2/high/keyboard 22 | #:inline-keyboard 23 | #:call-callback) 24 | (:import-from #:cl-telegram-bot2/bot 25 | #:initial-state) 26 | (:import-from #:cl-telegram-bot2/term/back 27 | #:back-to-id) 28 | (:import-from #:cl-telegram-bot2/actions/delete-messages 29 | #:delete-messages) 30 | (:import-from #:cl-telegram-bot2/api 31 | #:pre-checkout-query 32 | #:pre-checkout-query-id 33 | #:answer-pre-checkout-query) 34 | (:import-from #:cl-telegram-bot2/generics 35 | #:process-state 36 | #:on-pre-checkout-query) 37 | (:import-from #:cl-telegram-bot2/actions/send-photo 38 | #:send-photo) 39 | (:import-from #:cl-telegram-bot2/callback 40 | #:callback-data 41 | #:callback) 42 | (:import-from #:cl-telegram-bot2/debug/diagram/vars 43 | #:*state-to-name* 44 | #:*id-to-state* 45 | #:*name-to-state* 46 | #:*obj-to-id* 47 | #:*id-to-obj* 48 | #:*current-map-id* 49 | #:*current-obj-id* 50 | #:*diagram-stream* 51 | #:*on-after-object* 52 | #:*objects-created*) 53 | (:import-from #:alexandria 54 | #:once-only) 55 | (:import-from #:serapeum 56 | #:fmt 57 | #:push-end) 58 | (:import-from #:cl-telegram-bot2/debug/diagram/utils 59 | #:obj-id 60 | #:on-after-object 61 | #:with-on-after 62 | #:render-handlers-inner 63 | #:render-mapslot-value) 64 | (:import-from #:cl-telegram-bot2/debug/diagram/generics 65 | #:to-text 66 | #:render-handlers 67 | #:render-handler-link) 68 | (:import-from #:cl-telegram-bot2/action 69 | #:action) 70 | (:import-from #:cl-telegram-bot2/vars 71 | #:*current-bot*) 72 | (:export #:render-workflow-diagram)) 73 | (in-package #:cl-telegram-bot2/debug/diagram) 74 | 75 | 76 | (defmethod render-handler-link ((symbol symbol)) 77 | (render-mapslot-value 78 | "call" 79 | (symbol-name 80 | symbol))) 81 | 82 | 83 | (defmethod render-handlers ((obj list)) 84 | (render-handlers-inner obj (obj-id obj))) 85 | 86 | 87 | (defmethod to-text :around ((obj t)) 88 | (let ((*current-obj-id* (obj-id obj))) 89 | (call-next-method) 90 | (on-after-object *current-obj-id*))) 91 | 92 | 93 | (defmethod to-text ((symbol symbol)) 94 | ;; NOTE: Decided to not render blocks for funcs and actions. 95 | ;; Probably will need to show again if I decide to render 96 | ;; output arrows from functions. 97 | (values)) 98 | 99 | 100 | (defmethod to-text ((objects list)) 101 | (loop for obj in objects 102 | do (to-text obj))) 103 | 104 | 105 | (defun workflow-to-text (bot &key left-to-right) 106 | (with-output-to-string (*diagram-stream*) 107 | (with-on-after 108 | (let ((*state-to-name* (make-hash-table)) 109 | (*name-to-state* (make-hash-table :test 'equal)) 110 | (*id-to-state* (make-hash-table :test 'equal)) 111 | (*obj-to-id* (make-hash-table)) 112 | (*id-to-obj* (make-hash-table :test 'equal))) 113 | (format *diagram-stream* 114 | "@startuml~%") 115 | (when left-to-right 116 | (format *diagram-stream* 117 | "left to right direction~%")) 118 | (to-text (cl-telegram-bot2/bot::initial-state bot)) 119 | (format *diagram-stream* 120 | ;; remove @unlinked 121 | "@enduml~%"))))) 122 | 123 | 124 | (defclass render-workflow-diagram (action) 125 | ()) 126 | 127 | 128 | (defun render-workflow-diagram () 129 | (make-instance 'render-workflow-diagram)) 130 | 131 | 132 | (defmethod process-state ((bot t) (action render-workflow-diagram) (update t)) 133 | (handler-case 134 | (let ((workflow (workflow-to-text *current-bot*))) 135 | (uiop:with-temporary-file (:pathname temp-file :keep t) 136 | (40ants-plantuml:render workflow 137 | temp-file) 138 | 139 | (send-photo temp-file))) 140 | (serious-condition (err) 141 | (send-text (fmt "~A" 142 | err))))) 143 | 144 | 145 | -------------------------------------------------------------------------------- /v2/debug/diagram/utils.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/debug/diagram/utils 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/debug/diagram/vars 4 | #:*state-to-name* 5 | #:*id-to-state* 6 | #:*name-to-state* 7 | #:*obj-to-id* 8 | #:*id-to-obj* 9 | #:*current-map-id* 10 | #:*current-obj-id* 11 | #:*diagram-stream* 12 | #:*on-after-object* 13 | #:*objects-created*) 14 | (:import-from #:alexandria 15 | #:once-only) 16 | (:import-from #:serapeum 17 | #:push-end) 18 | (:import-from #:cl-telegram-bot2/debug/diagram/generics 19 | #:render-handler-link) 20 | (:export #:find-state-by-id 21 | #:render-mapslot-value-with-link 22 | #:render-mapslot-value 23 | #:obj-id 24 | #:after-object 25 | #:render-objects-link 26 | #:on-after-object 27 | #:render-handlers-inner)) 28 | (in-package #:cl-telegram-bot2/debug/diagram/utils) 29 | 30 | 31 | (defun find-state-by-id (state-id) 32 | "Returns a state with given ID. 33 | 34 | Works only during `PlantUML` diagram rendering." 35 | (gethash state-id 36 | *id-to-state*)) 37 | 38 | 39 | (defun obj-id (obj) 40 | "Returns an alias of obj to be used in `PlantUML` diagram as a reference." 41 | (let ((obj-id (gethash obj *obj-to-id*))) 42 | (cond 43 | (obj-id 44 | (values obj-id)) 45 | (t 46 | (loop for idx upfrom 1 47 | for possible-id = (format nil "obj_~A" 48 | idx) 49 | when (null (gethash possible-id *id-to-obj*)) 50 | do (return (progn 51 | (setf (gethash obj *obj-to-id*) 52 | possible-id) 53 | (setf (gethash possible-id *id-to-obj*) 54 | obj) 55 | (values possible-id)))))))) 56 | 57 | 58 | (defmacro with-on-after (&body body) 59 | `(cond 60 | ((boundp '*objects-created*) 61 | (error "Nested call of WITH-ON-AFTER is prohibited.")) 62 | (t 63 | (let ((*objects-created* nil) 64 | (*on-after-object* (make-hash-table :test 'equal))) 65 | ,@body)))) 66 | 67 | 68 | (defmacro after-object ((obj-id) &body body) 69 | "Executes block of code after the `PlantUML` entity with OBJ-ID alias 70 | has been rendered. Useful for ensuring that both objects are known 71 | to the `PlantUML` renderer when rendering a link between objects." 72 | (once-only (obj-id) 73 | `(let ((already-created (member ,obj-id *objects-created* 74 | :test #'equal))) 75 | (cond 76 | (already-created 77 | ,@body) 78 | (t 79 | (push-end 80 | (let ((dynamic-bindings (when (boundp '*current-map-id*) 81 | (list (cons '*current-map-id* 82 | *current-map-id*))))) 83 | (lambda () 84 | (progv 85 | (mapcar #'car dynamic-bindings) 86 | (mapcar #'cdr dynamic-bindings) 87 | ,@body))) 88 | (gethash ,obj-id *on-after-object*)))) 89 | (values)))) 90 | 91 | 92 | (defun on-after-object (obj-id) 93 | "Call this function after you've finished rendering of the `PlantUML` object." 94 | (loop for callback in (gethash obj-id *on-after-object*) 95 | do (funcall callback)) 96 | 97 | (push obj-id 98 | *objects-created*) 99 | 100 | (values)) 101 | 102 | 103 | (defun render-objects-link (from to) 104 | (format *diagram-stream* 105 | "~A ----> ~A~%" 106 | from 107 | to)) 108 | 109 | 110 | (defmacro render-map ((name id) &body body) 111 | (once-only (name id) 112 | `(let ((*current-map-id* ,id)) 113 | (format *diagram-stream* 114 | "map \"~A\" as ~A {~%" 115 | ,name 116 | ,id) 117 | 118 | ,@body 119 | 120 | (format *diagram-stream* 121 | "}~%")))) 122 | 123 | 124 | (defun render-mapslot-link (from to) 125 | (format *diagram-stream* 126 | "~A *---> ~A~%" 127 | from 128 | to)) 129 | 130 | 131 | (defun render-mapslot-value-with-link (key value link-to-obj-id) 132 | (format *diagram-stream* 133 | "~A => ~A~%" 134 | key 135 | value) 136 | ;; We don't want this piece to render inside the current 137 | ;; map and we need it to render only after the linked object 138 | ;; will be rendered. Otherwise PlantUML will complain 139 | ;; it is now know about such object. 140 | (after-object (*current-obj-id*) 141 | (after-object (link-to-obj-id) 142 | (format *diagram-stream* 143 | "~A::~A ---> ~A~%" 144 | *current-map-id* 145 | key 146 | link-to-obj-id)))) 147 | 148 | 149 | (defun render-mapslot-value (key value) 150 | (format *diagram-stream* 151 | "~A => ~A~%" 152 | key 153 | value)) 154 | 155 | 156 | (defun render-handlers-inner (handlers obj-id) 157 | (let ((handlers-id (format nil "~A_handlers" 158 | obj-id)) 159 | (handlers (uiop:ensure-list handlers))) 160 | (when handlers 161 | (render-map ("handlers" handlers-id) 162 | 163 | (loop for handler in handlers 164 | do (render-handler-link handler)))))) 165 | -------------------------------------------------------------------------------- /src/update.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot/update 2 | (:use #:cl) 3 | (:import-from #:log) 4 | (:import-from #:cl-telegram-bot/message 5 | #:*current-bot* 6 | #:make-message) 7 | (:import-from #:cl-telegram-bot/network 8 | #:make-request) 9 | (:import-from #:cl-telegram-bot/bot 10 | #:get-last-update-id 11 | #:bot) 12 | (:import-from #:cl-telegram-bot/pipeline 13 | #:process) 14 | (:import-from #:cl-telegram-bot/callback 15 | #:make-callback) 16 | (:import-from #:anaphora 17 | #:it 18 | #:acond) 19 | (:import-from #:cl-telegram-bot/envelope 20 | #:edited-message 21 | #:channel-post 22 | #:edited-channel-post) 23 | (:import-from #:cl-telegram-bot/chat 24 | #:get-chat) 25 | (:import-from #:cl-telegram-bot/payments 26 | #:make-successful-payment 27 | #:make-pre-checkout-query) 28 | (:import-from #:cl-telegram-bot/user 29 | #:get-user-info) 30 | (:export #:make-update 31 | #:get-raw-data 32 | #:get-update-id 33 | #:process-updates 34 | #:update 35 | #:get-payload)) 36 | (in-package cl-telegram-bot/update) 37 | 38 | 39 | (defclass update () 40 | ((id :initarg :id 41 | :reader get-update-id) 42 | (payload :initarg :payload 43 | :reader get-payload) 44 | (raw-data :initarg :raw-data 45 | :reader get-raw-data))) 46 | 47 | 48 | (defun make-update (data) 49 | (let ((update-id (getf data :|update_id|)) 50 | (payload 51 | (acond 52 | ((getf data :|message|) 53 | (cond 54 | ((getf it :|successful_payment|)) 55 | (t 56 | (make-message it)))) 57 | ((getf data :|edited_message|) 58 | (make-instance 'edited-message 59 | :message (make-message it))) 60 | ((getf data :|channel_post|) 61 | (make-instance 'channel-post 62 | :message (make-message it))) 63 | ((getf data :|edited_channel_post|) 64 | (make-instance 'edited-channel-post 65 | :message (make-message it))) 66 | ((getf data :|callback_query|) 67 | (make-callback *current-bot* 68 | it)) 69 | ((getf data :|pre_checkout_query|) 70 | (make-pre-checkout-query *current-bot* 71 | it)) 72 | ((getf data :|successful_payment|) 73 | (make-successful-payment *current-bot* 74 | it)) 75 | (t 76 | (log:warn "Received not supported update type" 77 | data) 78 | nil)))) 79 | (make-instance 'update 80 | :id update-id 81 | :payload payload 82 | :raw-data data))) 83 | 84 | 85 | (defun get-updates (bot &key limit timeout) 86 | "https://core.telegram.org/bots/api#getupdates" 87 | (let* ((current-id (get-last-update-id bot)) 88 | (results (make-request bot "getUpdates" 89 | :|offset| current-id 90 | :|limit| limit 91 | :|timeout| timeout 92 | :streamp t 93 | :timeout timeout))) 94 | 95 | (let ((updates (mapcar 'make-update results))) 96 | (when updates 97 | (let ((max-id (reduce #'max 98 | updates 99 | :key #'get-update-id))) 100 | ;; In original cl-telegram-bot a bug was here, because 101 | ;; it saved update's id only the first time, and after that, 102 | ;; just incremented that value 103 | (log:debug "Setting new" max-id) 104 | (setf (get-last-update-id bot) 105 | (+ max-id 1)))) 106 | 107 | (values updates)))) 108 | 109 | 110 | ;; Generics 111 | 112 | (defgeneric process-updates (bot) 113 | (:documentation "By default, this method starts an infinite loop and fetching new updates using long polling.")) 114 | 115 | 116 | (defmethod process-updates ((bot t)) 117 | "Starts inifinite loop to process updates using long polling." 118 | (loop with *current-bot* = bot 119 | do (loop for update in (restart-case 120 | (get-updates bot 121 | :timeout 10) 122 | (continue-processing (&optional delay) 123 | :report "Continue processing updates from Telegram" 124 | (when delay 125 | (sleep delay)) 126 | ;; Return no updates 127 | (values))) 128 | do (restart-case 129 | (process bot update) 130 | (continue-processing (&optional delay) 131 | :report "Continue processing updates from Telegram" 132 | (when delay 133 | (sleep delay))))))) 134 | 135 | 136 | (defmethod process ((bot t) (update update)) 137 | "By default, just calls `process' on the payload." 138 | (log:debug "Processing update" update) 139 | (let ((payload (get-payload update))) 140 | (process bot payload))) 141 | 142 | 143 | 144 | (defmethod get-chat ((update update)) 145 | (get-chat (get-payload update))) 146 | 147 | 148 | (defmethod get-user-info ((update update)) 149 | (get-user-info (get-payload update))) 150 | -------------------------------------------------------------------------------- /v2/states/ask-for-text.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2/states/ask-for-text 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot2/generics 4 | #:process-state 5 | #:on-state-activation) 6 | (:import-from #:cl-telegram-bot2/state 7 | #:callback-query-handlers 8 | #:validate-on-deletion-arg 9 | #:base-state) 10 | (:import-from #:cl-telegram-bot2/states/base 11 | #:state-var) 12 | (:import-from #:cl-telegram-bot2/pipeline 13 | #:back) 14 | (:import-from #:cl-telegram-bot2/high 15 | #:reply) 16 | (:import-from #:cl-telegram-bot2/api 17 | #:inline-keyboard-markup 18 | #:message-text 19 | #:update-message) 20 | (:import-from #:str 21 | #:trim) 22 | (:import-from #:serapeum 23 | #:dict 24 | #:-> 25 | #:soft-list-of) 26 | (:import-from #:cl-telegram-bot2/state 27 | #:state) 28 | (:import-from #:cl-telegram-bot2/debug/diagram/generics 29 | #:get-slots) 30 | (:import-from #:cl-telegram-bot2/debug/diagram/slot 31 | #:slot) 32 | (:import-from #:cl-telegram-bot2/state-with-commands 33 | #:state-with-commands-mixin) 34 | (:import-from #:cl-telegram-bot2/match 35 | #:matchp 36 | #:matcher) 37 | (:import-from #:cl-telegram-bot2/matchers/regex 38 | #:regex-matcher) 39 | (:import-from #:cl-telegram-bot2/workflow 40 | #:workflow-blocks) 41 | (:export #:ask-for-text 42 | #:prompt 43 | #:var-name 44 | #:on-success 45 | #:on-validation-error 46 | #:prompt-keyboard 47 | #:text-matcher)) 48 | (in-package #:cl-telegram-bot2/states/ask-for-text) 49 | 50 | 51 | (defparameter *default-var-name* "result") 52 | 53 | 54 | (defclass ask-for-text (state) 55 | ((prompt :initarg :prompt 56 | :type string 57 | :reader prompt) 58 | (prompt-keyboard :initarg :prompt-keyboard 59 | :type (or null inline-keyboard-markup) 60 | :reader prompt-keyboard) 61 | (matcher :initarg :matcher 62 | :type matcher 63 | :reader text-matcher) 64 | (var-name :initarg :to 65 | :initform *default-var-name* 66 | :type string 67 | :reader var-name) 68 | (on-success :initarg :on-success 69 | :initform nil 70 | :type workflow-blocks 71 | :reader on-success) 72 | (on-validation-error :initarg :on-validation-error 73 | :initform nil 74 | :type workflow-blocks 75 | :reader on-validation-error))) 76 | 77 | 78 | (-> ask-for-text (string 79 | &key 80 | (:prompt-keyboard (or null inline-keyboard-markup)) 81 | (:to string) 82 | (:regex string) 83 | (:on-success workflow-blocks) 84 | (:on-validation-error workflow-blocks) 85 | (:on-deletion workflow-blocks) 86 | (:on-callback-query callback-query-handlers) 87 | (:vars (or null hash-table)))) 88 | 89 | (defun ask-for-text (prompt &key 90 | prompt-keyboard 91 | (to *default-var-name*) 92 | (regex ".*") 93 | on-success 94 | on-validation-error 95 | on-deletion 96 | on-callback-query 97 | vars) 98 | 99 | (make-instance 'ask-for-text 100 | :prompt prompt 101 | :prompt-keyboard prompt-keyboard 102 | :matcher (regex-matcher regex) 103 | :to to 104 | :on-success (uiop:ensure-list 105 | on-success) 106 | :on-validation-error (uiop:ensure-list 107 | on-validation-error) 108 | :on-deletion (validate-on-deletion-arg on-deletion) 109 | :on-callback-query on-callback-query 110 | :vars (or vars 111 | (dict)))) 112 | 113 | 114 | (defmethod on-state-activation ((state ask-for-text)) 115 | (let ((keyboard (prompt-keyboard state)) 116 | (args (list (prompt state)))) 117 | (when keyboard 118 | (setf args 119 | (append args 120 | (list :reply-markup keyboard)))) 121 | (apply #'reply args)) 122 | (values)) 123 | 124 | 125 | (defmethod process-state ((bot t) (state ask-for-text) update) 126 | (let* ((message 127 | (update-message 128 | update)) 129 | (text 130 | (when message 131 | (message-text message)))) 132 | 133 | (cond 134 | (text 135 | (let ((trimmed (trim text))) 136 | (cond 137 | ((matchp (text-matcher state) trimmed) 138 | (setf (state-var state 139 | (var-name state)) 140 | trimmed) 141 | 142 | (process-state bot 143 | (on-success state) 144 | update)) 145 | (t 146 | (process-state bot 147 | (on-validation-error state) 148 | update))))) 149 | (t 150 | ;; To make callback queries handler work, 151 | ;; we need to call method of the parent class 152 | (call-next-method))))) 153 | 154 | 155 | (defmethod get-slots ((state ask-for-text)) 156 | (append 157 | (loop for slot-name in (list 158 | 'on-success 159 | 'on-validation-error) 160 | collect 161 | (slot (string-downcase slot-name) 162 | (slot-value state slot-name))) 163 | (call-next-method))) 164 | -------------------------------------------------------------------------------- /src/entities/command.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot/entities/command 2 | (:use #:cl) 3 | (:import-from #:log) 4 | (:import-from #:cl-telegram-bot/entities/generic 5 | #:make-entity-internal) 6 | (:import-from #:cl-telegram-bot/entities/core 7 | #:entity) 8 | (:import-from #:cl-telegram-bot/message 9 | #:message 10 | #:get-text) 11 | (:import-from #:cl-telegram-bot/utils 12 | #:make-keyword) 13 | (:import-from #:cl-telegram-bot/pipeline 14 | #:process) 15 | (:import-from #:cl-telegram-bot/bot 16 | #:bot-info 17 | #:bot 18 | #:sent-commands-cache) 19 | (:import-from #:alexandria 20 | #:assoc-value) 21 | (:import-from #:serapeum 22 | #:soft-alist-of 23 | #:soft-list-of) 24 | (:import-from #:closer-mop 25 | #:generic-function-methods 26 | #:method-specializers) 27 | (:import-from #:cl-telegram-bot/commands 28 | #:set-my-commands) 29 | (:import-from #:str 30 | #:replace-all) 31 | (:import-from #:cl-telegram-bot/user 32 | #:username) 33 | (:export #:get-command 34 | #:bot-command 35 | #:bot-username 36 | #:get-rest-text 37 | #:on-command)) 38 | (in-package #:cl-telegram-bot/entities/command) 39 | 40 | 41 | (defclass bot-command (entity) 42 | ((command :type keyword 43 | :initarg :command 44 | :reader get-command) 45 | (bot-username :type (or null string) 46 | :initarg :bot-username 47 | :reader bot-username) 48 | (rest-text :type string 49 | :initarg :rest-text 50 | :reader get-rest-text))) 51 | 52 | 53 | (defmethod make-entity-internal ((entity-type (eql :bot-command)) 54 | (payload message) data) 55 | (declare (ignorable entity-type)) 56 | (let* ((text (get-text payload)) 57 | (offset (getf data :|offset|)) 58 | (length (getf data :|length|)) 59 | (command-and-probably-bot-username 60 | (subseq text 61 | (+ offset 1) 62 | (+ offset length))) 63 | (rest-text (string-trim " " 64 | (subseq text 65 | (+ offset length))))) 66 | (destructuring-bind (command &optional bot-username) 67 | (str:split #\@ command-and-probably-bot-username 68 | :omit-nulls t 69 | :limit 2) 70 | (make-instance 'bot-command 71 | :command (make-keyword command) 72 | :payload payload 73 | :bot-username bot-username 74 | :rest-text rest-text 75 | :raw-data data)))) 76 | 77 | 78 | (defgeneric on-command (bot command rest-text) 79 | (:documentation "This method will be called for each command. 80 | First argument is a keyword. If user input was /save_note, then 81 | first argument will be :save-note. 82 | 83 | By default, logs call and does nothing.")) 84 | 85 | 86 | (defmethod on-command ((bot t) (command t) rest-text) 87 | (log:debug "Command was called" command rest-text)) 88 | 89 | 90 | (declaim (ftype (function (bot) (soft-list-of closer-mop:method)) 91 | bot-methods)) 92 | 93 | (defun bot-methods (bot) 94 | (loop for method in (generic-function-methods #'on-command) 95 | for specializers = (method-specializers method) 96 | when (eql (first specializers) 97 | (class-of bot)) 98 | collect method)) 99 | 100 | 101 | (declaim (ftype (function (bot) 102 | (soft-alist-of string string)) 103 | bot-commands)) 104 | 105 | (defun bot-commands (bot) 106 | (loop for method in (bot-methods bot) 107 | for specializers = (closer-mop:method-specializers method) 108 | for specializer = (second specializers) 109 | when (typep specializer 'closer-mop:eql-specializer) 110 | collect (cons (replace-all "-" "_" 111 | (string-downcase 112 | (closer-common-lisp:eql-specializer-object specializer))) 113 | (or (documentation method t) 114 | "No documentation.")))) 115 | 116 | 117 | (declaim (ftype (function (bot &key (:command-name-to-check (or null 118 | string))) 119 | (soft-alist-of string string)) 120 | update-commands)) 121 | 122 | (defun update-commands (bot &key command-name-to-check) 123 | (let ((commands (bot-commands bot))) 124 | ;; We don't want to send commands each time when user 125 | ;; enters /blah-something to prevent DoS attacks. 126 | ;; That is why we update commands list on the server 127 | ;; only if command is known: 128 | (when (or (null command-name-to-check) 129 | (assoc-value (sent-commands-cache bot) 130 | command-name-to-check 131 | :test #'string-equal)) 132 | (set-my-commands bot commands)) 133 | 134 | (values commands))) 135 | 136 | 137 | (defmethod process ((bot t) (command bot-command)) 138 | (let* ((command-name (get-command command)) 139 | (command-str-name (str:replace-all "-" "_" 140 | (string-downcase command-name)))) 141 | (unless (assoc-value (sent-commands-cache bot) 142 | command-str-name 143 | :test #'string-equal) 144 | (setf (sent-commands-cache bot) 145 | (update-commands bot 146 | :command-name-to-check command-str-name))) 147 | 148 | (when (or (null (bot-username command)) 149 | (string-equal (bot-username command) 150 | (username (bot-info bot)))) 151 | (on-command bot 152 | command-name 153 | (get-rest-text command))))) 154 | 155 | -------------------------------------------------------------------------------- /src/response.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot/response 2 | (:use #:cl) 3 | (:import-from #:cl-telegram-bot/message 4 | #:message 5 | #:get-chat 6 | #:send-message 7 | #:*current-message* 8 | #:*current-bot*) 9 | (:import-from #:cl-telegram-bot/response-processing 10 | #:interrupt-processing 11 | #:process-response) 12 | (:import-from #:cl-telegram-bot/callback 13 | #:callback-message 14 | #:callback) 15 | (:import-from #:cl-telegram-bot/inline-keyboard 16 | #:answer-callback-query) 17 | (:import-from #:cl-telegram-bot/markup 18 | #:to-markup) 19 | (:import-from #:alexandria 20 | #:removef 21 | #:remove-from-plistf) 22 | (:export #:response-text 23 | #:reply 24 | #:notify 25 | #:open-url 26 | #:alert 27 | #:response 28 | #:url-to-open 29 | #:rest-args 30 | #:response-with-text)) 31 | (in-package #:cl-telegram-bot/response) 32 | 33 | 34 | (defclass response () 35 | ((args :initarg :args 36 | :type list 37 | :reader rest-args))) 38 | 39 | 40 | (defclass response-with-text (response) 41 | ((text :initarg :text 42 | :reader response-text))) 43 | 44 | 45 | (defclass reply (response-with-text) 46 | ()) 47 | 48 | 49 | (defclass notify (response-with-text) 50 | ()) 51 | 52 | 53 | (defclass alert (response-with-text) 54 | ()) 55 | 56 | 57 | (defclass open-url (response) 58 | ((url :initarg :text 59 | :type string 60 | :reader url-to-open))) 61 | 62 | 63 | (defvar *reply-immediately* t 64 | "This variable will be set to NIL when REPLY function is called inside the async flow. Otherwise flow will hang because of non-local exit from the step.") 65 | 66 | 67 | (defun reply (text 68 | &rest args 69 | &key 70 | ;; Set this to "markdown" to allow rich formatting 71 | ;; https://core.telegram.org/bots/api#formatting-options 72 | parse-mode 73 | disable-web-page-preview 74 | disable-notification 75 | reply-to-message-id 76 | reply-markup 77 | (immediately *reply-immediately*)) 78 | (declare (ignorable parse-mode 79 | disable-web-page-preview 80 | disable-notification 81 | reply-to-message-id)) 82 | "Works like a SEND-MESSAGE, but only when an incoming message is processed. 83 | Automatically sends reply to a chat from where current message came from." 84 | (unless (and (boundp '*current-bot*) 85 | (boundp '*current-message*)) 86 | (error "Seems (reply ~S) was called outside of processing pipeline, because no current message is available." 87 | text)) 88 | 89 | (when reply-markup 90 | (setf (getf args :reply-markup) 91 | (to-markup reply-markup))) 92 | 93 | (remove-from-plistf args :immediately) 94 | 95 | (process-response *current-bot* 96 | *current-message* 97 | (make-instance 'reply 98 | :text text 99 | :args args)) 100 | (when immediately 101 | (interrupt-processing))) 102 | 103 | 104 | (defun notify (text) 105 | "Works like a SEND-MESSAGE, but only when an incoming message is processed. 106 | Automatically sends reply to a chat from where current message came from." 107 | (unless (and (boundp '*current-bot*) 108 | (boundp '*current-message*)) 109 | (error "Seems (notify ~S) was called outside of processing pipeline, because no current message is available." 110 | text)) 111 | 112 | (process-response *current-bot* 113 | *current-message* 114 | (make-instance 'notify 115 | :text text))) 116 | 117 | 118 | (defun alert (text) 119 | "Works like a SEND-MESSAGE, but only when an incoming message is processed. 120 | Automatically sends reply to a chat from where current message came from." 121 | (unless (and (boundp '*current-bot*) 122 | (boundp '*current-message*)) 123 | (error "Seems (alert ~S) was called outside of processing pipeline, because no current message is available." 124 | text)) 125 | 126 | (process-response *current-bot* 127 | *current-message* 128 | (make-instance 'alert 129 | :text text))) 130 | 131 | 132 | (defun open-url (url) 133 | "Works like a SEND-MESSAGE, but only when an incoming message is processed. 134 | Automatically sends reply to a chat from where current message came from." 135 | (unless (and (boundp '*current-bot*) 136 | (boundp '*current-message*)) 137 | (error "Seems (open-url ~S) was called outside of processing pipeline, because no current message is available." 138 | url)) 139 | 140 | (process-response *current-bot* 141 | *current-message* 142 | (make-instance 'open-url 143 | :url url))) 144 | 145 | 146 | (defmethod process-response ((bot t) (message message) (response reply)) 147 | (apply #'send-message 148 | bot 149 | (get-chat message) 150 | (response-text response) 151 | (rest-args response))) 152 | 153 | 154 | (defmethod process-response ((bot t) (callback callback) (response reply)) 155 | (apply #'send-message 156 | bot 157 | (get-chat (callback-message callback)) 158 | (response-text response) 159 | (rest-args response)) 160 | ;; And we need to send empty callback answer, just to hide loading process bar. 161 | (answer-callback-query bot 162 | callback)) 163 | 164 | 165 | (defmethod process-response ((bot t) (message callback) (response notify)) 166 | (answer-callback-query bot 167 | message 168 | :text (response-text response))) 169 | 170 | 171 | (defmethod process-response ((bot t) (message callback) (response alert)) 172 | (answer-callback-query bot 173 | message 174 | :text (response-text response) 175 | :show-alert t)) 176 | 177 | 178 | (defmethod process-response ((bot t) (message callback) (response open-url)) 179 | (answer-callback-query bot 180 | message 181 | :url (url-to-open response))) 182 | 183 | 184 | -------------------------------------------------------------------------------- /examples/all.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:cl-telegram-bot2-examples 2 | (:use #:cl) 3 | (:nicknames #:cl-telegram-bot2-examples/all) 4 | (:import-from #:40ants-logging) 5 | (:import-from #:bordeaux-threads) 6 | (:import-from #:cl-telegram-bot2/state 7 | #:state) 8 | (:import-from #:cl-telegram-bot2/server 9 | #:stop-polling 10 | #:start-polling) 11 | (:import-from #:cl-telegram-bot2/actions/send-text 12 | #:send-text) 13 | (:import-from #:cl-telegram-bot2/state-with-commands 14 | #:global-command 15 | #:command) 16 | (:import-from #:cl-telegram-bot2-examples/calc) 17 | (:import-from #:cl-telegram-bot2-examples/commands) 18 | (:import-from #:cl-telegram-bot2-examples/gallery) 19 | (:import-from #:cl-telegram-bot2-examples/payments) 20 | (:import-from #:cl-telegram-bot2-examples/mini-app) 21 | (:import-from #:cl-telegram-bot2-examples/echo) 22 | (:import-from #:cl-telegram-bot2-examples/text-chain) 23 | (:import-from #:cl-telegram-bot2/high/keyboard 24 | #:inline-keyboard 25 | #:call-callback) 26 | (:import-from #:cl-telegram-bot2/bot 27 | #:initial-state) 28 | (:import-from #:cl-telegram-bot2/term/back 29 | #:back-to-id) 30 | (:import-from #:cl-telegram-bot2/actions/delete-messages 31 | #:delete-messages) 32 | (:import-from #:cl-telegram-bot2/api 33 | #:pre-checkout-query 34 | #:pre-checkout-query-id 35 | #:answer-pre-checkout-query) 36 | (:import-from #:cl-telegram-bot2/generics 37 | #:on-pre-checkout-query) 38 | (:import-from #:cl-telegram-bot2/callback 39 | #:callback-data 40 | #:callback) 41 | (:import-from #:cl-telegram-bot2/debug/diagram 42 | #:render-workflow-diagram) 43 | (:export 44 | #:start 45 | #:stop)) 46 | (in-package #:cl-telegram-bot2-examples) 47 | 48 | 49 | (defclass all-examples-bot (cl-telegram-bot2/bot::bot) 50 | ()) 51 | 52 | 53 | (defun show-menu-buttons () 54 | (send-text "Choose an example to run:" 55 | :reply-markup 56 | (inline-keyboard 57 | (list 58 | (list 59 | (call-callback "Echo" 60 | "open-echo") 61 | (call-callback "Text Chain" 62 | "open-text-chain") 63 | (call-callback "Calc" 64 | "open-calc")) 65 | (list 66 | (call-callback "Commands" 67 | "open-commands") 68 | (call-callback "Gallery" 69 | "open-gallery") 70 | (call-callback "Mini-app" 71 | "open-mini-app")) 72 | (list 73 | (call-callback "Payments" 74 | "open-payments")))))) 75 | 76 | 77 | (defun make-mega-bot (token &rest args) 78 | (let* ((calc-state (initial-state 79 | (cl-telegram-bot2-examples/calc::make-test-bot token))) 80 | (echo-state (initial-state 81 | (cl-telegram-bot2-examples/echo::make-test-bot token))) 82 | (text-chain-state (initial-state 83 | (cl-telegram-bot2-examples/text-chain::make-test-bot token))) 84 | (commands-state (initial-state 85 | (cl-telegram-bot2-examples/commands::make-test-bot token))) 86 | (gallery-state (initial-state 87 | (cl-telegram-bot2-examples/gallery::make-test-bot token))) 88 | (mini-app-state (initial-state 89 | (cl-telegram-bot2-examples/mini-app::make-test-bot token))) 90 | (payments-state (initial-state 91 | (cl-telegram-bot2-examples/payments::make-test-bot token))) 92 | (mega-state 93 | (state 'show-menu-buttons 94 | :id "megabot-main-menu" 95 | :commands (list (global-command "/menu" 96 | (list (delete-messages) 97 | (back-to-id "megabot-main-menu")) 98 | :description "Show menu with all examples.") 99 | (global-command "/debug" 100 | (render-workflow-diagram) 101 | :description "Show menu with all examples.")) 102 | :on-result 'show-menu-buttons 103 | :on-callback-query (list (callback "open-echo" 104 | (list (delete-messages) 105 | echo-state)) 106 | (callback "open-text-chain" 107 | (list (delete-messages) 108 | text-chain-state)) 109 | (callback "open-calc" 110 | (list (delete-messages) 111 | calc-state)) 112 | (callback "open-commands" 113 | (list (delete-messages) 114 | commands-state)) 115 | (callback "open-gallery" 116 | (list (delete-messages) 117 | gallery-state)) 118 | (callback "open-mini-app" 119 | (list (delete-messages) 120 | mini-app-state)) 121 | (callback "open-payments" 122 | (list (delete-messages) 123 | payments-state)))))) 124 | (apply #'make-instance 125 | 'all-examples-bot 126 | :token token 127 | :initial-state mega-state 128 | args))) 129 | 130 | 131 | (defmethod on-pre-checkout-query ((bot all-examples-bot) (query pre-checkout-query)) 132 | (answer-pre-checkout-query (pre-checkout-query-id query) 133 | t) 134 | (values)) 135 | 136 | 137 | (defvar *bot* nil) 138 | 139 | 140 | (defun start (&key (log-level :warn) (debug t)) 141 | (stop) 142 | 143 | (40ants-logging:setup-for-repl :level log-level) 144 | 145 | (unless *bot* 146 | (setf *bot* 147 | (make-mega-bot (uiop:getenv "TELEGRAM_TOKEN")))) 148 | 149 | (start-polling *bot* :debug debug)) 150 | 151 | 152 | (defun stop () 153 | (when *bot* 154 | (stop-polling *bot*) 155 | (setf *bot* nil) 156 | 157 | (sleep 1) 158 | (bt:all-threads))) 159 | 160 | --------------------------------------------------------------------------------