[deltacredit] initial

common.lisp

@@ -184,12 +184,14 @@
 
            :poller-request
            :poller-validate
-           :poller-authenticate
+           :poller-get-token
 
            :poller-error
            :poller-no-secret
+           :poller-cant-get-token
            :poller-cant-authenticate
 
            :poller-call
-           :poller-poll-lists))
+           :poller-poll-lists
+           :poller-authenticate))
 (in-package :chatikbot.common)

plugins/deltacredit.lisp

@@ -0,0 +1,184 @@
+(in-package :cl-user)
+(defpackage chatikbot.plugins.deltacredit
+  (:use :cl :chatikbot.common :alexandria))
+(in-package :chatikbot.plugins.deltacredit)
+
+(defparameter +api-uri+ "https://info.deltacredit.ru/webby_mobile/MobileService.svc/v1/")
+
+;; poller methods
+(defun is-post (method)
+  (or (equal method "auth")
+      (equal method "bill/extract")))
+
+(defun is-raw-params (method)
+  (equal method "bill/extract"))
+
+(defmethod poller-request ((module (eql :deltacredit)) method &rest params)
+  (handler-case
+      (let* ((is-post (is-post method))
+             (is-raw (is-raw-params method))
+             (res
+              (json-request (concatenate 'string +api-uri+ method)
+                            :cookie-jar *poller-token*
+                            :method (if is-post :post :get)
+                            :json-content is-post
+                            (if is-post :content :parameters) (rest-parameters params is-raw))))
+        (unless (agets res "result")
+          (error (agets res "errMsg")))
+        (agets res "data"))
+    (dex:http-request-failed (e) e)))
+
+(defmethod poller-validate ((module (eql :deltacredit)) response)
+  (not (typep response 'dex:http-request-failed)))
+
+(defmethod poller-get-token ((module (eql :deltacredit)) secret)
+  (destructuring-bind (username . password) secret
+    (let* ((*poller-token* (cl-cookie:make-cookie-jar)))
+      (ignore-errors
+        (poller-request :deltacredit "auth"
+                        :login username
+                        :password password)
+        *poller-token*))))
+
+(defun list-credit ()
+  (poller-call :deltacredit "credit/list"))
+
+(defun profile-info ()
+  (poller-call :deltacredit "profile/info"))
+
+(defun bill-list ()
+  (poller-call :deltacredit "bill/list"))
+
+(defun bill-extract (bill-id &key start-date finish-date)
+  (poller-call :deltacredit "bill/extract" :|billId| bill-id :|startDate| start-date :|finishDate| finish-date))
+
+(defun format-credit (credit)
+  (let ((cur (agets credit "creditCurrency")))
+    (format nil "Кредит '~A' № ~A (~A)
+Всего:    ~$ ~A ~A - ~A
+Осталось: ~$ ~A, след. платёж ~$ ~A ~A"
+            (agets credit "contractType")
+            (agets credit "contractNumber")
+            (agets credit "contractStatus")
+            (agets credit "creditAmount") cur
+            (agets credit "sinceDate") (agets credit "untilDate")
+            (agets credit "remainingDebt") cur
+            (agets credit "nextPaymentAmount") cur (agets credit "nextPaymentDate"))))
+
+(defun format-bill (bill)
+   (format nil "~A ~A (~A)
+Баланс: ~$ ~A"
+           (agets bill "billTypeDescription")
+           (agets bill "billNumber")
+           (agets bill "statusDescription")
+           (agets bill "balance") (agets bill "currency")))
+
+(defun format-entries (changes)
+  (text-chunks (mapcar #'pta-ledger:render changes)))
+
+(defvar *entry-description* "deltacredit")
+(defvar *income-account* "assets")
+(defvar *expense-account* "expenses")
+(defvar *expense-account-interest* "expenses:Banking:Interest:Mortage")
+(defvar *liabilities-account* "liabilities:delta:mortage")
+
+(defun get-op-date (tr)
+  (local-time:timestamp-to-universal
+   (apply #'local-time:encode-timestamp 0 0 0 0
+          (mapcar #'parse-integer
+                  (split-sequence:split-sequence
+                   #\. (agets tr "operationDate"))))))
+
+(defun format-op-date (timestamp)
+  (local-time:format-timestring
+   nil timestamp
+   :format '((:day 2) "/" (:month 2) "/" (:year 4))))
+
+(defun transaction->entry (tr)
+  (let* ((pta-ledger (find-package :pta-ledger))
+         (make-entry (symbol-function (intern "MAKE-ENTRY" pta-ledger)))
+         (make-posting (symbol-function (intern "MAKE-POSTING" pta-ledger)))
+         (make-amount (symbol-function (intern "MAKE-AMOUNT" pta-ledger)))
+         (date (get-op-date tr))
+         (comment (agets tr "paymentDescription"))
+         (is-income (not (zerop (agets tr "inAmount"))))
+         (amount (agets tr (if is-income "inAmount" "outAmount")))
+         (expense-account (if is-income *income-account*
+                              (if (equal (subseq comment 0 17)
+                                         "Гашение процентов")
+                                  *expense-account-interest*
+                                  *expense-account*)))
+         (currency "RUB"))
+    (funcall make-entry
+     :date date
+     :description *entry-description*
+     :comment comment
+     :postings (list
+                (funcall make-posting
+                 :account expense-account
+                 :amount (funcall make-amount
+                                  :quantity (* (if is-income -1 1) amount)
+                          :commodity currency))
+                (funcall make-posting
+                 :account *liabilities-account*
+                 :amount (funcall make-amount
+                          :quantity (* (if is-income 1 -1) amount)
+                          :commodity currency))))))
+
+(defun get-transactions (&optional (days 30))
+  (let* ((now (local-time:now))
+         (finish-date (format-op-date now))
+         (start-date (format-op-date (local-time:timestamp- now days :day)))
+         (bills (bill-list)))
+    (loop for bill in bills
+       append (bill-extract (agets bill "id") :start-date start-date :finish-date finish-date))))
+
+(defun process-new (diff)
+  (let ((transactions (mapcar #'transaction->entry diff))
+        (ledger-package (find-package :chatikbot.plugins.ledger)))
+    (if ledger-package
+        (let ((new-chat-entry (symbol-function
+                               (intern "LEDGER/NEW-CHAT-ENTRY" ledger-package))))
+          (dolist (tr transactions)
+            (funcall new-chat-entry *chat-id* tr)))
+        (bot-send-message (format-entries transactions) :parse-mode "markdown"))))
+
+;; Cron
+(defcron process-deltacredit (:minute '(member 0 10 20 30 40 50))
+  (poller-poll-lists :deltacredit
+                     #'get-transactions
+                     #'process-new
+                     :key #'get-op-date))
+
+(defun handle-auth (login pass)
+  (handler-case
+      (progn
+        (poller-authenticate :deltacredit (cons login pass))
+        (handle-balance))
+    (poller-cant-authenticate ()
+      (bot-send-message "Чот не смог, пропробуй другие."))))
+
+(defun handle-balance ()
+  (bot-send-message
+   (handler-case
+       (let ((entries (append (mapcar 'format-credit (list-credit))
+                              (mapcar 'format-bill (bill-list)))))
+         (if entries (text-chunks entries) "Не нашлось"))
+     (poller-no-secret () "Нужен логин-пароль. /delta <login> <pass>")
+     (poller-cant-get-token () "Не смог получить данные. Попробуй перелогинься. /delta <login> <pass>"))
+   :parse-mode "markdown"))
+
+(defun handle-recent (&optional (days 30))
+  (bot-send-message
+   (handler-case
+       (format-entries (mapcar #'transaction->entry (get-transactions days)))
+     (poller-no-secret () "Нужен логин-пароль. /delta <login> <pass>")
+     (poller-cant-get-token () "Не смог получить данные. Попробуй перелогинься. /delta <login> <pass>"))
+   :parse-mode "markdown"))
+
+(def-message-cmd-handler handle-cmd-delta (:deltacredit :delta)
+  (let ((a0 (car *args*)))
+    (cond
+      ((= 2 (length *args*)) (apply 'handle-auth *args*))
+      ((or (null *args*) (equal a0 "bal")) (handle-balance))
+      (:otherwise (handle-recent (parse-integer a0 :junk-allowed t))))))

plugins/gazprom.lisp

@@ -19,7 +19,7 @@
 (defmethod poller-validate ((module (eql :gazprom)) response)
   (not (equal (agets response "message") "Необходимо авторизоваться")))
 
-(defmethod poller-authenticate ((module (eql :gazprom)) secret)
+(defmethod poller-get-token ((module (eql :gazprom)) secret)
   (destructuring-bind (username password) secret
     (agets (poller-request :gazprom "auth.php"
                            :login username

plugins/ledger.lisp

@@ -161,7 +161,7 @@
              (declare (ignorable ,journal ,updated))
              ,@body)
            (bot-send-message "Добавь журнал: uri - /ledger <url>; git - /ledger <remote> <path>"
-                             :chat-id chat-id)))))
+                             :chat-id ,chat-id)))))
 
 (defun ledger/handle-balance (query)
   (with-chat-journal (*chat-id* journal updated)
@@ -251,7 +251,7 @@
                                             :parse-mode "markdown")))))
            (list (list (inline-button ("Отмена")
                          (telegram-edit-message-reply-markup
-                          nil :chat-id *source-chat-id* :message-id source-message-id)))))))
+                          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")))
@@ -325,15 +325,6 @@
                   (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*))
-                                                    (symbol-name *cmd*))))
-    (:otherwise (bot-send-message (format nil "/~A <amount> <description>" *cmd*)))))
-
 (def-webhook-handler ledger/handle-webhook ("ledger")
   (when (= 2 (length *paths*))
     (destructuring-bind (chat-id hmac) *paths*
@@ -549,3 +540,12 @@
                   (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)
+  (cond
+    ((>= (length *args*) 2)
+     (ledger/new-chat-entry *chat-id* (create-entry *chat-id*
+                                                    (spaced (subseq *args* 1))
+                                                    (parse-float (car *args*))
+                                                    (symbol-name *cmd*))))
+    (:otherwise (bot-send-message (format nil "/~A <amount> <description>" *cmd*)))))

plugins/nalunch.lisp

@@ -16,7 +16,7 @@
     (dex:http-request-failed (e) e)))
 (defmethod poller-validate ((module (eql :nalunch)) response)
   (not (typep response 'dex:http-request-failed)))
-(defmethod poller-authenticate ((module (eql :nalunch)) secret)
+(defmethod poller-get-token ((module (eql :nalunch)) secret)
   (destructuring-bind (username . password) secret
     (agets (poller-request :nalunch "auth" :username username :password password)
            "token")))
@@ -129,11 +129,12 @@
                         "Без рассылки. '/nalunch on' - включить, /nalunch - последние.")))
 
 (defun handle-auth (login pass)
-  (let ((secret (cons login pass)))
-    (unless (poller-authenticate :nalunch secret)
-      (bot-send-message "Чот не смог, пропробуй другие."))
-    (secret-set `(:nalunch ,*chat-id*) secret)
-    (handle-set-cron t)))
+  (handler-case
+      (progn
+        (poller-authenticate :nalunch (cons login pass))
+        (handle-set-cron t))
+    (poller-cant-authenticate ()
+      (bot-send-message "Чот не смог, пропробуй другие."))))
 
 (defun handle-recent (&optional month)
   (bot-send-message (format-balance-left (user-balance)))

plugins/zsd.lisp

@@ -17,7 +17,7 @@
          "return"))
 (defmethod poller-validate ((module (eql :zsd)) response)
   response)
-(defmethod poller-authenticate ((module (eql :zsd)) secret)
+(defmethod poller-get-token ((module (eql :zsd)) secret)
   (destructuring-bind (username . password) secret
     (agets (json-request +auth-uri+ :method :post
                          :content (plist-json (list :realm "WHSD"
@@ -69,13 +69,12 @@
                         "Без рассылки. '/zsd on' - включить, /zsd - последние.")))
 
 (defun handle-auth (login pass)
-  (let ((secret (cons login pass)))
-    (if (poller-authenticate :zsd secret)
-        (progn
-          (log:info secret *chat-id*)
-          (secret-set `(:zsd ,*chat-id*) secret)
-          (handle-set-cron t))
-        (bot-send-message "Чот не смог, пропробуй другие."))))
+  (handler-case
+      (progn
+        (poller-authenticate :zsd (cons login pass))
+        (handle-set-cron t))
+    (poller-cant-authenticate ()
+      (bot-send-message "Чот не смог, пропробуй другие."))))
 
 (defun handle-recent ()
   (bot-send-message

poller.lisp

@@ -7,14 +7,16 @@
 
            :poller-request
            :poller-validate
-           :poller-authenticate
+           :poller-get-token
 
            :poller-error
            :poller-no-secret
+           :poller-cant-get-token
            :poller-cant-authenticate
 
            :poller-call
-           :poller-poll-lists))
+           :poller-poll-lists
+           :poller-authenticate))
 (in-package :chatikbot.poller)
 
 (defvar *tokens* (make-hash-table) "Module's tokens store")
@@ -22,9 +24,11 @@
 (defvar *poller-token* nil "Current user's API token")
 (defvar *poller-module* nil "Current module")
 
-(defun rest-parameters (rest)
+(defun rest-parameters (rest &optional raw)
   (loop for (param value) on rest by #'cddr
-     when value collect (cons (dekeyify param) value)))
+     when value collect (cons (if raw (string param)
+                                  (dekeyify param))
+                              value)))
 
 (defun get-data (store chat-id &optional (module *poller-module*))
   (let ((module-store (gethash module store)))
@@ -40,11 +44,12 @@
   (:documentation "Performs api request to module"))
 (defgeneric poller-validate (module response)
   (:documentation "Performs api result validation"))
-(defgeneric poller-authenticate (module secret)
-  (:documentation "Performs api request to module"))
+(defgeneric poller-get-token (module secret)
+  (:documentation "Performs token generation out of module"))
 
 (define-condition poller-error (error) ())
 (define-condition poller-no-secret (poller-error) ())
+(define-condition poller-cant-get-token (poller-error) ())
 (define-condition poller-cant-authenticate (poller-error) ())
 
 (defun poller-call (module method &rest params)
@@ -55,11 +60,17 @@
     (if (poller-validate module response) response
         (with-secret (secret (list module chat-id))
           (unless secret (error 'poller-no-secret))
-          (let ((*poller-token* (poller-authenticate module secret)))
-            (unless *poller-token* (error 'poller-cant-authenticate))
+          (let ((*poller-token* (poller-get-token module secret)))
+            (unless *poller-token* (error 'poller-cant-get-token))
             (set-data *tokens* chat-id *poller-token* module)
             (values (apply 'poller-request module method params)))))))
 
+(defun poller-authenticate (module secret)
+  (let ((token (poller-get-token module secret)))
+    (unless token (error 'poller-cant-authenticate))
+    (secret-set (list module *chat-id*) secret)
+    token))
+
 (defun poller-poll-lists (module get-state-fn process-diff-fn &key (test #'equalp) (predicate #'<) key (max-store 200))
   (dolist (*chat-id* (lists-get module))
     (handler-case

utils.lisp

@@ -352,7 +352,7 @@ is replaced with replacement."
 (defun json-request (url &rest args &key method parameters content headers basic-auth cookie-jar keep-alive use-connection-pool timeout ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path user-agent (object-as :alist) json-content)
   (declare (ignore method parameters basic-auth cookie-jar keep-alive use-connection-pool timeout ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path user-agent))
   (when (and (consp content) json-content)
-    (setf content (yason:encode-alist content))
+    (setf content (with-output-to-string (s) (yason:encode-alist content s)))
     (push (cons :content-type "application/json") headers))
   (remf args :object-as)
   (remf args :headers)