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

(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 <url>; git - /ledger <remote> <path>"))))

(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 <url>; git - /ledger <remote> <path>"
                             :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)
    (let ((balance (pta-ledger:journal-balance journal query)))
      (when balance
        (bot-send-message (text-chunks (split-sequence:split-sequence
                                        #\Newline
                                        (format nil "*~A*~%~%~A" name balance))
                                       :text-sep "
")
                          :parse-mode "markdown"
                          :chat-id chat-id))
      t)))

(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 &optional account)
  (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)) (or account (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-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))
                           (show-harshly))
             (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 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 message-id entry))))

(defun merge-cheque (entry cheque)
  (labels ((positive-posting (p)
             (plusp (pta-ledger:amount-quantity (pta-ledger:posting-amount p)))))
    (let ((postings (append
                     (remove-if-not #'positive-posting (pta-ledger:entry-postings cheque))
                     (remove-if #'positive-posting (pta-ledger:entry-postings entry))))
          (default-account (symbol-value (intern "*DEFAULT-EXPENSE-ACCOUNT*"
                                                 (find-package :chatikbot.plugins.ofd))))
          (entry-positive (car (remove-if-not #'positive-posting (pta-ledger:entry-postings entry)))))
      (log:info entry cheque entry-positive postings)
      (when (zerop (pta-ledger:amount-quantity
                    (car (pta-ledger::complement-amounts postings t))))
        ;; Keep expense accounts if not specified in cheque
        (when entry-positive
          (loop for p in postings
             when (positive-posting p)
             when (equalp (pta-ledger:posting-account p) default-account)
             do (setf (pta-ledger:posting-account p)
                      (pta-ledger:posting-account entry-positive))))
        (setf (pta-ledger:entry-postings entry) postings)
        ;; Take comment from cheque if set
        (alexandria:when-let (comment (pta-ledger:entry-comment cheque))
          (setf (pta-ledger:entry-comment entry) comment))
        entry))))

(defun keyboard/entry (entry)
  (let* ((ofd-package (find-package :chatikbot.plugins.ofd))
         (handle-next-cheque (when ofd-package (symbol-function (intern "HANDLE-NEXT-CHEQUE" ofd-package)))))
    (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))
            (when handle-next-cheque
              (inline-button ("🧾")
                (let ((query-id *query-id*)
                      (source-chat-id *source-chat-id*)
                      (source-message-id *source-message-id*))
                  (telegram-answer-callback-query query-id :text "Жду чек")
                  (funcall handle-next-cheque
                           (lambda (cheque-entry)
                             (bot-send-message (format nil "Получил чек на сумму ~A"
                                                       (pta-ledger:entry-total-amount cheque-entry)))
                             (let ((merged (merge-cheque entry cheque-entry)))
                               (if merged
                                   (telegram-edit-message-text
                                    (format-entry merged)
                                    :chat-id source-chat-id
                                    :message-id source-message-id
                                    :parse-mode "markdown"
                                    :reply-markup (keyboard/entry entry))
                                   (bot-send-message "Суммы не сходятся :("))))))))
            (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 message-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 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 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 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 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 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 message-id entry posting nav-list)
       :chat-id chat-id :message-id message-id))))

(defun keyboard/account (chat-id message-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 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))))))))

(def-message-cmd-handler handler-create (:rub :usd :eur :thb :btc :czk :fuy)
  (cond
    ((>= (length *args*) 2)
     (ledger/new-chat-entry *chat-id* (create-entry *chat-id*
                                                    (spaced (subseq *args* 1))
                                                    (parse-float (car *args*))
						    (case *cmd*
						      (:fuy "CZK")
						      (t (symbol-name *cmd*)))
						    (case *cmd*
						      (:fuy "liabilities:people:fuy")))))
    (:otherwise (bot-send-message (format nil "/~A <amount> <description>" *cmd*)))))

(defun get-harshly-state (journal account day next-day)
  (labels ((get-account-balance (query)
             (car (gethash account
                           (apply #'pta-ledger:balance
                                  (pta-ledger::entries journal)
                                  (pta-ledger::parse-query query))))))
    (let* ((left-days (ceiling (- next-day day) 86400))
           (morning-balance (get-account-balance (format nil "~A date:-~A" account (format-date day))))
           (balance (get-account-balance (format nil "~A date:-~A" account (format-date (+ day pta-ledger::+day+)))))
           (today-amount (get-account-balance (format nil "amt:<0 ~A date:~A" account (format-date day))))
           (daily-amount (if (zerop left-days) balance
                             (pta-ledger:make-amount
                              :quantity (/ (pta-ledger:amount-quantity morning-balance) left-days)
                              :commodity (pta-ledger:amount-commodity morning-balance))))
           (left-today (pta-ledger:make-amount
                        :quantity (+ (pta-ledger:amount-quantity daily-amount)
                                     (if today-amount (pta-ledger:amount-quantity today-amount) 0))
                        :commodity (pta-ledger:amount-commodity morning-balance)))
           (overspent-today (< (pta-ledger:amount-quantity left-today) 0))
           (overspent-daily (when (and overspent-today (> left-days 0))
                              (pta-ledger:make-amount
                               :quantity (/ (pta-ledger:amount-quantity balance) (1- left-days))
                               :commodity (pta-ledger:amount-commodity balance)))))
      (list overspent-today left-days balance daily-amount today-amount left-today overspent-daily))))

(defun format-harshly-state (state)
  (destructuring-bind (overspent-today left-days balance daily-amount today-amount left-today overspent-daily)
      state
    (if overspent-today
        (apply #'format nil "До зарплаты ~A дн, осталось ~A. Сегодня покутил на ~a и осталось теперь по ~a в день"
               left-days
               (mapcar #'pta-ledger:render (list balance today-amount overspent-daily)))
        (if today-amount
            (apply #'format nil "До зарплаты ~a дн, осталось ~A. Это по ~A в день. Сегодня уже слито ~a и осталось на сегодня ~A."
                   left-days
                   (mapcar #'pta-ledger:render (list balance daily-amount today-amount left-today)))
            (apply #'format nil "До зарплаты ~a дн, осталось ~A. Это по ~A в день, на сегодня полностью."
                   left-days
                   (mapcar #'pta-ledger:render (list balance daily-amount)))))))

(defvar *harshly-account* "assets:revolut:czk")
(defvar *harshly-payday-schedule* '(:day-of-month (member 8)))
(defun show-harshly ()
  (with-chat-journal (*chat-id* journal updated)
    (format-harshly-state
     (get-harshly-state
      journal *harshly-account*
      (get-universal-time)
      (clon:next-time (apply #'clon:make-typed-cron-schedule
                               *harshly-payday-schedule*))))))
(def-message-cmd-handler handler-harshly (:harshly :harsh)
  (bot-send-message (show-harshly)))