(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))) (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) (namestring (uiop:ensure-directory-pathname (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 (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 (namestring 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/add-git (chat-id remote path text message) (let* ((location (git-get-chat-location chat-id remote)) (repo (git-get-repo location remote))) (git-append-latest-file repo path (format nil "~%~A~%" text) message))) (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) (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 format-date (ut) (multiple-value-bind (sec min hour day month year) (decode-universal-time ut) (declare (ignore sec min hour)) (format nil "~4,'0D-~2,'0D-~2,'0D" year month day))) (defun get-year (ut) (multiple-value-bind (sec min hour day month year) (decode-universal-time ut) (declare (ignore sec min hour day month)) year)) (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 () (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 (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))) (bot-send-message "Добавь журнал: uri - /ledger ; git - /ledger ")))) (defun ledger/handle-set-info (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) (bot-send-message (format nil "Добавил журнал с ~D записями. Веб-хук для обновления: ~A" (length journal) (ledger/get-hook-url *chat-id*)))) (pta-ledger:journal-failed (e) (bot-send-message (format nil "Не смог спарсить: ~A" e))) (dex:http-request-failed (e) (bot-send-message (format nil "Не смог в урл: ~A" (dex:response-body e)))))) (def-message-cmd-handler handler-ledger (:ledger) (cond ((<= 1 (length *args*) 2) (ledger/handle-set-info *args*)) (:otherwise (ledger/handle-info)))) (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 (declare (ignorable ,journal ,updated)) ,@body) (bot-send-message "Добавь журнал: uri - /ledger ; git - /ledger " :chat-id chat-id))))) (defun ledger/handle-balance (query) (with-chat-journal (*chat-id* journal updated) (bot-send-message (text-chunks (split-sequence:split-sequence #\Newline (or (pta-ledger:journal-balance journal query) "Не нашлось")) :text-sep " ") :parse-mode "markdown"))) (def-message-cmd-handler handler-balance (:balance :bal :budget) (cond ((null *args*) (ledger/handle-balance (if (eql *cmd* :budget) "budget" "assets"))) (:otherwise (ledger/handle-balance (spaced *args*))))) (defun ledger/handle-journal (query) (with-chat-journal (*chat-id* journal updated) (let* ((pta-ledger:*posting-length* 40) (entries (pta-ledger:journal-print journal query)) (len (length entries)) (count (min len 50))) (bot-send-message (if entries (text-chunks (subseq entries (- len count) len)) "Не нашлось") :parse-mode "markdown")))) (def-message-cmd-handler handler-journal (:journal) (cond ((null *args*) (ledger/handle-journal "date:thisweek")) (:otherwise (ledger/handle-journal (spaced *args*))))) (def-message-cmd-handler hander-add-report (:add_report) (bot-send-message "Введи название" :reply-markup (telegram-force-reply)) (on-next-message (let ((name *text*)) (bot-send-message "Введи запрос" :reply-markup (telegram-force-reply)) (on-next-message (let ((query *text*)) (pta-ledger:parse-query query) ;; Validate query (bot-send-message "Введи расписание, ex: (:day-of-week 0 :hour 10), (:day * :hour 10)" :reply-markup (telegram-force-reply)) (on-next-message (let* ((schedule *text*)) (add-chat-cron :ledger-report *chat-id* schedule name query) (bot-send-message "Добавил")))))))) (defun run-report (chat-id name query) (with-chat-journal (chat-id journal updated) (bot-send-message (text-chunks (split-sequence:split-sequence #\Newline (format nil "*~A*~%~%~A" name (pta-ledger:journal-balance journal query))) :text-sep " ") :parse-mode "markdown" :chat-id chat-id))) (def-chat-cron-handler handler-chat-cron (:ledger-report chat-id schedule name query) (run-report chat-id name query)) (def-message-cmd-handler handler-reports (:reports) (let ((crons (get-chat-crons :ledger-report *chat-id*))) (if crons (bot-send-message (format nil "Отчёты~%~%~{~A) ~A _~A_: ~A~^~%~}" (loop for (schedule name query) in crons for idx from 1 append (list idx name schedule query))) :parse-mode "markdown" :reply-markup (get-inline-keyboard (append (loop for (schedule name query) in crons for idx from 0 collect (let ((cron-index idx) (cron-name name)) (list (inline-button ((format nil "Удалить '~A'" cron-name)) (delete-chat-cron :ledger-report *source-chat-id* cron-index) (telegram-edit-message-reply-markup nil :chat-id *source-chat-id* :message-id *source-message-id*) (bot-send-message (format nil "Удалил *~A*" cron-name) :chat-id *source-chat-id* :parse-mode "markdown"))))) (list (list (inline-button ("Отмена") (telegram-edit-message-reply-markup nil :chat-id *source-chat-id* :message-id source-message-id))))))) (bot-send-message "Отчётов пока нет" :reply-markup (telegram-reply-keyboard-markup (list (list (list :text "/add_report"))) :one-time-keyboard t))))) (defun match-entry (text journal) (labels ((two-post (entries) (remove-if-not #'(lambda (e) (= 2 (length (pta-ledger:entry-postings e)))) entries))) (let ((desc (two-post (pta-ledger:journal-entries journal (format nil "desc:'~A'" text))))) (if desc (car (last desc)) (let ((comment (two-post (pta-ledger:journal-entries journal (format nil "comment:'~A'" text))))) (when comment (car (last comment)))))))) (defvar *expenses-account-root* "expenses" "Expenses accounts root.") (defun create-entry (chat-id text amount currency) (with-chat-journal (chat-id journal updated) (let* ((old (match-entry text journal)) (new (or (when old (pta-ledger:clone-entry old)) (pta-ledger:make-entry :description text :postings (list (pta-ledger:make-posting :account *expenses-account-root*) (pta-ledger:make-posting))))) (postings (pta-ledger:entry-postings new))) (setf (pta-ledger:entry-date new) (get-universal-time) (pta-ledger:posting-amount (car postings)) (pta-ledger:make-amount :quantity amount :commodity currency) (pta-ledger:posting-amount (cadr postings)) (pta-ledger:make-amount :quantity (- amount) :commodity currency) (pta-ledger:posting-account (cadr postings)) (format nil "assets:Cash:~A" currency)) new))) (defun find-posting (entry root) (when (and entry root) (find root (pta-ledger:entry-postings entry) :test #'equal :key #'(lambda (p) (car (pta-ledger:account-parents (pta-ledger:posting-account p) :tree :t)))))) (defvar *budget-account-root* "budget" "Budget accounts root. Extend entry with matching budget if set") (defvar *budget-search-date-query* "date:last30" "Date part of matching budget search") (defun extend-entry! (chat-id entry) (let ((expense (find-posting entry *expenses-account-root*)) (budget (find-posting entry *budget-account-root*))) (when (and *budget-account-root* expense (or (null budget) (equal #\! (pta-ledger:posting-status budget)))) (with-chat-journal (chat-id journal updated) (let* ((last-entries (pta-ledger:journal-entries journal (format nil "~A acct:^~A" *budget-search-date-query* (pta-ledger:posting-account expense)))) (last-budget (some #'(lambda (e) (find-posting e *budget-account-root*)) (reverse last-entries))) (expense-amount (car (pta-ledger:get-amounts expense (pta-ledger:entry-postings entry) :t)))) (when last-budget (unless budget (setf budget (pta-ledger:make-posting :status #\! :virtual #\()) (setf (pta-ledger:entry-postings entry) (append (pta-ledger:entry-postings entry) (list budget)))) (setf (pta-ledger:posting-amount budget) (pta-ledger:make-amount :quantity (- (pta-ledger:amount-quantity expense-amount)) :commodity (pta-ledger:amount-commodity expense-amount)) (pta-ledger:posting-account budget) (pta-ledger:posting-account last-budget)))))) entry)) (def-message-cmd-handler handler-create (:rub :usd :eur :thb :btc :czk) (cond ((>= (length *args*) 2) (ledger/new-chat-entry *chat-id* (create-entry *chat-id* (spaced (subseq *args* 1)) (parse-float (car *args*))))) (:otherwise (bot-send-message format nil "/~A " *cmd*)))) (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))) (log:info "Updating ledger for ~A" chat-id) (setf (gethash chat-id *ledger/chat-journals*) nil) (get-chat-journal-info chat-id info) "OK")))))))) ;; New entries (defun format-entry (entry) (let ((pta-ledger:*posting-length* 40)) (format nil "```~%~A```" (pta-ledger:render entry)))) (defun ledger/format-add-entry-message (from) (format nil "Ledger add from ~A ~A at ~A" (aget "first_name" from) (aget "last_name" from) (ledger/format-time (get-universal-time)))) (defun ledger/process-add-entry (chat-id from entry) (with-secret (info (list :ledger chat-id)) (if info (cond ((consp info) (handler-case (progn (ledger/add-git chat-id (car info) (cadr info) (pta-ledger:render entry) (ledger/format-add-entry-message from)) "Добавил!") (error (e) (log:error "~A" e) "Не смог :("))) (:otherwise "Добавляю только в git журнал :(")) "Добавь git журнал."))) (defun ledger/new-chat-entry (chat-id entry) (let ((entry (extend-entry! chat-id entry))) (bot-send-message (format-entry entry) :chat-id chat-id :parse-mode "markdown" :reply-markup (keyboard/entry chat-id entry)))) (defun entry-edit (chat-id message-id entry) (let ((entry (extend-entry! chat-id entry))) (telegram-edit-message-text (format-entry entry) :chat-id chat-id :message-id message-id :parse-mode "markdown" :reply-markup (keyboard/edit-entry chat-id entry)))) (defun keyboard/entry (chat-id entry) (get-inline-keyboard (list (list (inline-button ("➕") (telegram-answer-callback-query *query-id* :text "Добавляю...") (telegram-send-message *source-chat-id* (ledger/process-add-entry *source-chat-id* *from* entry)) (telegram-edit-message-reply-markup nil :chat-id *source-chat-id* :message-id *source-message-id*)) (inline-button ("💲") (entry-edit *source-chat-id* *source-message-id* entry)) (inline-button ("✖️") (telegram-delete-message *source-chat-id* *source-message-id*)))))) (defun def (str default) (if (or (null str) (string= "" str)) default str)) (defun keyboard/edit-entry (chat-id entry) (get-inline-keyboard (append (list (list (inline-button ((format-date (pta-ledger:entry-date entry))) (bot-send-message "Введите дату" :chat-id chat-id :reply-markup (telegram-force-reply)) (on-next-message (let ((date (pta-ledger:parse-date *text* (get-year (pta-ledger:entry-date entry))))) (if date (progn (setf (pta-ledger:entry-date entry) date) (entry-edit chat-id *source-message-id* entry)) (bot-send-message "Не разобрал" :chat-id chat-id))))) (inline-button ((def (pta-ledger:entry-description entry) "Описание")) (bot-send-message "Введите описание" :chat-id chat-id :reply-markup (telegram-force-reply)) (on-next-message (setf (pta-ledger:entry-description entry) *text*) (entry-edit chat-id *source-message-id* entry))) (inline-button ((def (pta-ledger:entry-comment entry) "Коммент")) (bot-send-message "Введите комментарий" :chat-id chat-id :reply-markup (telegram-force-reply)) (on-next-message (setf (pta-ledger:entry-comment entry) *text*) (entry-edit chat-id *source-message-id* entry))))) (loop for posting in (pta-ledger:entry-postings entry) collect (let ((this-posting posting)) (list (inline-button ((pta-ledger:posting-account posting)) (account-edit chat-id *source-message-id* entry this-posting (pta-ledger:posting-account this-posting))) (inline-button ((def (pta-ledger:render (pta-ledger:posting-amount posting)) "Сумма")) (bot-send-message "Введите сумму" :chat-id chat-id :reply-markup (telegram-force-reply)) (on-next-message (let ((amount (pta-ledger:parse-amount *text*))) (setf (pta-ledger:posting-amount this-posting) amount (pta-ledger:posting-status this-posting) nil) (entry-edit chat-id *source-message-id* entry)))) (inline-button ("❌") (setf (pta-ledger:entry-postings entry) (remove this-posting (pta-ledger:entry-postings entry) :test #'equalp)) (entry-edit chat-id *source-message-id* entry))))) (list (list (inline-button ("Готово") (telegram-edit-message-reply-markup (keyboard/entry chat-id entry) :chat-id chat-id :message-id *source-message-id*))))))) (defun accounts/nav (account accounts &optional (offset 0) (count 5)) (let* ((len (1+ (length account))) (sep-pos (position #\: account :from-end t)) (parent (when sep-pos (subseq account 0 sep-pos))) (head (when account (concatenate 'string account ":"))) (descendants (remove-if #'(lambda (a) (when head (not (equal head (subseq a 0 (min (length a) len)))))) accounts))) (if descendants (let* ((children (sort (remove-duplicates (mapcar #'(lambda (d) (subseq d 0 (or (position #\: d :start len) (length d)))) descendants) :test #'equal) #'string<)) (total (length children))) (when (stringp offset) (let ((off (position offset children :test #'equal))) (setf offset (if off (max 0 (- off (round count 2))) 0)))) (values account parent (mapcar #'(lambda (c) (let* ((needle (concatenate 'string c ":")) (n-l (length needle))) (cons c (not (find needle accounts :test #'equal :key #'(lambda (a) (subseq a 0 (min n-l (length a))))))))) (subseq children offset (min total (+ offset count)))) (unless (zerop offset) (max 0 (- offset count))) (when (< (+ offset count) total) (+ offset count)))) (when parent (accounts/nav parent accounts account))))) (defun account-edit (chat-id message-id entry posting account &optional (offset 0)) (with-chat-journal (chat-id journal updated) (let* ((accounts (pta-ledger:journal-accounts journal)) (nav-list (multiple-value-list (accounts/nav account accounts offset)))) (telegram-edit-message-reply-markup (apply #'keyboard/account chat-id entry posting nav-list) :chat-id chat-id :message-id message-id)))) (defun keyboard/account (chat-id entry posting account parent children prev next) (get-inline-keyboard (append (list (list (when account (inline-button (account) (setf (pta-ledger:posting-account posting) account (pta-ledger:posting-status posting) nil) (entry-edit chat-id *source-message-id* entry))) (inline-button ("Ввести") (bot-send-message "Введите счёт" :chat-id chat-id :reply-markup (telegram-force-reply)) (on-next-message (let ((account (pta-ledger:parse-account *text*))) (if account (progn (setf (pta-ledger:posting-account posting) account (pta-ledger:posting-status posting) nil) (entry-edit chat-id *source-message-id* entry)) (bot-send-message "Не разобрал" :chat-id chat-id))))))) (loop for (acc . leaf) in children collect (let ((this-account acc)) (list (if leaf (inline-button (this-account) (setf (pta-ledger:posting-account posting) this-account (pta-ledger:posting-status posting) nil) (entry-edit chat-id *source-message-id* entry)) (inline-button ((format nil "~A ..." this-account)) (account-edit chat-id *source-message-id* entry posting this-account)))))) (list (list (when prev (inline-button ("<<") (account-edit chat-id *source-message-id* entry posting account prev))) (when (or parent account) (inline-button ((or parent "ACC")) (account-edit chat-id *source-message-id* entry posting parent account))) (when next (inline-button (">>") (account-edit chat-id *source-message-id* entry posting account next))))))))