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 :legit)))

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

(defvar *git-repo-locks* (make-hash-table :test #'equal))
(defun git-get-repo-lock (repo)
  (let ((key (legit:location repo)))
    (setf key
          (etypecase key
            (string key)
            (pathname (namestring key))))
    (or (gethash key *git-repo-locks*)
        (setf (gethash key *git-repo-locks*)
              (bt:make-recursive-lock key)))))

(defun git-get-repo (location remote)
  (let ((repo (make-instance 'legit:repository :location location)))
    (bt:with-recursive-lock-held ((git-get-repo-lock repo))
      (legit:init repo :remote remote :if-does-not-exist :clone))
    repo))

(defsetting *git-repos-root* "/tmp/ledger-repos/")
(defun git-get-chat-location (chat-id remote)
  (merge-pathnames (format nil "~A-~A" chat-id (token-hmac remote))
                   *git-repos-root*))

(defun git-read-latest-file (repo path)
  (bt:with-recursive-lock-held ((git-get-repo-lock repo))
    (legit:fetch repo :branch "master" :remote "origin")
    (legit:reset repo :hard t :to "origin/master")
    (uiop:read-file-string (merge-pathnames path
                                            (uiop:ensure-directory-pathname
                                             (legit:location repo))))))

(defun ledger/refresh-git (chat-id remote path)
  (let* ((location (git-get-chat-location chat-id remote))
         (repo (git-get-repo location remote))
         (content (git-read-latest-file repo path))
         (journal (pta-ledger:parse-journal content))
         (updated (legit:current-age repo)))
    (setf (gethash chat-id *ledger/chat-journals*)
          (cons journal updated))))

(defun git-append-latest-file (repo path text message)
  (bt:with-recursive-lock-held ((git-get-repo-lock repo))
    (let ((repo-path (merge-pathnames path (legit:location repo))))
      (dotimes (tries 5)
        (let ((current (or (ignore-errors (git-read-latest-file repo path)) "")))
          (uiop/stream:with-output-file (s repo-path
                                           :if-exists :supersede
                                           :if-does-not-exist :create)
            (format s "~A~A~%" current text)))
        (legit:add repo repo-path)
        (legit:commit repo message)
        (handler-case
            (progn
              (legit:push repo)
              (return-from git-append-latest-file path))
          (legit:git-error ())))
      (error "Tried 5 times to push ~A to ~A" path (legit:remote-url repo)))))

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

(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/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/refresh-uri (chat-id uri)
  (setf (gethash chat-id *ledger/chat-journals*)
        (cons (pta-ledger:parse-journal (http-request uri))
              (get-universal-time))))

(defun get-chat-journal-info (chat-id &optional info)
  (labels ((process-info (info)
             (cond
               ((stringp info) (ledger/refresh-uri chat-id info))
               ((consp info) (apply #'ledger/refresh-git chat-id info))
               (:otherwise nil))))
    (let ((journal-info (gethash chat-id *ledger/chat-journals*)))
      (if journal-info journal-info
          (if info (process-info info)
              (with-secret (info (list :ledger chat-id))
                (process-info info)))))))

(Defun ledger/handle-info (chat-id)
  (with-secret (info (list :ledger chat-id))
    (if info
        (destructuring-bind (journal . ut)
            (get-chat-journal-info chat-id info)
          (let ((uri (cond
                       ((consp info) (car info))
                       ((stringp info) info))))
            (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))
                              :disable-web-preview t)))
        (send-response chat-id "Добавь журнал: uri - /ledger <url>; git - /ledger <remote> <path>"))))

(defun ledger/handle-set-info (chat-id info)
  (setf (gethash chat-id *ledger/chat-journals*) nil)
  (handler-case
      (destructuring-bind (journal . ut)
          (get-chat-journal-info chat-id info)
        (declare (ignore ut))
        (secret-set (list :ledger chat-id) info)
        (send-response chat-id (format nil "Добавил журнал с ~D записями. Веб-хук для обновления: ~A"
                                       (length journal)
                                       (ledger/get-hook-url chat-id))))
    (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))))))


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

(defmacro with-chat-journal ((chat-id journal updated) &body body)
  (let ((info (gensym "info")))
    `(let ((,info (get-chat-journal-info ,chat-id)))
       (if ,info
           (destructuring-bind (,journal . ,updated) ,info
             ,@body)
           (send-response ,chat-id "Добавь журнал: uri - /ledger <url>; git - /ledger <remote> <path>")))))

(defun ledger/handle-balance (chat-id query)
  (with-chat-journal (chat-id journal updated)
    (bot-send-message chat-id (format nil "```~%~A~%```Обновлено: ~A"
                                      (pta-ledger:journal-balance journal query)
                                      (ledger/format-time updated))
                              :parse-mode "markdown")))

(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)))))

(defun ledger/handle-journal (chat-id query)
  (with-chat-journal (chat-id journal updated)
    (let* ((entries (pta-ledger:journal-print journal query))
           (len (length entries))
           (count (min len 20)))
      (bot-send-message chat-id (format nil "```~%~{~A~^ ~%~%~}```Обновлено: ~A"
                                        (subseq entries (- len count) len)
                                        (ledger/format-time updated))
                        :parse-mode "markdown"))))

(def-message-cmd-handler handler-journal (:journal)
  (cond
    ((null args) (ledger/handle-journal chat-id "date:thisweek"))
    (:otherwise (ledger/handle-journal 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 (info (list :ledger chat-id))
            (when info
              (let ((chat-id (parse-integer chat-id)))
                (setf (gethash chat-id *ledger/chat-journals*) nil)
                (get-chat-journal-info chat-id info)
                "OK"))))))))