|
|
@@ -4,79 +4,152 @@
|
|
|
(in-package :chatikbot.plugins.ledger)
|
|
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
|
- (ql:quickload :pta-ledger))
|
|
|
+ (ql:quickload '(:pta-ledger :legit)))
|
|
|
|
|
|
(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))))
|
|
|
+(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 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 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/handle-set-uri (chat-id uri)
|
|
|
+(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)
|
|
|
- (ledger/parse-uri chat-id uri)
|
|
|
+ (get-chat-journal-info chat-id info)
|
|
|
(declare (ignore ut))
|
|
|
- (secret-set (list :ledger chat-id) uri)
|
|
|
+ (secret-set (list :ledger chat-id) info)
|
|
|
(send-response chat-id (format nil "Добавил журнал с ~D записями. Веб-хук для обновления: ~A"
|
|
|
(length journal)
|
|
|
- (ledger/get-hook-url chat-id uri))))
|
|
|
+ (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))))))
|
|
|
|
|
|
-(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)))
|
|
|
+ ((<= 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)
|
|
|
- (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>"))))))
|
|
|
+ (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
|
|
|
@@ -84,21 +157,14 @@
|
|
|
(:otherwise (ledger/handle-balance chat-id (spaced args)))))
|
|
|
|
|
|
(defun ledger/handle-journal (chat-id query)
|
|
|
- (let ((pair (gethash chat-id *ledger/chat-journals*)))
|
|
|
- (if pair
|
|
|
- (destructuring-bind (journal . ut) pair
|
|
|
- (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 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>"))))))
|
|
|
+ (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
|
|
|
@@ -110,6 +176,9 @@
|
|
|
(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))))))))
|
|
|
+ (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"))))))))
|
