mirror of
https://github.com/vale981/cl-telegram-bot
synced 2025-03-05 09:41:39 -05:00
Add reply-checker
This commit is contained in:
parent
5e77e1ccac
commit
d16266cbd2
4 changed files with 1122 additions and 1189 deletions
|
|
@ -2,8 +2,8 @@
|
|||
:description "Telegram Bot API"
|
||||
:author "Rei <https://github.com/sovietspaceship>"
|
||||
:license "MIT"
|
||||
:depends-on (#:cl-json #:alexandria #:closer-mop #:dexador)
|
||||
:depends-on (#:cl-json #:alexandria #:closer-mop #:dexador #:lparallel #:trivial-types)
|
||||
:serial t
|
||||
:components ((:file "package")
|
||||
(:file "cl-telegram-bot")
|
||||
(:file "API")))
|
||||
(:file "API")
|
||||
(:file "cl-telegram-bot")))
|
||||
|
|
|
|||
|
|
@ -22,10 +22,16 @@
|
|||
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
;; SOFTWARE.
|
||||
|
||||
|
||||
(in-package :cl-telegram-bot)
|
||||
|
||||
(alexandria:define-constant +http-ok+ 200 :test #'=)
|
||||
(defvar *bot* nil)
|
||||
(alexandria:define-constant +return-var+ '*)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; Basic BOT Implementation ;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defclass bot ()
|
||||
((id
|
||||
:documentation "Update id"
|
||||
|
|
@ -48,6 +54,14 @@
|
|||
:initarg :file-endpoint
|
||||
:accessor file-endpoint
|
||||
:documentation "HTTPS file-endpoint"
|
||||
:initform nil)
|
||||
(update-hooks
|
||||
:documentation "A list of functions to call after retrieving updates by FETCH-UPDATES."
|
||||
:type (proper-list function)
|
||||
:initform nil)
|
||||
(reply-queue
|
||||
:type (proper-list function)
|
||||
:documentation "A queue for storing reply fetchers."
|
||||
:initform nil)))
|
||||
|
||||
(defmethod initialize-instance :after ((object bot) &key &allow-other-keys)
|
||||
|
|
@ -58,6 +72,31 @@
|
|||
(setf endpoint (concatenate 'string api-uri "bot" token "/")
|
||||
file-endpoint (concatenate 'string api-uri "file/" "bot" token "/"))))
|
||||
|
||||
(defgeneric add-reply-fetcher (bot fetcher)
|
||||
(:documentation "Adds a reply fetcher function that takes one argument of type *UPDATE and returns T if the update is the desired reply. Returns a PROMISE."))
|
||||
|
||||
(defmethod add-reply-fetcher ((bot bot) fetcher)
|
||||
(let ((promise (lparallel:promise)))
|
||||
(push `(,promise . ,fetcher) (slot-value bot 'reply-queue))
|
||||
promise))
|
||||
|
||||
(defgeneric process-updates (bot updates)
|
||||
(:documentation "Processes the updates fetched by FETCH-UPDATES to detect commands and replies."))
|
||||
|
||||
;; check types before
|
||||
(defmethod process-updates :before (bot updates)
|
||||
(declare (type (vector *update) updates)))
|
||||
|
||||
(defmethod process-updates ((bot bot) updates)
|
||||
(with-slots (reply-queue) bot ; Process reply-fetchers
|
||||
(let ((unresolved nil))
|
||||
(loop for update across updates do
|
||||
(dolist (fetcher-cons reply-queue)
|
||||
(if (funcall (cdr fetcher-cons) update)
|
||||
(lparallel:fulfill (car fetcher-cons) update)
|
||||
(push fetcher-cons unresolved))))
|
||||
(setf reply-queue unresolved))))
|
||||
|
||||
(defun make-bot (token)
|
||||
"Create a new bot instance. Takes a token string."
|
||||
(make-instance 'bot :token token))
|
||||
|
|
@ -93,19 +132,22 @@
|
|||
(recursive-change-class value type))))))
|
||||
object)
|
||||
|
||||
(defun make-request (b name options &key (streamp nil) (return-type nil))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; HELPERS ;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun make-request (b name options &key (return-type nil))
|
||||
"Perform HTTP request to 'name API method with 'options JSON-encoded object."
|
||||
(let* ((results (multiple-value-list
|
||||
(handler-bind ((dex:http-request-bad-request #'dex:ignore-and-continue))
|
||||
(dex:request
|
||||
(concatenate 'string (endpoint b) name)
|
||||
:method :post
|
||||
:want-stream streamp
|
||||
:want-stream t
|
||||
:headers '(("Content-Type" . "Application/Json"))
|
||||
:content (json:encode-json-alist-to-string options)))))
|
||||
(message (nth 0 results)))
|
||||
;; (when (<= 400 status 599)
|
||||
;; (error 'request-error :what (format nil "request to ~A returned ~A (~A)" name status reason)))
|
||||
|
||||
(with-slots (ok result description) (decode message)
|
||||
(if ok
|
||||
(if return-type ; wether to cast into a known custom class or not
|
||||
|
|
@ -136,7 +178,7 @@
|
|||
(defgeneric decode (object))
|
||||
|
||||
(defmethod decode ((object stream))
|
||||
(let ((json:*json-symbols-package* nil))
|
||||
(let ((json:*json-symbols-package* :cl-telegram-bot))
|
||||
(json:with-decoder-simple-clos-semantics
|
||||
(prog1
|
||||
(json:decode-json object)
|
||||
|
|
@ -188,17 +230,87 @@
|
|||
"Finds the latest update id from a sequence of updates."
|
||||
(reduce #'max updates :key #'tg-update--id :from-end t))
|
||||
|
||||
(defun get-updates (b &key limit timeout)
|
||||
"https://core.telegram.org/bots/api#getupdates"
|
||||
(defgeneric fetch-updates (bot &key limit timeout)
|
||||
(:documentation "Fetches updates from the API. See https://core.telegram.org/bots/api#getupdates."))
|
||||
|
||||
(defmethod fetch-updates ((b bot) &key limit timeout)
|
||||
(let* ((current-id (id b))
|
||||
(results (make-request b "getUpdates"
|
||||
`(,(cons :offset current-id)
|
||||
,(when limit `(cons :limit ,limit))
|
||||
,(when timeout `(cons :limit ,timeout)))
|
||||
:streamp t
|
||||
:return-type '*UPDATE)))
|
||||
(results ($ (get-updates
|
||||
:limit limit
|
||||
:timeout timeout
|
||||
:offset current-id)
|
||||
(:bot b))))
|
||||
(when (> (length results) 0)
|
||||
(let ((id (get-latest-update-id results)))
|
||||
(setf (id b) id)
|
||||
(incf (id b) 1)))
|
||||
(process-updates b results)
|
||||
results))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; CONVENIENCE INTERFACE ;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun make-optional-body (body return-var return-val-sym)
|
||||
"Make the body part of the $ (api call macro)."
|
||||
(if body
|
||||
`(let ((,return-var ,return-val-sym))
|
||||
(wrap-$ ,@body))
|
||||
return-val-sym))
|
||||
|
||||
(defmacro wrap-$ (&rest body)
|
||||
"Wraps all forms following (:INLINE [$|$*] ...) into ([$|$*] ...)$."
|
||||
(let ((index
|
||||
(position nil body
|
||||
:test #'(lambda (_ el)
|
||||
(declare (ignore _))
|
||||
(and (listp el) (eq (car el) :inline)
|
||||
(or (eq (second el) '$*)
|
||||
(eq (second el) '$)))))))
|
||||
(if index
|
||||
`(progn ,@(subseq body 0 index) ,(nconc (cdr (nth index body)) (subseq body (1+ index))))
|
||||
`(progn ,@body))))
|
||||
|
||||
(defun make-$-method-call (method bot args)
|
||||
"Generate a call to MAKE-REQUEST."
|
||||
`(apply #'make-request (cons ,bot (,method ,@args))))
|
||||
|
||||
(defun make-$-reply-fetcher (bot reply-fetcher)
|
||||
`(add-reply-fetcher ,bot ,(cdr reply-fetcher)))
|
||||
|
||||
(defmacro $* ((method &rest args) &body body)
|
||||
"Call api method with standard BOT and RESULT-VAR. See $."
|
||||
`($ (,method ,@args) () ,@body))
|
||||
|
||||
(defmacro $ ((method &rest args)
|
||||
(&key (bot '*bot*) (return-var +return-var+) (parallel nil) (with-reply nil))
|
||||
&body body)
|
||||
"Call an API method. If a body is given the result of the call will be bound to RETURN-VAR and the body will be included. Subsequent calls to $ can be inlined like ($ ... FORMS (:INLINE $ ...) FORMS*) => ($ ... FORMS ($ ... FORMS*))."
|
||||
(when (not (find method *api-methods*)) (error "No such API method."))
|
||||
(let ((return-val-sym (gensym)))
|
||||
`(let ((,return-val-sym ,(if parallel
|
||||
`(lparallel:future ,(make-$-method-call method bot args))
|
||||
(make-$-method-call method bot args)))
|
||||
,@(when with-reply
|
||||
(check-type with-reply cons)
|
||||
`((,(car with-reply)
|
||||
,(make-$-reply-fetcher bot with-reply)
|
||||
))))
|
||||
,(make-optional-body body return-var return-val-sym))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; Convenience Wrappers ;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun make-inline-keyboard (keys)
|
||||
"Make an inline keyboard markup from an array of arrays of initializer lists of *INLINE-KEYBOARD-BUTTON."
|
||||
(declare (type list keys))
|
||||
(make-instance
|
||||
'*inline-keyboard-markup
|
||||
:inline--keyboard (mapcar
|
||||
#'(lambda (keys)
|
||||
(mapcar #'(lambda (key)
|
||||
(apply #'make-instance `(*inline-keyboard-button ,@key)))
|
||||
keys))
|
||||
keys)))
|
||||
|
|
|
|||
148
package.lisp
148
package.lisp
|
|
@ -1,153 +1,13 @@
|
|||
(defpackage :cl-telegram-bot
|
||||
(:nicknames :telegram-bot :tg-bot)
|
||||
(:size 55)
|
||||
(:use :closer-common-lisp :closer-mop)
|
||||
(:EXPORT :*USER
|
||||
:*CHAT
|
||||
:*MESSAGE
|
||||
:*MESSAGE-ENTITY
|
||||
:*PHOTO-SIZE
|
||||
:*AUDIO
|
||||
:*DOCUMENT
|
||||
:*VIDEO
|
||||
:*ANIMATION
|
||||
:*VOICE
|
||||
:*VIDEO-NOTE
|
||||
:*CONTACT
|
||||
:*LOCATION
|
||||
:*VENUE
|
||||
:*POLL-OPTION
|
||||
:*POLL
|
||||
:*USER-PROFILE-PHOTOS
|
||||
:*FILE
|
||||
:*REPLY-KEYBOARD-MARKUP
|
||||
:*KEYBOARD-BUTTON
|
||||
:*REPLY-KEYBOARD-REMOVE
|
||||
:*INLINE-KEYBOARD-MARKUP
|
||||
:*INLINE-KEYBOARD-BUTTON
|
||||
:*LOGIN-URL
|
||||
:*CALLBACK-QUERY
|
||||
:*FORCE-REPLY
|
||||
:*CHAT-PHOTO
|
||||
:*CHAT-MEMBER
|
||||
:*CHAT-PERMISSIONS
|
||||
:*RESPONSE-PARAMETERS
|
||||
:*INPUT-MEDIA
|
||||
:*INPUT-MEDIA-PHOTO
|
||||
:*INPUT-MEDIA-VIDEO
|
||||
:*INPUT-MEDIA-ANIMATION
|
||||
:*INPUT-MEDIA-AUDIO
|
||||
:*INPUT-MEDIA-DOCUMENT
|
||||
:*INPUT-FILE
|
||||
:GET-ME
|
||||
:SEND-MESSAGE
|
||||
:FORWARD-MESSAGE
|
||||
:SEND-PHOTO
|
||||
:SEND-AUDIO
|
||||
:SEND-DOCUMENT
|
||||
:SEND-VIDEO
|
||||
:SEND-ANIMATION
|
||||
:SEND-VOICE
|
||||
:SEND-VIDEO-NOTE
|
||||
:SEND-MEDIA-GROUP
|
||||
:SEND-LOCATION
|
||||
:EDIT-MESSAGE-LIVE-LOCATION
|
||||
:STOP-MESSAGE-LIVE-LOCATION
|
||||
:SEND-VENUE
|
||||
:SEND-CONTACT
|
||||
:SEND-POLL
|
||||
:SEND-CHAT-ACTION
|
||||
:GET-USER-PROFILE-PHOTOS
|
||||
:GET-FILE
|
||||
:KICK-CHAT-MEMBER
|
||||
:UNBAN-CHAT-MEMBER
|
||||
:RESTRICT-CHAT-MEMBER
|
||||
:PROMOTE-CHAT-MEMBER
|
||||
:SET-CHAT-PERMISSIONS
|
||||
:EXPORT-CHAT-INVITE-LINK
|
||||
:SET-CHAT-PHOTO
|
||||
:DELETE-CHAT-PHOTO
|
||||
:SET-CHAT-TITLE
|
||||
:SET-CHAT-DESCRIPTION
|
||||
:PIN-CHAT-MESSAGE
|
||||
:UNPIN-CHAT-MESSAGE
|
||||
:LEAVE-CHAT
|
||||
:GET-CHAT
|
||||
:GET-CHAT-ADMINISTRATORS
|
||||
:GET-CHAT-MEMBERS-COUNT
|
||||
:GET-CHAT-MEMBER
|
||||
:SET-CHAT-STICKER-SET
|
||||
:DELETE-CHAT-STICKER-SET
|
||||
:ANSWER-CALLBACK-QUERY
|
||||
:EDIT-MESSAGE-TEXT
|
||||
:EDIT-MESSAGE-CAPTION
|
||||
:EDIT-MESSAGE-MEDIA
|
||||
:EDIT-MESSAGE-REPLY-MARKUP
|
||||
:STOP-POLL
|
||||
:DELETE-MESSAGE
|
||||
:*STICKER
|
||||
:*STICKER-SET
|
||||
:*MASK-POSITION
|
||||
:SEND-STICKER
|
||||
:GET-STICKER-SET
|
||||
:UPLOAD-STICKER-FILE
|
||||
:CREATE-NEW-STICKER-SET
|
||||
:ADD-STICKER-TO-SET
|
||||
:SET-STICKER-POSITION-IN-SET
|
||||
:DELETE-STICKER-FROM-SET
|
||||
:*INLINE-QUERY
|
||||
:ANSWER-INLINE-QUERY
|
||||
:*INLINE-QUERY-RESULT
|
||||
:*INLINE-QUERY-RESULT-ARTICLE
|
||||
:*INLINE-QUERY-RESULT-PHOTO
|
||||
:*INLINE-QUERY-RESULT-GIF
|
||||
:*INLINE-QUERY-RESULT-MPEG-4-*GIF
|
||||
:*INLINE-QUERY-RESULT-VIDEO
|
||||
:*INLINE-QUERY-RESULT-AUDIO
|
||||
:*INLINE-QUERY-RESULT-VOICE
|
||||
:*INLINE-QUERY-RESULT-DOCUMENT
|
||||
:*INLINE-QUERY-RESULT-LOCATION
|
||||
:*INLINE-QUERY-RESULT-VENUE
|
||||
:*INLINE-QUERY-RESULT-CONTACT
|
||||
:*INLINE-QUERY-RESULT-GAME
|
||||
:*INLINE-QUERY-RESULT-CACHED-PHOTO
|
||||
:*INLINE-QUERY-RESULT-CACHED-GIF
|
||||
:*INLINE-QUERY-RESULT-CACHED-MPEG-4-*GIF
|
||||
:*INLINE-QUERY-RESULT-CACHED-STICKER
|
||||
:*INLINE-QUERY-RESULT-CACHED-DOCUMENT
|
||||
:*INLINE-QUERY-RESULT-CACHED-VIDEO
|
||||
:*INLINE-QUERY-RESULT-CACHED-VOICE
|
||||
:*INLINE-QUERY-RESULT-CACHED-AUDIO
|
||||
:*INPUT-MESSAGE-CONTENT
|
||||
:*INPUT-TEXT-MESSAGE-CONTENT
|
||||
:*INPUT-LOCATION-MESSAGE-CONTENT
|
||||
:*INPUT-VENUE-MESSAGE-CONTENT
|
||||
:*INPUT-CONTACT-MESSAGE-CONTENT
|
||||
:*CHOSEN-INLINE-RESULT
|
||||
:*PASSPORT-DATA
|
||||
:*PASSPORT-FILE
|
||||
:*ENCRYPTED-PASSPORT-ELEMENT
|
||||
:*ENCRYPTED-CREDENTIALS
|
||||
:SET-PASSPORT-DATA-ERRORS
|
||||
:*PASSPORT-ELEMENT-ERROR
|
||||
:*PASSPORT-ELEMENT-ERROR-DATA-FIELD
|
||||
:*PASSPORT-ELEMENT-ERROR-FRONT-SIDE
|
||||
:*PASSPORT-ELEMENT-ERROR-REVERSE-SIDE
|
||||
:*PASSPORT-ELEMENT-ERROR-SELFIE
|
||||
:*PASSPORT-ELEMENT-ERROR-FILE
|
||||
:*PASSPORT-ELEMENT-ERROR-FILES
|
||||
:*PASSPORT-ELEMENT-ERROR-TRANSLATION-FILE
|
||||
:*PASSPORT-ELEMENT-ERROR-TRANSLATION-FILES
|
||||
:*PASSPORT-ELEMENT-ERROR-UNSPECIFIED
|
||||
:SEND-GAME
|
||||
:*GAME
|
||||
:SET-GAME-SCORE
|
||||
:GET-GAME-HIGH-SCORES
|
||||
:*GAME-HIGH-SCORE)
|
||||
(:use :closer-common-lisp :closer-mop :trivial-types)
|
||||
(:export
|
||||
#:bot
|
||||
#:make-bot
|
||||
#:access
|
||||
#:get-updates
|
||||
#:set-webhook
|
||||
#:get-webhook-info))
|
||||
#:get-webhook-info
|
||||
#:$
|
||||
#:$*))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue