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")))
     (declare (ignorable message-id from-id chat-id 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 chat-id
                               (format nil "Ошибочка вышла~@[: ~A~]"
                                       (when (member chat-id *admins*) 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 (member chat-id *admins*)
                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")))
     (declare (ignorable query-id from raw-data source-message inline-message-id
                         from-id source-chat-id source-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 (or source-chat-id from-id)
                               (format nil "Ошибочка вышла~@[: ~A~]"
                                       (when (member source-chat-id *admins*) e)))))))
     (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))))