From b4c1f66e1631f40d8a7d0f80523470677a91381f Mon Sep 17 00:00:00 2001 From: Uko Kokņevičs Date: Fri, 10 Oct 2025 12:30:46 +0300 Subject: Bunch of changes - Animations - Rewrite of serialization deserialization - Bunch of new TG types --- src/bot/advanced.lisp | 27 ++++++++++++++- src/bot/impl.lisp | 91 ++++++++++++++++++++++++++++++--------------------- src/bot/methods.lisp | 46 ++++++++++++++++++-------- 3 files changed, 113 insertions(+), 51 deletions(-) (limited to 'src/bot') diff --git a/src/bot/advanced.lisp b/src/bot/advanced.lisp index a6ad9ba..241b04d 100644 --- a/src/bot/advanced.lisp +++ b/src/bot/advanced.lisp @@ -2,7 +2,7 @@ ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/bot/advanced (:use :c2cl :ukkoclot/bot/impl :ukkoclot/bot/methods :ukkoclot/tg-types) - (:export :bot-id :bot-username :reply-message)) + (:export :bot-id :bot-username :reply-animation :reply-message :try-delete-message)) (in-package :ukkoclot/bot/advanced) (defun bot-id (bot) @@ -17,6 +17,20 @@ (get-me bot) (bot-username% bot)))) +;; TODO: Some kind of caching for files? +(defun reply-animation (bot msg animation &key allow-sending-without-reply text parse-mode caption-above) + (send-animation bot + :chat-id (message-chat-id msg) + :animation animation + :caption text + :parse-mode parse-mode + :show-caption-above-media caption-above + :reply-parameters + (make-reply-parameters + :allow-sending-without-reply allow-sending-without-reply + :message-id (message-id msg) + :chat-id (message-chat-id msg)))) + (defun reply-message (bot msg text &key parse-mode allow-sending-without-reply) (send-message bot :chat-id (message-chat-id msg) @@ -27,3 +41,14 @@ :allow-sending-without-reply allow-sending-without-reply :message-id (message-id msg) :chat-id (message-chat-id msg)))) + +(defun try-delete-message (bot msg) + (handler-case + (delete-message bot + :chat-id (message-chat-id msg) + :message-id (message-id msg)) + (error () + (handler-case + (reply-animation bot msg #P"blob/do-not.mp4" + :allow-sending-without-reply nil) + (error () nil))))) diff --git a/src/bot/impl.lisp b/src/bot/impl.lisp index b57e2d3..57a9572 100644 --- a/src/bot/impl.lisp +++ b/src/bot/impl.lisp @@ -8,41 +8,62 @@ (:local-nicknames (:jzon :com.inuoe.jzon)) (:export - :arg-encode :bot :bot-p :make-bot :do-call + :bot :bot-p :make-bot :fixup-value :do-call :parse-value :bot-config :bot-db :bot-base-uri :bot-power-on :bot-username% :bot-id%)) (in-package :ukkoclot/bot/impl) -(defgeneric will-arg-encode (object) - (:documentation "Whether the OBJECT has any transformation done to it by arg-encode") - (:method (obj) - nil) - (:method ((obj cons)) - (or (will-arg-encode (car obj)) - (will-arg-encode (cdr obj))))) +(defgeneric parse-value (type json) + (:documentation "Parse value of TYPE from the parsed JSON") + (:method (type json) + (log-error "I don't know how to parse simple type ~A!" type) + (error "I don't know how to parse simple type ~A!" type)) + (:method ((type (eql 'boolean)) json) + (check-type json boolean) + json) + (:method ((type (eql 'integer)) json) + (check-type json integer) + json) + (:method ((type (eql 'null)) json) + (check-type json null) + json) + (:method ((type (eql 'string)) json) + (check-type json string) + json)) -(defgeneric arg-encode (object) - (:documentation "Encode the OBJECT to a form that our HTTP code is happy about.") - (:method (obj) - obj) - (:method ((obj cons)) - (if (not (will-arg-encode obj)) - obj - (cons (arg-encode (car obj)) - (arg-encode (cdr obj)))))) +(defun try-parse-value (type json) + (handler-case (values t (parse-value type json)) + (error () (values nil nil)))) -(defgeneric fixup-arg (value) - (:documentation "Make sure Telegram & QURI & whatever like the arg") +(defmethod parse-value ((type cons) json) + (cond ((and (eq (car type) 'array) + (null (cddr type))) + (when json + (let ((element-type (cadr type))) + (iter (for element in-vector json) + (collect (parse-value element-type element) result-type vector))))) + ((eq (car type) 'or) + (iter (for el-type in (cdr type)) + (multiple-value-bind (success res) (try-parse-value el-type json) + (when success + (return res))) + (finally + (error "Failed to parse ~S as ~A!" json type)))) + (t + (error "I don't know how to parse complex type ~A!" type)))) + +(defgeneric fixup-value (value) + (:documentation "Fixup top-level VALUE before passing it onto telegram") (:method (value) - (error "Unsupported argument type ~S (~S)" (class-name (class-of value)) value)) + (jzon:stringify value)) (:method ((value null)) value) (:method ((value number)) value) - (:method ((value string)) + (:method ((value pathname)) value) - (:method ((value hash-table)) - (jzon:stringify value))) + (:method ((value string)) + value)) (defstruct (bot (:constructor make-bot%)) (config (error "No value given for config") :read-only t) @@ -58,39 +79,35 @@ (config-bot-token config) "/"))) (make-bot% :config config :db db :base-uri base-uri))) -(defun args-plist->alist (args-plist) - (iter (for (old-key value) on args-plist by #'cddr) +(defun fixup-args (args) + (iter (for (key . value) in args) (collect - (let ((new-key (string-downcase (lisp->snake-case (symbol-name old-key))))) - (cons new-key value))))) - -(defun fixup-args (args-alist) - (iter (for (name . value) in args-alist) - (collecting (cons name (fixup-arg (arg-encode value)))))) + (cons (string-downcase (lisp->snake-case (symbol-name key))) + (fixup-value value))))) (defun req (uri method content) ;; We deal with this manually (handler-bind ((dex:http-request-too-many-requests #'dex:ignore-and-continue)) (dex:request uri :method method :content content))) -(defun do-call% (bot method uri mapfn args-encoded) +(defun do-call% (bot method uri type args-encoded) (let ((body (req uri method args-encoded))) (let ((hash (jzon:parse body))) (acond - ((gethash "ok" hash) (funcall mapfn (gethash "result" hash))) + ((gethash "ok" hash) (parse-value type (gethash "result" hash))) ((aand (gethash "parameters" hash) (gethash "retry_after" it)) (log-info "Should sleep for ~A seconds" it) (sleep it) (log-info "Good morning!") - (do-call% bot method uri mapfn args-encoded)) + (do-call% bot method uri type args-encoded)) (t (error "TG error ~A: ~A ~:A" (gethash "error_code" hash) (gethash "description" hash) (gethash "parameters" hash))))))) -(defun do-call (bot method path mapfn args-plist) +(defun do-call (bot method path type args) (let ((uri (concatenate 'string (bot-base-uri bot) path)) - (args-encoded (fixup-args (args-plist->alist args-plist)))) + (args-encoded (fixup-args args))) (log-debug "~A .../~A ~S" method path args-encoded) - (do-call% bot method uri mapfn args-encoded))) + (do-call% bot method uri type args-encoded))) diff --git a/src/bot/methods.lisp b/src/bot/methods.lisp index 99b6411..7ccc4ad 100644 --- a/src/bot/methods.lisp +++ b/src/bot/methods.lisp @@ -2,22 +2,22 @@ ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/bot/methods (:use :c2cl :ukkoclot/bot/impl :ukkoclot/tg-types :ukkoclot/tg-types/macros) - (:export :answer-callback-query :delete-message :edit-message-text :get-me :get-updates :send-message :set-my-name)) + (:export :answer-callback-query :delete-message :send-animation :edit-message-text :get-me :get-updates :send-message :set-my-name)) (in-package :ukkoclot/bot/methods) -(define-tg-method (answer-callback-query boolean "answerCallbackQuery" #'identity) +(define-tg-method (answer-callback-query boolean "answerCallbackQuery") (callback-query-id string) (text (or string null) nil) (show-alert boolean nil) (url (or string null) nil) (cache-time (or integer null) nil)) -(define-tg-method (delete-message boolean "deleteMessage" #'identity) +(define-tg-method (delete-message boolean "deleteMessage") (chat-id (or integer string)) (message-id integer)) ;; TODO: Add a way to simply specify :message msg :) -(define-tg-method (edit-message-text message "editMessageText" #'hash->message) +(define-tg-method (edit-message-text message "editMessageText") (business-connection-id (or string null) nil) (chat-id (or integer string null) nil) (message-id (or integer null) nil) @@ -28,7 +28,7 @@ (link-preview-options (or link-preview-options null) nil) (reply-markup (or inline-keyboard-markup null) nil)) -(define-tg-method (get-me% user "getMe" #'hash->user :GET)) +(define-tg-method (get-me% user "getMe" :GET)) (defun get-me (bot) (let ((res (get-me% bot))) @@ -36,16 +36,39 @@ (setf (bot-username% bot) (user-username res)) res)) -(define-tg-method (get-my-name bot-name "getMyName" #'hash->bot-name :GET) +(define-tg-method (get-my-name bot-name "getMyName" :GET) (language-code (or string null) nil)) -(define-tg-method (get-updates (array update) "getUpdates" #'parse-update-array) +(define-tg-method (get-updates (array update) "getUpdates") (offset (or integer null) nil) (limit (or integer null) nil) (timeout (or integer null) nil) (allowed-updates (or string null) nil)) -(define-tg-method (send-message message "sendMessage" #'hash->message) +(define-tg-method (send-animation message "sendAnimation") + (business-connection-id (or string null) nil) + (chat-id (or integer string)) + (message-thread-id (or integer null) nil) + (direct-messages-topic-id (or integer null) nil) + (animation (or pathname string)) + (duration (or integer null) nil) + (width (or integer null) nil) + (height (or integer null) nil) + (thumbnail (or pathname string null) nil) + (caption (or string null) nil) + (parse-mode (or string null) nil) + (caption-entities (or (array message-entity) null) nil) + (show-caption-above-media boolean nil) + (has-spoiler boolean nil) + (disable-notification boolean nil) + (protect-content boolean nil) + (allow-paid-broadcast boolean nil) + (message-effect-id (or string null) nil) + (suggested-post-parameters (or suggested-post-parameters null) nil) + (reply-parameters (or reply-parameters null) nil) + (reply-markup (or inline-keyboard-markup reply-keyboard-markup reply-keyboard-remove force-reply null) nil)) + +(define-tg-method (send-message message "sendMessage") (business-connection-id (or string null) nil) (chat-id (or integer string)) (message-thread-id (or integer null) nil) @@ -58,12 +81,9 @@ (protect-content (or boolean null) nil) (message-effect-id (or string null) nil) (reply-parameters (or reply-parameters null) nil) - (reply-markup (or inline-keyboard-markup - ;; TODO: reply-keyboard-markup - ;; TODO: reply-keyboard-remove - force-reply null) nil)) + (reply-markup (or inline-keyboard-markup reply-keyboard-markup reply-keyboard-remove force-reply null) nil)) -(define-tg-method (set-my-name% boolean "setMyName" #'identity) +(define-tg-method (set-my-name% boolean "setMyName") (name (or string null) nil) (language-code (or string null) nil)) -- cgit v1.2.3