[banking] raif and tink

common.lisp

@@ -17,6 +17,7 @@
            :lists-get
            :*admins*
            :*bot-name*
+           :+day+
            :add-hook
            :remove-hook
            :keyify

macros.lisp

@@ -107,7 +107,7 @@
        (defun ,name ()
          (unwind-protect
               (handler-case (progn ,@body)
-                (error (e) (log:error e)))
+                (error (e) (log:error "~A" e)))
            (dex:clear-connection-pool)))
        (defun ,scheduler ()
          (clon:schedule-function

plugins/raiffeisen.lisp

@@ -0,0 +1,251 @@
+(in-package :cl-user)
+(defpackage chatikbot.plugins.raiffeisen
+  (:use :cl :chatikbot.common))
+(in-package :chatikbot.plugins.raiffeisen)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (ql:quickload :cxml-stp))
+
+(defvar *raif-ws* "https://connect.raiffeisen.ru/Mobile-WS/services/" "Base WS URL")
+(defvar *ua* "Dalvik/2.1.0 (Linux; U; Android 6.0.1; ONE A2003 Build/MMB29M) Android/3.19.0(459)" "User agent")
+(defvar *soap-dom* (cxml:parse "<?xml version='1.0' encoding='UTF-8' standalone='yes' ?><soapenv:Envelope xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\" xmlns:xsd=\"http://entry.rconnect/xsd\" xmlns:ser=\"http://service.rconnect\" xmlns:soapenv=\"http://schemas.xmlsoap.org/soap/envelope/\" xmlns:soapenc=\"http://schemas.xmlsoap.org/soap/encoding/\"><soapenv:Header /><soapenv:Body></soapenv:Body></soapenv:Envelope>" (stp:make-builder)) "XML SOAP raif service envelope")
+(defparameter +ns-soap-env+ "http://schemas.xmlsoap.org/soap/envelope/" "Soap envelope xmlns")
+(defparameter +ns-rconnect+ "http://service.rconnect" "Service r-connect xmlns")
+(defparameter +ct-xml+ "text/xml;charset=UTF-8" "XML Content-Type")
+(defvar *rc-auth-service* "RCAuthorizationService")
+(defvar *rc-account-service* "RCAccountService")
+(defvar *cookie-jar* nil "Active cookie jar")
+(defvar *credentials-provider* nil "Active credentials provider")
+
+(defun get-service-url (service-name)
+  (concatenate 'string *raif-ws* service-name))
+
+(defun soap-request-serialize (body)
+  (let* ((doc (stp:copy *soap-dom*))
+         (n-body (stp:find-recursively-if (stp:of-name "Body" +ns-soap-env+) doc)))
+    (stp:append-child n-body (stp:copy body))
+    (stp:serialize doc (cxml:make-string-sink))))
+
+(define-condition soap-error (error)
+  ((name :initarg :name :reader soap-error-name)
+   (message :initarg :message :reader soap-error-message))
+  (:report (lambda (condition stream)
+             (with-slots (name message) condition
+               (format stream "Soap error ~A: ~A" name message)))))
+
+(defun %rs/login (login password)
+  (let ((n-method (stp:make-element "ser:login" +ns-rconnect+))
+        (n-login (stp:make-element "login"))
+        (n-password (stp:make-element "password")))
+    (stp:append-child n-login (stp:make-text login))
+    (stp:append-child n-password (stp:make-text password))
+    (stp:append-child n-method n-login)
+    (stp:append-child n-method n-password)
+    n-method))
+
+(defun %r-call (service request)
+  (let* ((body
+          (handler-case
+              (http-request (get-service-url service)
+                            :method :post
+                            :content (soap-request-serialize request)
+                            :cookie-jar *cookie-jar*
+                            :user-agent *ua*
+                            :headers `(("SOAPAction" . "")
+                                       (:content-type . ,+ct-xml+)))
+            (dex:http-request-internal-server-error (e)
+              (dex:response-body e))))
+         (x/body
+          (stp:first-child
+           (stp:find-recursively-if
+            (stp:of-name "Body" +ns-soap-env+)
+            (cxml:parse body (stp:make-builder))))))
+    (if (string-equal (stp:local-name x/body) "Fault")
+        (let ((name (stp:local-name (stp:first-child (stp:find-recursively-if (stp:of-name "detail") x/body))))
+              (message (stp:data (stp:first-child (stp:find-recursively-if (stp:of-name "faultstring") x/body)))))
+          (if (and *credentials-provider*
+                   (string-equal name "sessionExpiredFault"))
+              (progn
+                (funcall *credentials-provider*
+                         (lambda (login password)
+                           (%r-call *rc-auth-service* (%rs/login login password))))
+                (%r-call service request))
+              (error 'soap-error :name name :message message)))
+        x/body)))
+
+(defun rc/get-batch-response ()
+  (%r-call *rc-auth-service* (stp:make-element "ser:getBatchResponse" +ns-rconnect+)))
+
+(defun get-accounts (batch-response)
+  (stp:filter-recursively (stp:of-name "accounts") batch-response))
+
+(defun %rs/get-last-account-movements (account count)
+  (let ((n-method (stp:make-element "ser:GetLastAccountMovements" +ns-rconnect+))
+        (n-account (stp:copy account))
+        (n-count (stp:make-element "count")))
+    (setf (stp:local-name n-account) "account")
+    (stp:append-child n-count (stp:make-text (princ-to-string count)))
+    (stp:append-child n-method n-account)
+    (stp:append-child n-method n-count)
+    n-method))
+
+(defun rc/get-last-account-movements (account count)
+  (let ((info (%r-call *rc-account-service* (%rs/get-last-account-movements account count))))
+    (stp:filter-recursively (stp:of-name "return") info)))
+
+(defun %rs/get-account-movements (account start-date end-date)
+  (let ((n-method (stp:make-element "ser:GetAccountMovements" +ns-rconnect+))
+        (n-account (stp:copy account))
+        (n-start-date (stp:make-element "startDate"))
+        (n-end-date (stp:make-element "endDate")))
+    (setf (stp:local-name n-account) "account")
+    (stp:append-child n-start-date (stp:make-text start-date))
+    (stp:append-child n-end-date (stp:make-text end-date))
+    (stp:append-child n-method n-account)
+    (stp:append-child n-method n-start-date)
+    (stp:append-child n-method n-end-date)
+    n-method))
+
+(defun rc/get-account-movements (account start-ut end-ut)
+  (labels ((format-ut (ut)
+             (multiple-value-bind (sec min hour day month year)
+                 (decode-universal-time ut)
+               (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D.0"
+                       year month day hour min sec))))
+    (let ((info (%r-call *rc-account-service*
+                         (%rs/get-account-movements account
+                                                    (format-ut start-ut)
+                                                    (format-ut end-ut)))))
+      (stp:filter-recursively (stp:of-name "return") info))))
+
+(defun tag->keyword (tag)
+  (setf tag (cl-ppcre:regex-replace-all "([a-z])([A-Z])" tag '(0 "-" 1)))
+  (setf tag (cl-ppcre:regex-replace-all "_" tag "-"))
+  (intern (string-upcase tag) :keyword))
+
+(defun node->alist (node &optional keep-id)
+  (let (res)
+    (stp:do-children (child node (nreverse res))
+      (let ((name (stp:local-name child)))
+        (when (or keep-id
+                  (not (string-equal "id" name)))
+          (push (cons (tag->keyword name)
+                      (stp:string-value child))
+                res))))))
+
+(defun get-account-currency (account)
+  (let ((currency (agets account :currency)))
+    (cond
+      ((equal currency "RUR") "RUB")
+      (t currency))))
+
+(defun get-account-name (account)
+  (let ((num (agets account :number)))
+    (concatenate 'string "assets:Raiffeisen:"
+                 (cond
+                   ((string= num "40817810503000266700") "Debit")
+                   ((string= num "40817978803000110883") "Savings:EUR")
+                   ((string= num "40817810203001534278") "Savings:Renov")
+                   ((string= num "40817810103001667025") "Savings:For credit")
+                   (:overwise (concatenate 'string
+                                           (agets account :account-type)
+                                           ":"
+                                           num
+                                           ":"
+                                           (get-account-currency account)))))))
+
+(defun get-move-payee (move)
+  (agets move :short-description))
+
+(defun get-move-description (move)
+  (let ((full (agets move :full-description)))
+    (unless (or (zerop (length full))
+                (string= "CARD **" (subseq full 0 (min (length full) 7))))
+      (cl-ppcre:regex-replace-all "\\s" full " "))))
+
+(defun get-move-account2 (move)
+  (let ((desc (agets move :short-description)))
+    (cond
+      ((equal desc "P/O 001,40817810503000266700RC") "assets:Raiffeisen:Debit")
+      ((equal desc "P/O 001,40817810203001534278RC") "assets:Raiffeisen:Savings:Renov")
+      ((equal desc "TINKOFF BANK CARD2CARD MOSCOW") "assets:Tinkoff:Debit")
+      ((equal (subseq desc 0 (min 7 (length desc))) "RBA ATM") "assets:Cash:RUB")
+      (t (if (string= "1" (agets move :type)) "income" "expenses")))))
+
+(defun short-date (date)
+  (cl-ppcre:regex-replace-all "-" (subseq date 0 10) "/"))
+
+(defun move->journal (move)
+  (let* ((account (agets move :account))
+         (account1 (get-account-name account))
+         (account2 (get-move-account2 move))
+         (currency (get-account-currency account))
+         (date (short-date (agets move :commit-date)))
+         (payee (get-move-payee move))
+         (description (get-move-description move))
+         (amount (parse-float (agets move :amount)))
+         (expense (equal "0" (agets move :type))))
+    (format nil "~A~@[ (~A)~] ~A~@[ ; ~A~]~%    ~37A  ~A~,2F ~A~%    ~37A  ~A~,2F ~A"
+            date nil payee description
+            account2 (if expense " " "-") amount currency
+            account1 (if expense "-" " ") amount currency)))
+
+(defun move->balance (move)
+  (let ((account (agets move :account)))
+    (format nil "; balance ~A ~A  = ~,2F ~A"
+            (short-date (agets account :balance-date))
+            (get-account-name account)
+            (parse-float (agets account :balance))
+            (get-account-currency account))))
+
+
+(defun get-last-n-movements (&optional (count 10))
+  (loop for account in (get-accounts (rc/get-batch-response))
+     append (loop for move in (nreverse (rc/get-last-account-movements account count))
+               collect (cons (cons :account (node->alist account t))
+                             (node->alist move)))))
+
+(defun get-last-movements (begin-ut end-ut)
+  (loop for account in (get-accounts (rc/get-batch-response))
+     append (loop for move in (nreverse (rc/get-account-movements account begin-ut end-ut))
+               collect (cons (cons :account (node->alist account t))
+                             (node->alist move)))))
+
+(defun format-changes (movements)
+  (format nil "```~%~{~A~^~%~%~}```"
+          (append (mapcar #'move->journal movements)
+                  (list (move->balance (car (last movements)))))))
+
+;; Cron
+(defvar *last-movements* (make-hash-table) "Last per-chat movements")
+(defvar *cookie-jars* (make-hash-table) "Per-chat cookie jars")
+
+(defun get-chat-last-movements (chat-id &optional (offset +day+))
+  (let* ((*cookie-jar* (or (gethash chat-id *cookie-jars*)
+                           (cl-cookie:make-cookie-jar)))
+         (*credentials-provider* (lambda (authenticator)
+                                   (with-secret (login-pass (list :raiffeisen chat-id))
+                                     (if login-pass
+                                         (apply authenticator login-pass)
+                                         (error "no raiffeisen credentials for ~A" chat-id)))))
+         (now (get-universal-time))
+         (pre (- now offset))
+         (new (get-last-movements pre now)))
+      (when new
+        (setf (gethash chat-id *cookie-jars*) *cookie-jar*))
+      new))
+
+(defcron process-raiffeisen (:minute '(member 0 5 10 15 20 25 30 35 40 45 50 55))
+  (dolist (chat-id (lists-get :raiffeisen))
+    (let ((old (gethash chat-id *last-movements*))
+          (new (get-chat-last-movements chat-id (* 7 +day+))))
+      (when new
+        (log:info "Got ~A raif events" (length new))
+        (when old
+          (alexandria:when-let (changes (set-difference new old :test #'equal))
+            (bot-send-message chat-id (format-changes changes) :parse-mode "markdown")))
+        (setf (gethash chat-id *last-movements*) new)))))
+
+(def-message-cmd-handler handler-raif (:raif)
+  (let ((last (get-chat-last-movements chat-id (* (if args (parse-integer (car args)) 7) +day+))))
+    (bot-send-message chat-id (format-changes last) :parse-mode "markdown")))

plugins/tinkoff.lisp

@@ -0,0 +1,185 @@
+(in-package :cl-user)
+(defpackage chatikbot.plugins.tinkoff
+  (:use :cl :chatikbot.common))
+(in-package :chatikbot.plugins.tinkoff)
+
+(defsetting *ua* "OnePlus ONE A2003/android: 6.0.1/TCSMB/3.4.2" "User agent")
+(defsetting *device-id* "1df9bdeac787e08")
+(defsetting *app-version* "3.4.2")
+
+(defvar *api-base-url* "https://api.tinkoff.ru/v1/")
+(defvar *session-id* nil "Last session id")
+(defvar *origin* "mobile,ib5,loyalty,platform")
+(defvar *platform* "android")
+(defvar *credentials-provider* nil "Active credentials provider")
+
+(defun api-url (method)
+  (concatenate 'string *api-base-url* method))
+
+(defun default-params ()
+  `(("origin" . ,*origin*)
+    ("platform" . ,*platform*)
+    ("deviceId" . ,*device-id*)
+    ("appVersion" . ,*app-version*)
+    ("sessionid" . ,*session-id*)
+    ("ccc" . "true")))
+
+(define-condition api-error (error)
+  ((code :initarg :code :reader api-error-code)
+   (message :initarg :message :reader api-error-message))
+  (:report (lambda (condition stream)
+             (with-slots (code message) condition
+               (format stream "Tinkoff api error ~A: ~A" code message)))))
+
+(defun request (method &key params content retry)
+  (let* ((params (loop for (k . v) in (append (default-params) params) when v
+                    collect (cons (princ-to-string k) (princ-to-string v))))
+         (r (json-request (api-url method) :method (if content :POST :GET)
+                          :parameters params
+                          :content content)))
+    (if (string= "OK" (agets r "resultCode"))
+        (agets r "payload")
+        (let ((code (agets r "resultCode"))
+              (message (agets r "errorMessage")))
+          (if (and (not retry)
+                   *credentials-provider*
+                   (string-equal code "INSUFFICIENT_PRIVILEGES"))
+              (progn
+                (funcall *credentials-provider*
+                         (lambda (login password)
+                           (api/login login password)))
+                (request method :params params :content content :retry t))
+              (error 'api-error :code code :message message))))))
+
+(defun api/login (username password)
+  (let ((new-session (request "session")))
+    (prog1
+        (let* ((*session-id* new-session))
+          (request "sign_up" :params `(("username" . ,username)
+                                       ("password" . ,password)))
+          (request "level_up"))
+      (setf *session-id* new-session))))
+
+(defun api/accounts ()
+  (request "accounts_flat"))
+
+(defun api/operations (&key account start end)
+  (request "operations" :params `(("account" . ,account)
+                                  ("start" . ,start)
+                                  ("end" . ,end))))
+
+(defvar *unix-epoch-difference*
+  (encode-universal-time 0 0 0 1 1 1970 0))
+
+(defun universal-to-unix-time (universal-time)
+  (- universal-time *unix-epoch-difference*))
+
+(defun unix-to-universal-time (unix-time)
+  (+ unix-time *unix-epoch-difference*))
+
+(defun get-unix-time ()
+  (universal-to-unix-time (get-universal-time)))
+
+(defun short-date (ms)
+  (if ms
+   (multiple-value-bind (sec min hour day month year)
+       (decode-universal-time (unix-to-universal-time (round ms 1000)))
+     (declare (ignore sec min hour))
+     (format nil "~4,'0D/~2,'0D/~2,'0D" year month day))
+   "-"))
+
+(defun get-op-description (op)
+  (let ((cat (parse-integer (agets op "category" "id") :junk-allowed t)))
+    (cond
+      ((equal cat 16) (if (> (agets op "accountAmount" "value")
+                             1500)
+                      "project: Volvo" "project: Smart"))
+      (:otherwise
+       (or
+        (agets op "payment" "fieldsValues" "comment")
+        (agets op "brand" "name"))))))
+
+(defun get-op-account1 (op)
+  (case (parse-integer (agets op "account"))
+    (5001173482 "assets:Tinkoff:Debit")
+    (1850735 "assets:Raiffeisen:Debit")
+    (0047479860 "liabilities:Tinkoff:Credit:Platinum")
+    (8102961813 "assets:Tinkoff:Savings:For credit")
+    (t (concatenate 'string "assets:Tinkoff:" (agets op "account")))))
+
+(defun get-op-account2 (op)
+  (let ((cat (parse-integer (agets op "category" "id") :junk-allowed t)))
+    (case cat
+      (60 "expenses:Food:Fast-food")
+      (36 "expenses:Transport")
+      (32 "expenses:Food:Restaurant")
+      (20 "expenses:Life:Wear")
+      (16 "expenses:Transport:Car:Gas")
+      (10 "expenses:Food:Grocery")
+      (t (concatenate 'string
+                      (if (equal "Credit" (agets op "type"))
+                          "income:" "expenses:")
+                      (agets op "category" "name"))))))
+
+(defun ops->journal (ops)
+  (loop for op in ops
+     for status = (agets op "status")
+     for date = (short-date (agets op "operationTime" "milliseconds"))
+     for id = (agets op "ucid")
+     for payee = (agets op "description")
+     for description = (get-op-description op)
+     for account-amount = (agets op "accountAmount" "value")
+     for account-currency = (agets op "accountAmount" "currency" "name")
+     for amount = (agets op "amount" "value")
+     for currency = (agets op "amount" "currency" "name")
+     for account1 = (get-op-account1 op)
+     for account2 = (get-op-account2 op)
+     for expense = (equal "Debit" (agets op "type"))
+     unless (string= status "FAILED")
+     collect (format nil "~A~@[ (~A)~] ~A~@[ ; ~A~]~%    ~38A  ~A~,2F ~A~@[ @@ ~{~A~,2F ~A~}~]~%    ~38A  ~A~,2F ~A"
+                     date nil payee (unless (equal payee description) description)
+                     account2 (if expense " " "-") amount currency
+                     (unless (equal currency account-currency)
+                       (list (if expense "" "-") account-amount account-currency))
+                     account1 (if expense "-" " ") account-amount account-currency)))
+
+
+(defun get-last-movements (begin-ut end-ut)
+  (api/operations :start (* 1000 (universal-to-unix-time begin-ut))
+                  :end (* 1000 (universal-to-unix-time end-ut))))
+
+;; Cron
+(defvar *last-movements* (make-hash-table) "Last per-chat movements")
+(defvar *chat-sessions* (make-hash-table) "Per-chat sessions")
+
+(defun get-chat-last-movements (chat-id &optional (offset +day+))
+  (let* ((*session-id* (gethash chat-id *chat-sessions*))
+         (*credentials-provider* (lambda (authenticator)
+                                   (with-secret (login-pass (list :tinkoff chat-id))
+                                     (if login-pass
+                                         (apply authenticator login-pass)
+                                         (error "no tinkoff credentials for ~A" chat-id)))))
+         (now (get-universal-time))
+         (pre (- now offset))
+         (new (get-last-movements pre now)))
+      (when new
+        (setf (gethash chat-id *chat-sessions*) *session-id*))
+      new))
+
+(defun format-changes (changes)
+  (format nil "```~%~{~A~^~%~%~}```" (ops->journal changes)))
+
+(defcron process-tinkoff (:minute '(member 0 5 10 15 20 25 30 35 40 45 50 55))
+  (dolist (chat-id (lists-get :tinkoff))
+    (let ((old (gethash chat-id *last-movements*))
+          (new (get-chat-last-movements chat-id (* 7 24 60 60))))
+      (when new
+        (log:info "Got ~A tinkoff events" (length new))
+        (when old
+          (alexandria:when-let (changes (set-difference new old :test #'equal))
+            (bot-send-message chat-id (format-changes changes) :parse-mode "markdown")))
+        (setf (gethash chat-id *last-movements*) new)))))
+
+(def-message-cmd-handler handler-tink (:tink)
+  (let ((last (get-chat-last-movements chat-id (* (if args (parse-integer (car args)) 7) +day+))))
+    (bot-send-message chat-id (format-changes last) :parse-mode "markdown")))

utils.lisp

@@ -4,6 +4,7 @@
   (:export :*admins*
            :*bot-name*
            :*hooks*
+           :+day+
            :run-hooks
            :add-hook
            :remove-hook
@@ -68,6 +69,7 @@
 (defvar *admins* nil "Admins chat-ids")
 (defvar *bot-name* nil "bot name to properly handle text input")
 (defvar *hooks* (make-hash-table) "Hooks storage")
+(defparameter +day+ (* 24 60 60) "Seconds in day")
 
 (defun run-hooks (event &rest arguments)
   (let ((hooks (gethash event *hooks*)))