|
|
@@ -271,6 +271,8 @@
|
|
|
(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))
|
|
|
@@ -278,7 +280,7 @@
|
|
|
(pta-ledger:make-entry
|
|
|
:description text
|
|
|
:postings (list
|
|
|
- (pta-ledger:make-posting :account "expenses")
|
|
|
+ (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)
|
|
|
@@ -291,6 +293,40 @@
|
|
|
(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)
|
|
|
(cond
|
|
|
((>= (length args) 2)
|
|
|
@@ -342,17 +378,19 @@
|
|
|
"Добавь git журнал.")))
|
|
|
|
|
|
(defun ledger/new-chat-entry (chat-id entry)
|
|
|
- (bot-send-message
|
|
|
- chat-id (format-entry entry)
|
|
|
- :parse-mode "markdown"
|
|
|
- :reply-markup (keyboard/entry chat-id entry)))
|
|
|
+ (let ((entry (extend-entry! chat-id entry)))
|
|
|
+ (bot-send-message
|
|
|
+ chat-id (format-entry entry)
|
|
|
+ :parse-mode "markdown"
|
|
|
+ :reply-markup (keyboard/entry chat-id entry))))
|
|
|
|
|
|
(defun entry-edit (chat-id message-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)))
|
|
|
+ (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
|
|
|
@@ -414,8 +452,14 @@
|
|
|
:reply-markup (telegram-force-reply))
|
|
|
(on-next-message chat-id
|
|
|
(let ((amount (pta-ledger:parse-amount text)))
|
|
|
- (setf (pta-ledger:posting-amount this-posting) amount)
|
|
|
- (entry-edit chat-id source-message-id entry)))))))
|
|
|
+ (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)
|
|
|
@@ -473,7 +517,8 @@
|
|
|
(append
|
|
|
(list (list (when account
|
|
|
(inline-button (account)
|
|
|
- (setf (pta-ledger:posting-account posting) 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 "Введите счёт"
|
|
|
@@ -482,14 +527,16 @@
|
|
|
(let ((account (pta-ledger:parse-account text)))
|
|
|
(if account
|
|
|
(progn
|
|
|
- (setf (pta-ledger:posting-account posting) account)
|
|
|
+ (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 "Не разобрал")))))))
|
|
|
(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)
|
|
|
+ (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
|
