chatikbot/plugins/ledger.lisp

(in-package :cl-user)
(defpackage chatikbot.plugins.ledger
  (:use :cl :chatikbot.common))
(in-package :chatikbot.plugins.ledger)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :pta-ledger))

(defsetting *ledger/default-timezone* -3 "Default timezone for time display. GMT+3")
(defvar *ledger/chat-journals* (make-hash-table))

(defun ledger/get-hook-url (chat-id url)
  (declare (ignore url))
  (get-webhook-url "ledger" chat-id (token-hmac (write-to-string chat-id))))

(defun ledger/parse-uri (chat-id uri)
  (setf (gethash chat-id *ledger/chat-journals*)
        (cons (pta-ledger:parse-journal (http-request uri))
              (get-universal-time))))

(defun ledger/format-uri (url)
  (let ((uri (quri:uri url)))
    (quri:render-uri (quri:make-uri :userinfo (when (quri:uri-userinfo uri) "*:*")
                                    :defaults url))))

(defun ledger/handle-set-uri (chat-id uri)
  (handler-case
      (destructuring-bind (journal . ut)
          (ledger/parse-uri chat-id uri)
        (declare (ignore ut))
        (secret-set (list :ledger chat-id) uri)
        (send-response chat-id (format nil "Добавил журнал с ~D записями. Веб-хук для обновления: ~A"
                                       (length journal)
                                       (ledger/get-hook-url chat-id uri))))
    (pta-ledger:journal-failed (e)
      (send-response chat-id (format nil "Не смог спарсить: ~A" e)))
    (dex:http-request-failed (e)
      (send-response chat-id (format nil "Не смог в урл: ~A" (dex:response-body e))))))

(defun ledger/format-time (universal-time)
  (when universal-time
    (multiple-value-bind (sec min hour day month year dow dst-p tz)
        (decode-universal-time universal-time *ledger/default-timezone*)
      (declare (ignore dow dst-p tz))
      (format nil "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
              year month day hour min sec))))

(defun ledger/handle-info (chat-id)
  (with-secret (uri (list :ledger chat-id))
    (if uri
        (destructuring-bind (journal . ut)
            (or (gethash chat-id *ledger/chat-journals*)
                (ledger/parse-uri chat-id uri))
          (bot-send-message chat-id (format nil "Журнал с ~D записями, из ~A, обновлён ~A.~%Веб-хук: ~A"
                                            (length journal)
                                            (ledger/format-uri uri)
                                            (ledger/format-time ut)
                                            (ledger/get-hook-url chat-id uri))
                            :disable-web-preview t))
        (send-response chat-id "Добавь урл журнала, /ledger <url>"))))

(def-message-cmd-handler handler-ledger (:ledger)
  (cond
    ((= 1 (length args)) (ledger/handle-set-uri chat-id (car args)))
    (:otherwise (ledger/handle-info chat-id))))

(defun ledger/handle-balance (chat-id query)
  (let ((pair (gethash chat-id *ledger/chat-journals*)))
    (if pair
        (destructuring-bind (journal . ut) pair
          (bot-send-message chat-id (format nil "```~%~A~%```Обновлено: ~A"
                                            (pta-ledger:journal-balance journal query)
                                            (ledger/format-time ut))
                            :parse-mode "markdown"))
        (with-secret (uri (list :ledger chat-id))
          (if uri
              (progn (ledger/parse-uri chat-id uri)
                     (ledger/handle-balance chat-id query))
              (send-response chat-id "Добавь урл журнала, /ledger <url>"))))))

(def-message-cmd-handler handler-balance (:balance :bal)
  (cond
    ((null args) (ledger/handle-balance chat-id "assets"))
    (:otherwise (ledger/handle-balance chat-id (spaced args)))))

(def-webhook-handler ledger/handle-webhook ("ledger")
  (when (= 2 (length paths))
    (destructuring-bind (chat-id hmac) paths
      (let ((true-hmac (token-hmac chat-id)))
        (when (string= true-hmac hmac)
          (with-secret (uri (list :ledger chat-id))
            (when uri
              (ledger/parse-uri (parse-integer chat-id) uri))))))))