chatikbot/macros.lisp

(in-package :cl-user)
(defpackage chatikbot.macros
  (:use :cl :chatikbot.utils :chatikbot.telegram :chatikbot.crypto)
  (:export :def-db-init
           :with-parsed-message
           :def-message-handler
           :def-message-cmd-handler
           :def-message-admin-cmd-handler
           :with-parsed-callback
           :def-callback-handler
           :def-callback-section-handler
           :def-oauth-handler
           :def-oauth-section-handler
           :with-random-state
           :defcron))
(in-package #:chatikbot.macros)

(defmacro def-db-init (&body body)
  `(add-hook :db-init #'(lambda ()
                          (handler-case (progn ,@body)
                            (error (e) (log:error e)))
                          (values))))

(defmacro with-parsed-message (message &body body)
  `(let ((*message-id* (agets ,message "message_id"))
         (*from-id* (agets ,message "from" "id"))
         (*chat-id* (agets ,message "chat" "id"))
         (*text* (agets ,message "text")))
     ,@body))

(defmacro def-message-handler (name (message &optional prio) &body body)
  `(progn
     (defun ,name (,message)
       (with-parsed-message ,message
         (handler-case (progn ,@body)
           (error (e)
             (log:error "~A" e)
             (bot-send-message (format nil "Ошибочка вышла~@[: ~A~]"
                                       (when (is-admin) e)))))))
     (when ,prio (setf (get ',name :prio) ,prio))
     (add-hook :update-message ',name)))

(defmacro def-message-cmd-handler (name (&rest commands) &body body)
  `(def-message-handler ,name (*message*)
     (when (and *text* (equal #\/ (char *text* 0)))
       (multiple-value-bind (*cmd* *args*) (parse-cmd *text*)
         (when (member *cmd* (list ,@commands))
           (log:info *cmd* *message-id* *chat-id* *from-id* *args*)
           ,@body
           t)))))

(defmacro def-message-admin-cmd-handler (name (&rest commands) &body body)
  `(def-message-handler ,name (*message*)
     (when (and (is-admin)
                *text* (equal #\/ (char *text* 0)))
       (multiple-value-bind (*cmd* *args*) (parse-cmd *text*)
         (when (member *cmd* (list ,@commands))
           (log:info *cmd* *message-id* *chat-id* *from-id* *args*)
           ,@body
           t)))))

(defmacro with-parsed-callback (callback &body body)
  `(let* ((*query-id* (agets ,callback "id"))
          (*from* (agets ,callback "from"))
          (*raw-data* (agets ,callback "data"))
          (*source-message* (agets ,callback "message"))
          (*inline-message-id* (agets ,callback "inline_message_id"))
          (*from-id* (agets *from* "id"))
          (*source-chat-id* (agets *source-message* "chat" "id"))
          (*source-message-id* (agets *source-message* "message_id")))
     ,@body))

(defmacro def-callback-handler (name (callback &optional prio) &body body)
  `(progn
     (defun ,name (,callback)
       (with-parsed-callback ,callback
         (handler-case (progn ,@body)
           (error (e)
             (log:error "~A" e)
             (bot-send-message (format nil "Ошибочка вышла~@[: ~A~]"
                                       (when (member *source-chat-id* *admins*) e))
                               :chat-id (or *source-chat-id* *from-id*))))))
     (when ,prio (setf (get ',name :prio) ,prio))
     (add-hook :update-callback-query ',name)))

(defmacro def-callback-section-handler (name (&rest sections) &body body)
  `(def-callback-handler ,name (*callback*)
     (when *source-chat-id*
       (multiple-value-bind (*data* *section*) (decode-callback-data *source-chat-id* *raw-data*)
         (when (member *section* (list ,@sections))
           (log:info *query-id* *from-id* *source-chat-id* *source-message-id* *section* *data*)
           ,@body
           t)))))

(defmacro def-oauth-handler (name (code error state &optional prio) &body body)
  `(progn
     (defun ,name (,code ,error ,state)
       (declare (ignorable ,code ,error ,state))
       (handler-case (progn ,@body)
         (error (e)
           (log:error "~A" e)
           (hunchentoot:redirect "/error"))))
     (when ,prio (setf (get ',name :prio) ,prio))
     (add-hook :oauth ',name)))

(defmacro def-oauth-section-handler (name (&rest sections) &body body)
  `(def-oauth-handler ,name (*code* *error* *raw-state*)
     (multiple-value-bind (*state* *section*) (decode-oauth-state *raw-state*)
       (when (member *section* (list ,@sections))
         ,@body
         t))))

;; On CCL at least, new thread clones origin *random-state* thus
;; all cron threads generate same random values. To overcome this we'll
;; generate per-thread *random-state*
(defvar *random-state-lock* (bt:make-recursive-lock
                             "random state lock") "per-thread random state lock")
(defvar *thread-random-state* (tg:make-weak-hash-table :weakness :key) "Per-thread *random-state* storage")
(defun get-thread-random-state ()
  (bt:with-recursive-lock-held (*random-state-lock*)
    (let ((self (bt:current-thread)))
      (or (gethash self *thread-random-state*)
          (setf (gethash self *thread-random-state*)
                (make-random-state t))))))

(defmacro with-random-state (&body body)
  `(let ((*random-state* (get-thread-random-state)))
     ,@body))

;; Schedule
(defmacro defcron (name (&rest schedule) &body body)
  (let ((schedule (or schedule '(:minute '* :hour '*)))
        (scheduler (symbol-append name '-scheduler)))
    `(progn
       (defun ,name ()
         (with-random-state
           (unwind-protect
                (handler-case
                    #+sbcl (sb-sys:with-interrupts ,@body)
                    #-sbcl (progn ,@body)
                    (error (e) (log:error "~A" e)))
             (dex:clear-connection-pool))))
       (defun ,scheduler ()
         (clon:schedule-function
          ',name (clon:make-scheduler
                  (clon:make-typed-cron-schedule
                   ,@schedule)
                  :allow-now-p t)
          :name ',name
          :thread (bt:make-thread (lambda () (loop (sleep 1)))
                                  :name (format nil "Sleeper '~A'" (symbol-name ',name))))
         (values))
       (add-hook :starting ',scheduler))))